|
| From: | Andy Wingo |
| Subject: | [Guile-commits] GNU Guile branch, master, updated. release_1-9-4-35-ge18a5e1 |
| Date: | Fri, 23 Oct 2009 15:01:46 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=e18a5e16e8215e8967d0757b1379b6813da9da30
The branch, master has been updated
via e18a5e16e8215e8967d0757b1379b6813da9da30 (commit)
via 19f41878dc93d016a46a55052d17003aa541c8db (commit)
via 236413db1a0a9e55beff45bc207e31da1280c43c (commit)
via 7ab42fa20cd997ce6ccb4f3f59bb400e04d2d666 (commit)
via 3092a14d6758bd002113ffe4bc51e4c6930c4ce5 (commit)
via 899d37a6cf2e5f5a6822b8451cda95f53c007608 (commit)
via 7e01997e88c54216678271de36b1c2088377492d (commit)
via 8753fd537c4eadf7495f4ba867def99e77246dfc (commit)
via 8a4ca0ea3bd3e378fc63ef719ce828b7252b3985 (commit)
via c783b0827c5e5485209879b6cd329a7f095ecf9c (commit)
via 258344b4db4b9dab1979bbef53606c0cd34b4095 (commit)
via 56164a5a6c45a4fba065be2cc9a2539ef5cd2b71 (commit)
via a6f15a1eba208c92df5640001390277d641909b8 (commit)
via 55d9bc947ef529157c5598e097eba23179b94987 (commit)
via 6c6a44390b841d716042e845bf4133fbf987cc9f (commit)
via 1e2a8c266d720a5dca97a96e5cde860a9d934ad6 (commit)
from 04c68c039194f33d5bd7e8b1f21eba7c8bd6adbe (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit e18a5e16e8215e8967d0757b1379b6813da9da30
Author: Andy Wingo <address@hidden>
Date: Fri Oct 23 16:29:06 2009 +0200
swap optargs impl
commit 19f41878dc93d016a46a55052d17003aa541c8db
Author: Andy Wingo <address@hidden>
Date: Fri Oct 23 15:50:53 2009 +0200
optargs psyntax
commit 236413db1a0a9e55beff45bc207e31da1280c43c
Author: Andy Wingo <address@hidden>
Date: Fri Oct 23 15:51:00 2009 +0200
tree-il changes
commit 7ab42fa20cd997ce6ccb4f3f59bb400e04d2d666
Author: Andy Wingo <address@hidden>
Date: Fri Oct 23 15:47:08 2009 +0200
add some optargs tests
* libguile/modules.c (scm_module_lookup, scm_lookup): Throw to
'unbound-variable, like eval.i.c does.
* test-suite/tests/optargs.test: Add an optargs test. Run optargs tests
under both the VM and the interpreter.
commit 3092a14d6758bd002113ffe4bc51e4c6930c4ce5
Author: Andy Wingo <address@hidden>
Date: Fri Oct 23 15:44:22 2009 +0200
vm support for optional/kwarg init code, and bugfixes
* libguile/vm-i-system.c (local-bound?, long-local-bound?)
(variable-bound?): New instructions, push #f unless the local is
bound. You can get unbound locals from optional arguments.
(bind-optionals/shuffle): A number of bugfixes.
(bind-kwargs): Bugfixes. If we enocunter an improper kwarg list but
the procedure has a rest argument, just stop kwarg processing, but
without an error.
Renumbered ops.
* libguile/_scm.h (SCM_OBJCODE_MAJOR_VERSION): Bump.
commit 899d37a6cf2e5f5a6822b8451cda95f53c007608
Author: Andy Wingo <address@hidden>
Date: Mon Oct 19 22:13:08 2009 +0200
more work towards compiling and interpreting keyword args
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bumparoo
* libguile/vm-i-system.c (push-rest, bind-rest): Logically there are
actually two rest binders -- one that pops, conses, and pushes, and
one that pops, conses, and local-sets. The latter is used on keyword
arguments, because the keyword arguments themselves have been shuffled
up on the stack. Renumber ops again.
* module/language/tree-il/compile-glil.scm (flatten): Attempt to handle
compilation of lambda-case with keyword arguments. Might need some
help.
* module/ice-9/psyntax.scm (build-lambda-case): An attempt to handle the
interpreted case correctly. This might need a couple iterations, but
at least it looks like the compile-glil code.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/glil.scm (<glil>): Rename "rest?" to "rest" in
<glil-opt-prelude> and <glil-kw-prelude>, as it is no longer a simple
boolean, but if true is an integer: the index of the local variable to
which the rest should be bound.
* module/language/glil/compile-assembly.scm (glil->assembly): Adapt to
"rest" vs "rest?". In the keyword case, use "bind-rest" instead of
"push-rest".
* test-suite/tests/tree-il.test: Update for opt-prelude change.
commit 7e01997e88c54216678271de36b1c2088377492d
Author: Andy Wingo <address@hidden>
Date: Sat Oct 17 17:23:09 2009 +0200
finish support for optional & keyword args; update ecmascript compiler
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump.
* libguile/vm-i-system.c (br-if-nargs-ne, br-if-args-lt)
(br-if-nargs-gt): New instructions, for use by different lambda cases.
(bind-optionals, bind-optionals/shuffle, bind-kwargs): New
instructions, for binding optional and keyword arguments. Renumber
other ops.
* module/language/ecmascript/compile-tree-il.scm (comp, comp-body):
Update for new tree-il. Use the new optional argument mechanism
instead of emulating it with rest arguments.
* module/language/glil/compile-assembly.scm (glil->assembly): Tweaks for
optional and keyword argument compilation.
* module/language/tree-il.scm (parse-tree-il, unparse-tree-il): Make the
else case optional, in the s-expression serialization of tree-il.
* module/language/tree-il/compile-glil.scm (flatten): Handle all of the
lambda-case capabilities.
commit 8753fd537c4eadf7495f4ba867def99e77246dfc
Author: Andy Wingo <address@hidden>
Date: Fri Oct 16 17:56:39 2009 +0200
fix brainfuck for new tree-il, and add tests
* test-suite/Makefile.am:
* test-suite/tests/brainfuck.test: Add a brainfuck test.
* module/system/base/compile.scm: Also export read-and-compile.
* module/language/tree-il/spec.scm (join): Fix the joiner in the
0-expression case.
* module/language/tree-il/primitives.scm (+): Recognize (+ x -1) as 1-.
* module/language/brainfuck/parse.scm (read-brainfuck): Return EOF if we
actually received EOF, and there were no expressions read.
* module/language/brainfuck/compile-tree-il.scm (compile-body): Fix the
compiler for the new format of "lambda" in tree-il.
commit 8a4ca0ea3bd3e378fc63ef719ce828b7252b3985
Author: Andy Wingo <address@hidden>
Date: Wed Oct 14 00:08:35 2009 +0200
tree-il support for case-lambda
* module/language/tree-il.scm (<lambda>, <lambda-case>): Split lambda
into the lambda itself, denoting the procedure, and lambda-case,
denoting a particular arity case. Lambda-case is fairly featureful,
and has not yet been fully tested.
(<let-values>): Use a <lambda-case> as the binding expression. Seems
to suit the purpose well.
Adapt parsers, unparsers, traversal operators, etc. Sometimes in this
first version we assume there are no optional args, rest args, or a
predicate.
* module/language/tree-il/analyze.scm (analyze-lexicals): Adapt for the
new case-lambda regime. Fairly well commented. It actually simplifies
things.
(report-unused-variables): Update for new tree-il.
* module/language/tree-il/compile-glil.scm: Adapt for the new tree-il.
There are some first stabs here at proper case-lambda compilation, but
they are untested as of yet.
* module/language/tree-il/inline.scm (inline!): Rework so we can
recurse on a single node; though these transformations are strictly
reductive, so they should complete in bounded time. Simplify
accordingly, and adapt to case-lambda. Oh, and we handle lambda->let
in not just the nullary case.
* module/ice-9/psyntax.scm (build-simple-lambda, build-case-lambda)
(build-lambda-case): New constructors. The idea is that after syntax
expansion, we shouldn't have to deal with improper lists any more.
Build-simple-lambda is a shortcut for the common case. The others are
not fully exercised yet. Adapt callers.
(syntax): Add some debugging in the lambda case. I don't fully
understand this, but in practice we don't seem to see rest args here.
(lambda): Inline chi-lambda-clause, and adapt for build-simple-lambda.
* module/ice-9/psyntax-pp.scm: Regenerated.
* test-suite/tests/tree-il.test: Update tests for new tree-il lambda
format, and to expect post-prelude labels for all glil programs.
commit c783b0827c5e5485209879b6cd329a7f095ecf9c
Author: Andy Wingo <address@hidden>
Date: Tue Oct 13 23:58:36 2009 +0200
procedure property efficiency tweak
* libguile/procprop.c (scm_procedure_property)
scm_set_procedure_property_x): Fix to not call
scm_procedure_properties(), and thus to avoid consing up the arity as
well.
commit 258344b4db4b9dab1979bbef53606c0cd34b4095
Author: Andy Wingo <address@hidden>
Date: Tue Oct 13 23:55:58 2009 +0200
flesh out glil support for optional and keyword arguments
* libguile/vm-i-system.c (bind-rest): Renamed from push-rest-list.
(reserve-locals): Change so that instead of reserving space for some
additional number of locals, reserve-locals takes the absolute number
of locals, including the arguments.
* module/language/glil.scm (<glil-std-prelude>, <glil-opt-prelude>)
(<glil-kw-prelude>): New GLIL constructs, to replace <glil-arity>.
* module/language/glil/compile-assembly.scm (glil->assembly): Compile
the new preludes. Some instructions are not yet implemented, though.
* module/language/tree-il/analyze.scm (analyze-lexicals): The nlocs for
a lambda will now be the total number of locals, including arguments.
* module/language/tree-il/compile-glil.scm (flatten-lambda): Update to
write the new prelude.
* module/system/vm/program.scm (program-bindings-for-ip): If a given
index doesn't have a binding at the ip given, don't cons it on the
resulting list.
* test-suite/tests/tree-il.test: Update for GLIL changes.
commit 56164a5a6c45a4fba065be2cc9a2539ef5cd2b71
Author: Andy Wingo <address@hidden>
Date: Tue Oct 13 23:45:22 2009 +0200
de-nargs struct scm_objcode; procedure-property refactor
* libguile/objcodes.h (struct scm_objcode): Remove nargs, nrest, and
nlocs, as they are no longer needed. Also obviates the need for a
padding word.
* libguile/procs.c (scm_thunk_p): Use scm_i_program_arity for programs.
* libguile/procprop.c (scm_i_procedure_arity): Use scm_i_program_arity
for programs.
(scm_procedure_properties, scm_set_procedure_properties_x)
(scm_procedure_property, scm_set_procedure_property_x): Rework so that
non-closure properties are stored directly in a weak hash, instead of
needing a weak hash of "stand-in" closures to hold the properties. Fix
docstrings also.
* libguile/root.h (scm_stand_in_procs): Remove from the scm_sys_protects
set. Actually with libGC, we should be able to store the elements of
scm_sys_protects directly as global variables.
* libguile/gc.c (scm_init_storage): Remove scm_stand_in_procs
initialization.
* libguile/programs.c (scm_i_program_arity): New private accessor, tries
to determine the "minimum arity" of a program.
* libguile/vm.c (really_make_boot_program): Adapt to changes in
struct scm_objcode.
* module/language/assembly.scm (*program-header-len*, byte-length):
* module/language/assembly/compile-bytecode.scm (write-bytecode):
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
* module/language/assembly/disassemble.scm (disassemble-load-program):
Adapt to changes in objcode.
* module/system/xref.scm (program-callee-rev-vars): Adapt to changes in
assembly.
* module/language/glil.scm: Remove nargs, nrest, and nlocs from
glil-program.
* module/language/glil/compile-assembly.scm (make-meta, glil->assembly):
* module/language/glil/decompile-assembly.scm (decompile-toplevel):
(decompile-load-program): Adapt to changes in GLIL and assembly.
* module/language/tree-il/compile-glil.scm (flatten-lambda): Adapt to
changes in GLIL.
* test-suite/tests/asm-to-bytecode.test: Adapt to assembly and bytecode
changes.
* test-suite/tests/tree-il.test: Adapt to GLIL changes.
commit a6f15a1eba208c92df5640001390277d641909b8
Author: Andy Wingo <address@hidden>
Date: Sun Sep 27 20:25:39 2009 -0400
callees now check their args, cons rest list, reserve locals
* gdbinit: Ignore SIGPWR and SIGXCPU, which the BDW GC seems to use.
* libguile/vm-engine.h (FETCH_WIDTH): Remove unused macro.
(INIT_ARGS, INIT_FRAME): Remove; callees now check their args and
reserve space for their locals.
* libguile/vm-engine.c:
* libguile/vm-i-system.c: Turn on callee arg checking and local
reservation. Seems to work!
commit 55d9bc947ef529157c5598e097eba23179b94987
Author: Andy Wingo <address@hidden>
Date: Sun Sep 27 19:50:06 2009 -0400
callees reserve their own local vars
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump.
* libguile/vm-i-system.c (reserve-locals): New instruction, to reserve
space for local vars. Other ops renumbered.
* module/language/tree-il/compile-glil.scm (flatten-lambda): Emit
reserve-locals instructions as necessary.
* test-suite/tests/tree-il.test: Update to expect reserve-locals as
appropriate.
commit 6c6a44390b841d716042e845bf4133fbf987cc9f
Author: Andy Wingo <address@hidden>
Date: Sun Sep 27 19:25:58 2009 -0400
runtime and debugging support for callee-parsed procedure args
* libguile/objcodes.h: Bump for metadata format change.
* libguile/frames.h: Rework so we don't frob the program's nargs, nlocs,
etc at runtime. Instead we don't really know what's a local var, an
argument, or an intermediate value. It's a little unfortunate, but
this will allow for case-lambda, and eventually for good polymorphic
generic dispatch; and the nlocs etc can be heuristically
reconstructed. Such a reconstruction would be better done at the
Scheme level, though.
(SCM_FRAME_STACK_ADDRESS): New macro, the pointer to the base of the
stack elements (not counting the program).
(SCM_FRAME_UPPER_ADDRESS): Repurpose to be the address of the last
element in the bookkeeping part of the stack -- i.e. to point to the
return address.
* libguile/vm-engine.h:
* libguile/vm-i-system.c: Adapt to removal of stack_base. Though we
still detect stack-smashing underflow, we don't do so as precisely as
we did before, because now we only detect overwriting of the frame
metadata.
* libguile/vm-engine.c (vm_engine): Remove the stack_base variable. It
is unnecessary, and difficult to keep track of in the face of
case-lambda. Also fix miscommented "ra" and "mvra" pushes. Push the
vp->ip as the first ra...
* libguile/vm-i-system.c (halt): ...because here we can restore the
vp->ip instead of setting ip to 0. Allows us to introspect ips all
down the stack, including in recursive VM invocations.
* libguile/frames.h:
* libguile/frames.c (scm_vm_frame_stack): Removed, because it's getting
more difficult to tell what's an argument and what's a temporary stack
element.
(scm_vm_frame_num_locals): New accessor.
(scm_vm_frame_instruction_pointer): New accessor.
(scm_vm_frame_arguments): Defer to an implementation in Scheme.
(scm_vm_frame_num_locals scm_vm_frame_local_ref)
(scm_vm_frame_local_set_x): Since we can get not-yet-active frames on
the stack now, with our current calling convention, we have to add a
heuristic here to jump over those frames -- because frames have
pointers in them, not Scheme values.
* libguile/programs.h:
* libguile/programs.c (scm_program_arity): Remove, in favor of..
(scm_program_arities): ...this, which a list of arities, in a new
format, occupying a slot in the metadata.
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
Fix mv-call decompilation.
* module/system/vm/frame.scm (vm-frame-bindings, vm-frame-binding-ref)
(vm-frame-binding-set!): New functions, to access bindings by name in
a frame.
(vm-frame-arguments): Function now implemented in Scheme. Commented
fairly extensively.
* module/system/vm/program.scm (program-bindings-by-index)
(program-bindings-for-ip): New accessors, parsing the program bindings
metadata into something more useful.
(program-arities, program-arguments): In a case-lambda world, we have
to assume that programs can have multiple arities. But it's tough to
detect this algorithmically; instead we're going to require that the
program metadata include information about the arities, and the parts
of the program that that metadata applies to.
(program-lambda-list): New accessor.
(write-program): Show multiple arities.
* module/language/glil/compile-assembly.scm (glil->assembly): Add
"arities" to the state of the compiler, and add arities entries as
appropriate.
commit 1e2a8c266d720a5dca97a96e5cde860a9d934ad6
Author: Andy Wingo <address@hidden>
Date: Sun Sep 27 18:16:56 2009 -0400
steps on the way to have the callee check the number of arguments
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump.
* libguile/vm-i-system.c (assert-nargs-ee, assert-nargs-ge)
(push-rest-list): New instructions, which for now don't actually do
anything. Renumber the rest of the ops in this file.
* module/language/glil.scm (<glil-arity>): New GLIL type, an entity that
checks the number of args for a block, optionally consing a rest list,
and either branching or erroring if the arity doesn't match.
* module/language/glil/compile-assembly.scm (glil->assembly): Compile
<glil-arity> to assembly. Some of these VM ops are not implemented --
notably the branching case.
* module/language/tree-il/compile-glil.scm (flatten-lambda): Emit
<glil-arity>.
* test-suite/tests/tree-il.test: Update.
-----------------------------------------------------------------------
Summary of changes:
gdbinit | 3 +
libguile/_scm.h | 2 +-
libguile/frames.c | 152 +-
libguile/frames.h | 25 +-
libguile/gc.c | 1 -
libguile/modules.c | 12 +-
libguile/objcodes.h | 7 -
libguile/procprop.c | 131 +-
libguile/procprop.h | 8 +-
libguile/procs.c | 14 +-
libguile/programs.c | 75 +-
libguile/programs.h | 3 +-
libguile/root.h | 15 +-
libguile/vm-engine.c | 22 +-
libguile/vm-engine.h | 41 +-
libguile/vm-i-system.c | 390 +-
libguile/vm.c | 4 -
module/ice-9/optargs.scm | 448 +-
module/ice-9/psyntax-pp.scm |11204 +++++++++++++++--------
module/ice-9/psyntax.scm | 366 +-
module/language/assembly.scm | 6 +-
module/language/assembly/compile-bytecode.scm | 6 +-
module/language/assembly/decompile-bytecode.scm | 8 +-
module/language/assembly/disassemble.scm | 6 +-
module/language/brainfuck/compile-tree-il.scm | 19 +-
module/language/brainfuck/parse.scm | 13 +-
module/language/ecmascript/compile-tree-il.scm | 124 +-
module/language/glil.scm | 38 +-
module/language/glil/compile-assembly.scm | 169 +-
module/language/glil/decompile-assembly.scm | 13 +-
module/language/tree-il.scm | 108 +-
module/language/tree-il/analyze.scm | 213 +-
module/language/tree-il/compile-glil.scm | 336 +-
module/language/tree-il/inline.scm | 72 +-
module/language/tree-il/primitives.scm | 14 +-
module/language/tree-il/spec.scm | 6 +-
module/system/base/compile.scm | 5 +-
module/system/vm/frame.scm | 61 +-
module/system/vm/program.scm | 169 +-
module/system/xref.scm | 2 +-
test-suite/Makefile.am | 1 +
test-suite/tests/asm-to-bytecode.test | 14 +-
test-suite/tests/brainfuck.test | 51 +
test-suite/tests/optargs.test | 50 +-
test-suite/tests/tree-il.test | 242 +-
45 files changed, 9427 insertions(+), 5242 deletions(-)
create mode 100644 test-suite/tests/brainfuck.test
diff --git a/gdbinit b/gdbinit
index b66e3e2..812f04b 100644
--- a/gdbinit
+++ b/gdbinit
@@ -1,5 +1,8 @@
# -*- GDB-Script -*-
+handle SIGPWR noprint nostop
+handle SIGXCPU noprint nostop
+
define newline
call (void)scm_newline (scm_current_error_port ())
end
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 6aedebe..93cdfa1 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -172,7 +172,7 @@
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION E
+#define SCM_OBJCODE_MINOR_VERSION K
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
diff --git a/libguile/frames.c b/libguile/frames.c
index a6835fb..39f78e0 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -80,32 +80,19 @@ SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0,
0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_vm_frame_arguments
+SCM
+scm_vm_frame_arguments (SCM frame)
+#define FUNC_NAME "vm-frame-arguments"
{
- SCM *fp;
- int i;
- struct scm_objcode *bp;
- SCM ret;
+ static SCM var = SCM_BOOL_F;
SCM_VALIDATE_VM_FRAME (1, frame);
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ if (scm_is_false (var))
+ var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
+ "vm-frame-arguments");
- if (!bp->nargs)
- return SCM_EOL;
- else if (bp->nrest)
- ret = SCM_FRAME_VARIABLE (fp, bp->nargs - 1);
- else
- ret = scm_cons (SCM_FRAME_VARIABLE (fp, bp->nargs - 1), SCM_EOL);
-
- for (i = bp->nargs - 2; i >= 0; i--)
- ret = scm_cons (SCM_FRAME_VARIABLE (fp, i), ret);
-
- return ret;
+ return scm_call_1 (SCM_VARIABLE_REF (var), frame);
}
#undef FUNC_NAME
@@ -127,47 +114,114 @@ SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1,
0, 0,
}
#undef FUNC_NAME
+/* The number of locals would be a simple thing to compute, if it weren't for
+ the presence of not-yet-active frames on the stack. So we have a cheap
+ heuristic to detect not-yet-active frames, and skip over them. Perhaps we
+ should represent them more usefully.
+ */
+SCM_DEFINE (scm_vm_frame_num_locals, "vm-frame-num-locals", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_num_locals
+{
+ SCM *sp, *p;
+ unsigned int n = 0;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ return scm_from_uint (n);
+}
+#undef FUNC_NAME
+
+/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
(SCM frame, SCM index),
"")
#define FUNC_NAME s_scm_vm_frame_local_ref
{
- SCM *fp;
+ SCM *sp, *p;
+ unsigned int n = 0;
unsigned int i;
- struct scm_objcode *bp;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
- SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
- return SCM_FRAME_VARIABLE (fp, i);
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else if (n == i)
+ return *p;
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ SCM_OUT_OF_RANGE (SCM_ARG2, index);
}
#undef FUNC_NAME
+/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
(SCM frame, SCM index, SCM val),
"")
#define FUNC_NAME s_scm_vm_frame_local_set_x
{
- SCM *fp;
+ SCM *sp, *p;
+ unsigned int n = 0;
unsigned int i;
- struct scm_objcode *bp;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
- SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
- SCM_FRAME_VARIABLE (fp, i) = val;
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else if (n == i)
+ {
+ *p = val;
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ SCM_OUT_OF_RANGE (SCM_ARG2, index);
+}
+#undef FUNC_NAME
- return SCM_UNSPECIFIED;
+SCM_DEFINE (scm_vm_frame_instruction_pointer, "vm-frame-instruction-pointer",
1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_instruction_pointer
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return scm_from_ulong ((unsigned long)
+ (SCM_VM_FRAME_IP (frame)
+ - SCM_PROGRAM_DATA (scm_vm_frame_program
(frame))->base));
}
#undef FUNC_NAME
@@ -209,24 +263,6 @@ SCM_DEFINE (scm_vm_frame_dynamic_link,
"vm-frame-dynamic-link", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_vm_frame_stack
-{
- SCM *top, *bottom, ret = SCM_EOL;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- top = SCM_VM_FRAME_SP (frame);
- bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame));
- while (bottom <= top)
- ret = scm_cons (*bottom++, ret);
-
- return ret;
-}
-#undef FUNC_NAME
-
extern SCM
scm_c_vm_frame_prev (SCM frame)
{
diff --git a/libguile/frames.h b/libguile/frames.h
index 0165924..f744c2b 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -31,15 +31,15 @@
---------------
| ... |
- | Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs =
SCM_FRAME_UPPER_ADDRESS (fp)
- +==================+
+ | Intermed. val. 0 | <- fp + nargs + nlocs
+ +------------------+
| Local variable 1 |
- | Local variable 0 | <- fp + bp->nargs
+ | Local variable 0 | <- fp + nargs
| Argument 1 |
- | Argument 0 | <- fp
+ | Argument 0 | <- fp = SCM_FRAME_STACK_ADDRESS (fp)
| Program | <- fp - 1
- +------------------+
- | Return address |
+ +==================+
+ | Return address | <- SCM_FRAME_UPPER_ADDRESS (fp)
| MV return address|
| Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) =
SCM_FRAME_LOWER_ADDRESS (fp)
+==================+
@@ -50,10 +50,8 @@
assumed to be as long as SCM objects. */
#define SCM_FRAME_DATA_ADDRESS(fp) (fp - 4)
-#define SCM_FRAME_UPPER_ADDRESS(fp) \
- (fp \
- + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
- + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
+#define SCM_FRAME_STACK_ADDRESS(fp) (fp)
+#define SCM_FRAME_UPPER_ADDRESS(fp) (fp - 2)
#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 4)
#define SCM_FRAME_BYTE_CAST(x) ((scm_t_uint8 *) SCM_UNPACK (x))
@@ -71,8 +69,8 @@
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
-#define SCM_FRAME_VARIABLE(fp,i) fp[i]
-#define SCM_FRAME_PROGRAM(fp) fp[-1]
+#define SCM_FRAME_VARIABLE(fp,i) SCM_FRAME_STACK_ADDRESS (fp)[i]
+#define SCM_FRAME_PROGRAM(fp) SCM_FRAME_STACK_ADDRESS (fp)[-1]
/*
@@ -105,12 +103,13 @@ SCM_API SCM scm_vm_frame_p (SCM obj);
SCM_API SCM scm_vm_frame_program (SCM frame);
SCM_API SCM scm_vm_frame_arguments (SCM frame);
SCM_API SCM scm_vm_frame_source (SCM frame);
+SCM_API SCM scm_vm_frame_num_locals (SCM frame);
SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index);
SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
+SCM_API SCM scm_vm_frame_instruction_pointer (SCM frame);
SCM_API SCM scm_vm_frame_return_address (SCM frame);
SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
-SCM_API SCM scm_vm_frame_stack (SCM frame);
SCM_API SCM scm_c_vm_frame_prev (SCM frame);
diff --git a/libguile/gc.c b/libguile/gc.c
index 7c508af..9c56d04 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -680,7 +680,6 @@ scm_init_storage ()
#endif
- scm_stand_in_procs = scm_make_weak_key_hash_table (scm_from_int (257));
scm_protects = scm_c_make_hash_table (31);
return 0;
diff --git a/libguile/modules.c b/libguile/modules.c
index deae23a..c7f0a46 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -46,6 +46,12 @@ static SCM the_module;
static SCM the_root_module_var;
+static SCM unbound_variable (const char *func, SCM sym)
+{
+ scm_error (scm_from_locale_symbol ("unbound-variable"), func,
+ "Unbound variable: ~S", scm_list_1 (sym), SCM_BOOL_F);
+}
+
static SCM
the_root_module ()
{
@@ -740,7 +746,7 @@ scm_module_lookup (SCM module, SCM sym)
var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
if (scm_is_false (var))
- SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
+ unbound_variable (FUNC_NAME, sym);
return var;
}
#undef FUNC_NAME
@@ -757,7 +763,7 @@ scm_lookup (SCM sym)
SCM var =
scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
if (scm_is_false (var))
- scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
+ unbound_variable (NULL, sym);
return var;
}
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 2bb4e60..ab4db3d 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -23,13 +23,9 @@
/* objcode data should be directly mappable to this C structure. */
struct scm_objcode {
- scm_t_uint8 nargs;
- scm_t_uint8 nrest;
- scm_t_uint16 nlocs;
scm_t_uint32 len; /* the maximum index of base[] */
scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of
base[] for metadata */
- scm_t_uint32 unused; /* pad so that `base' is 8-byte aligned */
scm_t_uint8 base[0];
};
@@ -46,9 +42,6 @@ SCM_API scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len)
#define SCM_OBJCODE_META_LEN(x) (SCM_OBJCODE_DATA (x)->metalen)
#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN
(x))
-#define SCM_OBJCODE_NARGS(x) (SCM_OBJCODE_DATA (x)->nargs)
-#define SCM_OBJCODE_NREST(x) (SCM_OBJCODE_DATA (x)->nrest)
-#define SCM_OBJCODE_NLOCS(x) (SCM_OBJCODE_DATA (x)->nlocs)
#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 5054291..c066eca 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -42,6 +42,9 @@
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
+static SCM non_closure_props;
+static scm_i_pthread_mutex_t non_closure_props_lock =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
SCM
scm_i_procedure_arity (SCM proc)
{
@@ -74,10 +77,10 @@ scm_i_procedure_arity (SCM proc)
r = 1;
break;
case scm_tc7_program:
- a += SCM_PROGRAM_DATA (proc)->nargs;
- r = SCM_PROGRAM_DATA (proc)->nrest;
- a -= r;
- break;
+ if (scm_i_program_arity (proc, &a, &o, &r))
+ break;
+ else
+ return SCM_BOOL_F;
case scm_tc7_lsubr_2:
a += 2;
r = 1;
@@ -137,92 +140,99 @@ scm_i_procedure_arity (SCM proc)
return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
}
-/* XXX - instead of using a stand-in value for everything except
- closures, we should find other ways to store the procedure
- properties for those other kinds of procedures. For example, subrs
- have their own property slot, which is unused at present.
-*/
-
-static SCM
-scm_stand_in_scm_proc(SCM proc)
-{
- SCM handle, answer;
- handle = scm_hashq_get_handle (scm_stand_in_procs, proc);
- if (scm_is_false (handle))
- {
- answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL);
- scm_hashq_set_x (scm_stand_in_procs, proc, answer);
- }
- else
- answer = SCM_CDR (handle);
- return answer;
-}
+/* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
+ other means; for example subrs have their own property slot, which is unused
+ at present. */
SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
(SCM proc),
"Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
+ SCM props;
+
SCM_VALIDATE_PROC (1, proc);
- return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
- SCM_PROCPROPS (SCM_CLOSUREP (proc)
- ? proc
- : scm_stand_in_scm_proc (proc)));
+ if (SCM_CLOSUREP (proc))
+ props = SCM_PROCPROPS (proc);
+ else
+ {
+ scm_i_pthread_mutex_lock (&non_closure_props_lock);
+ props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ }
+ return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), props);
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0,
0,
- (SCM proc, SCM new_val),
- "Set @var{obj}'s property list to @var{alist}.")
+ (SCM proc, SCM alist),
+ "Set @var{proc}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_procedure_properties_x
{
- if (!SCM_CLOSUREP (proc))
- proc = scm_stand_in_scm_proc(proc);
- SCM_VALIDATE_CLOSURE (1, proc);
- SCM_SETPROCPROPS (proc, new_val);
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_CLOSUREP (proc))
+ SCM_SETPROCPROPS (proc, alist);
+ else
+ {
+ scm_i_pthread_mutex_lock (&non_closure_props_lock);
+ scm_hashq_set_x (non_closure_props, proc, alist);
+ scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
- (SCM p, SCM k),
- "Return the property of @var{obj} with name @var{key}.")
+ (SCM proc, SCM key),
+ "Return the property of @var{proc} with name @var{key}.")
#define FUNC_NAME s_scm_procedure_property
{
- SCM assoc;
- if (scm_is_eq (k, scm_sym_arity))
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (scm_is_eq (key, scm_sym_arity))
+ /* avoid a cons in this case */
+ return scm_i_procedure_arity (proc);
+ else
{
- SCM arity;
- SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)),
- p, SCM_ARG1, FUNC_NAME);
- return arity;
+ SCM props;
+ if (SCM_CLOSUREP (proc))
+ props = SCM_PROCPROPS (proc);
+ else
+ {
+ scm_i_pthread_mutex_lock (&non_closure_props_lock);
+ props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ }
+ return scm_assq_ref (props, key);
}
- SCM_VALIDATE_PROC (1, p);
- assoc = scm_sloppy_assq (k,
- SCM_PROCPROPS (SCM_CLOSUREP (p)
- ? p
- : scm_stand_in_scm_proc (p)));
- return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
- (SCM p, SCM k, SCM v),
- "In @var{obj}'s property list, set the property named @var{key}
to\n"
- "@var{value}.")
+ (SCM proc, SCM key, SCM val),
+ "In @var{proc}'s property list, set the property named @var{key}
to\n"
+ "@var{val}.")
#define FUNC_NAME s_scm_set_procedure_property_x
{
- SCM assoc;
- if (!SCM_CLOSUREP (p))
- p = scm_stand_in_scm_proc(p);
- SCM_VALIDATE_CLOSURE (1, p);
- if (scm_is_eq (k, scm_sym_arity))
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (scm_is_eq (key, scm_sym_arity))
SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
- assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
- if (SCM_NIMP (assoc))
- SCM_SETCDR (assoc, v);
+
+ if (SCM_CLOSUREP (proc))
+ SCM_SETPROCPROPS (proc,
+ scm_assq_set_x (SCM_PROCPROPS (proc), key, val));
else
- SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
+ {
+ scm_i_pthread_mutex_lock (&non_closure_props_lock);
+ scm_hashq_set_x (non_closure_props, proc,
+ scm_assq_set_x (scm_hashq_ref (non_closure_props, proc,
+ SCM_EOL),
+ key, val));
+ scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ }
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -233,6 +243,7 @@ SCM_DEFINE (scm_set_procedure_property_x,
"set-procedure-property!", 3, 0, 0,
void
scm_init_procprop ()
{
+ non_closure_props = scm_make_doubly_weak_hash_table (SCM_UNDEFINED);
#include "libguile/procprop.x"
}
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 04cd384..7a11314 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -3,7 +3,7 @@
#ifndef SCM_PROCPROP_H
#define SCM_PROCPROP_H
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -35,9 +35,9 @@ SCM_API SCM scm_sym_system_procedure;
SCM_INTERNAL SCM scm_i_procedure_arity (SCM proc);
SCM_API SCM scm_procedure_properties (SCM proc);
-SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM new_val);
-SCM_API SCM scm_procedure_property (SCM p, SCM k);
-SCM_API SCM scm_set_procedure_property_x (SCM p, SCM k, SCM v);
+SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
+SCM_API SCM scm_procedure_property (SCM proc, SCM key);
+SCM_API SCM scm_set_procedure_property_x (SCM proc, SCM key, SCM val);
SCM_INTERNAL void scm_init_procprop (void);
#endif /* SCM_PROCPROP_H */
diff --git a/libguile/procs.c b/libguile/procs.c
index 40d6231..5de2f33 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -144,16 +144,18 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
case scm_tc7_gsubr:
return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
case scm_tc7_program:
- return scm_from_bool (SCM_PROGRAM_DATA (obj)->nargs == 0
- || (SCM_PROGRAM_DATA (obj)->nargs == 1
- && SCM_PROGRAM_DATA (obj)->nrest));
+ {
+ int a, o, r;
+ if (scm_i_program_arity (obj, &a, &o, &r))
+ return scm_from_bool (a == 0);
+ else
+ return SCM_BOOL_F;
+ }
case scm_tc7_pws:
obj = SCM_PROCEDURE (obj);
goto again;
default:
- if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0)
- return SCM_BOOL_T;
- /* otherwise fall through */
+ return SCM_BOOL_F;
}
}
return SCM_BOOL_F;
diff --git a/libguile/programs.c b/libguile/programs.c
index b2bf806..61a0f11 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -102,22 +102,6 @@ SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_arity
-{
- struct scm_objcode *p;
-
- SCM_VALIDATE_PROGRAM (1, program);
-
- p = SCM_PROGRAM_DATA (program);
- return scm_list_3 (SCM_I_MAKINUM (p->nargs),
- SCM_I_MAKINUM (p->nrest),
- SCM_I_MAKINUM (p->nlocs));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
(SCM program),
"")
@@ -209,6 +193,23 @@ SCM_DEFINE (scm_program_sources, "program-sources", 1, 0,
0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_arities
+{
+ SCM meta;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ meta = scm_program_meta (program);
+ if (scm_is_false (meta))
+ return SCM_BOOL_F;
+
+ return scm_caddr (scm_call_0 (meta));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
(SCM program),
"")
@@ -222,7 +223,7 @@ SCM_DEFINE (scm_program_properties, "program-properties",
1, 0, 0,
if (scm_is_false (meta))
return SCM_EOL;
- return scm_cddr (scm_call_0 (meta));
+ return scm_cdddr (scm_call_0 (meta));
}
#undef FUNC_NAME
@@ -281,11 +282,51 @@ SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0,
0,
}
#undef FUNC_NAME
+/* This one is a shim to pre-case-lambda internal interfaces. Avoid it if you
+ can -- use program-arguments or the like. */
+static SCM sym_arglist;
+int
+scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
+{
+ SCM arities, x;
+
+ arities = scm_program_arities (program);
+ if (!scm_is_pair (arities))
+ return 0;
+ /* take the last arglist, it will be least specific */
+ while (scm_is_pair (scm_cdr (arities)))
+ arities = scm_cdr (arities);
+ x = scm_cdar (arities);
+ if (scm_is_pair (x))
+ {
+ *req = scm_to_int (scm_car (x));
+ x = scm_cdr (x);
+ if (scm_is_pair (x))
+ {
+ *opt = scm_to_int (scm_car (x));
+ x = scm_cdr (x);
+ if (scm_is_pair (x))
+ *rest = scm_is_true (scm_car (x));
+ else
+ *rest = 0;
+ }
+ else
+ *opt = *rest = 0;
+ }
+ else
+ *req = *opt = *rest = 0;
+
+ return 1;
+}
+
void
scm_bootstrap_programs (void)
{
+ /* arglist can't be snarfed, because snarfage is only loaded when (system vm
+ program) is loaded. perhaps static-alloc will fix this. */
+ sym_arglist = scm_from_locale_symbol ("arglist");
scm_c_register_extension ("libguile", "scm_init_programs",
(scm_t_extension_init_func)scm_init_programs,
NULL);
}
diff --git a/libguile/programs.h b/libguile/programs.h
index c846c1b..836f1ff 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -40,11 +40,11 @@ SCM_API SCM scm_make_program (SCM objcode, SCM objtable,
SCM free_variables);
SCM_API SCM scm_program_p (SCM obj);
SCM_API SCM scm_program_base (SCM program);
-SCM_API SCM scm_program_arity (SCM program);
SCM_API SCM scm_program_meta (SCM program);
SCM_API SCM scm_program_bindings (SCM program);
SCM_API SCM scm_program_sources (SCM program);
SCM_API SCM scm_program_source (SCM program, SCM ip);
+SCM_API SCM scm_program_arities (SCM program);
SCM_API SCM scm_program_properties (SCM program);
SCM_API SCM scm_program_name (SCM program);
SCM_API SCM scm_program_objects (SCM program);
@@ -54,6 +54,7 @@ SCM_API SCM scm_program_objcode (SCM program);
SCM_API SCM scm_c_program_source (SCM program, size_t ip);
+SCM_INTERNAL int scm_i_program_arity (SCM program, int *req, int *opt, int
*rest);
SCM_INTERNAL void scm_i_program_print (SCM program, SCM port,
scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_programs (void);
diff --git a/libguile/root.h b/libguile/root.h
index 676a7b4..46b9be0 100644
--- a/libguile/root.h
+++ b/libguile/root.h
@@ -3,7 +3,7 @@
#ifndef SCM_ROOT_H
#define SCM_ROOT_H
-/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008, 2009 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -34,13 +34,12 @@
#define scm_nullvect scm_sys_protects[2]
#define scm_nullstr scm_sys_protects[3]
#define scm_keyword_obarray scm_sys_protects[4]
-#define scm_stand_in_procs scm_sys_protects[5]
-#define scm_object_whash scm_sys_protects[6]
-#define scm_asyncs scm_sys_protects[7]
-#define scm_protects scm_sys_protects[8]
-#define scm_properties_whash scm_sys_protects[9]
-#define scm_source_whash scm_sys_protects[10]
-#define SCM_NUM_PROTECTS 11
+#define scm_object_whash scm_sys_protects[5]
+#define scm_asyncs scm_sys_protects[6]
+#define scm_protects scm_sys_protects[7]
+#define scm_properties_whash scm_sys_protects[8]
+#define scm_source_whash scm_sys_protects[9]
+#define SCM_NUM_PROTECTS 10
SCM_API SCM scm_sys_protects[];
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index b373cd0..5d8f655 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -51,7 +51,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
size_t free_vars_count = 0; /* length of FREE_VARS */
SCM *objects = NULL; /* constant objects */
size_t object_count = 0; /* length of OBJECTS */
- SCM *stack_base = vp->stack_base; /* stack base address */
SCM *stack_limit = vp->stack_limit; /* stack limit address */
/* Internal variables */
@@ -108,16 +107,16 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
/* Initial frame */
CACHE_REGISTER ();
PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* ra */
PUSH (0); /* mvra */
+ PUSH ((SCM)ip); /* ra */
CACHE_PROGRAM ();
PUSH (program);
fp = sp + 1;
- INIT_FRAME ();
+ ip = bp->base;
/* MV-call frame, function & arguments */
PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* ra */
PUSH (0); /* mvra */
+ PUSH (0); /* ra */
PUSH (prog);
if (SCM_UNLIKELY (sp + nargs >= stack_limit))
goto vm_error_too_many_args;
@@ -171,6 +170,21 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
finish_args = SCM_EOL;
goto vm_error;
+ vm_error_kwargs_length_not_even:
+ err_msg = scm_from_locale_string ("Bad keyword argument list: odd
length");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_kwargs_invalid_keyword:
+ err_msg = scm_from_locale_string ("Bad keyword argument list: expected
keyword");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_kwargs_unrecognized_keyword:
+ err_msg = scm_from_locale_string ("Bad keyword argument list:
unrecognized keyword");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
vm_error_too_many_args:
err_msg = scm_from_locale_string ("VM: Too many arguments");
finish_args = scm_list_1 (scm_from_int (nargs));
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 3c1bbf6..d693289 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -107,7 +107,6 @@
ip = vp->ip; \
sp = vp->sp; \
fp = vp->fp; \
- stack_base = fp ? SCM_FRAME_UPPER_ADDRESS (fp) - 1 : vp->stack_base; \
}
#define SYNC_REGISTER() \
@@ -256,7 +255,7 @@
goto vm_error_stack_overflow
#define CHECK_UNDERFLOW() \
- if (sp < stack_base) \
+ if (sp < SCM_FRAME_UPPER_ADDRESS (fp)) \
goto vm_error_stack_underflow;
#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
@@ -336,7 +335,6 @@ do { \
#define FETCH() (*ip++)
#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8;
len+=*ip++; } while (0)
-#define FETCH_WIDTH(width) do { width=*ip++; } while (0)
#undef CLOCK
#if VM_USE_CLOCK
@@ -361,46 +359,9 @@ do { \
}
-/*
- * Stack frame
- */
-
-#define INIT_ARGS() \
-{ \
- if (SCM_UNLIKELY (bp->nrest)) \
- { \
- int n = nargs - (bp->nargs - 1); \
- if (n < 0) \
- goto vm_error_wrong_num_args; \
- /* NB, can cause GC while setting up the \
- stack frame */ \
- POP_LIST (n); \
- } \
- else \
- { \
- if (SCM_UNLIKELY (nargs != bp->nargs)) \
- goto vm_error_wrong_num_args; \
- } \
-}
-
/* See frames.h for the layout of stack frames */
/* When this is called, bp points to the new program data,
and the arguments are already on the stack */
-#define INIT_FRAME() \
-{ \
- int i; \
- \
- /* New registers */ \
- sp += bp->nlocs; \
- CHECK_OVERFLOW (); \
- stack_base = sp; \
- ip = bp->base; \
- \
- /* Init local variables */ \
- for (i=bp->nlocs; i;) \
- sp[-(--i)] = SCM_UNDEFINED; \
-}
-
#define DROP_FRAME() \
{ \
sp -= 3; \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index ac237e5..160c231 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -46,14 +46,18 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
}
{
- ASSERT (sp == stack_base);
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
+#ifdef VM_ENABLE_STACK_NULLING
+ SCM *old_sp = sp;
+#endif
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = NULL;
+ /* Setting the ip here doesn't actually affect control flow, as the calling
+ code will restore its own registers, but it does help when walking the
+ stack */
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- NULLSTACK (stack_base - sp);
+ NULLSTACK (old_sp - sp);
}
goto vm_done;
@@ -273,7 +277,28 @@ VM_DEFINE_INSTRUCTION (22, long_local_ref,
"long-local-ref", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (23, variable_ref, "variable-ref", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
+{
+ if (LOCAL_REF (FETCH ()) == SCM_UNDEFINED)
+ PUSH (SCM_BOOL_F);
+ else
+ PUSH (SCM_BOOL_T);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
+{
+ unsigned int i = FETCH ();
+ i <<= 8;
+ i += FETCH ();
+ if (LOCAL_REF (i) == SCM_UNDEFINED)
+ PUSH (SCM_BOOL_F);
+ else
+ PUSH (SCM_BOOL_T);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 0, 1)
{
SCM x = *sp;
@@ -292,7 +317,16 @@ VM_DEFINE_INSTRUCTION (23, variable_ref, "variable-ref",
0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (24, toplevel_ref, "toplevel-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 0, 1)
+{
+ if (VARIABLE_BOUNDP (*sp))
+ *sp = SCM_BOOL_T;
+ else
+ *sp = SCM_BOOL_F;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM what;
@@ -315,7 +349,7 @@ VM_DEFINE_INSTRUCTION (24, toplevel_ref, "toplevel-ref", 1,
0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (25, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -342,14 +376,14 @@ VM_DEFINE_INSTRUCTION (25, long_toplevel_ref,
"long-toplevel-ref", 2, 0, 1)
/* set */
-VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0)
{
LOCAL_SET (FETCH (), *sp);
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (27, long_local_set, "long-local-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -359,14 +393,14 @@ VM_DEFINE_INSTRUCTION (27, long_local_set,
"long-local-set", 2, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 1, 0)
{
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
}
-VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM what;
@@ -385,7 +419,7 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1,
1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (30, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -431,7 +465,7 @@ VM_DEFINE_INSTRUCTION (30, long_toplevel_set,
"long-toplevel-set", 2, 1, 0)
NEXT; \
}
-VM_DEFINE_INSTRUCTION (31, br, "br", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
{
scm_t_int32 offset;
FETCH_OFFSET (offset);
@@ -439,34 +473,34 @@ VM_DEFINE_INSTRUCTION (31, br, "br", 3, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0)
{
BR (!SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
{
BR (SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
{
sp--; /* underflow? */
BR (SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
{
sp--; /* underflow? */
BR (!SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
{
BR (SCM_NULLP (*sp));
}
-VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 3, 0, 0)
+VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
{
BR (!SCM_NULLP (*sp));
}
@@ -476,15 +510,218 @@ VM_DEFINE_INSTRUCTION (37, br_if_not_null,
"br-if-not-null", 3, 0, 0)
* Subprogram call
*/
-VM_DEFINE_INSTRUCTION (38, new_frame, "new-frame", 0, 0, 3)
+VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ scm_t_int32 offset;
+ FETCH_OFFSET (offset);
+ if (sp - (fp - 1) != n)
+ ip += offset;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ scm_t_int32 offset;
+ FETCH_OFFSET (offset);
+ if (sp - (fp - 1) < n)
+ ip += offset;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ scm_t_int32 offset;
+ FETCH_OFFSET (offset);
+ if (sp - (fp - 1) > n)
+ ip += offset;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ if (sp - (fp - 1) != n)
+ goto vm_error_wrong_num_args;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ if (sp - (fp - 1) < n)
+ goto vm_error_wrong_num_args;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ while (sp - (fp - 1) < n)
+ PUSH (SCM_UNDEFINED);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle",
6, -1, -1)
+{
+ SCM *walk;
+ scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
+ nreq = FETCH () << 8;
+ nreq += FETCH ();
+ nreq_and_opt = FETCH () << 8;
+ nreq_and_opt += FETCH ();
+ ntotal = FETCH () << 8;
+ ntotal += FETCH ();
+
+ /* look in optionals for first keyword or last positional */
+ /* starting after the last required positional arg */
+ walk = fp + nreq;
+ while (/* while we have args */
+ walk <= sp
+ /* and we still have positionals to fill */
+ && walk - fp < nreq_and_opt
+ /* and we haven't reached a keyword yet */
+ && !scm_is_keyword (*walk))
+ /* bind this optional arg (by leaving it in place) */
+ walk++;
+ /* now shuffle up, from walk to ntotal */
+ {
+ scm_t_ptrdiff nshuf = sp - walk + 1, i;
+ sp = (fp - 1) + ntotal + nshuf;
+ CHECK_OVERFLOW ();
+ for (i = 0; i < nshuf; i++)
+ sp[-i] = walk[nshuf-i-1];
+ }
+ /* and fill optionals & keyword args with SCM_UNDEFINED */
+ while (walk <= (fp - 1) + ntotal)
+ *walk++ = SCM_UNDEFINED;
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
+{
+ scm_t_uint16 idx;
+ scm_t_ptrdiff nkw;
+ int allow_other_keys_and_rest;
+ SCM kw;
+ idx = FETCH () << 8;
+ idx += FETCH ();
+ nkw = FETCH () << 8;
+ nkw += FETCH ();
+ allow_other_keys_and_rest = FETCH ();
+
+ if (!(allow_other_keys_and_rest & 2)
+ &&(sp - (fp - 1) - nkw) % 2)
+ goto vm_error_kwargs_length_not_even;
+
+ CHECK_OBJECT (idx);
+ kw = OBJECT_REF (idx);
+ /* switch nkw to be a negative index below sp */
+ for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw += 2)
+ {
+ SCM walk;
+ if (!scm_is_keyword (sp[nkw]))
+ {
+ if (allow_other_keys_and_rest & 2)
+ /* reached the end of keywords, but we have a rest arg; just cut
+ out */
+ break;
+ else
+ goto vm_error_kwargs_invalid_keyword;
+ }
+ for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
+ {
+ if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
+ {
+ SCM si = SCM_CDAR (walk);
+ LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
+ sp[nkw + 1]);
+ break;
+ }
+ }
+ if (!(allow_other_keys_and_rest & 1) && !scm_is_pair (walk))
+ goto vm_error_kwargs_unrecognized_keyword;
+ }
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1)
+{
+ scm_t_ptrdiff n;
+ SCM rest = SCM_EOL;
+ n = FETCH () << 8;
+ n += FETCH ();
+ while (sp - (fp - 1) > n)
+ /* No need to check for underflow. */
+ CONS (rest, *sp--, rest);
+ PUSH (rest);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1)
+{
+ scm_t_ptrdiff n;
+ scm_t_uint32 i;
+ SCM rest = SCM_EOL;
+ n = FETCH () << 8;
+ n += FETCH ();
+ i = FETCH () << 8;
+ i += FETCH ();
+ while (sp - (fp - 1) > n)
+ /* No need to check for underflow. */
+ CONS (rest, *sp--, rest);
+ LOCAL_SET (i, rest);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1)
+{
+ SCM *old_sp;
+ scm_t_int32 n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ old_sp = sp;
+ sp = (fp - 1) + n;
+
+ if (old_sp < sp)
+ {
+ CHECK_OVERFLOW ();
+ while (old_sp < sp)
+ *++old_sp = SCM_UNDEFINED;
+ }
+ else
+ NULLSTACK (old_sp - sp);
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3)
{
+ /* NB: if you change this, see frames.c:vm-frame-num-locals */
+ /* and frames.h, vm-engine.c, etc of course */
PUSH ((SCM)fp); /* dynamic link */
PUSH (0); /* mvra */
PUSH (0); /* ra */
NEXT;
}
-VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
@@ -502,13 +739,12 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
{
program = x;
CACHE_PROGRAM ();
- INIT_ARGS ();
- fp = sp - bp->nargs + 1;
+ fp = sp - nargs + 1;
ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
- INIT_FRAME ();
+ ip = bp->base;
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
@@ -546,7 +782,7 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
@@ -563,7 +799,8 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
{
int i;
#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp;
+ SCM *old_sp = sp;
+ CHECK_STACK_LEAK ();
#endif
EXIT_HOOK ();
@@ -571,22 +808,15 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1,
1)
/* switch programs */
program = x;
CACHE_PROGRAM ();
- INIT_ARGS ();
-
-#ifdef VM_ENABLE_STACK_NULLING
- old_sp = sp;
- CHECK_STACK_LEAK ();
-#endif
+ /* shuffle down the program and the arguments */
+ for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
+ SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
- /* delay shuffling the new program+args down so that if INIT_ARGS had to
- cons up a rest arg, going into GC, the stack still made sense */
- for (i = -1, sp = sp - bp->nargs + 1; i < bp->nargs; i++)
- fp[i] = sp[i];
sp = fp + i - 1;
NULLSTACK (old_sp - sp);
- INIT_FRAME ();
+ ip = bp->base;
ENTER_HOOK ();
APPLY_HOOK ();
@@ -625,7 +855,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (55, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -634,7 +864,7 @@ VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0,
1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (56, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -643,7 +873,7 @@ VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0,
1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 4, -1, 1)
+VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1)
{
SCM x;
scm_t_int32 offset;
@@ -662,13 +892,12 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 4, -1, 1)
{
program = x;
CACHE_PROGRAM ();
- INIT_ARGS ();
- fp = sp - bp->nargs + 1;
+ fp = sp - nargs + 1;
ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
- INIT_FRAME ();
+ ip = bp->base;
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
@@ -706,7 +935,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 4, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (58, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -725,7 +954,7 @@ VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (59, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -744,7 +973,7 @@ VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1,
1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (60, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -781,7 +1010,7 @@ VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (61, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -813,7 +1042,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (62, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
@@ -824,20 +1053,19 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
SCM ret;
POP (ret);
- ASSERT (sp == stack_base);
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
+
+#ifdef VM_ENABLE_STACK_NULLING
+ SCM *old_sp = sp;
+#endif
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp);
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- {
+
#ifdef VM_ENABLE_STACK_NULLING
- int nullcount = stack_base - sp;
+ NULLSTACK (old_sp - sp);
#endif
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
- NULLSTACK (nullcount);
- }
/* Set return value (sp is already pushed) */
*sp = ret;
@@ -850,7 +1078,7 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (63, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say.
*/
@@ -859,11 +1087,10 @@ VM_DEFINE_INSTRUCTION (49, return_values,
"return/values", 1, -1, -1)
EXIT_HOOK ();
RETURN_HOOK ();
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
-
- /* data[1] is the mv return address */
if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
{
+ /* A multiply-valued continuation */
+ SCM *vals = sp - nvalues;
int i;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
@@ -872,12 +1099,11 @@ VM_DEFINE_INSTRUCTION (49, return_values,
"return/values", 1, -1, -1)
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
- *++sp = stack_base[1+i];
+ *++sp = vals[i+1];
*++sp = SCM_I_MAKINUM (nvalues);
- /* Finally set new stack_base */
- NULLSTACK (stack_base - sp + nvalues + 1);
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ /* Finally null the end of the stack */
+ NULLSTACK (vals + nvalues - sp);
}
else if (nvalues >= 1)
{
@@ -885,17 +1111,17 @@ VM_DEFINE_INSTRUCTION (49, return_values,
"return/values", 1, -1, -1)
break with guile tradition and try and do something sensible. (Also,
this block handles the single-valued return to an mv
continuation.) */
+ SCM *vals = sp - nvalues;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
/* Push first value */
- *++sp = stack_base[1];
+ *++sp = vals[1];
- /* Finally set new stack_base */
- NULLSTACK (stack_base - sp + nvalues + 1);
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ /* Finally null the end of the stack */
+ NULLSTACK (vals + nvalues - sp);
}
else
goto vm_error_no_values;
@@ -907,7 +1133,7 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values",
1, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (64, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -930,7 +1156,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star,
"return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (65, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -953,7 +1179,7 @@ VM_DEFINE_INSTRUCTION (51, truncate_values,
"truncate-values", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (52, box, "box", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (66, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@@ -967,7 +1193,7 @@ VM_DEFINE_INSTRUCTION (52, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
-VM_DEFINE_INSTRUCTION (53, empty_box, "empty-box", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (67, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@@ -975,7 +1201,7 @@ VM_DEFINE_INSTRUCTION (53, empty_box, "empty-box", 1, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (54, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (68, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@@ -983,7 +1209,7 @@ VM_DEFINE_INSTRUCTION (54, local_boxed_ref,
"local-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (55, local_boxed_set, "local-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (69, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@@ -993,7 +1219,7 @@ VM_DEFINE_INSTRUCTION (55, local_boxed_set,
"local-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (56, free_ref, "free-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (70, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@@ -1004,7 +1230,7 @@ VM_DEFINE_INSTRUCTION (56, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
-VM_DEFINE_INSTRUCTION (57, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (71, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@@ -1015,7 +1241,7 @@ VM_DEFINE_INSTRUCTION (57, free_boxed_ref,
"free-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (58, free_boxed_set, "free-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (72, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@@ -1027,7 +1253,7 @@ VM_DEFINE_INSTRUCTION (58, free_boxed_set,
"free-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure", 0, 2, 1)
+VM_DEFINE_INSTRUCTION (73, make_closure, "make-closure", 0, 2, 1)
{
SCM vect;
POP (vect);
@@ -1038,7 +1264,7 @@ VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure",
0, 2, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (60, make_variable, "make-variable", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (74, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@@ -1046,7 +1272,7 @@ VM_DEFINE_INSTRUCTION (60, make_variable,
"make-variable", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (61, fix_closure, "fix-closure", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (75, fix_closure, "fix-closure", 2, 0, 1)
{
SCM x, vect;
unsigned int i = FETCH ();
@@ -1060,7 +1286,7 @@ VM_DEFINE_INSTRUCTION (61, fix_closure, "fix-closure", 2,
0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (62, define, "define", 0, 0, 2)
+VM_DEFINE_INSTRUCTION (76, define, "define", 0, 0, 2)
{
SCM sym, val;
POP (sym);
@@ -1072,7 +1298,7 @@ VM_DEFINE_INSTRUCTION (62, define, "define", 0, 0, 2)
NEXT;
}
-VM_DEFINE_INSTRUCTION (63, make_keyword, "make-keyword", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (77, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1080,7 +1306,7 @@ VM_DEFINE_INSTRUCTION (63, make_keyword, "make-keyword",
0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (64, make_symbol, "make-symbol", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (78, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
diff --git a/libguile/vm.c b/libguile/vm.c
index cd73051..df02f05 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -191,12 +191,8 @@ really_make_boot_program (long nargs)
bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
memcpy (bp->base, text, sizeof (text));
- bp->nargs = 0;
- bp->nrest = 0;
- bp->nlocs = 0;
bp->len = sizeof(text);
bp->metalen = 0;
- bp->unused = 0;
u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
sizeof (struct scm_objcode) + sizeof (text));
diff --git a/module/ice-9/optargs.scm b/module/ice-9/optargs.scm
index 3093e15..db639c5 100644
--- a/module/ice-9/optargs.scm
+++ b/module/ice-9/optargs.scm
@@ -1,6 +1,6 @@
;;;; optargs.scm -- support for optional arguments
;;;;
-;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009 Free
Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -58,14 +58,16 @@
;;; Code:
(define-module (ice-9 optargs)
- :export-syntax (let-optional
- let-optional*
- let-keywords
- let-keywords*
- define* lambda*
- define*-public
- defmacro*
- defmacro*-public))
+ #:use-module (system base pmatch)
+ #:re-export (lambda*)
+ #:export (let-optional
+ let-optional*
+ let-keywords
+ let-keywords*
+ define*
+ define*-public
+ defmacro*
+ defmacro*-public))
;; let-optional rest-arg (binding ...) . body
;; let-optional* rest-arg (binding ...) . body
@@ -83,12 +85,52 @@
;; bound to whatever may have been left of rest-arg.
;;
-(defmacro let-optional (REST-ARG BINDINGS . BODY)
- (let-optional-template REST-ARG BINDINGS BODY 'let))
-
-(defmacro let-optional* (REST-ARG BINDINGS . BODY)
- (let-optional-template REST-ARG BINDINGS BODY 'let*))
-
+(define (vars&inits bindings)
+ (let lp ((bindings bindings) (vars '()) (inits '()))
+ (syntax-case bindings ()
+ (()
+ (values (reverse vars) (reverse inits)))
+ (((v init) . rest) (identifier? #'v)
+ (lp #'rest (cons #'v vars) (cons #'init inits)))
+ ((v . rest) (identifier? #'v)
+ (lp #'rest (cons #'v vars) (cons #'#f inits))))))
+
+(define-syntax let-optional
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (n+1 (1+ (length vars)))
+ (vars (append vars (list #'rest-arg)))
+ ((t ...) (generate-temporaries vars))
+ ((i ...) inits))
+ #'(let ((t (lambda vars i))
+ ...)
+ (apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 n n n+1 #f '())
+ (list t ...)
+ #f
+ rest-arg)
+ (error "sth" rest-arg)))))))))))
+
+(define-syntax let-optional*
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (n+1 (1+ (length vars)))
+ (vars (append vars (list #'rest-arg)))
+ ((i ...) inits))
+ #'(apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 n n n+1 #f '())
+ (list (lambda vars i) ...)
+ #f
+ rest-arg)
+ (error "sth" rest-arg))))))))))
;; let-keywords rest-arg allow-other-keys? (binding ...) . body
@@ -106,82 +148,52 @@
;;
-(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
- (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))
-
-(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
- (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))
-
-
-;; some utility procedures for implementing the various let-forms.
-
-(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
- (let ((bindings (map (lambda (x)
- (if (list? x)
- x
- (list x #f)))
- BINDINGS)))
- `(,let-type ,(map proc bindings) ,@BODY)))
-
-(define (let-optional-template REST-ARG BINDINGS BODY let-type)
- (if (null? BINDINGS)
- `(let () ,@BODY)
- (let-o-k-template REST-ARG BINDINGS BODY let-type
- (lambda (optional)
- `(,(car optional)
- (cond
- ((not (null? ,REST-ARG))
- (let ((result (car ,REST-ARG)))
- ,(list 'set! REST-ARG
- `(cdr ,REST-ARG))
- result))
- (else
- ,(cadr optional))))))))
-
-(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY
let-type)
- (if (null? BINDINGS)
- `(let () ,@BODY)
- (let* ((kb-list-gensym (gensym "kb:G"))
- (bindfilter (lambda (key)
- `(,(car key)
- (cond
- ((assq ',(car key) ,kb-list-gensym)
- => cdr)
- (else
- ,(cadr key)))))))
- `(let ((,kb-list-gensym ((@@ (ice-9 optargs)
rest-arg->keyword-binding-list)
- ,REST-ARG ',(map (lambda (x)
(symbol->keyword (if (pair? x) (car x) x)))
- BINDINGS)
- ,ALLOW-OTHER-KEYS?)))
- ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))
-
-
-(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
- (if (null? rest-arg)
- '()
- (let loop ((first (car rest-arg))
- (rest (cdr rest-arg))
- (accum '()))
- (let ((next (lambda (a)
- (if (null? (cdr rest))
- a
- (loop (cadr rest) (cddr rest) a)))))
- (if (keyword? first)
- (cond
- ((memq first keywords)
- (if (null? rest)
- (error "Keyword argument has no value.")
- (next (cons (cons (keyword->symbol first)
- (car rest)) accum))))
- ((not allow-other-keys?)
- (error "Unknown keyword in arguments."))
- (else (if (null? rest)
- accum
- (next accum))))
- (if (null? rest)
- accum
- (loop (car rest) (cdr rest) accum)))))))
-
+(define-syntax let-keywords
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (vars vars)
+ ((kw ...) (map symbol->keyword
+ (map syntax->datum vars)))
+ ((idx ...) (iota (length vars)))
+ ((t ...) (generate-temporaries vars))
+ ((i ...) inits))
+ #'(let ((t (lambda vars i))
+ ...)
+ (apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
+ (list t ...)
+ #f
+ rest-arg)
+ (error "sth" rest-arg))))))))
+ ((_ rest-arg aok (binding ...) b0 b1 ...)
+ #'(let ((r rest-arg))
+ (let-keywords r aok (binding ...) b0 b1 ...))))))
+
+(define-syntax let-keywords*
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (vars vars)
+ ((kw ...) (map symbol->keyword
+ (map syntax->datum vars)))
+ ((idx ...) (iota (length vars)))
+ ((i ...) inits))
+ #'(apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
+ (list (lambda vars i) ...)
+ #f
+ rest-arg)
+ (error "sth" rest-arg)))))))
+ ((_ rest-arg aok (binding ...) b0 b1 ...)
+ #'(let ((r rest-arg))
+ (let-keywords* r aok (binding ...) b0 b1 ...))))))
;; lambda* args . body
;; lambda extended for optional and keyword arguments
@@ -230,132 +242,6 @@
;; Lisp dialects.
-(defmacro lambda* (ARGLIST . BODY)
- (parse-arglist
- ARGLIST
- (lambda (non-optional-args optionals keys aok? rest-arg)
- ;; Check for syntax errors.
- (if (not (every? symbol? non-optional-args))
- (error "Syntax error in fixed argument declaration."))
- (if (not (every? ext-decl? optionals))
- (error "Syntax error in optional argument declaration."))
- (if (not (every? ext-decl? keys))
- (error "Syntax error in keyword argument declaration."))
- (if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
- (error "Syntax error in rest argument declaration."))
- ;; generate the code.
- (let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
- (lambda-gensym (gensym "lambda*:L")))
- (if (not (and (null? optionals) (null? keys)))
- `(let ((,lambda-gensym
- (lambda (,@non-optional-args . ,rest-gensym)
- ;; Make sure that if the proc had a docstring, we put it
- ;; here where it will be visible.
- ,@(if (and (not (null? BODY))
- (string? (car BODY)))
- (list (car BODY))
- '())
- (let-optional*
- ,rest-gensym
- ,optionals
- (let-keywords* ,rest-gensym
- ,aok?
- ,keys
- ,@(if (and (not rest-arg) (null? keys))
- `((if (not (null? ,rest-gensym))
- (error "Too many arguments.")))
- '())
- (let ()
- ,@BODY))))))
- (set-procedure-property! ,lambda-gensym 'arglist
- '(,non-optional-args
- ,optionals
- ,keys
- ,aok?
- ,rest-arg))
- ,lambda-gensym)
- `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
- ,@BODY))))))
-
-
-(define (every? pred lst)
- (or (null? lst)
- (and (pred (car lst))
- (every? pred (cdr lst)))))
-
-(define (ext-decl? obj)
- (or (symbol? obj)
- (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
-
-;; XXX - not tail recursive
-(define (improper-list-copy obj)
- (if (pair? obj)
- (cons (car obj) (improper-list-copy (cdr obj)))
- obj))
-
-(define (parse-arglist arglist cont)
- (define (split-list-at val lst cont)
- (cond
- ((memq val lst)
- => (lambda (pos)
- (if (memq val (cdr pos))
- (error (with-output-to-string
- (lambda ()
- (map display `(,val
- " specified more than once in argument
list.")))))
- (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
- (else (cont lst '() #f))))
- (define (parse-opt-and-fixed arglist keys aok? rest cont)
- (split-list-at
- #:optional arglist
- (lambda (before after split?)
- (if (and split? (null? after))
- (error "#:optional specified but no optional arguments declared.")
- (cont before after keys aok? rest)))))
- (define (parse-keys arglist rest cont)
- (split-list-at
- #:allow-other-keys arglist
- (lambda (aok-before aok-after aok-split?)
- (if (and aok-split? (not (null? aok-after)))
- (error "#:allow-other-keys not at end of keyword argument
declarations.")
- (split-list-at
- #:key aok-before
- (lambda (key-before key-after key-split?)
- (cond
- ((and aok-split? (not key-split?))
- (error "#:allow-other-keys specified but no keyword arguments
declared."))
- (key-split?
- (cond
- ((null? key-after) (error "#:key specified but no keyword
arguments declared."))
- ((memq #:optional key-after) (error "#:optional arguments
declared after #:key arguments."))
- (else (parse-opt-and-fixed key-before key-after aok-split?
rest cont))))
- (else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
- (define (parse-rest arglist cont)
- (cond
- ((null? arglist) (cont '() '() '() #f #f))
- ((not (pair? arglist)) (cont '() '() '() #f arglist))
- ((not (list? arglist))
- (let* ((copy (improper-list-copy arglist))
- (lp (last-pair copy))
- (ra (cdr lp)))
- (set-cdr! lp '())
- (if (memq #:rest copy)
- (error "Cannot specify both #:rest and dotted rest argument.")
- (parse-keys copy ra cont))))
- (else (split-list-at
- #:rest arglist
- (lambda (before after split?)
- (if split?
- (case (length after)
- ((0) (error "#:rest not followed by argument."))
- ((1) (parse-keys before (car after) cont))
- (else (error "#:rest argument must be declared last.")))
- (parse-keys before #f cont)))))))
-
- (parse-rest arglist cont))
-
-
-
;; define* args . body
;; define*-public args . body
;; define and define-public extended for optional and keyword arguments
@@ -363,6 +249,7 @@
;; define* and define*-public support optional arguments with
;; a similar syntax to lambda*. They also support arbitrary-depth
;; currying, just like Guile's define. Some examples:
+;; XXXX
;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
;; defines a procedure x with a fixed argument y, an optional agument
;; a, another optional argument z with default value 3, a keyword argument w,
@@ -375,28 +262,15 @@
;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
;; in the same way as lambda*.
-(defmacro define* (ARGLIST . BODY)
- (define*-guts 'define ARGLIST BODY))
-
-(defmacro define*-public (ARGLIST . BODY)
- (define*-guts 'define-public ARGLIST BODY))
-
-;; The guts of define* and define*-public.
-(define (define*-guts DT ARGLIST BODY)
- (define (nest-lambda*s arglists)
- (if (null? arglists)
- BODY
- `((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
- (define (define*-guts-helper ARGLIST arglists)
- (let ((first (car ARGLIST))
- (al (cons (cdr ARGLIST) arglists)))
- (if (symbol? first)
- `(,DT ,first ,@(nest-lambda*s al))
- (define*-guts-helper first al))))
- (if (symbol? ARGLIST)
- `(,DT ,ARGLIST ,@BODY)
- (define*-guts-helper ARGLIST '())))
+(define-syntax define*
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (define id (lambda* args b0 b1 ...)))))
+(define-syntax define*-public
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (define-public id (lambda* args b0 b1 ...)))))
;; defmacro* name args . body
@@ -409,12 +283,92 @@
;; semantics. Here is an example of a macro with an optional argument:
;; (defmacro* transmorgify (a #:optional b)
-(defmacro defmacro* (NAME ARGLIST . BODY)
- `(define-macro ,NAME #f (lambda* ,ARGLIST ,@BODY)))
-
-(defmacro defmacro*-public (NAME ARGLIST . BODY)
- `(begin
- (defmacro* ,NAME ,ARGLIST ,@BODY)
- (export-syntax ,NAME)))
-
-;;; optargs.scm ends here
+(define-syntax defmacro*
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (defmacro id (lambda* args b0 b1 ...)))))
+(define-syntax defmacro*-public
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (begin
+ (defmacro id (lambda* args b0 b1 ...))
+ (export-syntax id)))))
+
+;;; Support for optional & keyword args with the interpreter.
+(define *uninitialized* (list 'uninitialized))
+(define (parse-lambda-case spec inits predicate args)
+ (pmatch spec
+ ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
+ (define (req args prev tail n)
+ (cond
+ ((zero? n)
+ (if prev (set-cdr! prev '()))
+ (let ((slots-tail (make-list (- nargs nreq) *uninitialized*)))
+ (opt (if prev (append! args slots-tail) slots-tail)
+ slots-tail tail nopt inits)))
+ ((null? tail)
+ #f) ;; fail
+ (else
+ (req args tail (cdr tail) (1- n)))))
+ (define (opt slots slots-tail args-tail n inits)
+ (cond
+ ((zero? n)
+ (rest-or-key slots slots-tail args-tail inits rest-idx))
+ ((null? args-tail)
+ (set-car! slots-tail (apply (car inits) slots))
+ (opt slots (cdr slots-tail) '() (1- n) (cdr inits)))
+ (else
+ (set-car! slots-tail (car args-tail))
+ (opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits)))))
+ (define (rest-or-key slots slots-tail args-tail inits rest-idx)
+ (cond
+ (rest-idx
+ ;; it has to be this way, vars are allocated in this order
+ (set-car! slots-tail args-tail)
+ (if (pair? kw-indices)
+ (key slots (cdr slots-tail) args-tail inits)
+ (rest-or-key slots (cdr slots-tail) '() inits #f)))
+ ((pair? kw-indices)
+ ;; fail early here, because once we're in keyword land we throw
+ ;; errors instead of failing
+ (and (or (null? args-tail) rest-idx (keyword? (car args-tail)))
+ (key slots slots-tail args-tail inits)))
+ ((pair? args-tail)
+ #f) ;; fail
+ (else
+ (pred slots))))
+ (define (key slots slots-tail args-tail inits)
+ (cond
+ ((null? args-tail)
+ (if (null? inits)
+ (pred slots)
+ (begin
+ (if (eq? (car slots-tail) *uninitialized*)
+ (set-car! slots-tail (apply (car inits) slots)))
+ (key slots (cdr slots-tail) '() (cdr inits)))))
+ ((not (keyword? (car args-tail)))
+ (if rest-idx
+ ;; no error checking, everything goes to the rest..
+ (key slots slots-tail '() inits)
+ (error "bad keyword argument list" args-tail)))
+ ((and (keyword? (car args-tail))
+ (pair? (cdr args-tail))
+ (assq-ref kw-indices (car args-tail)))
+ => (lambda (i)
+ (list-set! slots i (cadr args-tail))
+ (key slots slots-tail (cddr args-tail) inits)))
+ ((and (keyword? (car args-tail))
+ (pair? (cdr args-tail))
+ allow-other-keys?)
+ (key slots slots-tail (cddr args-tail) inits))
+ (else (error "unrecognized keyword" args-tail))))
+ (define (pred slots)
+ (cond
+ (predicate
+ (if (apply predicate slots)
+ slots
+ #f))
+ (else slots)))
+ (let ((args (list-copy args)))
+ (req args #f args nreq)))
+ (else (error "unexpected spec" spec))))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index a505744..5d68bb6 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2,18 +2,18 @@
(if #f #f)
(letrec ((#{and-map*\ 31}#
- (lambda (#{f\ 71}# #{first\ 70}# . #{rest\ 69}#)
+ (lambda (#{f\ 69}# #{first\ 70}# . #{rest\ 71}#)
(let ((#{t\ 72}# (null? #{first\ 70}#)))
(if #{t\ 72}#
#{t\ 72}#
- (if (null? #{rest\ 69}#)
+ (if (null? #{rest\ 71}#)
(letrec ((#{andmap\ 73}#
(lambda (#{first\ 74}#)
(let ((#{x\ 75}# (car #{first\ 74}#))
(#{first\ 76}# (cdr #{first\ 74}#)))
(if (null? #{first\ 76}#)
- (#{f\ 71}# #{x\ 75}#)
- (if (#{f\ 71}# #{x\ 75}#)
+ (#{f\ 69}# #{x\ 75}#)
+ (if (#{f\ 69}# #{x\ 75}#)
(#{andmap\ 73}# #{first\ 76}#)
#f))))))
(#{andmap\ 73}# #{first\ 70}#))
@@ -24,102 +24,102 @@
(#{first\ 82}# (cdr #{first\ 78}#))
(#{rest\ 83}# (map cdr #{rest\ 79}#)))
(if (null? #{first\ 82}#)
- (apply #{f\ 71}#
+ (apply #{f\ 69}#
(cons #{x\ 80}# #{xr\ 81}#))
- (if (apply #{f\ 71}#
+ (if (apply #{f\ 69}#
(cons #{x\ 80}# #{xr\ 81}#))
(#{andmap\ 77}#
#{first\ 82}#
#{rest\ 83}#)
#f))))))
- (#{andmap\ 77}# #{first\ 70}# #{rest\ 69}#))))))))
- (letrec ((#{lambda-var-list\ 177}#
- (lambda (#{vars\ 301}#)
- (letrec ((#{lvl\ 302}#
- (lambda (#{vars\ 303}# #{ls\ 304}# #{w\ 305}#)
- (if (pair? #{vars\ 303}#)
- (#{lvl\ 302}#
- (cdr #{vars\ 303}#)
- (cons (#{wrap\ 157}#
- (car #{vars\ 303}#)
- #{w\ 305}#
+ (#{andmap\ 77}# #{first\ 70}# #{rest\ 71}#))))))))
+ (letrec ((#{lambda-var-list\ 178}#
+ (lambda (#{vars\ 302}#)
+ (letrec ((#{lvl\ 303}#
+ (lambda (#{vars\ 304}# #{ls\ 305}# #{w\ 306}#)
+ (if (pair? #{vars\ 304}#)
+ (#{lvl\ 303}#
+ (cdr #{vars\ 304}#)
+ (cons (#{wrap\ 159}#
+ (car #{vars\ 304}#)
+ #{w\ 306}#
#f)
- #{ls\ 304}#)
- #{w\ 305}#)
- (if (#{id?\ 129}# #{vars\ 303}#)
- (cons (#{wrap\ 157}#
- #{vars\ 303}#
- #{w\ 305}#
+ #{ls\ 305}#)
+ #{w\ 306}#)
+ (if (#{id?\ 131}# #{vars\ 304}#)
+ (cons (#{wrap\ 159}#
+ #{vars\ 304}#
+ #{w\ 306}#
#f)
- #{ls\ 304}#)
- (if (null? #{vars\ 303}#)
- #{ls\ 304}#
- (if (#{syntax-object?\ 113}# #{vars\ 303}#)
- (#{lvl\ 302}#
- (#{syntax-object-expression\ 114}#
- #{vars\ 303}#)
- #{ls\ 304}#
- (#{join-wraps\ 148}#
- #{w\ 305}#
- (#{syntax-object-wrap\ 115}#
- #{vars\ 303}#)))
- (cons #{vars\ 303}# #{ls\ 304}#))))))))
- (#{lvl\ 302}#
- #{vars\ 301}#
+ #{ls\ 305}#)
+ (if (null? #{vars\ 304}#)
+ #{ls\ 305}#
+ (if (#{syntax-object?\ 115}# #{vars\ 304}#)
+ (#{lvl\ 303}#
+ (#{syntax-object-expression\ 116}#
+ #{vars\ 304}#)
+ #{ls\ 305}#
+ (#{join-wraps\ 150}#
+ #{w\ 306}#
+ (#{syntax-object-wrap\ 117}#
+ #{vars\ 304}#)))
+ (cons #{vars\ 304}# #{ls\ 305}#))))))))
+ (#{lvl\ 303}#
+ #{vars\ 302}#
'()
'(())))))
- (#{gen-var\ 176}#
- (lambda (#{id\ 306}#)
- (let ((#{id\ 307}#
- (if (#{syntax-object?\ 113}# #{id\ 306}#)
- (#{syntax-object-expression\ 114}# #{id\ 306}#)
- #{id\ 306}#)))
+ (#{gen-var\ 177}#
+ (lambda (#{id\ 307}#)
+ (let ((#{id\ 308}#
+ (if (#{syntax-object?\ 115}# #{id\ 307}#)
+ (#{syntax-object-expression\ 116}# #{id\ 307}#)
+ #{id\ 307}#)))
(gensym
- (string-append (symbol->string #{id\ 307}#) " ")))))
- (#{strip\ 175}#
- (lambda (#{x\ 308}# #{w\ 309}#)
+ (string-append (symbol->string #{id\ 308}#) " ")))))
+ (#{strip\ 176}#
+ (lambda (#{x\ 309}# #{w\ 310}#)
(if (memq 'top
- (#{wrap-marks\ 132}# #{w\ 309}#))
- #{x\ 308}#
- (letrec ((#{f\ 310}# (lambda (#{x\ 311}#)
- (if (#{syntax-object?\ 113}#
- #{x\ 311}#)
- (#{strip\ 175}#
- (#{syntax-object-expression\ 114}#
- #{x\ 311}#)
- (#{syntax-object-wrap\ 115}#
- #{x\ 311}#))
- (if (pair? #{x\ 311}#)
- (let ((#{a\ 312}# (#{f\ 310}# (car
#{x\ 311}#)))
- (#{d\ 313}# (#{f\ 310}# (cdr
#{x\ 311}#))))
- (if (if (eq? #{a\ 312}#
- (car #{x\ 311}#))
- (eq? #{d\ 313}#
- (cdr #{x\ 311}#))
+ (#{wrap-marks\ 134}# #{w\ 310}#))
+ #{x\ 309}#
+ (letrec ((#{f\ 311}# (lambda (#{x\ 312}#)
+ (if (#{syntax-object?\ 115}#
+ #{x\ 312}#)
+ (#{strip\ 176}#
+ (#{syntax-object-expression\ 116}#
+ #{x\ 312}#)
+ (#{syntax-object-wrap\ 117}#
+ #{x\ 312}#))
+ (if (pair? #{x\ 312}#)
+ (let ((#{a\ 313}# (#{f\ 311}# (car
#{x\ 312}#)))
+ (#{d\ 314}# (#{f\ 311}# (cdr
#{x\ 312}#))))
+ (if (if (eq? #{a\ 313}#
+ (car #{x\ 312}#))
+ (eq? #{d\ 314}#
+ (cdr #{x\ 312}#))
#f)
- #{x\ 311}#
- (cons #{a\ 312}# #{d\ 313}#)))
- (if (vector? #{x\ 311}#)
- (let ((#{old\ 314}#
+ #{x\ 312}#
+ (cons #{a\ 313}# #{d\ 314}#)))
+ (if (vector? #{x\ 312}#)
+ (let ((#{old\ 315}#
(vector->list
- #{x\ 311}#)))
- (let ((#{new\ 315}#
- (map #{f\ 310}#
- #{old\ 314}#)))
+ #{x\ 312}#)))
+ (let ((#{new\ 316}#
+ (map #{f\ 311}#
+ #{old\ 315}#)))
(if (#{and-map*\ 31}#
eq?
- #{old\ 314}#
- #{new\ 315}#)
- #{x\ 311}#
+ #{old\ 315}#
+ #{new\ 316}#)
+ #{x\ 312}#
(list->vector
- #{new\ 315}#))))
- #{x\ 311}#))))))
- (#{f\ 310}# #{x\ 308}#)))))
- (#{ellipsis?\ 174}#
- (lambda (#{x\ 316}#)
- (if (#{nonsymbol-id?\ 128}# #{x\ 316}#)
- (#{free-id=?\ 152}#
- #{x\ 316}#
+ #{new\ 316}#))))
+ #{x\ 312}#))))))
+ (#{f\ 311}# #{x\ 309}#)))))
+ (#{ellipsis?\ 175}#
+ (lambda (#{x\ 317}#)
+ (if (#{nonsymbol-id?\ 130}# #{x\ 317}#)
+ (#{free-id=?\ 154}#
+ #{x\ 317}#
'#(syntax-object
...
((top)
@@ -134,7 +134,6 @@
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -216,7 +215,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -350,6 +351,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -462,6 +464,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
@@ -469,1369 +472,1222 @@
("i" "i")))
(hygiene guile)))
#f)))
- (#{chi-void\ 173}#
+ (#{chi-void\ 174}#
(lambda () (#{build-void\ 95}# #f)))
- (#{eval-local-transformer\ 172}#
- (lambda (#{expanded\ 317}# #{mod\ 318}#)
- (let ((#{p\ 319}# (#{local-eval-hook\ 91}#
- #{expanded\ 317}#
- #{mod\ 318}#)))
- (if (procedure? #{p\ 319}#)
- #{p\ 319}#
+ (#{eval-local-transformer\ 173}#
+ (lambda (#{expanded\ 318}# #{mod\ 319}#)
+ (let ((#{p\ 320}# (#{local-eval-hook\ 91}#
+ #{expanded\ 318}#
+ #{mod\ 319}#)))
+ (if (procedure? #{p\ 320}#)
+ #{p\ 320}#
(syntax-violation
#f
"nonprocedure transformer"
- #{p\ 319}#)))))
- (#{chi-local-syntax\ 171}#
- (lambda (#{rec?\ 320}#
- #{e\ 321}#
- #{r\ 322}#
- #{w\ 323}#
- #{s\ 324}#
- #{mod\ 325}#
- #{k\ 326}#)
- ((lambda (#{tmp\ 327}#)
- ((lambda (#{tmp\ 328}#)
- (if #{tmp\ 328}#
- (apply (lambda (#{_\ 329}#
- #{id\ 330}#
- #{val\ 331}#
- #{e1\ 332}#
- #{e2\ 333}#)
- (let ((#{ids\ 334}# #{id\ 330}#))
- (if (not (#{valid-bound-ids?\ 154}#
- #{ids\ 334}#))
+ #{p\ 320}#)))))
+ (#{chi-local-syntax\ 172}#
+ (lambda (#{rec?\ 321}#
+ #{e\ 322}#
+ #{r\ 323}#
+ #{w\ 324}#
+ #{s\ 325}#
+ #{mod\ 326}#
+ #{k\ 327}#)
+ ((lambda (#{tmp\ 328}#)
+ ((lambda (#{tmp\ 329}#)
+ (if #{tmp\ 329}#
+ (apply (lambda (#{_\ 330}#
+ #{id\ 331}#
+ #{val\ 332}#
+ #{e1\ 333}#
+ #{e2\ 334}#)
+ (let ((#{ids\ 335}# #{id\ 331}#))
+ (if (not (#{valid-bound-ids?\ 156}#
+ #{ids\ 335}#))
(syntax-violation
#f
"duplicate bound keyword"
- #{e\ 321}#)
- (let ((#{labels\ 336}#
- (#{gen-labels\ 135}#
- #{ids\ 334}#)))
- (let ((#{new-w\ 337}#
- (#{make-binding-wrap\ 146}#
- #{ids\ 334}#
- #{labels\ 336}#
- #{w\ 323}#)))
- (#{k\ 326}# (cons #{e1\ 332}#
- #{e2\ 333}#)
- (#{extend-env\ 123}#
- #{labels\ 336}#
- (let ((#{w\ 339}# (if
#{rec?\ 320}#
-
#{new-w\ 337}#
- #{w\
323}#))
- (#{trans-r\ 340}#
-
(#{macros-only-env\ 125}#
- #{r\ 322}#)))
- (map (lambda (#{x\
341}#)
+ #{e\ 322}#)
+ (let ((#{labels\ 337}#
+ (#{gen-labels\ 137}#
+ #{ids\ 335}#)))
+ (let ((#{new-w\ 338}#
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 335}#
+ #{labels\ 337}#
+ #{w\ 324}#)))
+ (#{k\ 327}# (cons #{e1\ 333}#
+ #{e2\ 334}#)
+ (#{extend-env\ 125}#
+ #{labels\ 337}#
+ (let ((#{w\ 340}# (if
#{rec?\ 321}#
+
#{new-w\ 338}#
+ #{w\
324}#))
+ (#{trans-r\ 341}#
+
(#{macros-only-env\ 127}#
+ #{r\ 323}#)))
+ (map (lambda (#{x\
342}#)
(cons 'macro
-
(#{eval-local-transformer\ 172}#
- (#{chi\
165}#
- #{x\
341}#
-
#{trans-r\ 340}#
- #{w\
339}#
-
#{mod\ 325}#)
- #{mod\
325}#)))
- #{val\ 331}#))
- #{r\ 322}#)
- #{new-w\ 337}#
- #{s\ 324}#
- #{mod\ 325}#))))))
- #{tmp\ 328}#)
- ((lambda (#{_\ 343}#)
+
(#{eval-local-transformer\ 173}#
+ (#{chi\
167}#
+ #{x\
342}#
+
#{trans-r\ 341}#
+ #{w\
340}#
+
#{mod\ 326}#)
+ #{mod\
326}#)))
+ #{val\ 332}#))
+ #{r\ 323}#)
+ #{new-w\ 338}#
+ #{s\ 325}#
+ #{mod\ 326}#))))))
+ #{tmp\ 329}#)
+ ((lambda (#{_\ 344}#)
(syntax-violation
#f
"bad local syntax definition"
- (#{source-wrap\ 158}#
- #{e\ 321}#
- #{w\ 323}#
- #{s\ 324}#
- #{mod\ 325}#)))
- #{tmp\ 327}#)))
+ (#{source-wrap\ 160}#
+ #{e\ 322}#
+ #{w\ 324}#
+ #{s\ 325}#
+ #{mod\ 326}#)))
+ #{tmp\ 328}#)))
($sc-dispatch
- #{tmp\ 327}#
+ #{tmp\ 328}#
'(any #(each (any any)) any . each-any))))
- #{e\ 321}#)))
- (#{chi-lambda-clause\ 170}#
- (lambda (#{e\ 344}#
- #{docstring\ 345}#
- #{c\ 346}#
+ #{e\ 322}#)))
+ (#{chi-body\ 171}#
+ (lambda (#{body\ 345}#
+ #{outer-form\ 346}#
#{r\ 347}#
#{w\ 348}#
- #{mod\ 349}#
- #{k\ 350}#)
- ((lambda (#{tmp\ 351}#)
- ((lambda (#{tmp\ 352}#)
- (if (if #{tmp\ 352}#
- (apply (lambda (#{args\ 353}#
- #{doc\ 354}#
- #{e1\ 355}#
- #{e2\ 356}#)
- (if (string? (syntax->datum #{doc\ 354}#))
- (not #{docstring\ 345}#)
- #f))
- #{tmp\ 352}#)
- #f)
- (apply (lambda (#{args\ 357}#
- #{doc\ 358}#
- #{e1\ 359}#
- #{e2\ 360}#)
- (#{chi-lambda-clause\ 170}#
- #{e\ 344}#
- #{doc\ 358}#
- (cons #{args\ 357}#
- (cons #{e1\ 359}# #{e2\ 360}#))
- #{r\ 347}#
- #{w\ 348}#
- #{mod\ 349}#
- #{k\ 350}#))
- #{tmp\ 352}#)
- ((lambda (#{tmp\ 362}#)
- (if #{tmp\ 362}#
- (apply (lambda (#{id\ 363}#
- #{e1\ 364}#
- #{e2\ 365}#)
- (let ((#{ids\ 366}# #{id\ 363}#))
- (if (not (#{valid-bound-ids?\ 154}#
- #{ids\ 366}#))
- (syntax-violation
- 'lambda
- "invalid parameter list"
- #{e\ 344}#)
- (let ((#{labels\ 368}#
- (#{gen-labels\ 135}#
- #{ids\ 366}#))
- (#{new-vars\ 369}#
- (map #{gen-var\ 176}#
- #{ids\ 366}#)))
- (#{k\ 350}# (map syntax->datum
- #{ids\ 366}#)
- #{new-vars\ 369}#
- (if #{docstring\ 345}#
- (syntax->datum
- #{docstring\ 345}#)
- #f)
- (#{chi-body\ 169}#
- (cons #{e1\ 364}#
- #{e2\ 365}#)
- #{e\ 344}#
- (#{extend-var-env\
124}#
- #{labels\ 368}#
- #{new-vars\ 369}#
- #{r\ 347}#)
- (#{make-binding-wrap\
146}#
- #{ids\ 366}#
- #{labels\ 368}#
- #{w\ 348}#)
- #{mod\ 349}#))))))
- #{tmp\ 362}#)
- ((lambda (#{tmp\ 371}#)
- (if #{tmp\ 371}#
- (apply (lambda (#{ids\ 372}#
- #{e1\ 373}#
- #{e2\ 374}#)
- (let ((#{old-ids\ 375}#
- (#{lambda-var-list\ 177}#
- #{ids\ 372}#)))
- (if (not (#{valid-bound-ids?\ 154}#
- #{old-ids\ 375}#))
- (syntax-violation
- 'lambda
- "invalid parameter list"
- #{e\ 344}#)
- (let ((#{labels\ 376}#
- (#{gen-labels\ 135}#
- #{old-ids\ 375}#))
- (#{new-vars\ 377}#
- (map #{gen-var\ 176}#
- #{old-ids\ 375}#)))
- (#{k\ 350}# (letrec ((#{f\
378}# (lambda (#{ls1\ 379}#
-
#{ls2\ 380}#)
-
(if (null? #{ls1\ 379}#)
-
(syntax->datum
-
#{ls2\ 380}#)
-
(#{f\ 378}# (cdr #{ls1\ 379}#)
-
(cons (syntax->datum
-
(car #{ls1\ 379}#))
-
#{ls2\ 380}#))))))
- (#{f\ 378}# (cdr
#{old-ids\ 375}#)
- (car
#{old-ids\ 375}#)))
- (letrec ((#{f\
381}# (lambda (#{ls1\ 382}#
-
#{ls2\ 383}#)
-
(if (null? #{ls1\ 382}#)
-
#{ls2\ 383}#
-
(#{f\ 381}# (cdr #{ls1\ 382}#)
-
(cons (car #{ls1\ 382}#)
-
#{ls2\ 383}#))))))
- (#{f\ 381}# (cdr
#{new-vars\ 377}#)
- (car
#{new-vars\ 377}#)))
- (if #{docstring\
345}#
- (syntax->datum
- #{docstring\
345}#)
- #f)
- (#{chi-body\ 169}#
- (cons #{e1\ 373}#
- #{e2\
374}#)
- #{e\ 344}#
-
(#{extend-var-env\ 124}#
- #{labels\ 376}#
- #{new-vars\
377}#
- #{r\ 347}#)
-
(#{make-binding-wrap\ 146}#
- #{old-ids\
375}#
- #{labels\ 376}#
- #{w\ 348}#)
- #{mod\
349}#))))))
- #{tmp\ 371}#)
- ((lambda (#{_\ 385}#)
- (syntax-violation
- 'lambda
- "bad lambda"
- #{e\ 344}#))
- #{tmp\ 351}#)))
- ($sc-dispatch
- #{tmp\ 351}#
- '(any any . each-any)))))
- ($sc-dispatch
- #{tmp\ 351}#
- '(each-any any . each-any)))))
- ($sc-dispatch
- #{tmp\ 351}#
- '(any any any . each-any))))
- #{c\ 346}#)))
- (#{chi-body\ 169}#
- (lambda (#{body\ 386}#
- #{outer-form\ 387}#
- #{r\ 388}#
- #{w\ 389}#
- #{mod\ 390}#)
- (let ((#{r\ 391}# (cons '("placeholder" placeholder)
- #{r\ 388}#)))
- (let ((#{ribcage\ 392}#
- (#{make-ribcage\ 136}#
+ #{mod\ 349}#)
+ (let ((#{r\ 350}# (cons '("placeholder" placeholder)
+ #{r\ 347}#)))
+ (let ((#{ribcage\ 351}#
+ (#{make-ribcage\ 138}#
'()
'()
'())))
- (let ((#{w\ 393}# (#{make-wrap\ 131}#
- (#{wrap-marks\ 132}# #{w\ 389}#)
- (cons #{ribcage\ 392}#
- (#{wrap-subst\ 133}#
- #{w\ 389}#)))))
- (letrec ((#{parse\ 394}#
- (lambda (#{body\ 395}#
- #{ids\ 396}#
- #{labels\ 397}#
- #{var-ids\ 398}#
- #{vars\ 399}#
- #{vals\ 400}#
- #{bindings\ 401}#)
- (if (null? #{body\ 395}#)
+ (let ((#{w\ 352}# (#{make-wrap\ 133}#
+ (#{wrap-marks\ 134}# #{w\ 348}#)
+ (cons #{ribcage\ 351}#
+ (#{wrap-subst\ 135}#
+ #{w\ 348}#)))))
+ (letrec ((#{parse\ 353}#
+ (lambda (#{body\ 354}#
+ #{ids\ 355}#
+ #{labels\ 356}#
+ #{var-ids\ 357}#
+ #{vars\ 358}#
+ #{vals\ 359}#
+ #{bindings\ 360}#)
+ (if (null? #{body\ 354}#)
(syntax-violation
#f
"no expressions in body"
- #{outer-form\ 387}#)
- (let ((#{e\ 403}# (cdar #{body\ 395}#))
- (#{er\ 404}# (caar #{body\ 395}#)))
+ #{outer-form\ 346}#)
+ (let ((#{e\ 362}# (cdar #{body\ 354}#))
+ (#{er\ 363}# (caar #{body\ 354}#)))
(call-with-values
(lambda ()
- (#{syntax-type\ 163}#
- #{e\ 403}#
- #{er\ 404}#
+ (#{syntax-type\ 165}#
+ #{e\ 362}#
+ #{er\ 363}#
'(())
- (#{source-annotation\ 120}#
- #{er\ 404}#)
- #{ribcage\ 392}#
- #{mod\ 390}#
+ (#{source-annotation\ 122}#
+ #{er\ 363}#)
+ #{ribcage\ 351}#
+ #{mod\ 349}#
#f))
- (lambda (#{type\ 405}#
- #{value\ 406}#
- #{e\ 407}#
- #{w\ 408}#
- #{s\ 409}#
- #{mod\ 410}#)
- (if (memv #{type\ 405}#
+ (lambda (#{type\ 364}#
+ #{value\ 365}#
+ #{e\ 366}#
+ #{w\ 367}#
+ #{s\ 368}#
+ #{mod\ 369}#)
+ (if (memv #{type\ 364}#
'(define-form))
- (let ((#{id\ 411}#
- (#{wrap\ 157}#
- #{value\ 406}#
- #{w\ 408}#
- #{mod\ 410}#))
- (#{label\ 412}#
- (#{gen-label\ 134}#)))
- (let ((#{var\ 413}#
- (#{gen-var\ 176}#
- #{id\ 411}#)))
+ (let ((#{id\ 370}#
+ (#{wrap\ 159}#
+ #{value\ 365}#
+ #{w\ 367}#
+ #{mod\ 369}#))
+ (#{label\ 371}#
+ (#{gen-label\ 136}#)))
+ (let ((#{var\ 372}#
+ (#{gen-var\ 177}#
+ #{id\ 370}#)))
(begin
- (#{extend-ribcage!\ 145}#
- #{ribcage\ 392}#
- #{id\ 411}#
- #{label\ 412}#)
- (#{parse\ 394}#
- (cdr #{body\ 395}#)
- (cons #{id\ 411}#
- #{ids\ 396}#)
- (cons #{label\ 412}#
- #{labels\ 397}#)
- (cons #{id\ 411}#
- #{var-ids\ 398}#)
- (cons #{var\ 413}#
- #{vars\ 399}#)
- (cons (cons #{er\ 404}#
- (#{wrap\ 157}#
- #{e\ 407}#
- #{w\ 408}#
- #{mod\
410}#))
- #{vals\ 400}#)
+ (#{extend-ribcage!\ 147}#
+ #{ribcage\ 351}#
+ #{id\ 370}#
+ #{label\ 371}#)
+ (#{parse\ 353}#
+ (cdr #{body\ 354}#)
+ (cons #{id\ 370}#
+ #{ids\ 355}#)
+ (cons #{label\ 371}#
+ #{labels\ 356}#)
+ (cons #{id\ 370}#
+ #{var-ids\ 357}#)
+ (cons #{var\ 372}#
+ #{vars\ 358}#)
+ (cons (cons #{er\ 363}#
+ (#{wrap\ 159}#
+ #{e\ 366}#
+ #{w\ 367}#
+ #{mod\
369}#))
+ #{vals\ 359}#)
(cons (cons 'lexical
- #{var\ 413}#)
- #{bindings\
401}#)))))
- (if (memv #{type\ 405}#
+ #{var\ 372}#)
+ #{bindings\
360}#)))))
+ (if (memv #{type\ 364}#
'(define-syntax-form))
- (let ((#{id\ 414}#
- (#{wrap\ 157}#
- #{value\ 406}#
- #{w\ 408}#
- #{mod\ 410}#))
- (#{label\ 415}#
- (#{gen-label\ 134}#)))
+ (let ((#{id\ 373}#
+ (#{wrap\ 159}#
+ #{value\ 365}#
+ #{w\ 367}#
+ #{mod\ 369}#))
+ (#{label\ 374}#
+ (#{gen-label\ 136}#)))
(begin
- (#{extend-ribcage!\ 145}#
- #{ribcage\ 392}#
- #{id\ 414}#
- #{label\ 415}#)
- (#{parse\ 394}#
- (cdr #{body\ 395}#)
- (cons #{id\ 414}#
- #{ids\ 396}#)
- (cons #{label\ 415}#
- #{labels\ 397}#)
- #{var-ids\ 398}#
- #{vars\ 399}#
- #{vals\ 400}#
+ (#{extend-ribcage!\ 147}#
+ #{ribcage\ 351}#
+ #{id\ 373}#
+ #{label\ 374}#)
+ (#{parse\ 353}#
+ (cdr #{body\ 354}#)
+ (cons #{id\ 373}#
+ #{ids\ 355}#)
+ (cons #{label\ 374}#
+ #{labels\ 356}#)
+ #{var-ids\ 357}#
+ #{vars\ 358}#
+ #{vals\ 359}#
(cons (cons 'macro
- (cons #{er\
404}#
- (#{wrap\
157}#
- #{e\
407}#
- #{w\
408}#
- #{mod\
410}#)))
- #{bindings\ 401}#))))
- (if (memv #{type\ 405}#
+ (cons #{er\
363}#
+ (#{wrap\
159}#
+ #{e\
366}#
+ #{w\
367}#
+ #{mod\
369}#)))
+ #{bindings\ 360}#))))
+ (if (memv #{type\ 364}#
'(begin-form))
- ((lambda (#{tmp\ 416}#)
- ((lambda (#{tmp\ 417}#)
- (if #{tmp\ 417}#
- (apply (lambda (#{_\
418}#
- #{e1\
419}#)
- (#{parse\
394}#
- (letrec
((#{f\ 420}# (lambda (#{forms\ 421}#)
-
(if (null? #{forms\ 421}#)
-
(cdr #{body\ 395}#)
-
(cons (cons #{er\ 404}#
-
(#{wrap\ 157}#
-
(car #{forms\ 421}#)
-
#{w\ 408}#
-
#{mod\ 410}#))
-
(#{f\ 420}# (cdr #{forms\ 421}#)))))))
- (#{f\
420}# #{e1\ 419}#))
- #{ids\ 396}#
- #{labels\
397}#
- #{var-ids\
398}#
- #{vars\
399}#
- #{vals\
400}#
- #{bindings\
401}#))
- #{tmp\ 417}#)
+ ((lambda (#{tmp\ 375}#)
+ ((lambda (#{tmp\ 376}#)
+ (if #{tmp\ 376}#
+ (apply (lambda (#{_\
377}#
+ #{e1\
378}#)
+ (#{parse\
353}#
+ (letrec
((#{f\ 379}# (lambda (#{forms\ 380}#)
+
(if (null? #{forms\ 380}#)
+
(cdr #{body\ 354}#)
+
(cons (cons #{er\ 363}#
+
(#{wrap\ 159}#
+
(car #{forms\ 380}#)
+
#{w\ 367}#
+
#{mod\ 369}#))
+
(#{f\ 379}# (cdr #{forms\ 380}#)))))))
+ (#{f\
379}# #{e1\ 378}#))
+ #{ids\ 355}#
+ #{labels\
356}#
+ #{var-ids\
357}#
+ #{vars\
358}#
+ #{vals\
359}#
+ #{bindings\
360}#))
+ #{tmp\ 376}#)
(syntax-violation
#f
"source expression
failed to match any pattern"
- #{tmp\ 416}#)))
+ #{tmp\ 375}#)))
($sc-dispatch
- #{tmp\ 416}#
+ #{tmp\ 375}#
'(any . each-any))))
- #{e\ 407}#)
- (if (memv #{type\ 405}#
+ #{e\ 366}#)
+ (if (memv #{type\ 364}#
'(local-syntax-form))
- (#{chi-local-syntax\ 171}#
- #{value\ 406}#
- #{e\ 407}#
- #{er\ 404}#
- #{w\ 408}#
- #{s\ 409}#
- #{mod\ 410}#
- (lambda (#{forms\ 423}#
- #{er\ 424}#
- #{w\ 425}#
- #{s\ 426}#
- #{mod\ 427}#)
- (#{parse\ 394}#
- (letrec ((#{f\ 428}#
(lambda (#{forms\ 429}#)
-
(if (null? #{forms\ 429}#)
-
(cdr #{body\ 395}#)
-
(cons (cons #{er\ 424}#
-
(#{wrap\ 157}#
-
(car #{forms\ 429}#)
-
#{w\ 425}#
-
#{mod\ 427}#))
-
(#{f\ 428}# (cdr #{forms\ 429}#)))))))
- (#{f\ 428}# #{forms\
423}#))
- #{ids\ 396}#
- #{labels\ 397}#
- #{var-ids\ 398}#
- #{vars\ 399}#
- #{vals\ 400}#
- #{bindings\ 401}#)))
- (if (null? #{ids\ 396}#)
- (#{build-sequence\ 108}#
+ (#{chi-local-syntax\ 172}#
+ #{value\ 365}#
+ #{e\ 366}#
+ #{er\ 363}#
+ #{w\ 367}#
+ #{s\ 368}#
+ #{mod\ 369}#
+ (lambda (#{forms\ 382}#
+ #{er\ 383}#
+ #{w\ 384}#
+ #{s\ 385}#
+ #{mod\ 386}#)
+ (#{parse\ 353}#
+ (letrec ((#{f\ 387}#
(lambda (#{forms\ 388}#)
+
(if (null? #{forms\ 388}#)
+
(cdr #{body\ 354}#)
+
(cons (cons #{er\ 383}#
+
(#{wrap\ 159}#
+
(car #{forms\ 388}#)
+
#{w\ 384}#
+
#{mod\ 386}#))
+
(#{f\ 387}# (cdr #{forms\ 388}#)))))))
+ (#{f\ 387}# #{forms\
382}#))
+ #{ids\ 355}#
+ #{labels\ 356}#
+ #{var-ids\ 357}#
+ #{vars\ 358}#
+ #{vals\ 359}#
+ #{bindings\ 360}#)))
+ (if (null? #{ids\ 355}#)
+ (#{build-sequence\ 110}#
#f
- (map (lambda (#{x\ 430}#)
- (#{chi\ 165}#
- (cdr #{x\ 430}#)
- (car #{x\ 430}#)
+ (map (lambda (#{x\ 389}#)
+ (#{chi\ 167}#
+ (cdr #{x\ 389}#)
+ (car #{x\ 389}#)
'(())
- #{mod\ 410}#))
- (cons (cons #{er\
404}#
-
(#{source-wrap\ 158}#
- #{e\
407}#
- #{w\
408}#
- #{s\
409}#
-
#{mod\ 410}#))
- (cdr #{body\
395}#))))
+ #{mod\ 369}#))
+ (cons (cons #{er\
363}#
+
(#{source-wrap\ 160}#
+ #{e\
366}#
+ #{w\
367}#
+ #{s\
368}#
+
#{mod\ 369}#))
+ (cdr #{body\
354}#))))
(begin
- (if (not
(#{valid-bound-ids?\ 154}#
- #{ids\ 396}#))
+ (if (not
(#{valid-bound-ids?\ 156}#
+ #{ids\ 355}#))
(syntax-violation
#f
"invalid or
duplicate identifier in definition"
- #{outer-form\ 387}#))
- (letrec ((#{loop\ 431}#
- (lambda
(#{bs\ 432}#
-
#{er-cache\ 433}#
-
#{r-cache\ 434}#)
- (if (not
(null? #{bs\ 432}#))
- (let
((#{b\ 435}# (car #{bs\ 432}#)))
- (if
(eq? (car #{b\ 435}#)
+ #{outer-form\ 346}#))
+ (letrec ((#{loop\ 390}#
+ (lambda
(#{bs\ 391}#
+
#{er-cache\ 392}#
+
#{r-cache\ 393}#)
+ (if (not
(null? #{bs\ 391}#))
+ (let
((#{b\ 394}# (car #{bs\ 391}#)))
+ (if
(eq? (car #{b\ 394}#)
'macro)
- (let
((#{er\ 436}#
-
(cadr #{b\ 435}#)))
-
(let ((#{r-cache\ 437}#
-
(if (eq? #{er\ 436}#
-
#{er-cache\ 433}#)
-
#{r-cache\ 434}#
-
(#{macros-only-env\ 125}#
-
#{er\ 436}#))))
+ (let
((#{er\ 395}#
+
(cadr #{b\ 394}#)))
+
(let ((#{r-cache\ 396}#
+
(if (eq? #{er\ 395}#
+
#{er-cache\ 392}#)
+
#{r-cache\ 393}#
+
(#{macros-only-env\ 127}#
+
#{er\ 395}#))))
(begin
(set-cdr!
-
#{b\ 435}#
-
(#{eval-local-transformer\ 172}#
-
(#{chi\ 165}#
-
(cddr #{b\ 435}#)
-
#{r-cache\ 437}#
+
#{b\ 394}#
+
(#{eval-local-transformer\ 173}#
+
(#{chi\ 167}#
+
(cddr #{b\ 394}#)
+
#{r-cache\ 396}#
'(())
-
#{mod\ 410}#)
-
#{mod\ 410}#))
-
(#{loop\ 431}#
-
(cdr #{bs\ 432}#)
-
#{er\ 436}#
-
#{r-cache\ 437}#))))
-
(#{loop\ 431}#
-
(cdr #{bs\ 432}#)
-
#{er-cache\ 433}#
-
#{r-cache\ 434}#)))))))
- (#{loop\ 431}#
- #{bindings\ 401}#
+
#{mod\ 369}#)
+
#{mod\ 369}#))
+
(#{loop\ 390}#
+
(cdr #{bs\ 391}#)
+
#{er\ 395}#
+
#{r-cache\ 396}#))))
+
(#{loop\ 390}#
+
(cdr #{bs\ 391}#)
+
#{er-cache\ 392}#
+
#{r-cache\ 393}#)))))))
+ (#{loop\ 390}#
+ #{bindings\ 360}#
#f
#f))
(set-cdr!
- #{r\ 391}#
- (#{extend-env\ 123}#
- #{labels\ 397}#
- #{bindings\ 401}#
- (cdr #{r\ 391}#)))
- (#{build-letrec\ 111}#
+ #{r\ 350}#
+ (#{extend-env\ 125}#
+ #{labels\ 356}#
+ #{bindings\ 360}#
+ (cdr #{r\ 350}#)))
+ (#{build-letrec\ 113}#
#f
(map syntax->datum
- #{var-ids\ 398}#)
- #{vars\ 399}#
- (map (lambda (#{x\
438}#)
- (#{chi\ 165}#
- (cdr #{x\
438}#)
- (car #{x\
438}#)
+ #{var-ids\ 357}#)
+ #{vars\ 358}#
+ (map (lambda (#{x\
397}#)
+ (#{chi\ 167}#
+ (cdr #{x\
397}#)
+ (car #{x\
397}#)
'(())
- #{mod\ 410}#))
- #{vals\ 400}#)
- (#{build-sequence\
108}#
+ #{mod\ 369}#))
+ #{vals\ 359}#)
+ (#{build-sequence\
110}#
#f
- (map (lambda (#{x\
439}#)
- (#{chi\ 165}#
- (cdr #{x\
439}#)
- (car #{x\
439}#)
+ (map (lambda (#{x\
398}#)
+ (#{chi\ 167}#
+ (cdr #{x\
398}#)
+ (car #{x\
398}#)
'(())
- #{mod\
410}#))
- (cons (cons
#{er\ 404}#
-
(#{source-wrap\ 158}#
-
#{e\ 407}#
-
#{w\ 408}#
-
#{s\ 409}#
-
#{mod\ 410}#))
- (cdr
#{body\ 395}#))))))))))))))))))
- (#{parse\ 394}#
- (map (lambda (#{x\ 402}#)
- (cons #{r\ 391}#
- (#{wrap\ 157}#
- #{x\ 402}#
- #{w\ 393}#
- #{mod\ 390}#)))
- #{body\ 386}#)
+ #{mod\
369}#))
+ (cons (cons
#{er\ 363}#
+
(#{source-wrap\ 160}#
+
#{e\ 366}#
+
#{w\ 367}#
+
#{s\ 368}#
+
#{mod\ 369}#))
+ (cdr
#{body\ 354}#))))))))))))))))))
+ (#{parse\ 353}#
+ (map (lambda (#{x\ 361}#)
+ (cons #{r\ 350}#
+ (#{wrap\ 159}#
+ #{x\ 361}#
+ #{w\ 352}#
+ #{mod\ 349}#)))
+ #{body\ 345}#)
'()
'()
'()
'()
'()
'())))))))
- (#{chi-macro\ 168}#
- (lambda (#{p\ 440}#
- #{e\ 441}#
- #{r\ 442}#
- #{w\ 443}#
- #{rib\ 444}#
- #{mod\ 445}#)
- (letrec ((#{rebuild-macro-output\ 446}#
- (lambda (#{x\ 447}# #{m\ 448}#)
- (if (pair? #{x\ 447}#)
- (cons (#{rebuild-macro-output\ 446}#
- (car #{x\ 447}#)
- #{m\ 448}#)
- (#{rebuild-macro-output\ 446}#
- (cdr #{x\ 447}#)
- #{m\ 448}#))
- (if (#{syntax-object?\ 113}# #{x\ 447}#)
- (let ((#{w\ 449}# (#{syntax-object-wrap\ 115}#
- #{x\ 447}#)))
- (let ((#{ms\ 450}#
- (#{wrap-marks\ 132}# #{w\ 449}#))
- (#{s\ 451}# (#{wrap-subst\ 133}#
- #{w\ 449}#)))
- (if (if (pair? #{ms\ 450}#)
- (eq? (car #{ms\ 450}#) #f)
+ (#{chi-macro\ 170}#
+ (lambda (#{p\ 399}#
+ #{e\ 400}#
+ #{r\ 401}#
+ #{w\ 402}#
+ #{rib\ 403}#
+ #{mod\ 404}#)
+ (letrec ((#{rebuild-macro-output\ 405}#
+ (lambda (#{x\ 406}# #{m\ 407}#)
+ (if (pair? #{x\ 406}#)
+ (cons (#{rebuild-macro-output\ 405}#
+ (car #{x\ 406}#)
+ #{m\ 407}#)
+ (#{rebuild-macro-output\ 405}#
+ (cdr #{x\ 406}#)
+ #{m\ 407}#))
+ (if (#{syntax-object?\ 115}# #{x\ 406}#)
+ (let ((#{w\ 408}# (#{syntax-object-wrap\ 117}#
+ #{x\ 406}#)))
+ (let ((#{ms\ 409}#
+ (#{wrap-marks\ 134}# #{w\ 408}#))
+ (#{s\ 410}# (#{wrap-subst\ 135}#
+ #{w\ 408}#)))
+ (if (if (pair? #{ms\ 409}#)
+ (eq? (car #{ms\ 409}#) #f)
#f)
- (#{make-syntax-object\ 112}#
- (#{syntax-object-expression\ 114}#
- #{x\ 447}#)
- (#{make-wrap\ 131}#
- (cdr #{ms\ 450}#)
- (if #{rib\ 444}#
- (cons #{rib\ 444}#
- (cdr #{s\ 451}#))
- (cdr #{s\ 451}#)))
- (#{syntax-object-module\ 116}#
- #{x\ 447}#))
- (#{make-syntax-object\ 112}#
- (#{syntax-object-expression\ 114}#
- #{x\ 447}#)
- (#{make-wrap\ 131}#
- (cons #{m\ 448}# #{ms\ 450}#)
- (if #{rib\ 444}#
- (cons #{rib\ 444}#
+ (#{make-syntax-object\ 114}#
+ (#{syntax-object-expression\ 116}#
+ #{x\ 406}#)
+ (#{make-wrap\ 133}#
+ (cdr #{ms\ 409}#)
+ (if #{rib\ 403}#
+ (cons #{rib\ 403}#
+ (cdr #{s\ 410}#))
+ (cdr #{s\ 410}#)))
+ (#{syntax-object-module\ 118}#
+ #{x\ 406}#))
+ (#{make-syntax-object\ 114}#
+ (#{syntax-object-expression\ 116}#
+ #{x\ 406}#)
+ (#{make-wrap\ 133}#
+ (cons #{m\ 407}# #{ms\ 409}#)
+ (if #{rib\ 403}#
+ (cons #{rib\ 403}#
(cons 'shift
- #{s\ 451}#))
- (cons (quote shift) #{s\ 451}#)))
- (let ((#{pmod\ 452}#
- (procedure-module #{p\ 440}#)))
- (if #{pmod\ 452}#
+ #{s\ 410}#))
+ (cons (quote shift) #{s\ 410}#)))
+ (let ((#{pmod\ 411}#
+ (procedure-module #{p\ 399}#)))
+ (if #{pmod\ 411}#
(cons 'hygiene
- (module-name #{pmod\ 452}#))
+ (module-name #{pmod\ 411}#))
'(hygiene guile)))))))
- (if (vector? #{x\ 447}#)
- (let ((#{n\ 453}# (vector-length
- #{x\ 447}#)))
- (let ((#{v\ 454}# (make-vector
- #{n\ 453}#)))
- (letrec ((#{loop\ 455}#
- (lambda (#{i\ 456}#)
+ (if (vector? #{x\ 406}#)
+ (let ((#{n\ 412}# (vector-length
+ #{x\ 406}#)))
+ (let ((#{v\ 413}# (make-vector
+ #{n\ 412}#)))
+ (letrec ((#{loop\ 414}#
+ (lambda (#{i\ 415}#)
(if (#{fx=\ 88}#
- #{i\ 456}#
- #{n\ 453}#)
+ #{i\ 415}#
+ #{n\ 412}#)
(begin
(if #f #f)
- #{v\ 454}#)
+ #{v\ 413}#)
(begin
(vector-set!
- #{v\ 454}#
- #{i\ 456}#
-
(#{rebuild-macro-output\ 446}#
+ #{v\ 413}#
+ #{i\ 415}#
+
(#{rebuild-macro-output\ 405}#
(vector-ref
- #{x\ 447}#
- #{i\ 456}#)
- #{m\ 448}#))
- (#{loop\ 455}#
+ #{x\ 406}#
+ #{i\ 415}#)
+ #{m\ 407}#))
+ (#{loop\ 414}#
(#{fx+\ 86}#
- #{i\ 456}#
+ #{i\ 415}#
1)))))))
- (#{loop\ 455}# 0))))
- (if (symbol? #{x\ 447}#)
+ (#{loop\ 414}# 0))))
+ (if (symbol? #{x\ 406}#)
(syntax-violation
#f
"encountered raw symbol in macro output"
- (#{source-wrap\ 158}#
- #{e\ 441}#
- #{w\ 443}#
- (#{wrap-subst\ 133}# #{w\ 443}#)
- #{mod\ 445}#)
- #{x\ 447}#)
- #{x\ 447}#)))))))
- (#{rebuild-macro-output\ 446}#
- (#{p\ 440}# (#{wrap\ 157}#
- #{e\ 441}#
- (#{anti-mark\ 144}# #{w\ 443}#)
- #{mod\ 445}#))
+ (#{source-wrap\ 160}#
+ #{e\ 400}#
+ #{w\ 402}#
+ (#{wrap-subst\ 135}# #{w\ 402}#)
+ #{mod\ 404}#)
+ #{x\ 406}#)
+ #{x\ 406}#)))))))
+ (#{rebuild-macro-output\ 405}#
+ (#{p\ 399}# (#{wrap\ 159}#
+ #{e\ 400}#
+ (#{anti-mark\ 146}# #{w\ 402}#)
+ #{mod\ 404}#))
(string #\m)))))
- (#{chi-application\ 167}#
- (lambda (#{x\ 457}#
- #{e\ 458}#
- #{r\ 459}#
- #{w\ 460}#
- #{s\ 461}#
- #{mod\ 462}#)
- ((lambda (#{tmp\ 463}#)
- ((lambda (#{tmp\ 464}#)
- (if #{tmp\ 464}#
- (apply (lambda (#{e0\ 465}# #{e1\ 466}#)
+ (#{chi-application\ 169}#
+ (lambda (#{x\ 416}#
+ #{e\ 417}#
+ #{r\ 418}#
+ #{w\ 419}#
+ #{s\ 420}#
+ #{mod\ 421}#)
+ ((lambda (#{tmp\ 422}#)
+ ((lambda (#{tmp\ 423}#)
+ (if #{tmp\ 423}#
+ (apply (lambda (#{e0\ 424}# #{e1\ 425}#)
(#{build-application\ 96}#
- #{s\ 461}#
- #{x\ 457}#
- (map (lambda (#{e\ 467}#)
- (#{chi\ 165}#
- #{e\ 467}#
- #{r\ 459}#
- #{w\ 460}#
- #{mod\ 462}#))
- #{e1\ 466}#)))
- #{tmp\ 464}#)
+ #{s\ 420}#
+ #{x\ 416}#
+ (map (lambda (#{e\ 426}#)
+ (#{chi\ 167}#
+ #{e\ 426}#
+ #{r\ 418}#
+ #{w\ 419}#
+ #{mod\ 421}#))
+ #{e1\ 425}#)))
+ #{tmp\ 423}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 463}#)))
+ #{tmp\ 422}#)))
($sc-dispatch
- #{tmp\ 463}#
+ #{tmp\ 422}#
'(any . each-any))))
- #{e\ 458}#)))
- (#{chi-expr\ 166}#
- (lambda (#{type\ 469}#
- #{value\ 470}#
- #{e\ 471}#
- #{r\ 472}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#)
- (if (memv #{type\ 469}# (quote (lexical)))
+ #{e\ 417}#)))
+ (#{chi-expr\ 168}#
+ (lambda (#{type\ 428}#
+ #{value\ 429}#
+ #{e\ 430}#
+ #{r\ 431}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#)
+ (if (memv #{type\ 428}# (quote (lexical)))
(#{build-lexical-reference\ 98}#
'value
- #{s\ 474}#
- #{e\ 471}#
- #{value\ 470}#)
- (if (memv #{type\ 469}# (quote (core core-form)))
- (#{value\ 470}#
- #{e\ 471}#
- #{r\ 472}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#)
- (if (memv #{type\ 469}# (quote (module-ref)))
+ #{s\ 433}#
+ #{e\ 430}#
+ #{value\ 429}#)
+ (if (memv #{type\ 428}# (quote (core core-form)))
+ (#{value\ 429}#
+ #{e\ 430}#
+ #{r\ 431}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#)
+ (if (memv #{type\ 428}# (quote (module-ref)))
(call-with-values
- (lambda () (#{value\ 470}# #{e\ 471}#))
- (lambda (#{id\ 476}# #{mod\ 477}#)
+ (lambda () (#{value\ 429}# #{e\ 430}#))
+ (lambda (#{id\ 435}# #{mod\ 436}#)
(#{build-global-reference\ 101}#
- #{s\ 474}#
- #{id\ 476}#
- #{mod\ 477}#)))
- (if (memv #{type\ 469}# (quote (lexical-call)))
- (#{chi-application\ 167}#
+ #{s\ 433}#
+ #{id\ 435}#
+ #{mod\ 436}#)))
+ (if (memv #{type\ 428}# (quote (lexical-call)))
+ (#{chi-application\ 169}#
(#{build-lexical-reference\ 98}#
'fun
- (#{source-annotation\ 120}# (car #{e\ 471}#))
- (car #{e\ 471}#)
- #{value\ 470}#)
- #{e\ 471}#
- #{r\ 472}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#)
- (if (memv #{type\ 469}# (quote (global-call)))
- (#{chi-application\ 167}#
+ (#{source-annotation\ 122}# (car #{e\ 430}#))
+ (car #{e\ 430}#)
+ #{value\ 429}#)
+ #{e\ 430}#
+ #{r\ 431}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#)
+ (if (memv #{type\ 428}# (quote (global-call)))
+ (#{chi-application\ 169}#
(#{build-global-reference\ 101}#
- (#{source-annotation\ 120}# (car #{e\ 471}#))
- (if (#{syntax-object?\ 113}# #{value\ 470}#)
- (#{syntax-object-expression\ 114}#
- #{value\ 470}#)
- #{value\ 470}#)
- (if (#{syntax-object?\ 113}# #{value\ 470}#)
- (#{syntax-object-module\ 116}# #{value\ 470}#)
- #{mod\ 475}#))
- #{e\ 471}#
- #{r\ 472}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#)
- (if (memv #{type\ 469}# (quote (constant)))
- (#{build-data\ 107}#
- #{s\ 474}#
- (#{strip\ 175}#
- (#{source-wrap\ 158}#
- #{e\ 471}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#)
+ (#{source-annotation\ 122}# (car #{e\ 430}#))
+ (if (#{syntax-object?\ 115}# #{value\ 429}#)
+ (#{syntax-object-expression\ 116}#
+ #{value\ 429}#)
+ #{value\ 429}#)
+ (if (#{syntax-object?\ 115}# #{value\ 429}#)
+ (#{syntax-object-module\ 118}# #{value\ 429}#)
+ #{mod\ 434}#))
+ #{e\ 430}#
+ #{r\ 431}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#)
+ (if (memv #{type\ 428}# (quote (constant)))
+ (#{build-data\ 109}#
+ #{s\ 433}#
+ (#{strip\ 176}#
+ (#{source-wrap\ 160}#
+ #{e\ 430}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#)
'(())))
- (if (memv #{type\ 469}# (quote (global)))
+ (if (memv #{type\ 428}# (quote (global)))
(#{build-global-reference\ 101}#
- #{s\ 474}#
- #{value\ 470}#
- #{mod\ 475}#)
- (if (memv #{type\ 469}# (quote (call)))
- (#{chi-application\ 167}#
- (#{chi\ 165}#
- (car #{e\ 471}#)
- #{r\ 472}#
- #{w\ 473}#
- #{mod\ 475}#)
- #{e\ 471}#
- #{r\ 472}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#)
- (if (memv #{type\ 469}# (quote (begin-form)))
- ((lambda (#{tmp\ 478}#)
- ((lambda (#{tmp\ 479}#)
- (if #{tmp\ 479}#
- (apply (lambda (#{_\ 480}#
- #{e1\ 481}#
- #{e2\ 482}#)
- (#{chi-sequence\ 159}#
- (cons #{e1\ 481}#
- #{e2\ 482}#)
- #{r\ 472}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#))
- #{tmp\ 479}#)
+ #{s\ 433}#
+ #{value\ 429}#
+ #{mod\ 434}#)
+ (if (memv #{type\ 428}# (quote (call)))
+ (#{chi-application\ 169}#
+ (#{chi\ 167}#
+ (car #{e\ 430}#)
+ #{r\ 431}#
+ #{w\ 432}#
+ #{mod\ 434}#)
+ #{e\ 430}#
+ #{r\ 431}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#)
+ (if (memv #{type\ 428}# (quote (begin-form)))
+ ((lambda (#{tmp\ 437}#)
+ ((lambda (#{tmp\ 438}#)
+ (if #{tmp\ 438}#
+ (apply (lambda (#{_\ 439}#
+ #{e1\ 440}#
+ #{e2\ 441}#)
+ (#{chi-sequence\ 161}#
+ (cons #{e1\ 440}#
+ #{e2\ 441}#)
+ #{r\ 431}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#))
+ #{tmp\ 438}#)
(syntax-violation
#f
"source expression failed to match
any pattern"
- #{tmp\ 478}#)))
+ #{tmp\ 437}#)))
($sc-dispatch
- #{tmp\ 478}#
+ #{tmp\ 437}#
'(any any . each-any))))
- #{e\ 471}#)
- (if (memv #{type\ 469}#
+ #{e\ 430}#)
+ (if (memv #{type\ 428}#
'(local-syntax-form))
- (#{chi-local-syntax\ 171}#
- #{value\ 470}#
- #{e\ 471}#
- #{r\ 472}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#
- #{chi-sequence\ 159}#)
- (if (memv #{type\ 469}#
+ (#{chi-local-syntax\ 172}#
+ #{value\ 429}#
+ #{e\ 430}#
+ #{r\ 431}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#
+ #{chi-sequence\ 161}#)
+ (if (memv #{type\ 428}#
'(eval-when-form))
- ((lambda (#{tmp\ 484}#)
- ((lambda (#{tmp\ 485}#)
- (if #{tmp\ 485}#
- (apply (lambda (#{_\ 486}#
- #{x\ 487}#
- #{e1\ 488}#
- #{e2\ 489}#)
- (let ((#{when-list\ 490}#
-
(#{chi-when-list\ 162}#
- #{e\ 471}#
- #{x\ 487}#
- #{w\ 473}#)))
+ ((lambda (#{tmp\ 443}#)
+ ((lambda (#{tmp\ 444}#)
+ (if #{tmp\ 444}#
+ (apply (lambda (#{_\ 445}#
+ #{x\ 446}#
+ #{e1\ 447}#
+ #{e2\ 448}#)
+ (let ((#{when-list\ 449}#
+
(#{chi-when-list\ 164}#
+ #{e\ 430}#
+ #{x\ 446}#
+ #{w\ 432}#)))
(if (memq 'eval
- #{when-list\
490}#)
- (#{chi-sequence\
159}#
- (cons #{e1\ 488}#
- #{e2\ 489}#)
- #{r\ 472}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#)
- (#{chi-void\
173}#))))
- #{tmp\ 485}#)
+ #{when-list\
449}#)
+ (#{chi-sequence\
161}#
+ (cons #{e1\ 447}#
+ #{e2\ 448}#)
+ #{r\ 431}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#)
+ (#{chi-void\
174}#))))
+ #{tmp\ 444}#)
(syntax-violation
#f
"source expression failed to
match any pattern"
- #{tmp\ 484}#)))
+ #{tmp\ 443}#)))
($sc-dispatch
- #{tmp\ 484}#
+ #{tmp\ 443}#
'(any each-any any . each-any))))
- #{e\ 471}#)
- (if (memv #{type\ 469}#
+ #{e\ 430}#)
+ (if (memv #{type\ 428}#
'(define-form
define-syntax-form))
(syntax-violation
#f
"definition in expression context"
- #{e\ 471}#
- (#{wrap\ 157}#
- #{value\ 470}#
- #{w\ 473}#
- #{mod\ 475}#))
- (if (memv #{type\ 469}#
+ #{e\ 430}#
+ (#{wrap\ 159}#
+ #{value\ 429}#
+ #{w\ 432}#
+ #{mod\ 434}#))
+ (if (memv #{type\ 428}#
'(syntax))
(syntax-violation
#f
"reference to pattern variable
outside syntax form"
- (#{source-wrap\ 158}#
- #{e\ 471}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#))
- (if (memv #{type\ 469}#
+ (#{source-wrap\ 160}#
+ #{e\ 430}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#))
+ (if (memv #{type\ 428}#
'(displaced-lexical))
(syntax-violation
#f
"reference to identifier outside
its scope"
- (#{source-wrap\ 158}#
- #{e\ 471}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#))
+ (#{source-wrap\ 160}#
+ #{e\ 430}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#))
(syntax-violation
#f
"unexpected syntax"
- (#{source-wrap\ 158}#
- #{e\ 471}#
- #{w\ 473}#
- #{s\ 474}#
- #{mod\ 475}#))))))))))))))))))
- (#{chi\ 165}#
- (lambda (#{e\ 493}# #{r\ 494}# #{w\ 495}# #{mod\ 496}#)
+ (#{source-wrap\ 160}#
+ #{e\ 430}#
+ #{w\ 432}#
+ #{s\ 433}#
+ #{mod\ 434}#))))))))))))))))))
+ (#{chi\ 167}#
+ (lambda (#{e\ 452}# #{r\ 453}# #{w\ 454}# #{mod\ 455}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 163}#
- #{e\ 493}#
- #{r\ 494}#
- #{w\ 495}#
- (#{source-annotation\ 120}# #{e\ 493}#)
+ (#{syntax-type\ 165}#
+ #{e\ 452}#
+ #{r\ 453}#
+ #{w\ 454}#
+ (#{source-annotation\ 122}# #{e\ 452}#)
#f
- #{mod\ 496}#
+ #{mod\ 455}#
#f))
- (lambda (#{type\ 497}#
- #{value\ 498}#
- #{e\ 499}#
- #{w\ 500}#
- #{s\ 501}#
- #{mod\ 502}#)
- (#{chi-expr\ 166}#
- #{type\ 497}#
- #{value\ 498}#
- #{e\ 499}#
- #{r\ 494}#
- #{w\ 500}#
- #{s\ 501}#
- #{mod\ 502}#)))))
- (#{chi-top\ 164}#
- (lambda (#{e\ 503}#
- #{r\ 504}#
- #{w\ 505}#
- #{m\ 506}#
- #{esew\ 507}#
- #{mod\ 508}#)
+ (lambda (#{type\ 456}#
+ #{value\ 457}#
+ #{e\ 458}#
+ #{w\ 459}#
+ #{s\ 460}#
+ #{mod\ 461}#)
+ (#{chi-expr\ 168}#
+ #{type\ 456}#
+ #{value\ 457}#
+ #{e\ 458}#
+ #{r\ 453}#
+ #{w\ 459}#
+ #{s\ 460}#
+ #{mod\ 461}#)))))
+ (#{chi-top\ 166}#
+ (lambda (#{e\ 462}#
+ #{r\ 463}#
+ #{w\ 464}#
+ #{m\ 465}#
+ #{esew\ 466}#
+ #{mod\ 467}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 163}#
- #{e\ 503}#
- #{r\ 504}#
- #{w\ 505}#
- (#{source-annotation\ 120}# #{e\ 503}#)
+ (#{syntax-type\ 165}#
+ #{e\ 462}#
+ #{r\ 463}#
+ #{w\ 464}#
+ (#{source-annotation\ 122}# #{e\ 462}#)
#f
- #{mod\ 508}#
+ #{mod\ 467}#
#f))
- (lambda (#{type\ 516}#
- #{value\ 517}#
- #{e\ 518}#
- #{w\ 519}#
- #{s\ 520}#
- #{mod\ 521}#)
- (if (memv #{type\ 516}# (quote (begin-form)))
- ((lambda (#{tmp\ 522}#)
- ((lambda (#{tmp\ 523}#)
- (if #{tmp\ 523}#
- (apply (lambda (#{_\ 524}#) (#{chi-void\ 173}#))
- #{tmp\ 523}#)
- ((lambda (#{tmp\ 525}#)
- (if #{tmp\ 525}#
- (apply (lambda (#{_\ 526}#
- #{e1\ 527}#
- #{e2\ 528}#)
- (#{chi-top-sequence\ 160}#
- (cons #{e1\ 527}# #{e2\ 528}#)
- #{r\ 504}#
- #{w\ 519}#
- #{s\ 520}#
- #{m\ 506}#
- #{esew\ 507}#
- #{mod\ 521}#))
- #{tmp\ 525}#)
+ (lambda (#{type\ 475}#
+ #{value\ 476}#
+ #{e\ 477}#
+ #{w\ 478}#
+ #{s\ 479}#
+ #{mod\ 480}#)
+ (if (memv #{type\ 475}# (quote (begin-form)))
+ ((lambda (#{tmp\ 481}#)
+ ((lambda (#{tmp\ 482}#)
+ (if #{tmp\ 482}#
+ (apply (lambda (#{_\ 483}#) (#{chi-void\ 174}#))
+ #{tmp\ 482}#)
+ ((lambda (#{tmp\ 484}#)
+ (if #{tmp\ 484}#
+ (apply (lambda (#{_\ 485}#
+ #{e1\ 486}#
+ #{e2\ 487}#)
+ (#{chi-top-sequence\ 162}#
+ (cons #{e1\ 486}# #{e2\ 487}#)
+ #{r\ 463}#
+ #{w\ 478}#
+ #{s\ 479}#
+ #{m\ 465}#
+ #{esew\ 466}#
+ #{mod\ 480}#))
+ #{tmp\ 484}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 522}#)))
+ #{tmp\ 481}#)))
($sc-dispatch
- #{tmp\ 522}#
+ #{tmp\ 481}#
'(any any . each-any)))))
- ($sc-dispatch #{tmp\ 522}# (quote (any)))))
- #{e\ 518}#)
- (if (memv #{type\ 516}# (quote (local-syntax-form)))
- (#{chi-local-syntax\ 171}#
- #{value\ 517}#
- #{e\ 518}#
- #{r\ 504}#
- #{w\ 519}#
- #{s\ 520}#
- #{mod\ 521}#
- (lambda (#{body\ 530}#
- #{r\ 531}#
- #{w\ 532}#
- #{s\ 533}#
- #{mod\ 534}#)
- (#{chi-top-sequence\ 160}#
- #{body\ 530}#
- #{r\ 531}#
- #{w\ 532}#
- #{s\ 533}#
- #{m\ 506}#
- #{esew\ 507}#
- #{mod\ 534}#)))
- (if (memv #{type\ 516}# (quote (eval-when-form)))
- ((lambda (#{tmp\ 535}#)
- ((lambda (#{tmp\ 536}#)
- (if #{tmp\ 536}#
- (apply (lambda (#{_\ 537}#
- #{x\ 538}#
- #{e1\ 539}#
- #{e2\ 540}#)
- (let ((#{when-list\ 541}#
- (#{chi-when-list\ 162}#
- #{e\ 518}#
- #{x\ 538}#
- #{w\ 519}#))
- (#{body\ 542}#
- (cons #{e1\ 539}#
- #{e2\ 540}#)))
- (if (eq? #{m\ 506}# (quote e))
+ ($sc-dispatch #{tmp\ 481}# (quote (any)))))
+ #{e\ 477}#)
+ (if (memv #{type\ 475}# (quote (local-syntax-form)))
+ (#{chi-local-syntax\ 172}#
+ #{value\ 476}#
+ #{e\ 477}#
+ #{r\ 463}#
+ #{w\ 478}#
+ #{s\ 479}#
+ #{mod\ 480}#
+ (lambda (#{body\ 489}#
+ #{r\ 490}#
+ #{w\ 491}#
+ #{s\ 492}#
+ #{mod\ 493}#)
+ (#{chi-top-sequence\ 162}#
+ #{body\ 489}#
+ #{r\ 490}#
+ #{w\ 491}#
+ #{s\ 492}#
+ #{m\ 465}#
+ #{esew\ 466}#
+ #{mod\ 493}#)))
+ (if (memv #{type\ 475}# (quote (eval-when-form)))
+ ((lambda (#{tmp\ 494}#)
+ ((lambda (#{tmp\ 495}#)
+ (if #{tmp\ 495}#
+ (apply (lambda (#{_\ 496}#
+ #{x\ 497}#
+ #{e1\ 498}#
+ #{e2\ 499}#)
+ (let ((#{when-list\ 500}#
+ (#{chi-when-list\ 164}#
+ #{e\ 477}#
+ #{x\ 497}#
+ #{w\ 478}#))
+ (#{body\ 501}#
+ (cons #{e1\ 498}#
+ #{e2\ 499}#)))
+ (if (eq? #{m\ 465}# (quote e))
(if (memq 'eval
- #{when-list\ 541}#)
- (#{chi-top-sequence\ 160}#
- #{body\ 542}#
- #{r\ 504}#
- #{w\ 519}#
- #{s\ 520}#
+ #{when-list\ 500}#)
+ (#{chi-top-sequence\ 162}#
+ #{body\ 501}#
+ #{r\ 463}#
+ #{w\ 478}#
+ #{s\ 479}#
'e
'(eval)
- #{mod\ 521}#)
- (#{chi-void\ 173}#))
+ #{mod\ 480}#)
+ (#{chi-void\ 174}#))
(if (memq 'load
- #{when-list\ 541}#)
- (if (let ((#{t\ 545}# (memq
'compile
-
#{when-list\ 541}#)))
- (if #{t\ 545}#
- #{t\ 545}#
- (if (eq? #{m\ 506}#
+ #{when-list\ 500}#)
+ (if (let ((#{t\ 504}# (memq
'compile
+
#{when-list\ 500}#)))
+ (if #{t\ 504}#
+ #{t\ 504}#
+ (if (eq? #{m\ 465}#
'c&e)
(memq 'eval
- #{when-list\
541}#)
+ #{when-list\
500}#)
#f)))
- (#{chi-top-sequence\ 160}#
- #{body\ 542}#
- #{r\ 504}#
- #{w\ 519}#
- #{s\ 520}#
+ (#{chi-top-sequence\ 162}#
+ #{body\ 501}#
+ #{r\ 463}#
+ #{w\ 478}#
+ #{s\ 479}#
'c&e
'(compile load)
- #{mod\ 521}#)
- (if (memq #{m\ 506}#
+ #{mod\ 480}#)
+ (if (memq #{m\ 465}#
'(c c&e))
- (#{chi-top-sequence\ 160}#
- #{body\ 542}#
- #{r\ 504}#
- #{w\ 519}#
- #{s\ 520}#
+ (#{chi-top-sequence\ 162}#
+ #{body\ 501}#
+ #{r\ 463}#
+ #{w\ 478}#
+ #{s\ 479}#
'c
'(load)
- #{mod\ 521}#)
- (#{chi-void\ 173}#)))
- (if (let ((#{t\ 546}# (memq
'compile
-
#{when-list\ 541}#)))
- (if #{t\ 546}#
- #{t\ 546}#
- (if (eq? #{m\ 506}#
+ #{mod\ 480}#)
+ (#{chi-void\ 174}#)))
+ (if (let ((#{t\ 505}# (memq
'compile
+
#{when-list\ 500}#)))
+ (if #{t\ 505}#
+ #{t\ 505}#
+ (if (eq? #{m\ 465}#
'c&e)
(memq 'eval
- #{when-list\
541}#)
+ #{when-list\
500}#)
#f)))
(begin
(#{top-level-eval-hook\
90}#
- (#{chi-top-sequence\
160}#
- #{body\ 542}#
- #{r\ 504}#
- #{w\ 519}#
- #{s\ 520}#
+ (#{chi-top-sequence\
162}#
+ #{body\ 501}#
+ #{r\ 463}#
+ #{w\ 478}#
+ #{s\ 479}#
'e
'(eval)
- #{mod\ 521}#)
- #{mod\ 521}#)
- (#{chi-void\ 173}#))
- (#{chi-void\ 173}#))))))
- #{tmp\ 536}#)
+ #{mod\ 480}#)
+ #{mod\ 480}#)
+ (#{chi-void\ 174}#))
+ (#{chi-void\ 174}#))))))
+ #{tmp\ 495}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 535}#)))
+ #{tmp\ 494}#)))
($sc-dispatch
- #{tmp\ 535}#
+ #{tmp\ 494}#
'(any each-any any . each-any))))
- #{e\ 518}#)
- (if (memv #{type\ 516}# (quote (define-syntax-form)))
- (let ((#{n\ 547}# (#{id-var-name\ 151}#
- #{value\ 517}#
- #{w\ 519}#))
- (#{r\ 548}# (#{macros-only-env\ 125}#
- #{r\ 504}#)))
- (if (memv #{m\ 506}# (quote (c)))
- (if (memq (quote compile) #{esew\ 507}#)
- (let ((#{e\ 549}# (#{chi-install-global\ 161}#
- #{n\ 547}#
- (#{chi\ 165}#
- #{e\ 518}#
- #{r\ 548}#
- #{w\ 519}#
- #{mod\ 521}#))))
+ #{e\ 477}#)
+ (if (memv #{type\ 475}# (quote (define-syntax-form)))
+ (let ((#{n\ 506}# (#{id-var-name\ 153}#
+ #{value\ 476}#
+ #{w\ 478}#))
+ (#{r\ 507}# (#{macros-only-env\ 127}#
+ #{r\ 463}#)))
+ (if (memv #{m\ 465}# (quote (c)))
+ (if (memq (quote compile) #{esew\ 466}#)
+ (let ((#{e\ 508}# (#{chi-install-global\ 163}#
+ #{n\ 506}#
+ (#{chi\ 167}#
+ #{e\ 477}#
+ #{r\ 507}#
+ #{w\ 478}#
+ #{mod\ 480}#))))
(begin
(#{top-level-eval-hook\ 90}#
- #{e\ 549}#
- #{mod\ 521}#)
- (if (memq (quote load) #{esew\ 507}#)
- #{e\ 549}#
- (#{chi-void\ 173}#))))
- (if (memq (quote load) #{esew\ 507}#)
- (#{chi-install-global\ 161}#
- #{n\ 547}#
- (#{chi\ 165}#
- #{e\ 518}#
- #{r\ 548}#
- #{w\ 519}#
- #{mod\ 521}#))
- (#{chi-void\ 173}#)))
- (if (memv #{m\ 506}# (quote (c&e)))
- (let ((#{e\ 550}# (#{chi-install-global\ 161}#
- #{n\ 547}#
- (#{chi\ 165}#
- #{e\ 518}#
- #{r\ 548}#
- #{w\ 519}#
- #{mod\ 521}#))))
+ #{e\ 508}#
+ #{mod\ 480}#)
+ (if (memq (quote load) #{esew\ 466}#)
+ #{e\ 508}#
+ (#{chi-void\ 174}#))))
+ (if (memq (quote load) #{esew\ 466}#)
+ (#{chi-install-global\ 163}#
+ #{n\ 506}#
+ (#{chi\ 167}#
+ #{e\ 477}#
+ #{r\ 507}#
+ #{w\ 478}#
+ #{mod\ 480}#))
+ (#{chi-void\ 174}#)))
+ (if (memv #{m\ 465}# (quote (c&e)))
+ (let ((#{e\ 509}# (#{chi-install-global\ 163}#
+ #{n\ 506}#
+ (#{chi\ 167}#
+ #{e\ 477}#
+ #{r\ 507}#
+ #{w\ 478}#
+ #{mod\ 480}#))))
(begin
(#{top-level-eval-hook\ 90}#
- #{e\ 550}#
- #{mod\ 521}#)
- #{e\ 550}#))
+ #{e\ 509}#
+ #{mod\ 480}#)
+ #{e\ 509}#))
(begin
- (if (memq (quote eval) #{esew\ 507}#)
+ (if (memq (quote eval) #{esew\ 466}#)
(#{top-level-eval-hook\ 90}#
- (#{chi-install-global\ 161}#
- #{n\ 547}#
- (#{chi\ 165}#
- #{e\ 518}#
- #{r\ 548}#
- #{w\ 519}#
- #{mod\ 521}#))
- #{mod\ 521}#))
- (#{chi-void\ 173}#)))))
- (if (memv #{type\ 516}# (quote (define-form)))
- (let ((#{n\ 551}# (#{id-var-name\ 151}#
- #{value\ 517}#
- #{w\ 519}#)))
- (let ((#{type\ 552}#
- (#{binding-type\ 121}#
- (#{lookup\ 126}#
- #{n\ 551}#
- #{r\ 504}#
- #{mod\ 521}#))))
- (if (memv #{type\ 552}#
+ (#{chi-install-global\ 163}#
+ #{n\ 506}#
+ (#{chi\ 167}#
+ #{e\ 477}#
+ #{r\ 507}#
+ #{w\ 478}#
+ #{mod\ 480}#))
+ #{mod\ 480}#))
+ (#{chi-void\ 174}#)))))
+ (if (memv #{type\ 475}# (quote (define-form)))
+ (let ((#{n\ 510}# (#{id-var-name\ 153}#
+ #{value\ 476}#
+ #{w\ 478}#)))
+ (let ((#{type\ 511}#
+ (#{binding-type\ 123}#
+ (#{lookup\ 128}#
+ #{n\ 510}#
+ #{r\ 463}#
+ #{mod\ 480}#))))
+ (if (memv #{type\ 511}#
'(global core macro module-ref))
(begin
(if (if (not (module-local-variable
(current-module)
- #{n\ 551}#))
+ #{n\ 510}#))
(current-module)
#f)
- (let ((#{old\ 553}#
+ (let ((#{old\ 512}#
(module-variable
(current-module)
- #{n\ 551}#)))
+ #{n\ 510}#)))
(module-define!
(current-module)
- #{n\ 551}#
- (if (variable? #{old\ 553}#)
- (variable-ref #{old\ 553}#)
+ #{n\ 510}#
+ (if (variable? #{old\ 512}#)
+ (variable-ref #{old\ 512}#)
#f))))
- (let ((#{x\ 554}#
(#{build-global-definition\ 104}#
- #{s\ 520}#
- #{n\ 551}#
- (#{chi\ 165}#
- #{e\ 518}#
- #{r\ 504}#
- #{w\ 519}#
- #{mod\ 521}#))))
+ (let ((#{x\ 513}#
(#{build-global-definition\ 104}#
+ #{s\ 479}#
+ #{n\ 510}#
+ (#{chi\ 167}#
+ #{e\ 477}#
+ #{r\ 463}#
+ #{w\ 478}#
+ #{mod\ 480}#))))
(begin
- (if (eq? #{m\ 506}# (quote c&e))
+ (if (eq? #{m\ 465}# (quote c&e))
(#{top-level-eval-hook\ 90}#
- #{x\ 554}#
- #{mod\ 521}#))
- #{x\ 554}#)))
- (if (memv #{type\ 552}#
+ #{x\ 513}#
+ #{mod\ 480}#))
+ #{x\ 513}#)))
+ (if (memv #{type\ 511}#
'(displaced-lexical))
(syntax-violation
#f
"identifier out of context"
- #{e\ 518}#
- (#{wrap\ 157}#
- #{value\ 517}#
- #{w\ 519}#
- #{mod\ 521}#))
+ #{e\ 477}#
+ (#{wrap\ 159}#
+ #{value\ 476}#
+ #{w\ 478}#
+ #{mod\ 480}#))
(syntax-violation
#f
"cannot define keyword at top level"
- #{e\ 518}#
- (#{wrap\ 157}#
- #{value\ 517}#
- #{w\ 519}#
- #{mod\ 521}#))))))
- (let ((#{x\ 555}# (#{chi-expr\ 166}#
- #{type\ 516}#
- #{value\ 517}#
- #{e\ 518}#
- #{r\ 504}#
- #{w\ 519}#
- #{s\ 520}#
- #{mod\ 521}#)))
+ #{e\ 477}#
+ (#{wrap\ 159}#
+ #{value\ 476}#
+ #{w\ 478}#
+ #{mod\ 480}#))))))
+ (let ((#{x\ 514}# (#{chi-expr\ 168}#
+ #{type\ 475}#
+ #{value\ 476}#
+ #{e\ 477}#
+ #{r\ 463}#
+ #{w\ 478}#
+ #{s\ 479}#
+ #{mod\ 480}#)))
(begin
- (if (eq? #{m\ 506}# (quote c&e))
+ (if (eq? #{m\ 465}# (quote c&e))
(#{top-level-eval-hook\ 90}#
- #{x\ 555}#
- #{mod\ 521}#))
- #{x\ 555}#)))))))))))
- (#{syntax-type\ 163}#
- (lambda (#{e\ 556}#
- #{r\ 557}#
- #{w\ 558}#
- #{s\ 559}#
- #{rib\ 560}#
- #{mod\ 561}#
- #{for-car?\ 562}#)
- (if (symbol? #{e\ 556}#)
- (let ((#{n\ 563}# (#{id-var-name\ 151}#
- #{e\ 556}#
- #{w\ 558}#)))
- (let ((#{b\ 564}# (#{lookup\ 126}#
- #{n\ 563}#
- #{r\ 557}#
- #{mod\ 561}#)))
- (let ((#{type\ 565}#
- (#{binding-type\ 121}# #{b\ 564}#)))
- (if (memv #{type\ 565}# (quote (lexical)))
+ #{x\ 514}#
+ #{mod\ 480}#))
+ #{x\ 514}#)))))))))))
+ (#{syntax-type\ 165}#
+ (lambda (#{e\ 515}#
+ #{r\ 516}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{rib\ 519}#
+ #{mod\ 520}#
+ #{for-car?\ 521}#)
+ (if (symbol? #{e\ 515}#)
+ (let ((#{n\ 522}# (#{id-var-name\ 153}#
+ #{e\ 515}#
+ #{w\ 517}#)))
+ (let ((#{b\ 523}# (#{lookup\ 128}#
+ #{n\ 522}#
+ #{r\ 516}#
+ #{mod\ 520}#)))
+ (let ((#{type\ 524}#
+ (#{binding-type\ 123}# #{b\ 523}#)))
+ (if (memv #{type\ 524}# (quote (lexical)))
(values
- #{type\ 565}#
- (#{binding-value\ 122}# #{b\ 564}#)
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)
- (if (memv #{type\ 565}# (quote (global)))
+ #{type\ 524}#
+ (#{binding-value\ 124}# #{b\ 523}#)
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)
+ (if (memv #{type\ 524}# (quote (global)))
(values
- #{type\ 565}#
- #{n\ 563}#
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)
- (if (memv #{type\ 565}# (quote (macro)))
- (if #{for-car?\ 562}#
+ #{type\ 524}#
+ #{n\ 522}#
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)
+ (if (memv #{type\ 524}# (quote (macro)))
+ (if #{for-car?\ 521}#
(values
- #{type\ 565}#
- (#{binding-value\ 122}# #{b\ 564}#)
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)
- (#{syntax-type\ 163}#
- (#{chi-macro\ 168}#
- (#{binding-value\ 122}# #{b\ 564}#)
- #{e\ 556}#
- #{r\ 557}#
- #{w\ 558}#
- #{rib\ 560}#
- #{mod\ 561}#)
- #{r\ 557}#
+ #{type\ 524}#
+ (#{binding-value\ 124}# #{b\ 523}#)
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)
+ (#{syntax-type\ 165}#
+ (#{chi-macro\ 170}#
+ (#{binding-value\ 124}# #{b\ 523}#)
+ #{e\ 515}#
+ #{r\ 516}#
+ #{w\ 517}#
+ #{rib\ 519}#
+ #{mod\ 520}#)
+ #{r\ 516}#
'(())
- #{s\ 559}#
- #{rib\ 560}#
- #{mod\ 561}#
+ #{s\ 518}#
+ #{rib\ 519}#
+ #{mod\ 520}#
#f))
(values
- #{type\ 565}#
- (#{binding-value\ 122}# #{b\ 564}#)
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)))))))
- (if (pair? #{e\ 556}#)
- (let ((#{first\ 566}# (car #{e\ 556}#)))
+ #{type\ 524}#
+ (#{binding-value\ 124}# #{b\ 523}#)
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)))))))
+ (if (pair? #{e\ 515}#)
+ (let ((#{first\ 525}# (car #{e\ 515}#)))
(call-with-values
(lambda ()
- (#{syntax-type\ 163}#
- #{first\ 566}#
- #{r\ 557}#
- #{w\ 558}#
- #{s\ 559}#
- #{rib\ 560}#
- #{mod\ 561}#
+ (#{syntax-type\ 165}#
+ #{first\ 525}#
+ #{r\ 516}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{rib\ 519}#
+ #{mod\ 520}#
#t))
- (lambda (#{ftype\ 567}#
- #{fval\ 568}#
- #{fe\ 569}#
- #{fw\ 570}#
- #{fs\ 571}#
- #{fmod\ 572}#)
- (if (memv #{ftype\ 567}# (quote (lexical)))
+ (lambda (#{ftype\ 526}#
+ #{fval\ 527}#
+ #{fe\ 528}#
+ #{fw\ 529}#
+ #{fs\ 530}#
+ #{fmod\ 531}#)
+ (if (memv #{ftype\ 526}# (quote (lexical)))
(values
'lexical-call
- #{fval\ 568}#
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)
- (if (memv #{ftype\ 567}# (quote (global)))
+ #{fval\ 527}#
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)
+ (if (memv #{ftype\ 526}# (quote (global)))
(values
'global-call
- (#{make-syntax-object\ 112}#
- #{fval\ 568}#
- #{w\ 558}#
- #{fmod\ 572}#)
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)
- (if (memv #{ftype\ 567}# (quote (macro)))
- (#{syntax-type\ 163}#
- (#{chi-macro\ 168}#
- #{fval\ 568}#
- #{e\ 556}#
- #{r\ 557}#
- #{w\ 558}#
- #{rib\ 560}#
- #{mod\ 561}#)
- #{r\ 557}#
+ (#{make-syntax-object\ 114}#
+ #{fval\ 527}#
+ #{w\ 517}#
+ #{fmod\ 531}#)
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)
+ (if (memv #{ftype\ 526}# (quote (macro)))
+ (#{syntax-type\ 165}#
+ (#{chi-macro\ 170}#
+ #{fval\ 527}#
+ #{e\ 515}#
+ #{r\ 516}#
+ #{w\ 517}#
+ #{rib\ 519}#
+ #{mod\ 520}#)
+ #{r\ 516}#
'(())
- #{s\ 559}#
- #{rib\ 560}#
- #{mod\ 561}#
- #{for-car?\ 562}#)
- (if (memv #{ftype\ 567}# (quote (module-ref)))
+ #{s\ 518}#
+ #{rib\ 519}#
+ #{mod\ 520}#
+ #{for-car?\ 521}#)
+ (if (memv #{ftype\ 526}# (quote (module-ref)))
(call-with-values
- (lambda () (#{fval\ 568}# #{e\ 556}#))
- (lambda (#{sym\ 573}# #{mod\ 574}#)
- (#{syntax-type\ 163}#
- #{sym\ 573}#
- #{r\ 557}#
- #{w\ 558}#
- #{s\ 559}#
- #{rib\ 560}#
- #{mod\ 574}#
- #{for-car?\ 562}#)))
- (if (memv #{ftype\ 567}# (quote (core)))
+ (lambda () (#{fval\ 527}# #{e\ 515}#))
+ (lambda (#{sym\ 532}# #{mod\ 533}#)
+ (#{syntax-type\ 165}#
+ #{sym\ 532}#
+ #{r\ 516}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{rib\ 519}#
+ #{mod\ 533}#
+ #{for-car?\ 521}#)))
+ (if (memv #{ftype\ 526}# (quote (core)))
(values
'core-form
- #{fval\ 568}#
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)
- (if (memv #{ftype\ 567}#
+ #{fval\ 527}#
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)
+ (if (memv #{ftype\ 526}#
'(local-syntax))
(values
'local-syntax-form
- #{fval\ 568}#
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)
- (if (memv #{ftype\ 567}# (quote (begin)))
+ #{fval\ 527}#
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)
+ (if (memv #{ftype\ 526}# (quote (begin)))
(values
'begin-form
#f
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)
- (if (memv #{ftype\ 567}#
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)
+ (if (memv #{ftype\ 526}#
'(eval-when))
(values
'eval-when-form
#f
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)
- (if (memv #{ftype\ 567}#
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)
+ (if (memv #{ftype\ 526}#
'(define))
- ((lambda (#{tmp\ 575}#)
- ((lambda (#{tmp\ 576}#)
- (if (if #{tmp\ 576}#
- (apply (lambda (#{_\
577}#
- #{name\
578}#
- #{val\
579}#)
- (#{id?\ 129}#
- #{name\
578}#))
- #{tmp\ 576}#)
+ ((lambda (#{tmp\ 534}#)
+ ((lambda (#{tmp\ 535}#)
+ (if (if #{tmp\ 535}#
+ (apply (lambda (#{_\
536}#
+ #{name\
537}#
+ #{val\
538}#)
+ (#{id?\ 131}#
+ #{name\
537}#))
+ #{tmp\ 535}#)
#f)
- (apply (lambda (#{_\ 580}#
- #{name\
581}#
- #{val\
582}#)
+ (apply (lambda (#{_\ 539}#
+ #{name\
540}#
+ #{val\
541}#)
(values
'define-form
- #{name\ 581}#
- #{val\ 582}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#))
- #{tmp\ 576}#)
- ((lambda (#{tmp\ 583}#)
- (if (if #{tmp\ 583}#
- (apply (lambda
(#{_\ 584}#
-
#{name\ 585}#
-
#{args\ 586}#
-
#{e1\ 587}#
-
#{e2\ 588}#)
- (if
(#{id?\ 129}#
-
#{name\ 585}#)
-
(#{valid-bound-ids?\ 154}#
-
(#{lambda-var-list\ 177}#
-
#{args\ 586}#))
+ #{name\ 540}#
+ #{val\ 541}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#))
+ #{tmp\ 535}#)
+ ((lambda (#{tmp\ 542}#)
+ (if (if #{tmp\ 542}#
+ (apply (lambda
(#{_\ 543}#
+
#{name\ 544}#
+
#{args\ 545}#
+
#{e1\ 546}#
+
#{e2\ 547}#)
+ (if
(#{id?\ 131}#
+
#{name\ 544}#)
+
(#{valid-bound-ids?\ 156}#
+
(#{lambda-var-list\ 178}#
+
#{args\ 545}#))
#f))
- #{tmp\
583}#)
+ #{tmp\
542}#)
#f)
- (apply (lambda (#{_\
589}#
-
#{name\ 590}#
-
#{args\ 591}#
- #{e1\
592}#
- #{e2\
593}#)
+ (apply (lambda (#{_\
548}#
+
#{name\ 549}#
+
#{args\ 550}#
+ #{e1\
551}#
+ #{e2\
552}#)
(values
'define-form
- (#{wrap\
157}#
- #{name\
590}#
- #{w\ 558}#
- #{mod\
561}#)
+ (#{wrap\
159}#
+ #{name\
549}#
+ #{w\ 517}#
+ #{mod\
520}#)
(#{decorate-source\ 94}#
(cons
'#(syntax-object
lambda
@@ -1929,7 +1785,6 @@
chi-void
eval-local-transformer
chi-local-syntax
-
chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -2011,7 +1866,9 @@
build-sequence
build-data
build-primref
-
build-lambda
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -2145,6 +2002,7 @@
(top)
(top)
(top)
+
(top)
(top))
("i"
"i"
@@ -2257,6 +2115,7 @@
"i"
"i"
"i"
+
"i"
"i"))
#(ribcage
(define-structure
@@ -2267,33 +2126,33 @@
"i")))
(hygiene
guile))
-
(#{wrap\ 157}#
-
(cons #{args\ 591}#
-
(cons #{e1\ 592}#
-
#{e2\ 593}#))
-
#{w\ 558}#
-
#{mod\ 561}#))
- #{s\
559}#)
+
(#{wrap\ 159}#
+
(cons #{args\ 550}#
+
(cons #{e1\ 551}#
+
#{e2\ 552}#))
+
#{w\ 517}#
+
#{mod\ 520}#))
+ #{s\
518}#)
'(())
- #{s\ 559}#
- #{mod\
561}#))
- #{tmp\ 583}#)
- ((lambda (#{tmp\ 595}#)
- (if (if #{tmp\ 595}#
- (apply
(lambda (#{_\ 596}#
-
#{name\ 597}#)
-
(#{id?\ 129}#
-
#{name\ 597}#))
- #{tmp\
595}#)
+ #{s\ 518}#
+ #{mod\
520}#))
+ #{tmp\ 542}#)
+ ((lambda (#{tmp\ 554}#)
+ (if (if #{tmp\ 554}#
+ (apply
(lambda (#{_\ 555}#
+
#{name\ 556}#)
+
(#{id?\ 131}#
+
#{name\ 556}#))
+ #{tmp\
554}#)
#f)
- (apply (lambda
(#{_\ 598}#
-
#{name\ 599}#)
+ (apply (lambda
(#{_\ 557}#
+
#{name\ 558}#)
(values
'define-form
-
(#{wrap\ 157}#
-
#{name\ 599}#
- #{w\
558}#
-
#{mod\ 561}#)
+
(#{wrap\ 159}#
+
#{name\ 558}#
+ #{w\
517}#
+
#{mod\ 520}#)
'(#(syntax-object
if
((top)
@@ -2381,7 +2240,6 @@
chi-void
eval-local-transformer
chi-local-syntax
-
chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -2463,7 +2321,9 @@
build-sequence
build-data
build-primref
-
build-lambda
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -2597,6 +2457,7 @@
(top)
(top)
(top)
+
(top)
(top))
("i"
"i"
@@ -2709,6 +2570,7 @@
"i"
"i"
"i"
+
"i"
"i"))
#(ribcage
(define-structure
@@ -2806,7 +2668,6 @@
chi-void
eval-local-transformer
chi-local-syntax
-
chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -2888,7 +2749,9 @@
build-sequence
build-data
build-primref
-
build-lambda
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -3022,6 +2885,7 @@
(top)
(top)
(top)
+
(top)
(top))
("i"
"i"
@@ -3134,6 +2998,7 @@
"i"
"i"
"i"
+
"i"
"i"))
#(ribcage
(define-structure
@@ -3231,7 +3096,6 @@
chi-void
eval-local-transformer
chi-local-syntax
-
chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -3313,7 +3177,9 @@
build-sequence
build-data
build-primref
-
build-lambda
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -3447,6 +3313,7 @@
(top)
(top)
(top)
+
(top)
(top))
("i"
"i"
@@ -3559,6 +3426,7 @@
"i"
"i"
"i"
+
"i"
"i"))
#(ribcage
(define-structure
@@ -3570,102 +3438,102 @@
(hygiene
guile)))
'(())
- #{s\
559}#
- #{mod\
561}#))
- #{tmp\
595}#)
+ #{s\
518}#
+ #{mod\
520}#))
+ #{tmp\
554}#)
(syntax-violation
#f
"source
expression failed to match any pattern"
- #{tmp\ 575}#)))
+ #{tmp\ 534}#)))
($sc-dispatch
- #{tmp\ 575}#
+ #{tmp\ 534}#
'(any any)))))
($sc-dispatch
- #{tmp\ 575}#
+ #{tmp\ 534}#
'(any (any . any)
any
.
each-any)))))
($sc-dispatch
- #{tmp\ 575}#
+ #{tmp\ 534}#
'(any any any))))
- #{e\ 556}#)
- (if (memv #{ftype\ 567}#
+ #{e\ 515}#)
+ (if (memv #{ftype\ 526}#
'(define-syntax))
- ((lambda (#{tmp\ 600}#)
- ((lambda (#{tmp\ 601}#)
- (if (if #{tmp\ 601}#
- (apply (lambda (#{_\
602}#
-
#{name\ 603}#
-
#{val\ 604}#)
- (#{id?\ 129}#
- #{name\
603}#))
- #{tmp\ 601}#)
+ ((lambda (#{tmp\ 559}#)
+ ((lambda (#{tmp\ 560}#)
+ (if (if #{tmp\ 560}#
+ (apply (lambda (#{_\
561}#
+
#{name\ 562}#
+
#{val\ 563}#)
+ (#{id?\ 131}#
+ #{name\
562}#))
+ #{tmp\ 560}#)
#f)
- (apply (lambda (#{_\ 605}#
- #{name\
606}#
- #{val\
607}#)
+ (apply (lambda (#{_\ 564}#
+ #{name\
565}#
+ #{val\
566}#)
(values
'define-syntax-form
- #{name\ 606}#
- #{val\ 607}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#))
- #{tmp\ 601}#)
+ #{name\ 565}#
+ #{val\ 566}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#))
+ #{tmp\ 560}#)
(syntax-violation
#f
"source expression
failed to match any pattern"
- #{tmp\ 600}#)))
+ #{tmp\ 559}#)))
($sc-dispatch
- #{tmp\ 600}#
+ #{tmp\ 559}#
'(any any any))))
- #{e\ 556}#)
+ #{e\ 515}#)
(values
'call
#f
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#))))))))))))))
- (if (#{syntax-object?\ 113}# #{e\ 556}#)
- (#{syntax-type\ 163}#
- (#{syntax-object-expression\ 114}# #{e\ 556}#)
- #{r\ 557}#
- (#{join-wraps\ 148}#
- #{w\ 558}#
- (#{syntax-object-wrap\ 115}# #{e\ 556}#))
- #{s\ 559}#
- #{rib\ 560}#
- (let ((#{t\ 608}# (#{syntax-object-module\ 116}#
- #{e\ 556}#)))
- (if #{t\ 608}# #{t\ 608}# #{mod\ 561}#))
- #{for-car?\ 562}#)
- (if (self-evaluating? #{e\ 556}#)
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#))))))))))))))
+ (if (#{syntax-object?\ 115}# #{e\ 515}#)
+ (#{syntax-type\ 165}#
+ (#{syntax-object-expression\ 116}# #{e\ 515}#)
+ #{r\ 516}#
+ (#{join-wraps\ 150}#
+ #{w\ 517}#
+ (#{syntax-object-wrap\ 117}# #{e\ 515}#))
+ #{s\ 518}#
+ #{rib\ 519}#
+ (let ((#{t\ 567}# (#{syntax-object-module\ 118}#
+ #{e\ 515}#)))
+ (if #{t\ 567}# #{t\ 567}# #{mod\ 520}#))
+ #{for-car?\ 521}#)
+ (if (self-evaluating? #{e\ 515}#)
(values
'constant
#f
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)
(values
'other
#f
- #{e\ 556}#
- #{w\ 558}#
- #{s\ 559}#
- #{mod\ 561}#)))))))
- (#{chi-when-list\ 162}#
- (lambda (#{e\ 609}# #{when-list\ 610}# #{w\ 611}#)
- (letrec ((#{f\ 612}# (lambda (#{when-list\ 613}#
- #{situations\ 614}#)
- (if (null? #{when-list\ 613}#)
- #{situations\ 614}#
- (#{f\ 612}# (cdr #{when-list\ 613}#)
- (cons (let ((#{x\ 615}#
(car #{when-list\ 613}#)))
- (if (#{free-id=?\
152}#
- #{x\ 615}#
+ #{e\ 515}#
+ #{w\ 517}#
+ #{s\ 518}#
+ #{mod\ 520}#)))))))
+ (#{chi-when-list\ 164}#
+ (lambda (#{e\ 568}# #{when-list\ 569}# #{w\ 570}#)
+ (letrec ((#{f\ 571}# (lambda (#{when-list\ 572}#
+ #{situations\ 573}#)
+ (if (null? #{when-list\ 572}#)
+ #{situations\ 573}#
+ (#{f\ 571}# (cdr #{when-list\ 572}#)
+ (cons (let ((#{x\ 574}#
(car #{when-list\ 572}#)))
+ (if (#{free-id=?\
154}#
+ #{x\ 574}#
'#(syntax-object
compile
((top)
@@ -3721,7 +3589,6 @@
chi-void
eval-local-transformer
chi-local-syntax
-
chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -3803,7 +3670,9 @@
build-sequence
build-data
build-primref
-
build-lambda
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -3937,6 +3806,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -4049,6 +3919,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -4060,8 +3931,8 @@
(hygiene
guile)))
'compile
- (if
(#{free-id=?\ 152}#
- #{x\ 615}#
+ (if
(#{free-id=?\ 154}#
+ #{x\ 574}#
'#(syntax-object
load
((top)
@@ -4117,7 +3988,6 @@
chi-void
eval-local-transformer
chi-local-syntax
-
chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -4199,7 +4069,9 @@
build-sequence
build-data
build-primref
-
build-lambda
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -4333,6 +4205,7 @@
(top)
(top)
(top)
+
(top)
(top))
("i"
"i"
@@ -4445,6 +4318,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -4456,8 +4330,8 @@
(hygiene
guile)))
'load
- (if
(#{free-id=?\ 152}#
- #{x\
615}#
+ (if
(#{free-id=?\ 154}#
+ #{x\
574}#
'#(syntax-object
eval
((top)
@@ -4513,7 +4387,6 @@
chi-void
eval-local-transformer
chi-local-syntax
-
chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -4595,7 +4468,9 @@
build-sequence
build-data
build-primref
-
build-lambda
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -4729,6 +4604,7 @@
(top)
(top)
(top)
+
(top)
(top))
("i"
"i"
@@ -4841,6 +4717,7 @@
"i"
"i"
"i"
+
"i"
"i"))
#(ribcage
(define-structure
@@ -4855,1072 +4732,1212 @@
(syntax-violation
'eval-when
"invalid
situation"
- #{e\ 609}#
- (#{wrap\
157}#
- #{x\
615}#
- #{w\
611}#
+ #{e\ 568}#
+ (#{wrap\
159}#
+ #{x\
574}#
+ #{w\
570}#
#f))))))
- #{situations\
614}#))))))
- (#{f\ 612}# #{when-list\ 610}# (quote ())))))
- (#{chi-install-global\ 161}#
- (lambda (#{name\ 616}# #{e\ 617}#)
+ #{situations\
573}#))))))
+ (#{f\ 571}# #{when-list\ 569}# (quote ())))))
+ (#{chi-install-global\ 163}#
+ (lambda (#{name\ 575}# #{e\ 576}#)
(#{build-global-definition\ 104}#
#f
- #{name\ 616}#
- (if (let ((#{v\ 618}# (module-variable
+ #{name\ 575}#
+ (if (let ((#{v\ 577}# (module-variable
(current-module)
- #{name\ 616}#)))
- (if #{v\ 618}#
- (if (variable-bound? #{v\ 618}#)
- (if (macro? (variable-ref #{v\ 618}#))
- (not (eq? (macro-type (variable-ref #{v\ 618}#))
+ #{name\ 575}#)))
+ (if #{v\ 577}#
+ (if (variable-bound? #{v\ 577}#)
+ (if (macro? (variable-ref #{v\ 577}#))
+ (not (eq? (macro-type (variable-ref #{v\ 577}#))
'syncase-macro))
#f)
#f)
#f))
(#{build-application\ 96}#
#f
- (#{build-primref\ 106}#
+ (#{build-primref\ 108}#
#f
'make-extended-syncase-macro)
(list (#{build-application\ 96}#
#f
- (#{build-primref\ 106}# #f (quote module-ref))
+ (#{build-primref\ 108}# #f (quote module-ref))
(list (#{build-application\ 96}#
#f
- (#{build-primref\ 106}#
+ (#{build-primref\ 108}#
#f
'current-module)
'())
- (#{build-data\ 107}# #f #{name\ 616}#)))
- (#{build-data\ 107}# #f (quote macro))
- #{e\ 617}#))
+ (#{build-data\ 109}# #f #{name\ 575}#)))
+ (#{build-data\ 109}# #f (quote macro))
+ #{e\ 576}#))
(#{build-application\ 96}#
#f
- (#{build-primref\ 106}#
+ (#{build-primref\ 108}#
#f
'make-syncase-macro)
- (list (#{build-data\ 107}# #f (quote macro))
- #{e\ 617}#))))))
- (#{chi-top-sequence\ 160}#
- (lambda (#{body\ 619}#
- #{r\ 620}#
- #{w\ 621}#
- #{s\ 622}#
- #{m\ 623}#
- #{esew\ 624}#
- #{mod\ 625}#)
- (#{build-sequence\ 108}#
- #{s\ 622}#
- (letrec ((#{dobody\ 626}#
- (lambda (#{body\ 627}#
- #{r\ 628}#
- #{w\ 629}#
- #{m\ 630}#
- #{esew\ 631}#
- #{mod\ 632}#)
- (if (null? #{body\ 627}#)
+ (list (#{build-data\ 109}# #f (quote macro))
+ #{e\ 576}#))))))
+ (#{chi-top-sequence\ 162}#
+ (lambda (#{body\ 578}#
+ #{r\ 579}#
+ #{w\ 580}#
+ #{s\ 581}#
+ #{m\ 582}#
+ #{esew\ 583}#
+ #{mod\ 584}#)
+ (#{build-sequence\ 110}#
+ #{s\ 581}#
+ (letrec ((#{dobody\ 585}#
+ (lambda (#{body\ 586}#
+ #{r\ 587}#
+ #{w\ 588}#
+ #{m\ 589}#
+ #{esew\ 590}#
+ #{mod\ 591}#)
+ (if (null? #{body\ 586}#)
'()
- (let ((#{first\ 633}#
- (#{chi-top\ 164}#
- (car #{body\ 627}#)
- #{r\ 628}#
- #{w\ 629}#
- #{m\ 630}#
- #{esew\ 631}#
- #{mod\ 632}#)))
- (cons #{first\ 633}#
- (#{dobody\ 626}#
- (cdr #{body\ 627}#)
- #{r\ 628}#
- #{w\ 629}#
- #{m\ 630}#
- #{esew\ 631}#
- #{mod\ 632}#)))))))
- (#{dobody\ 626}#
- #{body\ 619}#
- #{r\ 620}#
- #{w\ 621}#
- #{m\ 623}#
- #{esew\ 624}#
- #{mod\ 625}#)))))
- (#{chi-sequence\ 159}#
- (lambda (#{body\ 634}#
- #{r\ 635}#
- #{w\ 636}#
- #{s\ 637}#
- #{mod\ 638}#)
- (#{build-sequence\ 108}#
- #{s\ 637}#
- (letrec ((#{dobody\ 639}#
- (lambda (#{body\ 640}#
- #{r\ 641}#
- #{w\ 642}#
- #{mod\ 643}#)
- (if (null? #{body\ 640}#)
+ (let ((#{first\ 592}#
+ (#{chi-top\ 166}#
+ (car #{body\ 586}#)
+ #{r\ 587}#
+ #{w\ 588}#
+ #{m\ 589}#
+ #{esew\ 590}#
+ #{mod\ 591}#)))
+ (cons #{first\ 592}#
+ (#{dobody\ 585}#
+ (cdr #{body\ 586}#)
+ #{r\ 587}#
+ #{w\ 588}#
+ #{m\ 589}#
+ #{esew\ 590}#
+ #{mod\ 591}#)))))))
+ (#{dobody\ 585}#
+ #{body\ 578}#
+ #{r\ 579}#
+ #{w\ 580}#
+ #{m\ 582}#
+ #{esew\ 583}#
+ #{mod\ 584}#)))))
+ (#{chi-sequence\ 161}#
+ (lambda (#{body\ 593}#
+ #{r\ 594}#
+ #{w\ 595}#
+ #{s\ 596}#
+ #{mod\ 597}#)
+ (#{build-sequence\ 110}#
+ #{s\ 596}#
+ (letrec ((#{dobody\ 598}#
+ (lambda (#{body\ 599}#
+ #{r\ 600}#
+ #{w\ 601}#
+ #{mod\ 602}#)
+ (if (null? #{body\ 599}#)
'()
- (let ((#{first\ 644}#
- (#{chi\ 165}#
- (car #{body\ 640}#)
- #{r\ 641}#
- #{w\ 642}#
- #{mod\ 643}#)))
- (cons #{first\ 644}#
- (#{dobody\ 639}#
- (cdr #{body\ 640}#)
- #{r\ 641}#
- #{w\ 642}#
- #{mod\ 643}#)))))))
- (#{dobody\ 639}#
- #{body\ 634}#
- #{r\ 635}#
- #{w\ 636}#
- #{mod\ 638}#)))))
- (#{source-wrap\ 158}#
- (lambda (#{x\ 645}#
- #{w\ 646}#
- #{s\ 647}#
- #{defmod\ 648}#)
- (#{wrap\ 157}#
- (#{decorate-source\ 94}# #{x\ 645}# #{s\ 647}#)
- #{w\ 646}#
- #{defmod\ 648}#)))
- (#{wrap\ 157}#
- (lambda (#{x\ 649}# #{w\ 650}# #{defmod\ 651}#)
- (if (if (null? (#{wrap-marks\ 132}# #{w\ 650}#))
- (null? (#{wrap-subst\ 133}# #{w\ 650}#))
+ (let ((#{first\ 603}#
+ (#{chi\ 167}#
+ (car #{body\ 599}#)
+ #{r\ 600}#
+ #{w\ 601}#
+ #{mod\ 602}#)))
+ (cons #{first\ 603}#
+ (#{dobody\ 598}#
+ (cdr #{body\ 599}#)
+ #{r\ 600}#
+ #{w\ 601}#
+ #{mod\ 602}#)))))))
+ (#{dobody\ 598}#
+ #{body\ 593}#
+ #{r\ 594}#
+ #{w\ 595}#
+ #{mod\ 597}#)))))
+ (#{source-wrap\ 160}#
+ (lambda (#{x\ 604}#
+ #{w\ 605}#
+ #{s\ 606}#
+ #{defmod\ 607}#)
+ (#{wrap\ 159}#
+ (#{decorate-source\ 94}# #{x\ 604}# #{s\ 606}#)
+ #{w\ 605}#
+ #{defmod\ 607}#)))
+ (#{wrap\ 159}#
+ (lambda (#{x\ 608}# #{w\ 609}# #{defmod\ 610}#)
+ (if (if (null? (#{wrap-marks\ 134}# #{w\ 609}#))
+ (null? (#{wrap-subst\ 135}# #{w\ 609}#))
#f)
- #{x\ 649}#
- (if (#{syntax-object?\ 113}# #{x\ 649}#)
- (#{make-syntax-object\ 112}#
- (#{syntax-object-expression\ 114}# #{x\ 649}#)
- (#{join-wraps\ 148}#
- #{w\ 650}#
- (#{syntax-object-wrap\ 115}# #{x\ 649}#))
- (#{syntax-object-module\ 116}# #{x\ 649}#))
- (if (null? #{x\ 649}#)
- #{x\ 649}#
- (#{make-syntax-object\ 112}#
- #{x\ 649}#
- #{w\ 650}#
- #{defmod\ 651}#))))))
- (#{bound-id-member?\ 156}#
- (lambda (#{x\ 652}# #{list\ 653}#)
- (if (not (null? #{list\ 653}#))
- (let ((#{t\ 654}# (#{bound-id=?\ 153}#
- #{x\ 652}#
- (car #{list\ 653}#))))
- (if #{t\ 654}#
- #{t\ 654}#
- (#{bound-id-member?\ 156}#
- #{x\ 652}#
- (cdr #{list\ 653}#))))
+ #{x\ 608}#
+ (if (#{syntax-object?\ 115}# #{x\ 608}#)
+ (#{make-syntax-object\ 114}#
+ (#{syntax-object-expression\ 116}# #{x\ 608}#)
+ (#{join-wraps\ 150}#
+ #{w\ 609}#
+ (#{syntax-object-wrap\ 117}# #{x\ 608}#))
+ (#{syntax-object-module\ 118}# #{x\ 608}#))
+ (if (null? #{x\ 608}#)
+ #{x\ 608}#
+ (#{make-syntax-object\ 114}#
+ #{x\ 608}#
+ #{w\ 609}#
+ #{defmod\ 610}#))))))
+ (#{bound-id-member?\ 158}#
+ (lambda (#{x\ 611}# #{list\ 612}#)
+ (if (not (null? #{list\ 612}#))
+ (let ((#{t\ 613}# (#{bound-id=?\ 155}#
+ #{x\ 611}#
+ (car #{list\ 612}#))))
+ (if #{t\ 613}#
+ #{t\ 613}#
+ (#{bound-id-member?\ 158}#
+ #{x\ 611}#
+ (cdr #{list\ 612}#))))
#f)))
- (#{distinct-bound-ids?\ 155}#
- (lambda (#{ids\ 655}#)
- (letrec ((#{distinct?\ 656}#
- (lambda (#{ids\ 657}#)
- (let ((#{t\ 658}# (null? #{ids\ 657}#)))
- (if #{t\ 658}#
- #{t\ 658}#
- (if (not (#{bound-id-member?\ 156}#
- (car #{ids\ 657}#)
- (cdr #{ids\ 657}#)))
- (#{distinct?\ 656}# (cdr #{ids\ 657}#))
+ (#{distinct-bound-ids?\ 157}#
+ (lambda (#{ids\ 614}#)
+ (letrec ((#{distinct?\ 615}#
+ (lambda (#{ids\ 616}#)
+ (let ((#{t\ 617}# (null? #{ids\ 616}#)))
+ (if #{t\ 617}#
+ #{t\ 617}#
+ (if (not (#{bound-id-member?\ 158}#
+ (car #{ids\ 616}#)
+ (cdr #{ids\ 616}#)))
+ (#{distinct?\ 615}# (cdr #{ids\ 616}#))
#f))))))
- (#{distinct?\ 656}# #{ids\ 655}#))))
- (#{valid-bound-ids?\ 154}#
- (lambda (#{ids\ 659}#)
- (if (letrec ((#{all-ids?\ 660}#
- (lambda (#{ids\ 661}#)
- (let ((#{t\ 662}# (null? #{ids\ 661}#)))
- (if #{t\ 662}#
- #{t\ 662}#
- (if (#{id?\ 129}# (car #{ids\ 661}#))
- (#{all-ids?\ 660}# (cdr #{ids\ 661}#))
+ (#{distinct?\ 615}# #{ids\ 614}#))))
+ (#{valid-bound-ids?\ 156}#
+ (lambda (#{ids\ 618}#)
+ (if (letrec ((#{all-ids?\ 619}#
+ (lambda (#{ids\ 620}#)
+ (let ((#{t\ 621}# (null? #{ids\ 620}#)))
+ (if #{t\ 621}#
+ #{t\ 621}#
+ (if (#{id?\ 131}# (car #{ids\ 620}#))
+ (#{all-ids?\ 619}# (cdr #{ids\ 620}#))
#f))))))
- (#{all-ids?\ 660}# #{ids\ 659}#))
- (#{distinct-bound-ids?\ 155}# #{ids\ 659}#)
+ (#{all-ids?\ 619}# #{ids\ 618}#))
+ (#{distinct-bound-ids?\ 157}# #{ids\ 618}#)
#f)))
- (#{bound-id=?\ 153}#
- (lambda (#{i\ 663}# #{j\ 664}#)
- (if (if (#{syntax-object?\ 113}# #{i\ 663}#)
- (#{syntax-object?\ 113}# #{j\ 664}#)
+ (#{bound-id=?\ 155}#
+ (lambda (#{i\ 622}# #{j\ 623}#)
+ (if (if (#{syntax-object?\ 115}# #{i\ 622}#)
+ (#{syntax-object?\ 115}# #{j\ 623}#)
#f)
- (if (eq? (#{syntax-object-expression\ 114}# #{i\ 663}#)
- (#{syntax-object-expression\ 114}# #{j\ 664}#))
- (#{same-marks?\ 150}#
- (#{wrap-marks\ 132}#
- (#{syntax-object-wrap\ 115}# #{i\ 663}#))
- (#{wrap-marks\ 132}#
- (#{syntax-object-wrap\ 115}# #{j\ 664}#)))
+ (if (eq? (#{syntax-object-expression\ 116}# #{i\ 622}#)
+ (#{syntax-object-expression\ 116}# #{j\ 623}#))
+ (#{same-marks?\ 152}#
+ (#{wrap-marks\ 134}#
+ (#{syntax-object-wrap\ 117}# #{i\ 622}#))
+ (#{wrap-marks\ 134}#
+ (#{syntax-object-wrap\ 117}# #{j\ 623}#)))
#f)
- (eq? #{i\ 663}# #{j\ 664}#))))
- (#{free-id=?\ 152}#
- (lambda (#{i\ 665}# #{j\ 666}#)
- (if (eq? (let ((#{x\ 667}# #{i\ 665}#))
- (if (#{syntax-object?\ 113}# #{x\ 667}#)
- (#{syntax-object-expression\ 114}# #{x\ 667}#)
- #{x\ 667}#))
- (let ((#{x\ 668}# #{j\ 666}#))
- (if (#{syntax-object?\ 113}# #{x\ 668}#)
- (#{syntax-object-expression\ 114}# #{x\ 668}#)
- #{x\ 668}#)))
- (eq? (#{id-var-name\ 151}# #{i\ 665}# (quote (())))
- (#{id-var-name\ 151}# #{j\ 666}# (quote (()))))
+ (eq? #{i\ 622}# #{j\ 623}#))))
+ (#{free-id=?\ 154}#
+ (lambda (#{i\ 624}# #{j\ 625}#)
+ (if (eq? (let ((#{x\ 626}# #{i\ 624}#))
+ (if (#{syntax-object?\ 115}# #{x\ 626}#)
+ (#{syntax-object-expression\ 116}# #{x\ 626}#)
+ #{x\ 626}#))
+ (let ((#{x\ 627}# #{j\ 625}#))
+ (if (#{syntax-object?\ 115}# #{x\ 627}#)
+ (#{syntax-object-expression\ 116}# #{x\ 627}#)
+ #{x\ 627}#)))
+ (eq? (#{id-var-name\ 153}# #{i\ 624}# (quote (())))
+ (#{id-var-name\ 153}# #{j\ 625}# (quote (()))))
#f)))
- (#{id-var-name\ 151}#
- (lambda (#{id\ 669}# #{w\ 670}#)
- (letrec ((#{search-vector-rib\ 673}#
- (lambda (#{sym\ 679}#
- #{subst\ 680}#
- #{marks\ 681}#
- #{symnames\ 682}#
- #{ribcage\ 683}#)
- (let ((#{n\ 684}# (vector-length
- #{symnames\ 682}#)))
- (letrec ((#{f\ 685}# (lambda (#{i\ 686}#)
+ (#{id-var-name\ 153}#
+ (lambda (#{id\ 628}# #{w\ 629}#)
+ (letrec ((#{search-vector-rib\ 632}#
+ (lambda (#{sym\ 638}#
+ #{subst\ 639}#
+ #{marks\ 640}#
+ #{symnames\ 641}#
+ #{ribcage\ 642}#)
+ (let ((#{n\ 643}# (vector-length
+ #{symnames\ 641}#)))
+ (letrec ((#{f\ 644}# (lambda (#{i\ 645}#)
(if (#{fx=\ 88}#
- #{i\ 686}#
- #{n\ 684}#)
- (#{search\ 671}#
- #{sym\ 679}#
- (cdr #{subst\ 680}#)
- #{marks\ 681}#)
+ #{i\ 645}#
+ #{n\ 643}#)
+ (#{search\ 630}#
+ #{sym\ 638}#
+ (cdr #{subst\ 639}#)
+ #{marks\ 640}#)
(if (if (eq? (vector-ref
-
#{symnames\ 682}#
- #{i\
686}#)
- #{sym\
679}#)
- (#{same-marks?\
150}#
- #{marks\ 681}#
+
#{symnames\ 641}#
+ #{i\
645}#)
+ #{sym\
638}#)
+ (#{same-marks?\
152}#
+ #{marks\ 640}#
(vector-ref
-
(#{ribcage-marks\ 139}#
- #{ribcage\
683}#)
- #{i\ 686}#))
+
(#{ribcage-marks\ 141}#
+ #{ribcage\
642}#)
+ #{i\ 645}#))
#f)
(values
(vector-ref
-
(#{ribcage-labels\ 140}#
- #{ribcage\
683}#)
- #{i\ 686}#)
- #{marks\ 681}#)
- (#{f\ 685}# (#{fx+\
86}#
- #{i\
686}#
+
(#{ribcage-labels\ 142}#
+ #{ribcage\
642}#)
+ #{i\ 645}#)
+ #{marks\ 640}#)
+ (#{f\ 644}# (#{fx+\
86}#
+ #{i\
645}#
1)))))))
- (#{f\ 685}# 0)))))
- (#{search-list-rib\ 672}#
- (lambda (#{sym\ 687}#
- #{subst\ 688}#
- #{marks\ 689}#
- #{symnames\ 690}#
- #{ribcage\ 691}#)
- (letrec ((#{f\ 692}# (lambda (#{symnames\ 693}#
- #{i\ 694}#)
- (if (null? #{symnames\
693}#)
- (#{search\ 671}#
- #{sym\ 687}#
- (cdr #{subst\ 688}#)
- #{marks\ 689}#)
- (if (if (eq? (car
#{symnames\ 693}#)
- #{sym\ 687}#)
- (#{same-marks?\
150}#
- #{marks\ 689}#
+ (#{f\ 644}# 0)))))
+ (#{search-list-rib\ 631}#
+ (lambda (#{sym\ 646}#
+ #{subst\ 647}#
+ #{marks\ 648}#
+ #{symnames\ 649}#
+ #{ribcage\ 650}#)
+ (letrec ((#{f\ 651}# (lambda (#{symnames\ 652}#
+ #{i\ 653}#)
+ (if (null? #{symnames\
652}#)
+ (#{search\ 630}#
+ #{sym\ 646}#
+ (cdr #{subst\ 647}#)
+ #{marks\ 648}#)
+ (if (if (eq? (car
#{symnames\ 652}#)
+ #{sym\ 646}#)
+ (#{same-marks?\
152}#
+ #{marks\ 648}#
(list-ref
-
(#{ribcage-marks\ 139}#
- #{ribcage\
691}#)
- #{i\ 694}#))
+
(#{ribcage-marks\ 141}#
+ #{ribcage\
650}#)
+ #{i\ 653}#))
#f)
(values
(list-ref
- (#{ribcage-labels\
140}#
- #{ribcage\ 691}#)
- #{i\ 694}#)
- #{marks\ 689}#)
- (#{f\ 692}# (cdr
#{symnames\ 693}#)
+ (#{ribcage-labels\
142}#
+ #{ribcage\ 650}#)
+ #{i\ 653}#)
+ #{marks\ 648}#)
+ (#{f\ 651}# (cdr
#{symnames\ 652}#)
(#{fx+\ 86}#
- #{i\ 694}#
+ #{i\ 653}#
1)))))))
- (#{f\ 692}# #{symnames\ 690}# 0))))
- (#{search\ 671}#
- (lambda (#{sym\ 695}# #{subst\ 696}# #{marks\ 697}#)
- (if (null? #{subst\ 696}#)
- (values #f #{marks\ 697}#)
- (let ((#{fst\ 698}# (car #{subst\ 696}#)))
- (if (eq? #{fst\ 698}# (quote shift))
- (#{search\ 671}#
- #{sym\ 695}#
- (cdr #{subst\ 696}#)
- (cdr #{marks\ 697}#))
- (let ((#{symnames\ 699}#
- (#{ribcage-symnames\ 138}#
- #{fst\ 698}#)))
- (if (vector? #{symnames\ 699}#)
- (#{search-vector-rib\ 673}#
- #{sym\ 695}#
- #{subst\ 696}#
- #{marks\ 697}#
- #{symnames\ 699}#
- #{fst\ 698}#)
- (#{search-list-rib\ 672}#
- #{sym\ 695}#
- #{subst\ 696}#
- #{marks\ 697}#
- #{symnames\ 699}#
- #{fst\ 698}#)))))))))
- (if (symbol? #{id\ 669}#)
- (let ((#{t\ 700}# (call-with-values
+ (#{f\ 651}# #{symnames\ 649}# 0))))
+ (#{search\ 630}#
+ (lambda (#{sym\ 654}# #{subst\ 655}# #{marks\ 656}#)
+ (if (null? #{subst\ 655}#)
+ (values #f #{marks\ 656}#)
+ (let ((#{fst\ 657}# (car #{subst\ 655}#)))
+ (if (eq? #{fst\ 657}# (quote shift))
+ (#{search\ 630}#
+ #{sym\ 654}#
+ (cdr #{subst\ 655}#)
+ (cdr #{marks\ 656}#))
+ (let ((#{symnames\ 658}#
+ (#{ribcage-symnames\ 140}#
+ #{fst\ 657}#)))
+ (if (vector? #{symnames\ 658}#)
+ (#{search-vector-rib\ 632}#
+ #{sym\ 654}#
+ #{subst\ 655}#
+ #{marks\ 656}#
+ #{symnames\ 658}#
+ #{fst\ 657}#)
+ (#{search-list-rib\ 631}#
+ #{sym\ 654}#
+ #{subst\ 655}#
+ #{marks\ 656}#
+ #{symnames\ 658}#
+ #{fst\ 657}#)))))))))
+ (if (symbol? #{id\ 628}#)
+ (let ((#{t\ 659}# (call-with-values
(lambda ()
- (#{search\ 671}#
- #{id\ 669}#
- (#{wrap-subst\ 133}# #{w\ 670}#)
- (#{wrap-marks\ 132}# #{w\ 670}#)))
- (lambda (#{x\ 702}# . #{ignore\ 701}#)
- #{x\ 702}#))))
- (if #{t\ 700}# #{t\ 700}# #{id\ 669}#))
- (if (#{syntax-object?\ 113}# #{id\ 669}#)
- (let ((#{id\ 703}#
- (#{syntax-object-expression\ 114}# #{id\ 669}#))
- (#{w1\ 704}#
- (#{syntax-object-wrap\ 115}# #{id\ 669}#)))
- (let ((#{marks\ 705}#
- (#{join-marks\ 149}#
- (#{wrap-marks\ 132}# #{w\ 670}#)
- (#{wrap-marks\ 132}# #{w1\ 704}#))))
+ (#{search\ 630}#
+ #{id\ 628}#
+ (#{wrap-subst\ 135}# #{w\ 629}#)
+ (#{wrap-marks\ 134}# #{w\ 629}#)))
+ (lambda (#{x\ 660}# . #{ignore\ 661}#)
+ #{x\ 660}#))))
+ (if #{t\ 659}# #{t\ 659}# #{id\ 628}#))
+ (if (#{syntax-object?\ 115}# #{id\ 628}#)
+ (let ((#{id\ 662}#
+ (#{syntax-object-expression\ 116}# #{id\ 628}#))
+ (#{w1\ 663}#
+ (#{syntax-object-wrap\ 117}# #{id\ 628}#)))
+ (let ((#{marks\ 664}#
+ (#{join-marks\ 151}#
+ (#{wrap-marks\ 134}# #{w\ 629}#)
+ (#{wrap-marks\ 134}# #{w1\ 663}#))))
(call-with-values
(lambda ()
- (#{search\ 671}#
- #{id\ 703}#
- (#{wrap-subst\ 133}# #{w\ 670}#)
- #{marks\ 705}#))
- (lambda (#{new-id\ 706}# #{marks\ 707}#)
- (let ((#{t\ 708}# #{new-id\ 706}#))
- (if #{t\ 708}#
- #{t\ 708}#
- (let ((#{t\ 709}# (call-with-values
+ (#{search\ 630}#
+ #{id\ 662}#
+ (#{wrap-subst\ 135}# #{w\ 629}#)
+ #{marks\ 664}#))
+ (lambda (#{new-id\ 665}# #{marks\ 666}#)
+ (let ((#{t\ 667}# #{new-id\ 665}#))
+ (if #{t\ 667}#
+ #{t\ 667}#
+ (let ((#{t\ 668}# (call-with-values
(lambda ()
- (#{search\ 671}#
- #{id\ 703}#
- (#{wrap-subst\ 133}#
- #{w1\ 704}#)
- #{marks\ 707}#))
- (lambda (#{x\ 711}#
+ (#{search\ 630}#
+ #{id\ 662}#
+ (#{wrap-subst\ 135}#
+ #{w1\ 663}#)
+ #{marks\ 666}#))
+ (lambda (#{x\ 669}#
.
- #{ignore\ 710}#)
- #{x\ 711}#))))
- (if #{t\ 709}#
- #{t\ 709}#
- #{id\ 703}#))))))))
+ #{ignore\ 670}#)
+ #{x\ 669}#))))
+ (if #{t\ 668}#
+ #{t\ 668}#
+ #{id\ 662}#))))))))
(syntax-violation
'id-var-name
"invalid id"
- #{id\ 669}#))))))
- (#{same-marks?\ 150}#
- (lambda (#{x\ 712}# #{y\ 713}#)
- (let ((#{t\ 714}# (eq? #{x\ 712}# #{y\ 713}#)))
- (if #{t\ 714}#
- #{t\ 714}#
- (if (not (null? #{x\ 712}#))
- (if (not (null? #{y\ 713}#))
- (if (eq? (car #{x\ 712}#) (car #{y\ 713}#))
- (#{same-marks?\ 150}#
- (cdr #{x\ 712}#)
- (cdr #{y\ 713}#))
+ #{id\ 628}#))))))
+ (#{same-marks?\ 152}#
+ (lambda (#{x\ 671}# #{y\ 672}#)
+ (let ((#{t\ 673}# (eq? #{x\ 671}# #{y\ 672}#)))
+ (if #{t\ 673}#
+ #{t\ 673}#
+ (if (not (null? #{x\ 671}#))
+ (if (not (null? #{y\ 672}#))
+ (if (eq? (car #{x\ 671}#) (car #{y\ 672}#))
+ (#{same-marks?\ 152}#
+ (cdr #{x\ 671}#)
+ (cdr #{y\ 672}#))
#f)
#f)
#f)))))
- (#{join-marks\ 149}#
- (lambda (#{m1\ 715}# #{m2\ 716}#)
- (#{smart-append\ 147}# #{m1\ 715}# #{m2\ 716}#)))
- (#{join-wraps\ 148}#
- (lambda (#{w1\ 717}# #{w2\ 718}#)
- (let ((#{m1\ 719}# (#{wrap-marks\ 132}# #{w1\ 717}#))
- (#{s1\ 720}# (#{wrap-subst\ 133}# #{w1\ 717}#)))
- (if (null? #{m1\ 719}#)
- (if (null? #{s1\ 720}#)
- #{w2\ 718}#
- (#{make-wrap\ 131}#
- (#{wrap-marks\ 132}# #{w2\ 718}#)
- (#{smart-append\ 147}#
- #{s1\ 720}#
- (#{wrap-subst\ 133}# #{w2\ 718}#))))
- (#{make-wrap\ 131}#
- (#{smart-append\ 147}#
- #{m1\ 719}#
- (#{wrap-marks\ 132}# #{w2\ 718}#))
- (#{smart-append\ 147}#
- #{s1\ 720}#
- (#{wrap-subst\ 133}# #{w2\ 718}#)))))))
- (#{smart-append\ 147}#
- (lambda (#{m1\ 721}# #{m2\ 722}#)
- (if (null? #{m2\ 722}#)
- #{m1\ 721}#
- (append #{m1\ 721}# #{m2\ 722}#))))
- (#{make-binding-wrap\ 146}#
- (lambda (#{ids\ 723}# #{labels\ 724}# #{w\ 725}#)
- (if (null? #{ids\ 723}#)
- #{w\ 725}#
- (#{make-wrap\ 131}#
- (#{wrap-marks\ 132}# #{w\ 725}#)
- (cons (let ((#{labelvec\ 726}#
- (list->vector #{labels\ 724}#)))
- (let ((#{n\ 727}# (vector-length
- #{labelvec\ 726}#)))
- (let ((#{symnamevec\ 728}#
- (make-vector #{n\ 727}#))
- (#{marksvec\ 729}#
- (make-vector #{n\ 727}#)))
+ (#{join-marks\ 151}#
+ (lambda (#{m1\ 674}# #{m2\ 675}#)
+ (#{smart-append\ 149}# #{m1\ 674}# #{m2\ 675}#)))
+ (#{join-wraps\ 150}#
+ (lambda (#{w1\ 676}# #{w2\ 677}#)
+ (let ((#{m1\ 678}# (#{wrap-marks\ 134}# #{w1\ 676}#))
+ (#{s1\ 679}# (#{wrap-subst\ 135}# #{w1\ 676}#)))
+ (if (null? #{m1\ 678}#)
+ (if (null? #{s1\ 679}#)
+ #{w2\ 677}#
+ (#{make-wrap\ 133}#
+ (#{wrap-marks\ 134}# #{w2\ 677}#)
+ (#{smart-append\ 149}#
+ #{s1\ 679}#
+ (#{wrap-subst\ 135}# #{w2\ 677}#))))
+ (#{make-wrap\ 133}#
+ (#{smart-append\ 149}#
+ #{m1\ 678}#
+ (#{wrap-marks\ 134}# #{w2\ 677}#))
+ (#{smart-append\ 149}#
+ #{s1\ 679}#
+ (#{wrap-subst\ 135}# #{w2\ 677}#)))))))
+ (#{smart-append\ 149}#
+ (lambda (#{m1\ 680}# #{m2\ 681}#)
+ (if (null? #{m2\ 681}#)
+ #{m1\ 680}#
+ (append #{m1\ 680}# #{m2\ 681}#))))
+ (#{make-binding-wrap\ 148}#
+ (lambda (#{ids\ 682}# #{labels\ 683}# #{w\ 684}#)
+ (if (null? #{ids\ 682}#)
+ #{w\ 684}#
+ (#{make-wrap\ 133}#
+ (#{wrap-marks\ 134}# #{w\ 684}#)
+ (cons (let ((#{labelvec\ 685}#
+ (list->vector #{labels\ 683}#)))
+ (let ((#{n\ 686}# (vector-length
+ #{labelvec\ 685}#)))
+ (let ((#{symnamevec\ 687}#
+ (make-vector #{n\ 686}#))
+ (#{marksvec\ 688}#
+ (make-vector #{n\ 686}#)))
(begin
- (letrec ((#{f\ 730}# (lambda (#{ids\ 731}#
- #{i\ 732}#)
- (if (not (null? #{ids\
731}#))
+ (letrec ((#{f\ 689}# (lambda (#{ids\ 690}#
+ #{i\ 691}#)
+ (if (not (null? #{ids\
690}#))
(call-with-values
(lambda ()
-
(#{id-sym-name&marks\ 130}#
- (car #{ids\
731}#)
- #{w\ 725}#))
- (lambda
(#{symname\ 733}#
- #{marks\
734}#)
+
(#{id-sym-name&marks\ 132}#
+ (car #{ids\
690}#)
+ #{w\ 684}#))
+ (lambda
(#{symname\ 692}#
+ #{marks\
693}#)
(begin
(vector-set!
-
#{symnamevec\ 728}#
- #{i\ 732}#
- #{symname\
733}#)
+
#{symnamevec\ 687}#
+ #{i\ 691}#
+ #{symname\
692}#)
(vector-set!
- #{marksvec\
729}#
- #{i\ 732}#
- #{marks\
734}#)
- (#{f\ 730}#
(cdr #{ids\ 731}#)
+ #{marksvec\
688}#
+ #{i\ 691}#
+ #{marks\
693}#)
+ (#{f\ 689}#
(cdr #{ids\ 690}#)
(#{fx+\ 86}#
-
#{i\ 732}#
+
#{i\ 691}#
1)))))))))
- (#{f\ 730}# #{ids\ 723}# 0))
- (#{make-ribcage\ 136}#
- #{symnamevec\ 728}#
- #{marksvec\ 729}#
- #{labelvec\ 726}#)))))
- (#{wrap-subst\ 133}# #{w\ 725}#))))))
- (#{extend-ribcage!\ 145}#
- (lambda (#{ribcage\ 735}# #{id\ 736}# #{label\ 737}#)
+ (#{f\ 689}# #{ids\ 682}# 0))
+ (#{make-ribcage\ 138}#
+ #{symnamevec\ 687}#
+ #{marksvec\ 688}#
+ #{labelvec\ 685}#)))))
+ (#{wrap-subst\ 135}# #{w\ 684}#))))))
+ (#{extend-ribcage!\ 147}#
+ (lambda (#{ribcage\ 694}# #{id\ 695}# #{label\ 696}#)
(begin
- (#{set-ribcage-symnames!\ 141}#
- #{ribcage\ 735}#
- (cons (#{syntax-object-expression\ 114}# #{id\ 736}#)
- (#{ribcage-symnames\ 138}# #{ribcage\ 735}#)))
- (#{set-ribcage-marks!\ 142}#
- #{ribcage\ 735}#
- (cons (#{wrap-marks\ 132}#
- (#{syntax-object-wrap\ 115}# #{id\ 736}#))
- (#{ribcage-marks\ 139}# #{ribcage\ 735}#)))
- (#{set-ribcage-labels!\ 143}#
- #{ribcage\ 735}#
- (cons #{label\ 737}#
- (#{ribcage-labels\ 140}# #{ribcage\ 735}#))))))
- (#{anti-mark\ 144}#
- (lambda (#{w\ 738}#)
- (#{make-wrap\ 131}#
- (cons #f (#{wrap-marks\ 132}# #{w\ 738}#))
+ (#{set-ribcage-symnames!\ 143}#
+ #{ribcage\ 694}#
+ (cons (#{syntax-object-expression\ 116}# #{id\ 695}#)
+ (#{ribcage-symnames\ 140}# #{ribcage\ 694}#)))
+ (#{set-ribcage-marks!\ 144}#
+ #{ribcage\ 694}#
+ (cons (#{wrap-marks\ 134}#
+ (#{syntax-object-wrap\ 117}# #{id\ 695}#))
+ (#{ribcage-marks\ 141}# #{ribcage\ 694}#)))
+ (#{set-ribcage-labels!\ 145}#
+ #{ribcage\ 694}#
+ (cons #{label\ 696}#
+ (#{ribcage-labels\ 142}# #{ribcage\ 694}#))))))
+ (#{anti-mark\ 146}#
+ (lambda (#{w\ 697}#)
+ (#{make-wrap\ 133}#
+ (cons #f (#{wrap-marks\ 134}# #{w\ 697}#))
(cons 'shift
- (#{wrap-subst\ 133}# #{w\ 738}#)))))
- (#{set-ribcage-labels!\ 143}#
- (lambda (#{x\ 739}# #{update\ 740}#)
- (vector-set! #{x\ 739}# 3 #{update\ 740}#)))
- (#{set-ribcage-marks!\ 142}#
- (lambda (#{x\ 741}# #{update\ 742}#)
- (vector-set! #{x\ 741}# 2 #{update\ 742}#)))
- (#{set-ribcage-symnames!\ 141}#
- (lambda (#{x\ 743}# #{update\ 744}#)
- (vector-set! #{x\ 743}# 1 #{update\ 744}#)))
- (#{ribcage-labels\ 140}#
- (lambda (#{x\ 745}#) (vector-ref #{x\ 745}# 3)))
- (#{ribcage-marks\ 139}#
- (lambda (#{x\ 746}#) (vector-ref #{x\ 746}# 2)))
- (#{ribcage-symnames\ 138}#
- (lambda (#{x\ 747}#) (vector-ref #{x\ 747}# 1)))
- (#{ribcage?\ 137}#
- (lambda (#{x\ 748}#)
- (if (vector? #{x\ 748}#)
- (if (= (vector-length #{x\ 748}#) 4)
- (eq? (vector-ref #{x\ 748}# 0) (quote ribcage))
+ (#{wrap-subst\ 135}# #{w\ 697}#)))))
+ (#{set-ribcage-labels!\ 145}#
+ (lambda (#{x\ 698}# #{update\ 699}#)
+ (vector-set! #{x\ 698}# 3 #{update\ 699}#)))
+ (#{set-ribcage-marks!\ 144}#
+ (lambda (#{x\ 700}# #{update\ 701}#)
+ (vector-set! #{x\ 700}# 2 #{update\ 701}#)))
+ (#{set-ribcage-symnames!\ 143}#
+ (lambda (#{x\ 702}# #{update\ 703}#)
+ (vector-set! #{x\ 702}# 1 #{update\ 703}#)))
+ (#{ribcage-labels\ 142}#
+ (lambda (#{x\ 704}#) (vector-ref #{x\ 704}# 3)))
+ (#{ribcage-marks\ 141}#
+ (lambda (#{x\ 705}#) (vector-ref #{x\ 705}# 2)))
+ (#{ribcage-symnames\ 140}#
+ (lambda (#{x\ 706}#) (vector-ref #{x\ 706}# 1)))
+ (#{ribcage?\ 139}#
+ (lambda (#{x\ 707}#)
+ (if (vector? #{x\ 707}#)
+ (if (= (vector-length #{x\ 707}#) 4)
+ (eq? (vector-ref #{x\ 707}# 0) (quote ribcage))
#f)
#f)))
- (#{make-ribcage\ 136}#
- (lambda (#{symnames\ 749}#
- #{marks\ 750}#
- #{labels\ 751}#)
+ (#{make-ribcage\ 138}#
+ (lambda (#{symnames\ 708}#
+ #{marks\ 709}#
+ #{labels\ 710}#)
(vector
'ribcage
- #{symnames\ 749}#
- #{marks\ 750}#
- #{labels\ 751}#)))
- (#{gen-labels\ 135}#
- (lambda (#{ls\ 752}#)
- (if (null? #{ls\ 752}#)
+ #{symnames\ 708}#
+ #{marks\ 709}#
+ #{labels\ 710}#)))
+ (#{gen-labels\ 137}#
+ (lambda (#{ls\ 711}#)
+ (if (null? #{ls\ 711}#)
'()
- (cons (#{gen-label\ 134}#)
- (#{gen-labels\ 135}# (cdr #{ls\ 752}#))))))
- (#{gen-label\ 134}# (lambda () (string #\i)))
- (#{wrap-subst\ 133}# cdr)
- (#{wrap-marks\ 132}# car)
- (#{make-wrap\ 131}# cons)
- (#{id-sym-name&marks\ 130}#
- (lambda (#{x\ 753}# #{w\ 754}#)
- (if (#{syntax-object?\ 113}# #{x\ 753}#)
+ (cons (#{gen-label\ 136}#)
+ (#{gen-labels\ 137}# (cdr #{ls\ 711}#))))))
+ (#{gen-label\ 136}# (lambda () (string #\i)))
+ (#{wrap-subst\ 135}# cdr)
+ (#{wrap-marks\ 134}# car)
+ (#{make-wrap\ 133}# cons)
+ (#{id-sym-name&marks\ 132}#
+ (lambda (#{x\ 712}# #{w\ 713}#)
+ (if (#{syntax-object?\ 115}# #{x\ 712}#)
(values
- (#{syntax-object-expression\ 114}# #{x\ 753}#)
- (#{join-marks\ 149}#
- (#{wrap-marks\ 132}# #{w\ 754}#)
- (#{wrap-marks\ 132}#
- (#{syntax-object-wrap\ 115}# #{x\ 753}#))))
+ (#{syntax-object-expression\ 116}# #{x\ 712}#)
+ (#{join-marks\ 151}#
+ (#{wrap-marks\ 134}# #{w\ 713}#)
+ (#{wrap-marks\ 134}#
+ (#{syntax-object-wrap\ 117}# #{x\ 712}#))))
(values
- #{x\ 753}#
- (#{wrap-marks\ 132}# #{w\ 754}#)))))
- (#{id?\ 129}#
- (lambda (#{x\ 755}#)
- (if (symbol? #{x\ 755}#)
+ #{x\ 712}#
+ (#{wrap-marks\ 134}# #{w\ 713}#)))))
+ (#{id?\ 131}#
+ (lambda (#{x\ 714}#)
+ (if (symbol? #{x\ 714}#)
#t
- (if (#{syntax-object?\ 113}# #{x\ 755}#)
+ (if (#{syntax-object?\ 115}# #{x\ 714}#)
(symbol?
- (#{syntax-object-expression\ 114}# #{x\ 755}#))
+ (#{syntax-object-expression\ 116}# #{x\ 714}#))
#f))))
- (#{nonsymbol-id?\ 128}#
- (lambda (#{x\ 756}#)
- (if (#{syntax-object?\ 113}# #{x\ 756}#)
+ (#{nonsymbol-id?\ 130}#
+ (lambda (#{x\ 715}#)
+ (if (#{syntax-object?\ 115}# #{x\ 715}#)
(symbol?
- (#{syntax-object-expression\ 114}# #{x\ 756}#))
+ (#{syntax-object-expression\ 116}# #{x\ 715}#))
#f)))
- (#{global-extend\ 127}#
- (lambda (#{type\ 757}# #{sym\ 758}# #{val\ 759}#)
+ (#{global-extend\ 129}#
+ (lambda (#{type\ 716}# #{sym\ 717}# #{val\ 718}#)
(#{put-global-definition-hook\ 92}#
- #{sym\ 758}#
- #{type\ 757}#
- #{val\ 759}#)))
- (#{lookup\ 126}#
- (lambda (#{x\ 760}# #{r\ 761}# #{mod\ 762}#)
- (let ((#{t\ 763}# (assq #{x\ 760}# #{r\ 761}#)))
- (if #{t\ 763}#
- (cdr #{t\ 763}#)
- (if (symbol? #{x\ 760}#)
- (let ((#{t\ 764}# (#{get-global-definition-hook\ 93}#
- #{x\ 760}#
- #{mod\ 762}#)))
- (if #{t\ 764}# #{t\ 764}# (quote (global))))
+ #{sym\ 717}#
+ #{type\ 716}#
+ #{val\ 718}#)))
+ (#{lookup\ 128}#
+ (lambda (#{x\ 719}# #{r\ 720}# #{mod\ 721}#)
+ (let ((#{t\ 722}# (assq #{x\ 719}# #{r\ 720}#)))
+ (if #{t\ 722}#
+ (cdr #{t\ 722}#)
+ (if (symbol? #{x\ 719}#)
+ (let ((#{t\ 723}# (#{get-global-definition-hook\ 93}#
+ #{x\ 719}#
+ #{mod\ 721}#)))
+ (if #{t\ 723}# #{t\ 723}# (quote (global))))
'(displaced-lexical))))))
- (#{macros-only-env\ 125}#
- (lambda (#{r\ 765}#)
- (if (null? #{r\ 765}#)
+ (#{macros-only-env\ 127}#
+ (lambda (#{r\ 724}#)
+ (if (null? #{r\ 724}#)
'()
- (let ((#{a\ 766}# (car #{r\ 765}#)))
- (if (eq? (cadr #{a\ 766}#) (quote macro))
- (cons #{a\ 766}#
- (#{macros-only-env\ 125}# (cdr #{r\ 765}#)))
- (#{macros-only-env\ 125}# (cdr #{r\ 765}#)))))))
- (#{extend-var-env\ 124}#
- (lambda (#{labels\ 767}# #{vars\ 768}# #{r\ 769}#)
- (if (null? #{labels\ 767}#)
- #{r\ 769}#
- (#{extend-var-env\ 124}#
- (cdr #{labels\ 767}#)
- (cdr #{vars\ 768}#)
- (cons (cons (car #{labels\ 767}#)
- (cons (quote lexical) (car #{vars\ 768}#)))
- #{r\ 769}#)))))
- (#{extend-env\ 123}#
- (lambda (#{labels\ 770}# #{bindings\ 771}# #{r\ 772}#)
- (if (null? #{labels\ 770}#)
- #{r\ 772}#
- (#{extend-env\ 123}#
- (cdr #{labels\ 770}#)
- (cdr #{bindings\ 771}#)
- (cons (cons (car #{labels\ 770}#)
- (car #{bindings\ 771}#))
- #{r\ 772}#)))))
- (#{binding-value\ 122}# cdr)
- (#{binding-type\ 121}# car)
- (#{source-annotation\ 120}#
- (lambda (#{x\ 773}#)
- (if (#{syntax-object?\ 113}# #{x\ 773}#)
- (#{source-annotation\ 120}#
- (#{syntax-object-expression\ 114}# #{x\ 773}#))
- (if (pair? #{x\ 773}#)
- (let ((#{props\ 774}# (source-properties #{x\ 773}#)))
- (if (pair? #{props\ 774}#) #{props\ 774}# #f))
+ (let ((#{a\ 725}# (car #{r\ 724}#)))
+ (if (eq? (cadr #{a\ 725}#) (quote macro))
+ (cons #{a\ 725}#
+ (#{macros-only-env\ 127}# (cdr #{r\ 724}#)))
+ (#{macros-only-env\ 127}# (cdr #{r\ 724}#)))))))
+ (#{extend-var-env\ 126}#
+ (lambda (#{labels\ 726}# #{vars\ 727}# #{r\ 728}#)
+ (if (null? #{labels\ 726}#)
+ #{r\ 728}#
+ (#{extend-var-env\ 126}#
+ (cdr #{labels\ 726}#)
+ (cdr #{vars\ 727}#)
+ (cons (cons (car #{labels\ 726}#)
+ (cons (quote lexical) (car #{vars\ 727}#)))
+ #{r\ 728}#)))))
+ (#{extend-env\ 125}#
+ (lambda (#{labels\ 729}# #{bindings\ 730}# #{r\ 731}#)
+ (if (null? #{labels\ 729}#)
+ #{r\ 731}#
+ (#{extend-env\ 125}#
+ (cdr #{labels\ 729}#)
+ (cdr #{bindings\ 730}#)
+ (cons (cons (car #{labels\ 729}#)
+ (car #{bindings\ 730}#))
+ #{r\ 731}#)))))
+ (#{binding-value\ 124}# cdr)
+ (#{binding-type\ 123}# car)
+ (#{source-annotation\ 122}#
+ (lambda (#{x\ 732}#)
+ (if (#{syntax-object?\ 115}# #{x\ 732}#)
+ (#{source-annotation\ 122}#
+ (#{syntax-object-expression\ 116}# #{x\ 732}#))
+ (if (pair? #{x\ 732}#)
+ (let ((#{props\ 733}# (source-properties #{x\ 732}#)))
+ (if (pair? #{props\ 733}#) #{props\ 733}# #f))
#f))))
- (#{set-syntax-object-module!\ 119}#
- (lambda (#{x\ 775}# #{update\ 776}#)
- (vector-set! #{x\ 775}# 3 #{update\ 776}#)))
- (#{set-syntax-object-wrap!\ 118}#
- (lambda (#{x\ 777}# #{update\ 778}#)
- (vector-set! #{x\ 777}# 2 #{update\ 778}#)))
- (#{set-syntax-object-expression!\ 117}#
- (lambda (#{x\ 779}# #{update\ 780}#)
- (vector-set! #{x\ 779}# 1 #{update\ 780}#)))
- (#{syntax-object-module\ 116}#
- (lambda (#{x\ 781}#) (vector-ref #{x\ 781}# 3)))
- (#{syntax-object-wrap\ 115}#
- (lambda (#{x\ 782}#) (vector-ref #{x\ 782}# 2)))
- (#{syntax-object-expression\ 114}#
- (lambda (#{x\ 783}#) (vector-ref #{x\ 783}# 1)))
- (#{syntax-object?\ 113}#
- (lambda (#{x\ 784}#)
- (if (vector? #{x\ 784}#)
- (if (= (vector-length #{x\ 784}#) 4)
- (eq? (vector-ref #{x\ 784}# 0)
+ (#{set-syntax-object-module!\ 121}#
+ (lambda (#{x\ 734}# #{update\ 735}#)
+ (vector-set! #{x\ 734}# 3 #{update\ 735}#)))
+ (#{set-syntax-object-wrap!\ 120}#
+ (lambda (#{x\ 736}# #{update\ 737}#)
+ (vector-set! #{x\ 736}# 2 #{update\ 737}#)))
+ (#{set-syntax-object-expression!\ 119}#
+ (lambda (#{x\ 738}# #{update\ 739}#)
+ (vector-set! #{x\ 738}# 1 #{update\ 739}#)))
+ (#{syntax-object-module\ 118}#
+ (lambda (#{x\ 740}#) (vector-ref #{x\ 740}# 3)))
+ (#{syntax-object-wrap\ 117}#
+ (lambda (#{x\ 741}#) (vector-ref #{x\ 741}# 2)))
+ (#{syntax-object-expression\ 116}#
+ (lambda (#{x\ 742}#) (vector-ref #{x\ 742}# 1)))
+ (#{syntax-object?\ 115}#
+ (lambda (#{x\ 743}#)
+ (if (vector? #{x\ 743}#)
+ (if (= (vector-length #{x\ 743}#) 4)
+ (eq? (vector-ref #{x\ 743}# 0)
'syntax-object)
#f)
#f)))
- (#{make-syntax-object\ 112}#
- (lambda (#{expression\ 785}#
- #{wrap\ 786}#
- #{module\ 787}#)
+ (#{make-syntax-object\ 114}#
+ (lambda (#{expression\ 744}#
+ #{wrap\ 745}#
+ #{module\ 746}#)
(vector
'syntax-object
- #{expression\ 785}#
- #{wrap\ 786}#
- #{module\ 787}#)))
- (#{build-letrec\ 111}#
- (lambda (#{src\ 788}#
- #{ids\ 789}#
- #{vars\ 790}#
- #{val-exps\ 791}#
- #{body-exp\ 792}#)
- (if (null? #{vars\ 790}#)
- #{body-exp\ 792}#
- (let ((#{atom-key\ 793}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 793}# (quote (c)))
+ #{expression\ 744}#
+ #{wrap\ 745}#
+ #{module\ 746}#)))
+ (#{build-letrec\ 113}#
+ (lambda (#{src\ 747}#
+ #{ids\ 748}#
+ #{vars\ 749}#
+ #{val-exps\ 750}#
+ #{body-exp\ 751}#)
+ (if (null? #{vars\ 749}#)
+ #{body-exp\ 751}#
+ (let ((#{atom-key\ 752}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 752}# (quote (c)))
(begin
(for-each
#{maybe-name-value!\ 103}#
- #{ids\ 789}#
- #{val-exps\ 791}#)
+ #{ids\ 748}#
+ #{val-exps\ 750}#)
((@ (language tree-il) make-letrec)
- #{src\ 788}#
- #{ids\ 789}#
- #{vars\ 790}#
- #{val-exps\ 791}#
- #{body-exp\ 792}#))
+ #{src\ 747}#
+ #{ids\ 748}#
+ #{vars\ 749}#
+ #{val-exps\ 750}#
+ #{body-exp\ 751}#))
(#{decorate-source\ 94}#
(list 'letrec
- (map list #{vars\ 790}# #{val-exps\ 791}#)
- #{body-exp\ 792}#)
- #{src\ 788}#))))))
- (#{build-named-let\ 110}#
- (lambda (#{src\ 794}#
- #{ids\ 795}#
- #{vars\ 796}#
- #{val-exps\ 797}#
- #{body-exp\ 798}#)
- (let ((#{f\ 799}# (car #{vars\ 796}#))
- (#{f-name\ 800}# (car #{ids\ 795}#))
- (#{vars\ 801}# (cdr #{vars\ 796}#))
- (#{ids\ 802}# (cdr #{ids\ 795}#)))
- (let ((#{atom-key\ 803}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 803}# (quote (c)))
- (let ((#{proc\ 804}#
- (#{build-lambda\ 105}#
- #{src\ 794}#
- #{ids\ 802}#
- #{vars\ 801}#
+ (map list #{vars\ 749}# #{val-exps\ 750}#)
+ #{body-exp\ 751}#)
+ #{src\ 747}#))))))
+ (#{build-named-let\ 112}#
+ (lambda (#{src\ 753}#
+ #{ids\ 754}#
+ #{vars\ 755}#
+ #{val-exps\ 756}#
+ #{body-exp\ 757}#)
+ (let ((#{f\ 758}# (car #{vars\ 755}#))
+ (#{f-name\ 759}# (car #{ids\ 754}#))
+ (#{vars\ 760}# (cdr #{vars\ 755}#))
+ (#{ids\ 761}# (cdr #{ids\ 754}#)))
+ (let ((#{atom-key\ 762}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 762}# (quote (c)))
+ (let ((#{proc\ 763}#
+ (#{build-simple-lambda\ 105}#
+ #{src\ 753}#
+ #{ids\ 761}#
+ #f
+ #{vars\ 760}#
#f
- #{body-exp\ 798}#)))
+ #{body-exp\ 757}#)))
(begin
(#{maybe-name-value!\ 103}#
- #{f-name\ 800}#
- #{proc\ 804}#)
+ #{f-name\ 759}#
+ #{proc\ 763}#)
(for-each
#{maybe-name-value!\ 103}#
- #{ids\ 802}#
- #{val-exps\ 797}#)
+ #{ids\ 761}#
+ #{val-exps\ 756}#)
((@ (language tree-il) make-letrec)
- #{src\ 794}#
- (list #{f-name\ 800}#)
- (list #{f\ 799}#)
- (list #{proc\ 804}#)
+ #{src\ 753}#
+ (list #{f-name\ 759}#)
+ (list #{f\ 758}#)
+ (list #{proc\ 763}#)
(#{build-application\ 96}#
- #{src\ 794}#
+ #{src\ 753}#
(#{build-lexical-reference\ 98}#
'fun
- #{src\ 794}#
- #{f-name\ 800}#
- #{f\ 799}#)
- #{val-exps\ 797}#))))
+ #{src\ 753}#
+ #{f-name\ 759}#
+ #{f\ 758}#)
+ #{val-exps\ 756}#))))
(#{decorate-source\ 94}#
(list 'let
- #{f\ 799}#
- (map list #{vars\ 801}# #{val-exps\ 797}#)
- #{body-exp\ 798}#)
- #{src\ 794}#))))))
- (#{build-let\ 109}#
- (lambda (#{src\ 805}#
- #{ids\ 806}#
- #{vars\ 807}#
- #{val-exps\ 808}#
- #{body-exp\ 809}#)
- (if (null? #{vars\ 807}#)
- #{body-exp\ 809}#
- (let ((#{atom-key\ 810}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 810}# (quote (c)))
+ #{f\ 758}#
+ (map list #{vars\ 760}# #{val-exps\ 756}#)
+ #{body-exp\ 757}#)
+ #{src\ 753}#))))))
+ (#{build-let\ 111}#
+ (lambda (#{src\ 764}#
+ #{ids\ 765}#
+ #{vars\ 766}#
+ #{val-exps\ 767}#
+ #{body-exp\ 768}#)
+ (if (null? #{vars\ 766}#)
+ #{body-exp\ 768}#
+ (let ((#{atom-key\ 769}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 769}# (quote (c)))
(begin
(for-each
#{maybe-name-value!\ 103}#
- #{ids\ 806}#
- #{val-exps\ 808}#)
+ #{ids\ 765}#
+ #{val-exps\ 767}#)
((@ (language tree-il) make-let)
- #{src\ 805}#
- #{ids\ 806}#
- #{vars\ 807}#
- #{val-exps\ 808}#
- #{body-exp\ 809}#))
+ #{src\ 764}#
+ #{ids\ 765}#
+ #{vars\ 766}#
+ #{val-exps\ 767}#
+ #{body-exp\ 768}#))
(#{decorate-source\ 94}#
(list 'let
- (map list #{vars\ 807}# #{val-exps\ 808}#)
- #{body-exp\ 809}#)
- #{src\ 805}#))))))
- (#{build-sequence\ 108}#
- (lambda (#{src\ 811}# #{exps\ 812}#)
- (if (null? (cdr #{exps\ 812}#))
- (car #{exps\ 812}#)
- (let ((#{atom-key\ 813}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 813}# (quote (c)))
+ (map list #{vars\ 766}# #{val-exps\ 767}#)
+ #{body-exp\ 768}#)
+ #{src\ 764}#))))))
+ (#{build-sequence\ 110}#
+ (lambda (#{src\ 770}# #{exps\ 771}#)
+ (if (null? (cdr #{exps\ 771}#))
+ (car #{exps\ 771}#)
+ (let ((#{atom-key\ 772}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 772}# (quote (c)))
((@ (language tree-il) make-sequence)
- #{src\ 811}#
- #{exps\ 812}#)
+ #{src\ 770}#
+ #{exps\ 771}#)
(#{decorate-source\ 94}#
- (cons (quote begin) #{exps\ 812}#)
- #{src\ 811}#))))))
- (#{build-data\ 107}#
- (lambda (#{src\ 814}# #{exp\ 815}#)
- (let ((#{atom-key\ 816}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 816}# (quote (c)))
+ (cons (quote begin) #{exps\ 771}#)
+ #{src\ 770}#))))))
+ (#{build-data\ 109}#
+ (lambda (#{src\ 773}# #{exp\ 774}#)
+ (let ((#{atom-key\ 775}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 775}# (quote (c)))
((@ (language tree-il) make-const)
- #{src\ 814}#
- #{exp\ 815}#)
+ #{src\ 773}#
+ #{exp\ 774}#)
(#{decorate-source\ 94}#
- (if (if (self-evaluating? #{exp\ 815}#)
- (not (vector? #{exp\ 815}#))
+ (if (if (self-evaluating? #{exp\ 774}#)
+ (not (vector? #{exp\ 774}#))
#f)
- #{exp\ 815}#
- (list (quote quote) #{exp\ 815}#))
- #{src\ 814}#)))))
- (#{build-primref\ 106}#
- (lambda (#{src\ 817}# #{name\ 818}#)
+ #{exp\ 774}#
+ (list (quote quote) #{exp\ 774}#))
+ #{src\ 773}#)))))
+ (#{build-primref\ 108}#
+ (lambda (#{src\ 776}# #{name\ 777}#)
(if (equal?
(module-name (current-module))
'(guile))
- (let ((#{atom-key\ 819}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 819}# (quote (c)))
+ (let ((#{atom-key\ 778}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 778}# (quote (c)))
((@ (language tree-il) make-toplevel-ref)
- #{src\ 817}#
- #{name\ 818}#)
+ #{src\ 776}#
+ #{name\ 777}#)
(#{decorate-source\ 94}#
- #{name\ 818}#
- #{src\ 817}#)))
- (let ((#{atom-key\ 820}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 820}# (quote (c)))
+ #{name\ 777}#
+ #{src\ 776}#)))
+ (let ((#{atom-key\ 779}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 779}# (quote (c)))
((@ (language tree-il) make-module-ref)
- #{src\ 817}#
+ #{src\ 776}#
'(guile)
- #{name\ 818}#
+ #{name\ 777}#
#f)
(#{decorate-source\ 94}#
- (list (quote @@) (quote (guile)) #{name\ 818}#)
- #{src\ 817}#))))))
- (#{build-lambda\ 105}#
- (lambda (#{src\ 821}#
- #{ids\ 822}#
- #{vars\ 823}#
- #{docstring\ 824}#
- #{exp\ 825}#)
- (let ((#{atom-key\ 826}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 826}# (quote (c)))
+ (list (quote @@) (quote (guile)) #{name\ 777}#)
+ #{src\ 776}#))))))
+ (#{build-lambda-case\ 107}#
+ (lambda (#{src\ 780}#
+ #{req\ 781}#
+ #{opt\ 782}#
+ #{rest\ 783}#
+ #{kw\ 784}#
+ #{inits\ 785}#
+ #{vars\ 786}#
+ #{predicate\ 787}#
+ #{body\ 788}#
+ #{else-case\ 789}#)
+ (let ((#{atom-key\ 790}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 790}# (quote (c)))
+ ((@ (language tree-il) make-lambda-case)
+ #{src\ 780}#
+ #{req\ 781}#
+ #{opt\ 782}#
+ #{rest\ 783}#
+ #{kw\ 784}#
+ #{inits\ 785}#
+ #{vars\ 786}#
+ #{predicate\ 787}#
+ #{body\ 788}#
+ #{else-case\ 789}#)
+ (let ((#{nreq\ 791}# (length #{req\ 781}#)))
+ (let ((#{nopt\ 792}#
+ (if #{opt\ 782}# (length #{opt\ 782}#) 0)))
+ (let ((#{rest-idx\ 793}#
+ (if #{rest\ 783}#
+ (+ #{nreq\ 791}# #{nopt\ 792}#)
+ #f)))
+ (let ((#{allow-other-keys?\ 794}#
+ (if #{kw\ 784}# (car #{kw\ 784}#) #f)))
+ (let ((#{kw-indices\ 795}#
+ (map (lambda (#{x\ 796}#)
+ (cons (car #{x\ 796}#)
+ (list-index
+ #{vars\ 786}#
+ (caddr #{x\ 796}#))))
+ (if #{kw\ 784}#
+ (cdr #{kw\ 784}#)
+ '()))))
+ (let ((#{nargs\ 797}#
+ (apply max
+ (+ #{nreq\ 791}#
+ #{nopt\ 792}#
+ (if #{rest\ 783}# 1 0))
+ (map 1+
+ (map cdr
+ #{kw-indices\ 795}#)))))
+ (begin
+ (let ((#{t\ 798}# (= #{nargs\ 797}#
+ (length #{vars\ 786}#)
+ (+ #{nreq\ 791}#
+ (length
+ #{inits\ 785}#)
+ (if #{rest\ 783}#
+ 1
+ 0)))))
+ (if #{t\ 798}#
+ #{t\ 798}#
+ (error "something went wrong"
+ #{req\ 781}#
+ #{opt\ 782}#
+ #{rest\ 783}#
+ #{kw\ 784}#
+ #{inits\ 785}#
+ #{vars\ 786}#
+ #{nreq\ 791}#
+ #{nopt\ 792}#
+ #{kw-indices\ 795}#
+ #{nargs\ 797}#)))
+ (#{decorate-source\ 94}#
+ (cons (list (cons '(@@ (ice-9 optargs)
+ parse-lambda-case)
+ (cons (list 'quote
+ (list #{nreq\
791}#
+ #{nopt\
792}#
+
#{rest-idx\ 793}#
+
#{nargs\ 797}#
+
#{allow-other-keys?\ 794}#
+
#{kw-indices\ 795}#))
+ (cons (cons 'list
+ (map
(lambda (#{i\ 799}#)
+
(list 'lambda
+
#{vars\ 786}#
+
#{i\ 799}#))
+
#{inits\ 785}#))
+ (cons (if
#{predicate\ 787}#
+ (list
'lambda
+
#{vars\ 786}#
+
#{predicate\ 787}#)
+ #f)
+
'(%%args)))))
+ '=>
+ (list 'lambda
+ '(%%%args . _)
+ (cons 'apply
+ (cons (list 'lambda
+ #{vars\
786}#
+ #{body\
788}#)
+ '(%%%args)))))
+ (let ((#{t\ 800}# #{else-case\ 789}#))
+ (if #{t\ 800}#
+ #{t\ 800}#
+ '((%%args
+ (error "wrong number of
arguments"
+ %%args))))))
+ #{src\ 780}#))))))))))))
+ (#{build-case-lambda\ 106}#
+ (lambda (#{src\ 801}# #{docstring\ 802}# #{body\ 803}#)
+ (let ((#{atom-key\ 804}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 804}# (quote (c)))
((@ (language tree-il) make-lambda)
- #{src\ 821}#
- #{ids\ 822}#
- #{vars\ 823}#
- (if #{docstring\ 824}#
- (list (cons (quote documentation) #{docstring\ 824}#))
+ #{src\ 801}#
+ (if #{docstring\ 802}#
+ (list (cons (quote documentation) #{docstring\ 802}#))
'())
- #{exp\ 825}#)
+ #{body\ 803}#)
(#{decorate-source\ 94}#
(cons 'lambda
- (cons #{vars\ 823}#
+ (cons '%%args
(append
- (if #{docstring\ 824}#
- (list #{docstring\ 824}#)
+ (if #{docstring\ 802}#
+ (list #{docstring\ 802}#)
'())
- (list #{exp\ 825}#))))
- #{src\ 821}#)))))
+ (list (cons (quote cond) #{body\ 803}#)))))
+ #{src\ 801}#)))))
+ (#{build-simple-lambda\ 105}#
+ (lambda (#{src\ 805}#
+ #{req\ 806}#
+ #{rest\ 807}#
+ #{vars\ 808}#
+ #{docstring\ 809}#
+ #{exp\ 810}#)
+ (let ((#{atom-key\ 811}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 811}# (quote (c)))
+ ((@ (language tree-il) make-lambda)
+ #{src\ 805}#
+ (if #{docstring\ 809}#
+ (list (cons (quote documentation) #{docstring\ 809}#))
+ '())
+ ((@ (language tree-il) make-lambda-case)
+ #{src\ 805}#
+ #{req\ 806}#
+ #f
+ #{rest\ 807}#
+ #f
+ '()
+ #{vars\ 808}#
+ #f
+ #{exp\ 810}#
+ #f))
+ (#{decorate-source\ 94}#
+ (cons 'lambda
+ (cons (if #{rest\ 807}#
+ (apply cons* #{vars\ 808}#)
+ #{vars\ 808}#)
+ (append
+ (if #{docstring\ 809}#
+ (list #{docstring\ 809}#)
+ '())
+ (list #{exp\ 810}#))))
+ #{src\ 805}#)))))
(#{build-global-definition\ 104}#
- (lambda (#{source\ 827}# #{var\ 828}# #{exp\ 829}#)
- (let ((#{atom-key\ 830}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 830}# (quote (c)))
+ (lambda (#{source\ 812}# #{var\ 813}# #{exp\ 814}#)
+ (let ((#{atom-key\ 815}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 815}# (quote (c)))
(begin
(#{maybe-name-value!\ 103}#
- #{var\ 828}#
- #{exp\ 829}#)
+ #{var\ 813}#
+ #{exp\ 814}#)
((@ (language tree-il) make-toplevel-define)
- #{source\ 827}#
- #{var\ 828}#
- #{exp\ 829}#))
+ #{source\ 812}#
+ #{var\ 813}#
+ #{exp\ 814}#))
(#{decorate-source\ 94}#
- (list (quote define) #{var\ 828}# #{exp\ 829}#)
- #{source\ 827}#)))))
+ (list (quote define) #{var\ 813}# #{exp\ 814}#)
+ #{source\ 812}#)))))
(#{maybe-name-value!\ 103}#
- (lambda (#{name\ 831}# #{val\ 832}#)
- (if ((@ (language tree-il) lambda?) #{val\ 832}#)
- (let ((#{meta\ 833}#
- ((@ (language tree-il) lambda-meta) #{val\ 832}#)))
- (if (not (assq (quote name) #{meta\ 833}#))
+ (lambda (#{name\ 816}# #{val\ 817}#)
+ (if ((@ (language tree-il) lambda?) #{val\ 817}#)
+ (let ((#{meta\ 818}#
+ ((@ (language tree-il) lambda-meta) #{val\ 817}#)))
+ (if (not (assq (quote name) #{meta\ 818}#))
((setter (@ (language tree-il) lambda-meta))
- #{val\ 832}#
- (acons (quote name) #{name\ 831}# #{meta\ 833}#)))))))
+ #{val\ 817}#
+ (acons (quote name) #{name\ 816}# #{meta\ 818}#)))))))
(#{build-global-assignment\ 102}#
- (lambda (#{source\ 834}#
- #{var\ 835}#
- #{exp\ 836}#
- #{mod\ 837}#)
+ (lambda (#{source\ 819}#
+ #{var\ 820}#
+ #{exp\ 821}#
+ #{mod\ 822}#)
(#{analyze-variable\ 100}#
- #{mod\ 837}#
- #{var\ 835}#
- (lambda (#{mod\ 838}# #{var\ 839}# #{public?\ 840}#)
- (let ((#{atom-key\ 841}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 841}# (quote (c)))
+ #{mod\ 822}#
+ #{var\ 820}#
+ (lambda (#{mod\ 823}# #{var\ 824}# #{public?\ 825}#)
+ (let ((#{atom-key\ 826}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 826}# (quote (c)))
((@ (language tree-il) make-module-set)
- #{source\ 834}#
- #{mod\ 838}#
- #{var\ 839}#
- #{public?\ 840}#
- #{exp\ 836}#)
+ #{source\ 819}#
+ #{mod\ 823}#
+ #{var\ 824}#
+ #{public?\ 825}#
+ #{exp\ 821}#)
(#{decorate-source\ 94}#
(list 'set!
- (list (if #{public?\ 840}# (quote @) (quote @@))
- #{mod\ 838}#
- #{var\ 839}#)
- #{exp\ 836}#)
- #{source\ 834}#))))
- (lambda (#{var\ 842}#)
- (let ((#{atom-key\ 843}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 843}# (quote (c)))
+ (list (if #{public?\ 825}# (quote @) (quote @@))
+ #{mod\ 823}#
+ #{var\ 824}#)
+ #{exp\ 821}#)
+ #{source\ 819}#))))
+ (lambda (#{var\ 827}#)
+ (let ((#{atom-key\ 828}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 828}# (quote (c)))
((@ (language tree-il) make-toplevel-set)
- #{source\ 834}#
- #{var\ 842}#
- #{exp\ 836}#)
+ #{source\ 819}#
+ #{var\ 827}#
+ #{exp\ 821}#)
(#{decorate-source\ 94}#
- (list (quote set!) #{var\ 842}# #{exp\ 836}#)
- #{source\ 834}#)))))))
+ (list (quote set!) #{var\ 827}# #{exp\ 821}#)
+ #{source\ 819}#)))))))
(#{build-global-reference\ 101}#
- (lambda (#{source\ 844}# #{var\ 845}# #{mod\ 846}#)
+ (lambda (#{source\ 829}# #{var\ 830}# #{mod\ 831}#)
(#{analyze-variable\ 100}#
- #{mod\ 846}#
- #{var\ 845}#
- (lambda (#{mod\ 847}# #{var\ 848}# #{public?\ 849}#)
- (let ((#{atom-key\ 850}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 850}# (quote (c)))
+ #{mod\ 831}#
+ #{var\ 830}#
+ (lambda (#{mod\ 832}# #{var\ 833}# #{public?\ 834}#)
+ (let ((#{atom-key\ 835}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 835}# (quote (c)))
((@ (language tree-il) make-module-ref)
- #{source\ 844}#
- #{mod\ 847}#
- #{var\ 848}#
- #{public?\ 849}#)
+ #{source\ 829}#
+ #{mod\ 832}#
+ #{var\ 833}#
+ #{public?\ 834}#)
(#{decorate-source\ 94}#
- (list (if #{public?\ 849}# (quote @) (quote @@))
- #{mod\ 847}#
- #{var\ 848}#)
- #{source\ 844}#))))
- (lambda (#{var\ 851}#)
- (let ((#{atom-key\ 852}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 852}# (quote (c)))
+ (list (if #{public?\ 834}# (quote @) (quote @@))
+ #{mod\ 832}#
+ #{var\ 833}#)
+ #{source\ 829}#))))
+ (lambda (#{var\ 836}#)
+ (let ((#{atom-key\ 837}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 837}# (quote (c)))
((@ (language tree-il) make-toplevel-ref)
- #{source\ 844}#
- #{var\ 851}#)
+ #{source\ 829}#
+ #{var\ 836}#)
(#{decorate-source\ 94}#
- #{var\ 851}#
- #{source\ 844}#)))))))
+ #{var\ 836}#
+ #{source\ 829}#)))))))
(#{analyze-variable\ 100}#
- (lambda (#{mod\ 853}#
- #{var\ 854}#
- #{modref-cont\ 855}#
- #{bare-cont\ 856}#)
- (if (not #{mod\ 853}#)
- (#{bare-cont\ 856}# #{var\ 854}#)
- (let ((#{kind\ 857}# (car #{mod\ 853}#))
- (#{mod\ 858}# (cdr #{mod\ 853}#)))
- (if (memv #{kind\ 857}# (quote (public)))
- (#{modref-cont\ 855}#
- #{mod\ 858}#
- #{var\ 854}#
+ (lambda (#{mod\ 838}#
+ #{var\ 839}#
+ #{modref-cont\ 840}#
+ #{bare-cont\ 841}#)
+ (if (not #{mod\ 838}#)
+ (#{bare-cont\ 841}# #{var\ 839}#)
+ (let ((#{kind\ 842}# (car #{mod\ 838}#))
+ (#{mod\ 843}# (cdr #{mod\ 838}#)))
+ (if (memv #{kind\ 842}# (quote (public)))
+ (#{modref-cont\ 840}#
+ #{mod\ 843}#
+ #{var\ 839}#
#t)
- (if (memv #{kind\ 857}# (quote (private)))
+ (if (memv #{kind\ 842}# (quote (private)))
(if (not (equal?
- #{mod\ 858}#
+ #{mod\ 843}#
(module-name (current-module))))
- (#{modref-cont\ 855}#
- #{mod\ 858}#
- #{var\ 854}#
+ (#{modref-cont\ 840}#
+ #{mod\ 843}#
+ #{var\ 839}#
#f)
- (#{bare-cont\ 856}# #{var\ 854}#))
- (if (memv #{kind\ 857}# (quote (bare)))
- (#{bare-cont\ 856}# #{var\ 854}#)
- (if (memv #{kind\ 857}# (quote (hygiene)))
+ (#{bare-cont\ 841}# #{var\ 839}#))
+ (if (memv #{kind\ 842}# (quote (bare)))
+ (#{bare-cont\ 841}# #{var\ 839}#)
+ (if (memv #{kind\ 842}# (quote (hygiene)))
(if (if (not (equal?
- #{mod\ 858}#
+ #{mod\ 843}#
(module-name (current-module))))
(module-variable
- (resolve-module #{mod\ 858}#)
- #{var\ 854}#)
+ (resolve-module #{mod\ 843}#)
+ #{var\ 839}#)
#f)
- (#{modref-cont\ 855}#
- #{mod\ 858}#
- #{var\ 854}#
+ (#{modref-cont\ 840}#
+ #{mod\ 843}#
+ #{var\ 839}#
#f)
- (#{bare-cont\ 856}# #{var\ 854}#))
+ (#{bare-cont\ 841}# #{var\ 839}#))
(syntax-violation
#f
"bad module kind"
- #{var\ 854}#
- #{mod\ 858}#)))))))))
+ #{var\ 839}#
+ #{mod\ 843}#)))))))))
(#{build-lexical-assignment\ 99}#
- (lambda (#{source\ 859}#
- #{name\ 860}#
- #{var\ 861}#
- #{exp\ 862}#)
- (let ((#{atom-key\ 863}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 863}# (quote (c)))
+ (lambda (#{source\ 844}#
+ #{name\ 845}#
+ #{var\ 846}#
+ #{exp\ 847}#)
+ (let ((#{atom-key\ 848}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 848}# (quote (c)))
((@ (language tree-il) make-lexical-set)
- #{source\ 859}#
- #{name\ 860}#
- #{var\ 861}#
- #{exp\ 862}#)
+ #{source\ 844}#
+ #{name\ 845}#
+ #{var\ 846}#
+ #{exp\ 847}#)
(#{decorate-source\ 94}#
- (list (quote set!) #{var\ 861}# #{exp\ 862}#)
- #{source\ 859}#)))))
+ (list (quote set!) #{var\ 846}# #{exp\ 847}#)
+ #{source\ 844}#)))))
(#{build-lexical-reference\ 98}#
- (lambda (#{type\ 864}#
- #{source\ 865}#
- #{name\ 866}#
- #{var\ 867}#)
- (let ((#{atom-key\ 868}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 868}# (quote (c)))
+ (lambda (#{type\ 849}#
+ #{source\ 850}#
+ #{name\ 851}#
+ #{var\ 852}#)
+ (let ((#{atom-key\ 853}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 853}# (quote (c)))
((@ (language tree-il) make-lexical-ref)
- #{source\ 865}#
- #{name\ 866}#
- #{var\ 867}#)
+ #{source\ 850}#
+ #{name\ 851}#
+ #{var\ 852}#)
(#{decorate-source\ 94}#
- #{var\ 867}#
- #{source\ 865}#)))))
+ #{var\ 852}#
+ #{source\ 850}#)))))
(#{build-conditional\ 97}#
- (lambda (#{source\ 869}#
- #{test-exp\ 870}#
- #{then-exp\ 871}#
- #{else-exp\ 872}#)
- (let ((#{atom-key\ 873}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 873}# (quote (c)))
+ (lambda (#{source\ 854}#
+ #{test-exp\ 855}#
+ #{then-exp\ 856}#
+ #{else-exp\ 857}#)
+ (let ((#{atom-key\ 858}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 858}# (quote (c)))
((@ (language tree-il) make-conditional)
- #{source\ 869}#
- #{test-exp\ 870}#
- #{then-exp\ 871}#
- #{else-exp\ 872}#)
+ #{source\ 854}#
+ #{test-exp\ 855}#
+ #{then-exp\ 856}#
+ #{else-exp\ 857}#)
(#{decorate-source\ 94}#
- (if (equal? #{else-exp\ 872}# (quote (if #f #f)))
+ (if (equal? #{else-exp\ 857}# (quote (if #f #f)))
(list 'if
- #{test-exp\ 870}#
- #{then-exp\ 871}#)
+ #{test-exp\ 855}#
+ #{then-exp\ 856}#)
(list 'if
- #{test-exp\ 870}#
- #{then-exp\ 871}#
- #{else-exp\ 872}#))
- #{source\ 869}#)))))
+ #{test-exp\ 855}#
+ #{then-exp\ 856}#
+ #{else-exp\ 857}#))
+ #{source\ 854}#)))))
(#{build-application\ 96}#
- (lambda (#{source\ 874}#
- #{fun-exp\ 875}#
- #{arg-exps\ 876}#)
- (let ((#{atom-key\ 877}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 877}# (quote (c)))
+ (lambda (#{source\ 859}#
+ #{fun-exp\ 860}#
+ #{arg-exps\ 861}#)
+ (let ((#{atom-key\ 862}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 862}# (quote (c)))
((@ (language tree-il) make-application)
- #{source\ 874}#
- #{fun-exp\ 875}#
- #{arg-exps\ 876}#)
+ #{source\ 859}#
+ #{fun-exp\ 860}#
+ #{arg-exps\ 861}#)
(#{decorate-source\ 94}#
- (cons #{fun-exp\ 875}# #{arg-exps\ 876}#)
- #{source\ 874}#)))))
+ (cons #{fun-exp\ 860}# #{arg-exps\ 861}#)
+ #{source\ 859}#)))))
(#{build-void\ 95}#
- (lambda (#{source\ 878}#)
- (let ((#{atom-key\ 879}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 879}# (quote (c)))
+ (lambda (#{source\ 863}#)
+ (let ((#{atom-key\ 864}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 864}# (quote (c)))
((@ (language tree-il) make-void)
- #{source\ 878}#)
+ #{source\ 863}#)
(#{decorate-source\ 94}#
'(if #f #f)
- #{source\ 878}#)))))
+ #{source\ 863}#)))))
(#{decorate-source\ 94}#
- (lambda (#{e\ 880}# #{s\ 881}#)
+ (lambda (#{e\ 865}# #{s\ 866}#)
(begin
- (if (if (pair? #{e\ 880}#) #{s\ 881}# #f)
- (set-source-properties! #{e\ 880}# #{s\ 881}#))
- #{e\ 880}#)))
+ (if (if (pair? #{e\ 865}#) #{s\ 866}# #f)
+ (set-source-properties! #{e\ 865}# #{s\ 866}#))
+ #{e\ 865}#)))
(#{get-global-definition-hook\ 93}#
- (lambda (#{symbol\ 882}# #{module\ 883}#)
+ (lambda (#{symbol\ 867}# #{module\ 868}#)
(begin
- (if (if (not #{module\ 883}#) (current-module) #f)
+ (if (if (not #{module\ 868}#) (current-module) #f)
(warn "module system is booted, we should have a module"
- #{symbol\ 882}#))
- (let ((#{v\ 884}# (module-variable
- (if #{module\ 883}#
- (resolve-module (cdr #{module\ 883}#))
+ #{symbol\ 867}#))
+ (let ((#{v\ 869}# (module-variable
+ (if #{module\ 868}#
+ (resolve-module (cdr #{module\ 868}#))
(current-module))
- #{symbol\ 882}#)))
- (if #{v\ 884}#
- (if (variable-bound? #{v\ 884}#)
- (let ((#{val\ 885}# (variable-ref #{v\ 884}#)))
- (if (macro? #{val\ 885}#)
- (if (syncase-macro-type #{val\ 885}#)
- (cons (syncase-macro-type #{val\ 885}#)
- (syncase-macro-binding #{val\ 885}#))
+ #{symbol\ 867}#)))
+ (if #{v\ 869}#
+ (if (variable-bound? #{v\ 869}#)
+ (let ((#{val\ 870}# (variable-ref #{v\ 869}#)))
+ (if (macro? #{val\ 870}#)
+ (if (syncase-macro-type #{val\ 870}#)
+ (cons (syncase-macro-type #{val\ 870}#)
+ (syncase-macro-binding #{val\ 870}#))
#f)
#f))
#f)
#f)))))
(#{put-global-definition-hook\ 92}#
- (lambda (#{symbol\ 886}# #{type\ 887}# #{val\ 888}#)
- (let ((#{existing\ 889}#
- (let ((#{v\ 890}# (module-variable
+ (lambda (#{symbol\ 871}# #{type\ 872}# #{val\ 873}#)
+ (let ((#{existing\ 874}#
+ (let ((#{v\ 875}# (module-variable
(current-module)
- #{symbol\ 886}#)))
- (if #{v\ 890}#
- (if (variable-bound? #{v\ 890}#)
- (let ((#{val\ 891}# (variable-ref #{v\ 890}#)))
- (if (macro? #{val\ 891}#)
- (if (not (syncase-macro-type #{val\ 891}#))
- #{val\ 891}#
+ #{symbol\ 871}#)))
+ (if #{v\ 875}#
+ (if (variable-bound? #{v\ 875}#)
+ (let ((#{val\ 876}# (variable-ref #{v\ 875}#)))
+ (if (macro? #{val\ 876}#)
+ (if (not (syncase-macro-type #{val\ 876}#))
+ #{val\ 876}#
#f)
#f))
#f)
#f))))
(module-define!
(current-module)
- #{symbol\ 886}#
- (if #{existing\ 889}#
+ #{symbol\ 871}#
+ (if #{existing\ 874}#
(make-extended-syncase-macro
- #{existing\ 889}#
- #{type\ 887}#
- #{val\ 888}#)
- (make-syncase-macro #{type\ 887}# #{val\ 888}#))))))
+ #{existing\ 874}#
+ #{type\ 872}#
+ #{val\ 873}#)
+ (make-syncase-macro #{type\ 872}# #{val\ 873}#))))))
(#{local-eval-hook\ 91}#
- (lambda (#{x\ 892}# #{mod\ 893}#)
+ (lambda (#{x\ 877}# #{mod\ 878}#)
(primitive-eval
(list #{noexpand\ 84}#
- (let ((#{atom-key\ 894}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 894}# (quote (c)))
+ (let ((#{atom-key\ 879}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 879}# (quote (c)))
((@ (language tree-il) tree-il->scheme)
- #{x\ 892}#)
- #{x\ 892}#))))))
+ #{x\ 877}#)
+ #{x\ 877}#))))))
(#{top-level-eval-hook\ 90}#
- (lambda (#{x\ 895}# #{mod\ 896}#)
+ (lambda (#{x\ 880}# #{mod\ 881}#)
(primitive-eval
(list #{noexpand\ 84}#
- (let ((#{atom-key\ 897}# (fluid-ref #{*mode*\ 85}#)))
- (if (memv #{atom-key\ 897}# (quote (c)))
+ (let ((#{atom-key\ 882}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 882}# (quote (c)))
((@ (language tree-il) tree-il->scheme)
- #{x\ 895}#)
- #{x\ 895}#))))))
+ #{x\ 880}#)
+ #{x\ 880}#))))))
(#{fx<\ 89}# <)
(#{fx=\ 88}# =)
(#{fx-\ 87}# -)
@@ -5928,872 +5945,3943 @@
(#{*mode*\ 85}# (make-fluid))
(#{noexpand\ 84}# "noexpand"))
(begin
- (#{global-extend\ 127}#
+ (#{global-extend\ 129}#
'local-syntax
'letrec-syntax
#t)
- (#{global-extend\ 127}#
+ (#{global-extend\ 129}#
'local-syntax
'let-syntax
#f)
- (#{global-extend\ 127}#
+ (#{global-extend\ 129}#
'core
'fluid-let-syntax
- (lambda (#{e\ 898}#
- #{r\ 899}#
- #{w\ 900}#
- #{s\ 901}#
- #{mod\ 902}#)
- ((lambda (#{tmp\ 903}#)
- ((lambda (#{tmp\ 904}#)
- (if (if #{tmp\ 904}#
- (apply (lambda (#{_\ 905}#
- #{var\ 906}#
- #{val\ 907}#
- #{e1\ 908}#
- #{e2\ 909}#)
- (#{valid-bound-ids?\ 154}# #{var\ 906}#))
- #{tmp\ 904}#)
+ (lambda (#{e\ 883}#
+ #{r\ 884}#
+ #{w\ 885}#
+ #{s\ 886}#
+ #{mod\ 887}#)
+ ((lambda (#{tmp\ 888}#)
+ ((lambda (#{tmp\ 889}#)
+ (if (if #{tmp\ 889}#
+ (apply (lambda (#{_\ 890}#
+ #{var\ 891}#
+ #{val\ 892}#
+ #{e1\ 893}#
+ #{e2\ 894}#)
+ (#{valid-bound-ids?\ 156}# #{var\ 891}#))
+ #{tmp\ 889}#)
#f)
- (apply (lambda (#{_\ 911}#
- #{var\ 912}#
- #{val\ 913}#
- #{e1\ 914}#
- #{e2\ 915}#)
- (let ((#{names\ 916}#
- (map (lambda (#{x\ 917}#)
- (#{id-var-name\ 151}#
- #{x\ 917}#
- #{w\ 900}#))
- #{var\ 912}#)))
+ (apply (lambda (#{_\ 896}#
+ #{var\ 897}#
+ #{val\ 898}#
+ #{e1\ 899}#
+ #{e2\ 900}#)
+ (let ((#{names\ 901}#
+ (map (lambda (#{x\ 902}#)
+ (#{id-var-name\ 153}#
+ #{x\ 902}#
+ #{w\ 885}#))
+ #{var\ 897}#)))
(begin
(for-each
- (lambda (#{id\ 919}# #{n\ 920}#)
- (let ((#{atom-key\ 921}#
- (#{binding-type\ 121}#
- (#{lookup\ 126}#
- #{n\ 920}#
- #{r\ 899}#
- #{mod\ 902}#))))
- (if (memv #{atom-key\ 921}#
+ (lambda (#{id\ 904}# #{n\ 905}#)
+ (let ((#{atom-key\ 906}#
+ (#{binding-type\ 123}#
+ (#{lookup\ 128}#
+ #{n\ 905}#
+ #{r\ 884}#
+ #{mod\ 887}#))))
+ (if (memv #{atom-key\ 906}#
'(displaced-lexical))
(syntax-violation
'fluid-let-syntax
"identifier out of context"
- #{e\ 898}#
- (#{source-wrap\ 158}#
- #{id\ 919}#
- #{w\ 900}#
- #{s\ 901}#
- #{mod\ 902}#)))))
- #{var\ 912}#
- #{names\ 916}#)
- (#{chi-body\ 169}#
- (cons #{e1\ 914}# #{e2\ 915}#)
- (#{source-wrap\ 158}#
- #{e\ 898}#
- #{w\ 900}#
- #{s\ 901}#
- #{mod\ 902}#)
- (#{extend-env\ 123}#
- #{names\ 916}#
- (let ((#{trans-r\ 924}#
- (#{macros-only-env\ 125}#
- #{r\ 899}#)))
- (map (lambda (#{x\ 925}#)
+ #{e\ 883}#
+ (#{source-wrap\ 160}#
+ #{id\ 904}#
+ #{w\ 885}#
+ #{s\ 886}#
+ #{mod\ 887}#)))))
+ #{var\ 897}#
+ #{names\ 901}#)
+ (#{chi-body\ 171}#
+ (cons #{e1\ 899}# #{e2\ 900}#)
+ (#{source-wrap\ 160}#
+ #{e\ 883}#
+ #{w\ 885}#
+ #{s\ 886}#
+ #{mod\ 887}#)
+ (#{extend-env\ 125}#
+ #{names\ 901}#
+ (let ((#{trans-r\ 909}#
+ (#{macros-only-env\ 127}#
+ #{r\ 884}#)))
+ (map (lambda (#{x\ 910}#)
(cons 'macro
- (#{eval-local-transformer\
172}#
- (#{chi\ 165}#
- #{x\ 925}#
- #{trans-r\ 924}#
- #{w\ 900}#
- #{mod\ 902}#)
- #{mod\ 902}#)))
- #{val\ 913}#))
- #{r\ 899}#)
- #{w\ 900}#
- #{mod\ 902}#))))
- #{tmp\ 904}#)
- ((lambda (#{_\ 927}#)
+ (#{eval-local-transformer\
173}#
+ (#{chi\ 167}#
+ #{x\ 910}#
+ #{trans-r\ 909}#
+ #{w\ 885}#
+ #{mod\ 887}#)
+ #{mod\ 887}#)))
+ #{val\ 898}#))
+ #{r\ 884}#)
+ #{w\ 885}#
+ #{mod\ 887}#))))
+ #{tmp\ 889}#)
+ ((lambda (#{_\ 912}#)
(syntax-violation
'fluid-let-syntax
"bad syntax"
- (#{source-wrap\ 158}#
- #{e\ 898}#
- #{w\ 900}#
- #{s\ 901}#
- #{mod\ 902}#)))
- #{tmp\ 903}#)))
+ (#{source-wrap\ 160}#
+ #{e\ 883}#
+ #{w\ 885}#
+ #{s\ 886}#
+ #{mod\ 887}#)))
+ #{tmp\ 888}#)))
($sc-dispatch
- #{tmp\ 903}#
+ #{tmp\ 888}#
'(any #(each (any any)) any . each-any))))
- #{e\ 898}#)))
- (#{global-extend\ 127}#
+ #{e\ 883}#)))
+ (#{global-extend\ 129}#
'core
'quote
- (lambda (#{e\ 928}#
- #{r\ 929}#
- #{w\ 930}#
- #{s\ 931}#
- #{mod\ 932}#)
- ((lambda (#{tmp\ 933}#)
- ((lambda (#{tmp\ 934}#)
- (if #{tmp\ 934}#
- (apply (lambda (#{_\ 935}# #{e\ 936}#)
- (#{build-data\ 107}#
- #{s\ 931}#
- (#{strip\ 175}# #{e\ 936}# #{w\ 930}#)))
- #{tmp\ 934}#)
- ((lambda (#{_\ 937}#)
+ (lambda (#{e\ 913}#
+ #{r\ 914}#
+ #{w\ 915}#
+ #{s\ 916}#
+ #{mod\ 917}#)
+ ((lambda (#{tmp\ 918}#)
+ ((lambda (#{tmp\ 919}#)
+ (if #{tmp\ 919}#
+ (apply (lambda (#{_\ 920}# #{e\ 921}#)
+ (#{build-data\ 109}#
+ #{s\ 916}#
+ (#{strip\ 176}# #{e\ 921}# #{w\ 915}#)))
+ #{tmp\ 919}#)
+ ((lambda (#{_\ 922}#)
(syntax-violation
'quote
"bad syntax"
- (#{source-wrap\ 158}#
- #{e\ 928}#
- #{w\ 930}#
- #{s\ 931}#
- #{mod\ 932}#)))
- #{tmp\ 933}#)))
- ($sc-dispatch #{tmp\ 933}# (quote (any any)))))
- #{e\ 928}#)))
- (#{global-extend\ 127}#
+ (#{source-wrap\ 160}#
+ #{e\ 913}#
+ #{w\ 915}#
+ #{s\ 916}#
+ #{mod\ 917}#)))
+ #{tmp\ 918}#)))
+ ($sc-dispatch #{tmp\ 918}# (quote (any any)))))
+ #{e\ 913}#)))
+ (#{global-extend\ 129}#
'core
'syntax
- (letrec ((#{regen\ 945}#
- (lambda (#{x\ 946}#)
- (let ((#{atom-key\ 947}# (car #{x\ 946}#)))
- (if (memv #{atom-key\ 947}# (quote (ref)))
+ (letrec ((#{regen\ 930}#
+ (lambda (#{x\ 931}#)
+ (let ((#{atom-key\ 932}# (car #{x\ 931}#)))
+ (if (memv #{atom-key\ 932}# (quote (ref)))
(#{build-lexical-reference\ 98}#
'value
#f
- (cadr #{x\ 946}#)
- (cadr #{x\ 946}#))
- (if (memv #{atom-key\ 947}# (quote (primitive)))
- (#{build-primref\ 106}# #f (cadr #{x\ 946}#))
- (if (memv #{atom-key\ 947}# (quote (quote)))
- (#{build-data\ 107}# #f (cadr #{x\ 946}#))
- (if (memv #{atom-key\ 947}# (quote (lambda)))
- (#{build-lambda\ 105}#
- #f
- (cadr #{x\ 946}#)
- (cadr #{x\ 946}#)
- #f
- (#{regen\ 945}# (caddr #{x\ 946}#)))
+ (cadr #{x\ 931}#)
+ (cadr #{x\ 931}#))
+ (if (memv #{atom-key\ 932}# (quote (primitive)))
+ (#{build-primref\ 108}# #f (cadr #{x\ 931}#))
+ (if (memv #{atom-key\ 932}# (quote (quote)))
+ (#{build-data\ 109}# #f (cadr #{x\ 931}#))
+ (if (memv #{atom-key\ 932}# (quote (lambda)))
+ (if (list? (cadr #{x\ 931}#))
+ (#{build-simple-lambda\ 105}#
+ #f
+ (cadr #{x\ 931}#)
+ #f
+ (cadr #{x\ 931}#)
+ #f
+ (#{regen\ 930}# (caddr #{x\ 931}#)))
+ (error "how did we get here" #{x\ 931}#))
(#{build-application\ 96}#
#f
- (#{build-primref\ 106}# #f (car #{x\ 946}#))
- (map #{regen\ 945}# (cdr #{x\ 946}#))))))))))
- (#{gen-vector\ 944}#
- (lambda (#{x\ 948}#)
- (if (eq? (car #{x\ 948}#) (quote list))
- (cons (quote vector) (cdr #{x\ 948}#))
- (if (eq? (car #{x\ 948}#) (quote quote))
+ (#{build-primref\ 108}# #f (car #{x\ 931}#))
+ (map #{regen\ 930}# (cdr #{x\ 931}#))))))))))
+ (#{gen-vector\ 929}#
+ (lambda (#{x\ 933}#)
+ (if (eq? (car #{x\ 933}#) (quote list))
+ (cons (quote vector) (cdr #{x\ 933}#))
+ (if (eq? (car #{x\ 933}#) (quote quote))
(list 'quote
- (list->vector (cadr #{x\ 948}#)))
- (list (quote list->vector) #{x\ 948}#)))))
- (#{gen-append\ 943}#
- (lambda (#{x\ 949}# #{y\ 950}#)
- (if (equal? #{y\ 950}# (quote (quote ())))
- #{x\ 949}#
- (list (quote append) #{x\ 949}# #{y\ 950}#))))
- (#{gen-cons\ 942}#
- (lambda (#{x\ 951}# #{y\ 952}#)
- (let ((#{atom-key\ 953}# (car #{y\ 952}#)))
- (if (memv #{atom-key\ 953}# (quote (quote)))
- (if (eq? (car #{x\ 951}#) (quote quote))
+ (list->vector (cadr #{x\ 933}#)))
+ (list (quote list->vector) #{x\ 933}#)))))
+ (#{gen-append\ 928}#
+ (lambda (#{x\ 934}# #{y\ 935}#)
+ (if (equal? #{y\ 935}# (quote (quote ())))
+ #{x\ 934}#
+ (list (quote append) #{x\ 934}# #{y\ 935}#))))
+ (#{gen-cons\ 927}#
+ (lambda (#{x\ 936}# #{y\ 937}#)
+ (let ((#{atom-key\ 938}# (car #{y\ 937}#)))
+ (if (memv #{atom-key\ 938}# (quote (quote)))
+ (if (eq? (car #{x\ 936}#) (quote quote))
(list 'quote
- (cons (cadr #{x\ 951}#) (cadr #{y\ 952}#)))
- (if (eq? (cadr #{y\ 952}#) (quote ()))
- (list (quote list) #{x\ 951}#)
- (list (quote cons) #{x\ 951}# #{y\ 952}#)))
- (if (memv #{atom-key\ 953}# (quote (list)))
+ (cons (cadr #{x\ 936}#) (cadr #{y\ 937}#)))
+ (if (eq? (cadr #{y\ 937}#) (quote ()))
+ (list (quote list) #{x\ 936}#)
+ (list (quote cons) #{x\ 936}# #{y\ 937}#)))
+ (if (memv #{atom-key\ 938}# (quote (list)))
(cons 'list
- (cons #{x\ 951}# (cdr #{y\ 952}#)))
- (list (quote cons) #{x\ 951}# #{y\ 952}#))))))
- (#{gen-map\ 941}#
- (lambda (#{e\ 954}# #{map-env\ 955}#)
- (let ((#{formals\ 956}# (map cdr #{map-env\ 955}#))
- (#{actuals\ 957}#
- (map (lambda (#{x\ 958}#)
- (list (quote ref) (car #{x\ 958}#)))
- #{map-env\ 955}#)))
- (if (eq? (car #{e\ 954}#) (quote ref))
- (car #{actuals\ 957}#)
+ (cons #{x\ 936}# (cdr #{y\ 937}#)))
+ (list (quote cons) #{x\ 936}# #{y\ 937}#))))))
+ (#{gen-map\ 926}#
+ (lambda (#{e\ 939}# #{map-env\ 940}#)
+ (let ((#{formals\ 941}# (map cdr #{map-env\ 940}#))
+ (#{actuals\ 942}#
+ (map (lambda (#{x\ 943}#)
+ (list (quote ref) (car #{x\ 943}#)))
+ #{map-env\ 940}#)))
+ (if (eq? (car #{e\ 939}#) (quote ref))
+ (car #{actuals\ 942}#)
(if (and-map
- (lambda (#{x\ 959}#)
- (if (eq? (car #{x\ 959}#) (quote ref))
- (memq (cadr #{x\ 959}#) #{formals\ 956}#)
+ (lambda (#{x\ 944}#)
+ (if (eq? (car #{x\ 944}#) (quote ref))
+ (memq (cadr #{x\ 944}#) #{formals\ 941}#)
#f))
- (cdr #{e\ 954}#))
+ (cdr #{e\ 939}#))
(cons 'map
(cons (list 'primitive
- (car #{e\ 954}#))
- (map (let ((#{r\ 960}# (map cons
- #{formals\
956}#
- #{actuals\
957}#)))
- (lambda (#{x\ 961}#)
- (cdr (assq (cadr #{x\ 961}#)
- #{r\ 960}#))))
- (cdr #{e\ 954}#))))
+ (car #{e\ 939}#))
+ (map (let ((#{r\ 945}# (map cons
+ #{formals\
941}#
+ #{actuals\
942}#)))
+ (lambda (#{x\ 946}#)
+ (cdr (assq (cadr #{x\ 946}#)
+ #{r\ 945}#))))
+ (cdr #{e\ 939}#))))
(cons 'map
(cons (list 'lambda
- #{formals\ 956}#
- #{e\ 954}#)
- #{actuals\ 957}#)))))))
- (#{gen-mappend\ 940}#
- (lambda (#{e\ 962}# #{map-env\ 963}#)
+ #{formals\ 941}#
+ #{e\ 939}#)
+ #{actuals\ 942}#)))))))
+ (#{gen-mappend\ 925}#
+ (lambda (#{e\ 947}# #{map-env\ 948}#)
(list 'apply
'(primitive append)
- (#{gen-map\ 941}# #{e\ 962}# #{map-env\ 963}#))))
- (#{gen-ref\ 939}#
- (lambda (#{src\ 964}#
- #{var\ 965}#
- #{level\ 966}#
- #{maps\ 967}#)
- (if (#{fx=\ 88}# #{level\ 966}# 0)
- (values #{var\ 965}# #{maps\ 967}#)
- (if (null? #{maps\ 967}#)
+ (#{gen-map\ 926}# #{e\ 947}# #{map-env\ 948}#))))
+ (#{gen-ref\ 924}#
+ (lambda (#{src\ 949}#
+ #{var\ 950}#
+ #{level\ 951}#
+ #{maps\ 952}#)
+ (if (#{fx=\ 88}# #{level\ 951}# 0)
+ (values #{var\ 950}# #{maps\ 952}#)
+ (if (null? #{maps\ 952}#)
(syntax-violation
'syntax
"missing ellipsis"
- #{src\ 964}#)
+ #{src\ 949}#)
(call-with-values
(lambda ()
- (#{gen-ref\ 939}#
- #{src\ 964}#
- #{var\ 965}#
- (#{fx-\ 87}# #{level\ 966}# 1)
- (cdr #{maps\ 967}#)))
- (lambda (#{outer-var\ 968}# #{outer-maps\ 969}#)
- (let ((#{b\ 970}# (assq #{outer-var\ 968}#
- (car #{maps\ 967}#))))
- (if #{b\ 970}#
- (values (cdr #{b\ 970}#) #{maps\ 967}#)
- (let ((#{inner-var\ 971}#
- (#{gen-var\ 176}# (quote tmp))))
+ (#{gen-ref\ 924}#
+ #{src\ 949}#
+ #{var\ 950}#
+ (#{fx-\ 87}# #{level\ 951}# 1)
+ (cdr #{maps\ 952}#)))
+ (lambda (#{outer-var\ 953}# #{outer-maps\ 954}#)
+ (let ((#{b\ 955}# (assq #{outer-var\ 953}#
+ (car #{maps\ 952}#))))
+ (if #{b\ 955}#
+ (values (cdr #{b\ 955}#) #{maps\ 952}#)
+ (let ((#{inner-var\ 956}#
+ (#{gen-var\ 177}# (quote tmp))))
(values
- #{inner-var\ 971}#
- (cons (cons (cons #{outer-var\ 968}#
- #{inner-var\ 971}#)
- (car #{maps\ 967}#))
- #{outer-maps\ 969}#)))))))))))
- (#{gen-syntax\ 938}#
- (lambda (#{src\ 972}#
- #{e\ 973}#
- #{r\ 974}#
- #{maps\ 975}#
- #{ellipsis?\ 976}#
- #{mod\ 977}#)
- (if (#{id?\ 129}# #{e\ 973}#)
- (let ((#{label\ 978}#
- (#{id-var-name\ 151}# #{e\ 973}# (quote (())))))
- (let ((#{b\ 979}# (#{lookup\ 126}#
- #{label\ 978}#
- #{r\ 974}#
- #{mod\ 977}#)))
- (if (eq? (#{binding-type\ 121}# #{b\ 979}#)
+ #{inner-var\ 956}#
+ (cons (cons (cons #{outer-var\ 953}#
+ #{inner-var\ 956}#)
+ (car #{maps\ 952}#))
+ #{outer-maps\ 954}#)))))))))))
+ (#{gen-syntax\ 923}#
+ (lambda (#{src\ 957}#
+ #{e\ 958}#
+ #{r\ 959}#
+ #{maps\ 960}#
+ #{ellipsis?\ 961}#
+ #{mod\ 962}#)
+ (if (#{id?\ 131}# #{e\ 958}#)
+ (let ((#{label\ 963}#
+ (#{id-var-name\ 153}# #{e\ 958}# (quote (())))))
+ (let ((#{b\ 964}# (#{lookup\ 128}#
+ #{label\ 963}#
+ #{r\ 959}#
+ #{mod\ 962}#)))
+ (if (eq? (#{binding-type\ 123}# #{b\ 964}#)
'syntax)
(call-with-values
(lambda ()
- (let ((#{var.lev\ 980}#
- (#{binding-value\ 122}# #{b\ 979}#)))
- (#{gen-ref\ 939}#
- #{src\ 972}#
- (car #{var.lev\ 980}#)
- (cdr #{var.lev\ 980}#)
- #{maps\ 975}#)))
- (lambda (#{var\ 981}# #{maps\ 982}#)
+ (let ((#{var.lev\ 965}#
+ (#{binding-value\ 124}# #{b\ 964}#)))
+ (#{gen-ref\ 924}#
+ #{src\ 957}#
+ (car #{var.lev\ 965}#)
+ (cdr #{var.lev\ 965}#)
+ #{maps\ 960}#)))
+ (lambda (#{var\ 966}# #{maps\ 967}#)
(values
- (list (quote ref) #{var\ 981}#)
- #{maps\ 982}#)))
- (if (#{ellipsis?\ 976}# #{e\ 973}#)
+ (list (quote ref) #{var\ 966}#)
+ #{maps\ 967}#)))
+ (if (#{ellipsis?\ 961}# #{e\ 958}#)
(syntax-violation
'syntax
"misplaced ellipsis"
- #{src\ 972}#)
+ #{src\ 957}#)
(values
- (list (quote quote) #{e\ 973}#)
- #{maps\ 975}#)))))
- ((lambda (#{tmp\ 983}#)
- ((lambda (#{tmp\ 984}#)
- (if (if #{tmp\ 984}#
- (apply (lambda (#{dots\ 985}# #{e\ 986}#)
- (#{ellipsis?\ 976}# #{dots\ 985}#))
- #{tmp\ 984}#)
+ (list (quote quote) #{e\ 958}#)
+ #{maps\ 960}#)))))
+ ((lambda (#{tmp\ 968}#)
+ ((lambda (#{tmp\ 969}#)
+ (if (if #{tmp\ 969}#
+ (apply (lambda (#{dots\ 970}# #{e\ 971}#)
+ (#{ellipsis?\ 961}# #{dots\ 970}#))
+ #{tmp\ 969}#)
#f)
- (apply (lambda (#{dots\ 987}# #{e\ 988}#)
- (#{gen-syntax\ 938}#
- #{src\ 972}#
- #{e\ 988}#
- #{r\ 974}#
- #{maps\ 975}#
- (lambda (#{x\ 989}#) #f)
- #{mod\ 977}#))
- #{tmp\ 984}#)
- ((lambda (#{tmp\ 990}#)
- (if (if #{tmp\ 990}#
- (apply (lambda (#{x\ 991}#
- #{dots\ 992}#
- #{y\ 993}#)
- (#{ellipsis?\ 976}#
- #{dots\ 992}#))
- #{tmp\ 990}#)
+ (apply (lambda (#{dots\ 972}# #{e\ 973}#)
+ (#{gen-syntax\ 923}#
+ #{src\ 957}#
+ #{e\ 973}#
+ #{r\ 959}#
+ #{maps\ 960}#
+ (lambda (#{x\ 974}#) #f)
+ #{mod\ 962}#))
+ #{tmp\ 969}#)
+ ((lambda (#{tmp\ 975}#)
+ (if (if #{tmp\ 975}#
+ (apply (lambda (#{x\ 976}#
+ #{dots\ 977}#
+ #{y\ 978}#)
+ (#{ellipsis?\ 961}#
+ #{dots\ 977}#))
+ #{tmp\ 975}#)
#f)
- (apply (lambda (#{x\ 994}#
- #{dots\ 995}#
- #{y\ 996}#)
- (letrec ((#{f\ 997}# (lambda
(#{y\ 998}#
-
#{k\ 999}#)
- ((lambda
(#{tmp\ 1003}#)
-
((lambda (#{tmp\ 1004}#)
- (if
(if #{tmp\ 1004}#
-
(apply (lambda (#{dots\ 1005}#
-
#{y\ 1006}#)
-
(#{ellipsis?\ 976}#
-
#{dots\ 1005}#))
-
#{tmp\ 1004}#)
+ (apply (lambda (#{x\ 979}#
+ #{dots\ 980}#
+ #{y\ 981}#)
+ (letrec ((#{f\ 982}# (lambda
(#{y\ 983}#
+
#{k\ 984}#)
+ ((lambda
(#{tmp\ 988}#)
+
((lambda (#{tmp\ 989}#)
+ (if
(if #{tmp\ 989}#
+
(apply (lambda (#{dots\ 990}#
+
#{y\ 991}#)
+
(#{ellipsis?\ 961}#
+
#{dots\ 990}#))
+
#{tmp\ 989}#)
#f)
-
(apply (lambda (#{dots\ 1007}#
-
#{y\ 1008}#)
-
(#{f\ 997}# #{y\ 1008}#
-
(lambda (#{maps\ 1009}#)
+
(apply (lambda (#{dots\ 992}#
+
#{y\ 993}#)
+
(#{f\ 982}# #{y\ 993}#
+
(lambda (#{maps\ 994}#)
(call-with-values
(lambda ()
-
(#{k\ 999}# (cons '()
-
#{maps\ 1009}#)))
-
(lambda (#{x\ 1010}#
-
#{maps\ 1011}#)
-
(if (null? (car #{maps\ 1011}#))
+
(#{k\ 984}# (cons '()
+
#{maps\ 994}#)))
+
(lambda (#{x\ 995}#
+
#{maps\ 996}#)
+
(if (null? (car #{maps\ 996}#))
(syntax-violation
'syntax
"extra ellipsis"
-
#{src\ 972}#)
+
#{src\ 957}#)
(values
-
(#{gen-mappend\ 940}#
-
#{x\ 1010}#
-
(car #{maps\ 1011}#))
-
(cdr #{maps\ 1011}#))))))))
-
#{tmp\ 1004}#)
-
((lambda (#{_\ 1012}#)
+
(#{gen-mappend\ 925}#
+
#{x\ 995}#
+
(car #{maps\ 996}#))
+
(cdr #{maps\ 996}#))))))))
+
#{tmp\ 989}#)
+
((lambda (#{_\ 997}#)
(call-with-values
(lambda ()
-
(#{gen-syntax\ 938}#
-
#{src\ 972}#
-
#{y\ 998}#
-
#{r\ 974}#
-
#{maps\ 975}#
-
#{ellipsis?\ 976}#
-
#{mod\ 977}#))
-
(lambda (#{y\ 1013}#
-
#{maps\ 1014}#)
+
(#{gen-syntax\ 923}#
+
#{src\ 957}#
+
#{y\ 983}#
+
#{r\ 959}#
+
#{maps\ 960}#
+
#{ellipsis?\ 961}#
+
#{mod\ 962}#))
+
(lambda (#{y\ 998}#
+
#{maps\ 999}#)
(call-with-values
(lambda ()
-
(#{k\ 999}# #{maps\ 1014}#))
-
(lambda (#{x\ 1015}#
-
#{maps\ 1016}#)
+
(#{k\ 984}# #{maps\ 999}#))
+
(lambda (#{x\ 1000}#
+
#{maps\ 1001}#)
(values
-
(#{gen-append\ 943}#
-
#{x\ 1015}#
-
#{y\ 1013}#)
-
#{maps\ 1016}#))))))
-
#{tmp\ 1003}#)))
+
(#{gen-append\ 928}#
+
#{x\ 1000}#
+
#{y\ 998}#)
+
#{maps\ 1001}#))))))
+
#{tmp\ 988}#)))
($sc-dispatch
-
#{tmp\ 1003}#
+
#{tmp\ 988}#
'(any .
any))))
- #{y\
998}#))))
- (#{f\ 997}# #{y\ 996}#
- (lambda (#{maps\
1000}#)
+ #{y\
983}#))))
+ (#{f\ 982}# #{y\ 981}#
+ (lambda (#{maps\
985}#)
(call-with-values
(lambda ()
-
(#{gen-syntax\ 938}#
- #{src\ 972}#
- #{x\ 994}#
- #{r\ 974}#
+
(#{gen-syntax\ 923}#
+ #{src\ 957}#
+ #{x\ 979}#
+ #{r\ 959}#
(cons '()
-
#{maps\ 1000}#)
-
#{ellipsis?\ 976}#
- #{mod\
977}#))
- (lambda (#{x\
1001}#
-
#{maps\ 1002}#)
- (if (null?
(car #{maps\ 1002}#))
+
#{maps\ 985}#)
+
#{ellipsis?\ 961}#
+ #{mod\
962}#))
+ (lambda (#{x\
986}#
+
#{maps\ 987}#)
+ (if (null?
(car #{maps\ 987}#))
(syntax-violation
'syntax
"extra
ellipsis"
- #{src\
972}#)
+ #{src\
957}#)
(values
-
(#{gen-map\ 941}#
- #{x\
1001}#
- (car
#{maps\ 1002}#))
- (cdr
#{maps\ 1002}#)))))))))
- #{tmp\ 990}#)
- ((lambda (#{tmp\ 1017}#)
- (if #{tmp\ 1017}#
- (apply (lambda (#{x\ 1018}#
- #{y\ 1019}#)
+
(#{gen-map\ 926}#
+ #{x\
986}#
+ (car
#{maps\ 987}#))
+ (cdr
#{maps\ 987}#)))))))))
+ #{tmp\ 975}#)
+ ((lambda (#{tmp\ 1002}#)
+ (if #{tmp\ 1002}#
+ (apply (lambda (#{x\ 1003}#
+ #{y\ 1004}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 938}#
- #{src\ 972}#
- #{x\ 1018}#
- #{r\ 974}#
- #{maps\ 975}#
- #{ellipsis?\ 976}#
- #{mod\ 977}#))
- (lambda (#{x\ 1020}#
- #{maps\ 1021}#)
+ (#{gen-syntax\ 923}#
+ #{src\ 957}#
+ #{x\ 1003}#
+ #{r\ 959}#
+ #{maps\ 960}#
+ #{ellipsis?\ 961}#
+ #{mod\ 962}#))
+ (lambda (#{x\ 1005}#
+ #{maps\ 1006}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 938}#
- #{src\ 972}#
- #{y\ 1019}#
- #{r\ 974}#
- #{maps\ 1021}#
- #{ellipsis?\ 976}#
- #{mod\ 977}#))
- (lambda (#{y\ 1022}#
- #{maps\
1023}#)
+ (#{gen-syntax\ 923}#
+ #{src\ 957}#
+ #{y\ 1004}#
+ #{r\ 959}#
+ #{maps\ 1006}#
+ #{ellipsis?\ 961}#
+ #{mod\ 962}#))
+ (lambda (#{y\ 1007}#
+ #{maps\
1008}#)
(values
- (#{gen-cons\ 942}#
- #{x\ 1020}#
- #{y\ 1022}#)
- #{maps\
1023}#))))))
- #{tmp\ 1017}#)
- ((lambda (#{tmp\ 1024}#)
- (if #{tmp\ 1024}#
- (apply (lambda (#{e1\ 1025}#
- #{e2\ 1026}#)
+ (#{gen-cons\ 927}#
+ #{x\ 1005}#
+ #{y\ 1007}#)
+ #{maps\
1008}#))))))
+ #{tmp\ 1002}#)
+ ((lambda (#{tmp\ 1009}#)
+ (if #{tmp\ 1009}#
+ (apply (lambda (#{e1\ 1010}#
+ #{e2\ 1011}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 938}#
- #{src\ 972}#
- (cons #{e1\ 1025}#
- #{e2\
1026}#)
- #{r\ 974}#
- #{maps\ 975}#
- #{ellipsis?\ 976}#
- #{mod\ 977}#))
- (lambda (#{e\ 1028}#
- #{maps\
1029}#)
+ (#{gen-syntax\ 923}#
+ #{src\ 957}#
+ (cons #{e1\ 1010}#
+ #{e2\
1011}#)
+ #{r\ 959}#
+ #{maps\ 960}#
+ #{ellipsis?\ 961}#
+ #{mod\ 962}#))
+ (lambda (#{e\ 1013}#
+ #{maps\
1014}#)
(values
- (#{gen-vector\
944}#
- #{e\ 1028}#)
- #{maps\ 1029}#))))
- #{tmp\ 1024}#)
- ((lambda (#{_\ 1030}#)
+ (#{gen-vector\
929}#
+ #{e\ 1013}#)
+ #{maps\ 1014}#))))
+ #{tmp\ 1009}#)
+ ((lambda (#{_\ 1015}#)
(values
(list 'quote
- #{e\ 973}#)
- #{maps\ 975}#))
- #{tmp\ 983}#)))
+ #{e\ 958}#)
+ #{maps\ 960}#))
+ #{tmp\ 968}#)))
($sc-dispatch
- #{tmp\ 983}#
+ #{tmp\ 968}#
'#(vector (any . each-any))))))
($sc-dispatch
- #{tmp\ 983}#
+ #{tmp\ 968}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 983}#
+ #{tmp\ 968}#
'(any any . any)))))
- ($sc-dispatch #{tmp\ 983}# (quote (any any)))))
- #{e\ 973}#)))))
- (lambda (#{e\ 1031}#
- #{r\ 1032}#
- #{w\ 1033}#
- #{s\ 1034}#
- #{mod\ 1035}#)
- (let ((#{e\ 1036}#
- (#{source-wrap\ 158}#
- #{e\ 1031}#
- #{w\ 1033}#
- #{s\ 1034}#
- #{mod\ 1035}#)))
- ((lambda (#{tmp\ 1037}#)
- ((lambda (#{tmp\ 1038}#)
- (if #{tmp\ 1038}#
- (apply (lambda (#{_\ 1039}# #{x\ 1040}#)
+ ($sc-dispatch #{tmp\ 968}# (quote (any any)))))
+ #{e\ 958}#)))))
+ (lambda (#{e\ 1016}#
+ #{r\ 1017}#
+ #{w\ 1018}#
+ #{s\ 1019}#
+ #{mod\ 1020}#)
+ (let ((#{e\ 1021}#
+ (#{source-wrap\ 160}#
+ #{e\ 1016}#
+ #{w\ 1018}#
+ #{s\ 1019}#
+ #{mod\ 1020}#)))
+ ((lambda (#{tmp\ 1022}#)
+ ((lambda (#{tmp\ 1023}#)
+ (if #{tmp\ 1023}#
+ (apply (lambda (#{_\ 1024}# #{x\ 1025}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 938}#
- #{e\ 1036}#
- #{x\ 1040}#
- #{r\ 1032}#
+ (#{gen-syntax\ 923}#
+ #{e\ 1021}#
+ #{x\ 1025}#
+ #{r\ 1017}#
'()
- #{ellipsis?\ 174}#
- #{mod\ 1035}#))
- (lambda (#{e\ 1041}# #{maps\ 1042}#)
- (#{regen\ 945}# #{e\ 1041}#))))
- #{tmp\ 1038}#)
- ((lambda (#{_\ 1043}#)
+ #{ellipsis?\ 175}#
+ #{mod\ 1020}#))
+ (lambda (#{e\ 1026}# #{maps\ 1027}#)
+ (#{regen\ 930}# #{e\ 1026}#))))
+ #{tmp\ 1023}#)
+ ((lambda (#{_\ 1028}#)
(syntax-violation
'syntax
"bad `syntax' form"
- #{e\ 1036}#))
- #{tmp\ 1037}#)))
- ($sc-dispatch #{tmp\ 1037}# (quote (any any)))))
- #{e\ 1036}#)))))
- (#{global-extend\ 127}#
+ #{e\ 1021}#))
+ #{tmp\ 1022}#)))
+ ($sc-dispatch #{tmp\ 1022}# (quote (any any)))))
+ #{e\ 1021}#)))))
+ (#{global-extend\ 129}#
'core
'lambda
- (lambda (#{e\ 1044}#
- #{r\ 1045}#
- #{w\ 1046}#
- #{s\ 1047}#
- #{mod\ 1048}#)
- ((lambda (#{tmp\ 1049}#)
- ((lambda (#{tmp\ 1050}#)
- (if #{tmp\ 1050}#
- (apply (lambda (#{_\ 1051}# #{c\ 1052}#)
- (#{chi-lambda-clause\ 170}#
- (#{source-wrap\ 158}#
- #{e\ 1044}#
- #{w\ 1046}#
- #{s\ 1047}#
- #{mod\ 1048}#)
+ (lambda (#{e\ 1029}#
+ #{r\ 1030}#
+ #{w\ 1031}#
+ #{s\ 1032}#
+ #{mod\ 1033}#)
+ (letrec ((#{docstring&body\ 1034}#
+ (lambda (#{ids\ 1035}#
+ #{vars\ 1036}#
+ #{labels\ 1037}#
+ #{c\ 1038}#)
+ ((lambda (#{tmp\ 1039}#)
+ ((lambda (#{tmp\ 1040}#)
+ (if (if #{tmp\ 1040}#
+ (apply (lambda (#{docstring\ 1041}#
+ #{e1\ 1042}#
+ #{e2\ 1043}#)
+ (string?
+ (syntax->datum
+ #{docstring\ 1041}#)))
+ #{tmp\ 1040}#)
+ #f)
+ (apply (lambda (#{docstring\ 1044}#
+ #{e1\ 1045}#
+ #{e2\ 1046}#)
+ (values
+ (syntax->datum #{docstring\ 1044}#)
+ (#{chi-body\ 171}#
+ (cons #{e1\ 1045}# #{e2\ 1046}#)
+ (#{source-wrap\ 160}#
+ #{e\ 1029}#
+ #{w\ 1031}#
+ #{s\ 1032}#
+ #{mod\ 1033}#)
+ (#{extend-var-env\ 126}#
+ #{labels\ 1037}#
+ #{vars\ 1036}#
+ #{r\ 1030}#)
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 1035}#
+ #{labels\ 1037}#
+ #{w\ 1031}#)
+ #{mod\ 1033}#)))
+ #{tmp\ 1040}#)
+ ((lambda (#{tmp\ 1048}#)
+ (if #{tmp\ 1048}#
+ (apply (lambda (#{e1\ 1049}# #{e2\ 1050}#)
+ (values
+ #f
+ (#{chi-body\ 171}#
+ (cons #{e1\ 1049}#
+ #{e2\ 1050}#)
+ (#{source-wrap\ 160}#
+ #{e\ 1029}#
+ #{w\ 1031}#
+ #{s\ 1032}#
+ #{mod\ 1033}#)
+ (#{extend-var-env\ 126}#
+ #{labels\ 1037}#
+ #{vars\ 1036}#
+ #{r\ 1030}#)
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 1035}#
+ #{labels\ 1037}#
+ #{w\ 1031}#)
+ #{mod\ 1033}#)))
+ #{tmp\ 1048}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ #{tmp\ 1039}#)))
+ ($sc-dispatch
+ #{tmp\ 1039}#
+ '(any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 1039}#
+ '(any any . each-any))))
+ #{c\ 1038}#))))
+ ((lambda (#{tmp\ 1052}#)
+ ((lambda (#{tmp\ 1053}#)
+ (if #{tmp\ 1053}#
+ (apply (lambda (#{_\ 1054}#
+ #{id\ 1055}#
+ #{e1\ 1056}#
+ #{e2\ 1057}#)
+ (let ((#{ids\ 1058}# #{id\ 1055}#))
+ (if (not (#{valid-bound-ids?\ 156}#
+ #{ids\ 1058}#))
+ (syntax-violation
+ 'lambda
+ "invalid parameter list"
+ #{e\ 1029}#)
+ (let ((#{vars\ 1060}#
+ (map #{gen-var\ 177}# #{ids\ 1058}#))
+ (#{labels\ 1061}#
+ (#{gen-labels\ 137}# #{ids\ 1058}#)))
+ (call-with-values
+ (lambda ()
+ (#{docstring&body\ 1034}#
+ #{ids\ 1058}#
+ #{vars\ 1060}#
+ #{labels\ 1061}#
+ (cons #{e1\ 1056}# #{e2\ 1057}#)))
+ (lambda (#{docstring\ 1063}#
+ #{body\ 1064}#)
+ (#{build-simple-lambda\ 105}#
+ #{s\ 1032}#
+ (map syntax->datum #{ids\ 1058}#)
+ #f
+ #{vars\ 1060}#
+ #{docstring\ 1063}#
+ #{body\ 1064}#)))))))
+ #{tmp\ 1053}#)
+ ((lambda (#{tmp\ 1065}#)
+ (if #{tmp\ 1065}#
+ (apply (lambda (#{_\ 1066}#
+ #{ids\ 1067}#
+ #{e1\ 1068}#
+ #{e2\ 1069}#)
+ (let ((#{rids\ 1070}#
+ (#{lambda-var-list\ 178}#
+ #{ids\ 1067}#)))
+ (if (not (#{valid-bound-ids?\ 156}#
+ #{rids\ 1070}#))
+ (syntax-violation
+ 'lambda
+ "invalid parameter list"
+ #{e\ 1029}#)
+ (let ((#{req\ 1071}#
+ (reverse (cdr #{rids\ 1070}#))))
+ (let ((#{rest\ 1072}#
+ (car #{rids\ 1070}#)))
+ (let ((#{rrids\ 1073}#
+ (reverse #{rids\ 1070}#)))
+ (let ((#{vars\ 1074}#
+ (map #{gen-var\ 177}#
+ #{rrids\ 1073}#)))
+ (let ((#{labels\ 1075}#
+ (#{gen-labels\ 137}#
+ #{rrids\ 1073}#)))
+ (call-with-values
+ (lambda ()
+ (#{docstring&body\ 1034}#
+ #{rrids\ 1073}#
+ #{vars\ 1074}#
+ #{labels\ 1075}#
+ (cons #{e1\ 1068}#
+ #{e2\ 1069}#)))
+ (lambda (#{docstring\ 1077}#
+ #{body\ 1078}#)
+ (#{build-simple-lambda\
105}#
+ #{s\ 1032}#
+ (map syntax->datum
+ #{req\ 1071}#)
+ (syntax->datum
+ #{rest\ 1072}#)
+ #{vars\ 1074}#
+ #{docstring\ 1077}#
+ #{body\ 1078}#)))))))))))
+ #{tmp\ 1065}#)
+ ((lambda (#{_\ 1079}#)
+ (syntax-violation
+ 'lambda
+ "bad lambda"
+ #{e\ 1029}#))
+ #{tmp\ 1052}#)))
+ ($sc-dispatch
+ #{tmp\ 1052}#
+ '(any any any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 1052}#
+ '(any each-any any . each-any))))
+ #{e\ 1029}#))))
+ (#{global-extend\ 129}#
+ 'core
+ 'lambda*
+ (lambda (#{e\ 1080}#
+ #{r\ 1081}#
+ #{w\ 1082}#
+ #{s\ 1083}#
+ #{mod\ 1084}#)
+ (letrec ((#{expand-body\ 1092}#
+ (lambda (#{req\ 1093}#
+ #{opt\ 1094}#
+ #{rest\ 1095}#
+ #{kw\ 1096}#
+ #{body\ 1097}#
+ #{vars\ 1098}#
+ #{r*\ 1099}#
+ #{w*\ 1100}#
+ #{inits\ 1101}#)
+ ((lambda (#{tmp\ 1102}#)
+ ((lambda (#{tmp\ 1103}#)
+ (if (if #{tmp\ 1103}#
+ (apply (lambda (#{docstring\ 1104}#
+ #{e1\ 1105}#
+ #{e2\ 1106}#)
+ (string?
+ (syntax->datum
+ #{docstring\ 1104}#)))
+ #{tmp\ 1103}#)
+ #f)
+ (apply (lambda (#{docstring\ 1107}#
+ #{e1\ 1108}#
+ #{e2\ 1109}#)
+ (values
+ (syntax->datum #{docstring\ 1107}#)
+ #{req\ 1093}#
+ #{opt\ 1094}#
+ #{rest\ 1095}#
+ #{kw\ 1096}#
+ #{inits\ 1101}#
+ #{vars\ 1098}#
+ #f
+ (#{chi-body\ 171}#
+ (cons #{e1\ 1108}# #{e2\ 1109}#)
+ (#{source-wrap\ 160}#
+ #{e\ 1080}#
+ #{w\ 1082}#
+ #{s\ 1083}#
+ #{mod\ 1084}#)
+ #{r*\ 1099}#
+ #{w*\ 1100}#
+ #{mod\ 1084}#)))
+ #{tmp\ 1103}#)
+ ((lambda (#{tmp\ 1111}#)
+ (if #{tmp\ 1111}#
+ (apply (lambda (#{e1\ 1112}# #{e2\ 1113}#)
+ (values
+ #f
+ #{req\ 1093}#
+ #{opt\ 1094}#
+ #{rest\ 1095}#
+ #{kw\ 1096}#
+ #{inits\ 1101}#
+ #{vars\ 1098}#
+ #f
+ (#{chi-body\ 171}#
+ (cons #{e1\ 1112}#
+ #{e2\ 1113}#)
+ (#{source-wrap\ 160}#
+ #{e\ 1080}#
+ #{w\ 1082}#
+ #{s\ 1083}#
+ #{mod\ 1084}#)
+ #{r*\ 1099}#
+ #{w*\ 1100}#
+ #{mod\ 1084}#)))
+ #{tmp\ 1111}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ #{tmp\ 1102}#)))
+ ($sc-dispatch
+ #{tmp\ 1102}#
+ '(any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 1102}#
+ '(any any . each-any))))
+ #{body\ 1097}#)))
+ (#{expand-kw\ 1091}#
+ (lambda (#{req\ 1115}#
+ #{opt\ 1116}#
+ #{rest\ 1117}#
+ #{kw\ 1118}#
+ #{body\ 1119}#
+ #{vars\ 1120}#
+ #{r*\ 1121}#
+ #{w*\ 1122}#
+ #{aok\ 1123}#
+ #{out\ 1124}#
+ #{inits\ 1125}#)
+ (if (pair? #{kw\ 1118}#)
+ ((lambda (#{tmp\ 1126}#)
+ ((lambda (#{tmp\ 1127}#)
+ (if #{tmp\ 1127}#
+ (apply (lambda (#{k\ 1128}#
+ #{id\ 1129}#
+ #{i\ 1130}#)
+ (let ((#{v\ 1131}#
+ (#{gen-var\ 177}#
+ #{id\ 1129}#)))
+ (let ((#{l\ 1132}#
+ (#{gen-labels\ 137}#
+ (list #{v\ 1131}#))))
+ (let ((#{r**\ 1133}#
+ (#{extend-var-env\ 126}#
+ #{l\ 1132}#
+ (list #{v\ 1131}#)
+ #{r*\ 1121}#)))
+ (let ((#{w**\ 1134}#
+ (#{make-binding-wrap\
148}#
+ (list #{id\ 1129}#)
+ #{l\ 1132}#
+ #{w*\ 1122}#)))
+ (#{expand-kw\ 1091}#
+ #{req\ 1115}#
+ #{opt\ 1116}#
+ #{rest\ 1117}#
+ (cdr #{kw\ 1118}#)
+ #{body\ 1119}#
+ (cons #{v\ 1131}#
+ #{vars\ 1120}#)
+ #{r**\ 1133}#
+ #{w**\ 1134}#
+ #{aok\ 1123}#
+ (cons (list (syntax->datum
+ #{k\ 1128}#)
+ (syntax->datum
+ #{id\ 1129}#)
+ #{v\ 1131}#)
+ #{out\ 1124}#)
+ (cons (#{chi\ 167}#
+ #{i\ 1130}#
+ #{r*\ 1121}#
+ #{w*\ 1122}#
+ #{mod\ 1084}#)
+ #{inits\
1125}#)))))))
+ #{tmp\ 1127}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ #{tmp\ 1126}#)))
+ ($sc-dispatch
+ #{tmp\ 1126}#
+ '(any any any))))
+ (car #{kw\ 1118}#))
+ (#{expand-body\ 1092}#
+ #{req\ 1115}#
+ #{opt\ 1116}#
+ #{rest\ 1117}#
+ (if (let ((#{t\ 1135}# #{aok\ 1123}#))
+ (if #{t\ 1135}#
+ #{t\ 1135}#
+ (pair? #{out\ 1124}#)))
+ (cons #{aok\ 1123}# (reverse #{out\ 1124}#))
+ #f)
+ #{body\ 1119}#
+ (reverse #{vars\ 1120}#)
+ #{r*\ 1121}#
+ #{w*\ 1122}#
+ (reverse #{inits\ 1125}#)))))
+ (#{expand-opt\ 1090}#
+ (lambda (#{req\ 1136}#
+ #{opt\ 1137}#
+ #{rest\ 1138}#
+ #{kw\ 1139}#
+ #{body\ 1140}#
+ #{vars\ 1141}#
+ #{r*\ 1142}#
+ #{w*\ 1143}#
+ #{out\ 1144}#
+ #{inits\ 1145}#)
+ (if (pair? #{opt\ 1137}#)
+ ((lambda (#{tmp\ 1146}#)
+ ((lambda (#{tmp\ 1147}#)
+ (if #{tmp\ 1147}#
+ (apply (lambda (#{id\ 1148}# #{i\ 1149}#)
+ (let ((#{v\ 1150}#
+ (#{gen-var\ 177}#
+ #{id\ 1148}#)))
+ (let ((#{l\ 1151}#
+ (#{gen-labels\ 137}#
+ (list #{v\ 1150}#))))
+ (let ((#{r**\ 1152}#
+ (#{extend-var-env\ 126}#
+ #{l\ 1151}#
+ (list #{v\ 1150}#)
+ #{r*\ 1142}#)))
+ (let ((#{w**\ 1153}#
+ (#{make-binding-wrap\
148}#
+ (list #{id\ 1148}#)
+ #{l\ 1151}#
+ #{w*\ 1143}#)))
+ (#{expand-opt\ 1090}#
+ #{req\ 1136}#
+ (cdr #{opt\ 1137}#)
+ #{rest\ 1138}#
+ #{kw\ 1139}#
+ #{body\ 1140}#
+ (cons #{v\ 1150}#
+ #{vars\ 1141}#)
+ #{r**\ 1152}#
+ #{w**\ 1153}#
+ (cons (syntax->datum
+ #{id\ 1148}#)
+ #{out\ 1144}#)
+ (cons (#{chi\ 167}#
+ #{i\ 1149}#
+ #{r*\ 1142}#
+ #{w*\ 1143}#
+ #{mod\ 1084}#)
+ #{inits\
1145}#)))))))
+ #{tmp\ 1147}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ #{tmp\ 1146}#)))
+ ($sc-dispatch #{tmp\ 1146}# (quote (any any)))))
+ (car #{opt\ 1137}#))
+ (if #{rest\ 1138}#
+ (let ((#{v\ 1154}#
+ (#{gen-var\ 177}# #{rest\ 1138}#)))
+ (let ((#{l\ 1155}#
+ (#{gen-labels\ 137}# (list #{v\ 1154}#))))
+ (let ((#{r*\ 1156}#
+ (#{extend-var-env\ 126}#
+ #{l\ 1155}#
+ (list #{v\ 1154}#)
+ #{r*\ 1142}#)))
+ (let ((#{w*\ 1157}#
+ (#{make-binding-wrap\ 148}#
+ (list #{rest\ 1138}#)
+ #{l\ 1155}#
+ #{w*\ 1143}#)))
+ (#{expand-kw\ 1091}#
+ #{req\ 1136}#
+ (if (pair? #{out\ 1144}#)
+ (reverse #{out\ 1144}#)
+ #f)
+ (syntax->datum #{rest\ 1138}#)
+ (if (pair? #{kw\ 1139}#)
+ (cdr #{kw\ 1139}#)
+ #{kw\ 1139}#)
+ #{body\ 1140}#
+ (cons #{v\ 1154}# #{vars\ 1141}#)
+ #{r*\ 1156}#
+ #{w*\ 1157}#
+ (if (pair? #{kw\ 1139}#)
+ (car #{kw\ 1139}#)
+ #f)
+ '()
+ #{inits\ 1145}#)))))
+ (#{expand-kw\ 1091}#
+ #{req\ 1136}#
+ (if (pair? #{out\ 1144}#)
+ (reverse #{out\ 1144}#)
+ #f)
#f
- #{c\ 1052}#
- #{r\ 1045}#
- #{w\ 1046}#
- #{mod\ 1048}#
- (lambda (#{names\ 1053}#
- #{vars\ 1054}#
- #{docstring\ 1055}#
- #{body\ 1056}#)
- (#{build-lambda\ 105}#
- #{s\ 1047}#
- #{names\ 1053}#
- #{vars\ 1054}#
- #{docstring\ 1055}#
- #{body\ 1056}#))))
- #{tmp\ 1050}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp\ 1049}#)))
- ($sc-dispatch #{tmp\ 1049}# (quote (any . any)))))
- #{e\ 1044}#)))
- (#{global-extend\ 127}#
+ (if (pair? #{kw\ 1139}#)
+ (cdr #{kw\ 1139}#)
+ #{kw\ 1139}#)
+ #{body\ 1140}#
+ #{vars\ 1141}#
+ #{r*\ 1142}#
+ #{w*\ 1143}#
+ (if (pair? #{kw\ 1139}#) (car #{kw\ 1139}#) #f)
+ '()
+ #{inits\ 1145}#)))))
+ (#{expand-req\ 1089}#
+ (lambda (#{req\ 1158}#
+ #{opt\ 1159}#
+ #{rest\ 1160}#
+ #{kw\ 1161}#
+ #{body\ 1162}#)
+ (let ((#{vars\ 1163}#
+ (map #{gen-var\ 177}# #{req\ 1158}#))
+ (#{labels\ 1164}#
+ (#{gen-labels\ 137}# #{req\ 1158}#)))
+ (let ((#{r*\ 1165}#
+ (#{extend-var-env\ 126}#
+ #{labels\ 1164}#
+ #{vars\ 1163}#
+ #{r\ 1081}#))
+ (#{w*\ 1166}#
+ (#{make-binding-wrap\ 148}#
+ #{req\ 1158}#
+ #{labels\ 1164}#
+ #{w\ 1082}#)))
+ (#{expand-opt\ 1090}#
+ (map syntax->datum #{req\ 1158}#)
+ #{opt\ 1159}#
+ #{rest\ 1160}#
+ #{kw\ 1161}#
+ #{body\ 1162}#
+ (reverse #{vars\ 1163}#)
+ #{r*\ 1165}#
+ #{w*\ 1166}#
+ '()
+ '())))))
+ (#{rest\ 1088}#
+ (lambda (#{args\ 1167}#
+ #{req\ 1168}#
+ #{opt\ 1169}#
+ #{kw\ 1170}#)
+ ((lambda (#{tmp\ 1171}#)
+ ((lambda (#{tmp\ 1172}#)
+ (if (if #{tmp\ 1172}#
+ (apply (lambda (#{r\ 1173}#)
+ (symbol?
+ (syntax->datum #{r\ 1173}#)))
+ #{tmp\ 1172}#)
+ #f)
+ (apply (lambda (#{r\ 1174}#)
+ (values
+ #{req\ 1168}#
+ #{opt\ 1169}#
+ #{r\ 1174}#
+ #{kw\ 1170}#))
+ #{tmp\ 1172}#)
+ ((lambda (#{else\ 1175}#)
+ (syntax-violation
+ 'lambda*
+ "invalid rest argument"
+ #{e\ 1080}#
+ #{args\ 1167}#))
+ #{tmp\ 1171}#)))
+ (list #{tmp\ 1171}#)))
+ #{args\ 1167}#)))
+ (#{key\ 1087}#
+ (lambda (#{args\ 1176}#
+ #{req\ 1177}#
+ #{opt\ 1178}#
+ #{rkey\ 1179}#)
+ ((lambda (#{tmp\ 1180}#)
+ ((lambda (#{tmp\ 1181}#)
+ (if #{tmp\ 1181}#
+ (apply (lambda ()
+ (values
+ #{req\ 1177}#
+ #{opt\ 1178}#
+ #f
+ (cons #f (reverse #{rkey\ 1179}#))))
+ #{tmp\ 1181}#)
+ ((lambda (#{tmp\ 1182}#)
+ (if (if #{tmp\ 1182}#
+ (apply (lambda (#{a\ 1183}#
+ #{b\ 1184}#)
+ (symbol?
+ (syntax->datum
+ #{a\ 1183}#)))
+ #{tmp\ 1182}#)
+ #f)
+ (apply (lambda (#{a\ 1185}# #{b\ 1186}#)
+ ((lambda (#{tmp\ 1187}#)
+ ((lambda (#{k\ 1188}#)
+ (#{key\ 1087}#
+ #{b\ 1186}#
+ #{req\ 1177}#
+ #{opt\ 1178}#
+ (cons (cons #{k\ 1188}#
+ (cons #{a\
1185}#
+
'(#(syntax-object
+ #f
+
((top)
+
#(ribcage
+
#(k)
+
#((top))
+
#("i"))
+
#(ribcage
+
#(a
+
b)
+
#((top)
+
(top))
+
#("i"
+
"i"))
+
#(ribcage
+
()
+
()
+
())
+
#(ribcage
+
#(args
+
req
+
opt
+
rkey)
+
#((top)
+
(top)
+
(top)
+
(top))
+
#("i"
+
"i"
+
"i"
+
"i"))
+
#(ribcage
+
(expand-body
+
expand-kw
+
expand-opt
+
expand-req
+
rest
+
key
+
opt
+
req)
+
((top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top))
+
("i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"))
+
#(ribcage
+
#(e
+
r
+
w
+
s
+
mod)
+
#((top)
+
(top)
+
(top)
+
(top)
+
(top))
+
#("i"
+
"i"
+
"i"
+
"i"
+
"i"))
+
#(ribcage
+
(lambda-var-list
+
gen-var
+
strip
+
ellipsis?
+
chi-void
+
eval-local-transformer
+
chi-local-syntax
+
chi-body
+
chi-macro
+
chi-application
+
chi-expr
+
chi
+
chi-top
+
syntax-type
+
chi-when-list
+
chi-install-global
+
chi-top-sequence
+
chi-sequence
+
source-wrap
+
wrap
+
bound-id-member?
+
distinct-bound-ids?
+
valid-bound-ids?
+
bound-id=?
+
free-id=?
+
id-var-name
+
same-marks?
+
join-marks
+
join-wraps
+
smart-append
+
make-binding-wrap
+
extend-ribcage!
+
make-empty-ribcage
+
new-mark
+
anti-mark
+
the-anti-mark
+
top-marked?
+
top-wrap
+
empty-wrap
+
set-ribcage-labels!
+
set-ribcage-marks!
+
set-ribcage-symnames!
+
ribcage-labels
+
ribcage-marks
+
ribcage-symnames
+
ribcage?
+
make-ribcage
+
gen-labels
+
gen-label
+
make-rename
+
rename-marks
+
rename-new
+
rename-old
+
subst-rename?
+
wrap-subst
+
wrap-marks
+
make-wrap
+
id-sym-name&marks
+
id-sym-name
+
id?
+
nonsymbol-id?
+
global-extend
+
lookup
+
macros-only-env
+
extend-var-env
+
extend-env
+
null-env
+
binding-value
+
binding-type
+
make-binding
+
arg-check
+
source-annotation
+
no-source
+
set-syntax-object-module!
+
set-syntax-object-wrap!
+
set-syntax-object-expression!
+
syntax-object-module
+
syntax-object-wrap
+
syntax-object-expression
+
syntax-object?
+
make-syntax-object
+
build-lexical-var
+
build-letrec
+
build-named-let
+
build-let
+
build-sequence
+
build-data
+
build-primref
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
+
build-global-definition
+
maybe-name-value!
+
build-global-assignment
+
build-global-reference
+
analyze-variable
+
build-lexical-assignment
+
build-lexical-reference
+
build-conditional
+
build-application
+
build-void
+
decorate-source
+
get-global-definition-hook
+
put-global-definition-hook
+
gensym-hook
+
local-eval-hook
+
top-level-eval-hook
+
fx<
+
fx=
+
fx-
+
fx+
+
*mode*
+
noexpand)
+
((top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(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"))
+
#(ribcage
+
(define-structure
+
and-map*)
+
((top)
+
(top))
+
("i"
+
"i")))
+
(hygiene
+
guile)))))
+ #{rkey\ 1179}#)))
+ #{tmp\ 1187}#))
+ (symbol->keyword
+ (syntax->datum #{a\ 1185}#))))
+ #{tmp\ 1182}#)
+ ((lambda (#{tmp\ 1189}#)
+ (if (if #{tmp\ 1189}#
+ (apply (lambda (#{a\ 1190}#
+ #{init\ 1191}#
+ #{b\ 1192}#)
+ (symbol?
+ (syntax->datum
+ #{a\ 1190}#)))
+ #{tmp\ 1189}#)
+ #f)
+ (apply (lambda (#{a\ 1193}#
+ #{init\ 1194}#
+ #{b\ 1195}#)
+ ((lambda (#{tmp\ 1196}#)
+ ((lambda (#{k\ 1197}#)
+ (#{key\ 1087}#
+ #{b\ 1195}#
+ #{req\ 1177}#
+ #{opt\ 1178}#
+ (cons (list #{k\
1197}#
+ #{a\
1193}#
+ #{init\
1194}#)
+ #{rkey\
1179}#)))
+ #{tmp\ 1196}#))
+ (symbol->keyword
+ (syntax->datum
+ #{a\ 1193}#))))
+ #{tmp\ 1189}#)
+ ((lambda (#{tmp\ 1198}#)
+ (if (if #{tmp\ 1198}#
+ (apply (lambda (#{a\ 1199}#
+ #{init\
1200}#
+ #{k\ 1201}#
+ #{b\ 1202}#)
+ (if (symbol?
+ (syntax->datum
+ #{a\
1199}#))
+ (keyword?
+ (syntax->datum
+ #{k\ 1201}#))
+ #f))
+ #{tmp\ 1198}#)
+ #f)
+ (apply (lambda (#{a\ 1203}#
+ #{init\ 1204}#
+ #{k\ 1205}#
+ #{b\ 1206}#)
+ (#{key\ 1087}#
+ #{b\ 1206}#
+ #{req\ 1177}#
+ #{opt\ 1178}#
+ (cons (list #{k\
1205}#
+ #{a\
1203}#
+ #{init\
1204}#)
+ #{rkey\
1179}#)))
+ #{tmp\ 1198}#)
+ ((lambda (#{tmp\ 1207}#)
+ (if (if #{tmp\ 1207}#
+ (apply (lambda (#{aok\
1208}#)
+ (eq?
(syntax->datum
+ #{aok\
1208}#)
+
#:allow-other-keys))
+ #{tmp\ 1207}#)
+ #f)
+ (apply (lambda (#{aok\
1209}#)
+ (values
+ #{req\ 1177}#
+ #{opt\ 1178}#
+ #f
+ (cons #t
+ (reverse
+ #{rkey\
1179}#))))
+ #{tmp\ 1207}#)
+ ((lambda (#{tmp\ 1210}#)
+ (if (if #{tmp\ 1210}#
+ (apply (lambda
(#{aok\ 1211}#
+
#{a\ 1212}#
+
#{b\ 1213}#)
+ (if (eq?
(syntax->datum
+
#{aok\ 1211}#)
+
#:allow-other-keys)
+ (eq?
(syntax->datum
+
#{a\ 1212}#)
+
#:rest)
+ #f))
+ #{tmp\
1210}#)
+ #f)
+ (apply (lambda (#{aok\
1214}#
+ #{a\
1215}#
+ #{b\
1216}#)
+ (#{rest\
1088}#
+ #{b\ 1216}#
+ #{req\
1177}#
+ #{opt\
1178}#
+ (cons #t
+
(reverse
+
#{rkey\ 1179}#))))
+ #{tmp\ 1210}#)
+ ((lambda (#{tmp\
1217}#)
+ (if (if #{tmp\
1217}#
+ (apply
(lambda (#{aok\ 1218}#
+
#{r\ 1219}#)
+ (if
(eq? (syntax->datum
+
#{aok\ 1218}#)
+
#:allow-other-keys)
+
(symbol?
+
(syntax->datum
+
#{r\ 1219}#))
+
#f))
+ #{tmp\
1217}#)
+ #f)
+ (apply (lambda
(#{aok\ 1220}#
+
#{r\ 1221}#)
+ (#{rest\
1088}#
+ #{r\
1221}#
+ #{req\
1177}#
+ #{opt\
1178}#
+ (cons
#t
+
(reverse
+
#{rkey\ 1179}#))))
+ #{tmp\
1217}#)
+ ((lambda (#{tmp\
1222}#)
+ (if (if #{tmp\
1222}#
+ (apply
(lambda (#{a\ 1223}#
+
#{b\ 1224}#)
+
(eq? (syntax->datum
+
#{a\ 1223}#)
+
#:rest))
+
#{tmp\ 1222}#)
+ #f)
+ (apply
(lambda (#{a\ 1225}#
+
#{b\ 1226}#)
+
(#{rest\ 1088}#
+
#{b\ 1226}#
+
#{req\ 1177}#
+
#{opt\ 1178}#
+
(cons #f
+
(reverse
+
#{rkey\ 1179}#))))
+
#{tmp\ 1222}#)
+ ((lambda
(#{tmp\ 1227}#)
+ (if (if
#{tmp\ 1227}#
+
(apply (lambda (#{r\ 1228}#)
+
(symbol?
+
(syntax->datum
+
'#(syntax-object
+
a
+
((top)
+
#(ribcage
+
#(r)
+
#((top))
+
#("i"))
+
#(ribcage
+
()
+
()
+
())
+
#(ribcage
+
#(args
+
req
+
opt
+
rkey)
+
#((top)
+
(top)
+
(top)
+
(top))
+
#("i"
+
"i"
+
"i"
+
"i"))
+
#(ribcage
+
(expand-body
+
expand-kw
+
expand-opt
+
expand-req
+
rest
+
key
+
opt
+
req)
+
((top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top))
+
("i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"))
+
#(ribcage
+
#(e
+
r
+
w
+
s
+
mod)
+
#((top)
+
(top)
+
(top)
+
(top)
+
(top))
+
#("i"
+
"i"
+
"i"
+
"i"
+
"i"))
+
#(ribcage
+
(lambda-var-list
+
gen-var
+
strip
+
ellipsis?
+
chi-void
+
eval-local-transformer
+
chi-local-syntax
+
chi-body
+
chi-macro
+
chi-application
+
chi-expr
+
chi
+
chi-top
+
syntax-type
+
chi-when-list
+
chi-install-global
+
chi-top-sequence
+
chi-sequence
+
source-wrap
+
wrap
+
bound-id-member?
+
distinct-bound-ids?
+
valid-bound-ids?
+
bound-id=?
+
free-id=?
+
id-var-name
+
same-marks?
+
join-marks
+
join-wraps
+
smart-append
+
make-binding-wrap
+
extend-ribcage!
+
make-empty-ribcage
+
new-mark
+
anti-mark
+
the-anti-mark
+
top-marked?
+
top-wrap
+
empty-wrap
+
set-ribcage-labels!
+
set-ribcage-marks!
+
set-ribcage-symnames!
+
ribcage-labels
+
ribcage-marks
+
ribcage-symnames
+
ribcage?
+
make-ribcage
+
gen-labels
+
gen-label
+
make-rename
+
rename-marks
+
rename-new
+
rename-old
+
subst-rename?
+
wrap-subst
+
wrap-marks
+
make-wrap
+
id-sym-name&marks
+
id-sym-name
+
id?
+
nonsymbol-id?
+
global-extend
+
lookup
+
macros-only-env
+
extend-var-env
+
extend-env
+
null-env
+
binding-value
+
binding-type
+
make-binding
+
arg-check
+
source-annotation
+
no-source
+
set-syntax-object-module!
+
set-syntax-object-wrap!
+
set-syntax-object-expression!
+
syntax-object-module
+
syntax-object-wrap
+
syntax-object-expression
+
syntax-object?
+
make-syntax-object
+
build-lexical-var
+
build-letrec
+
build-named-let
+
build-let
+
build-sequence
+
build-data
+
build-primref
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
+
build-global-definition
+
maybe-name-value!
+
build-global-assignment
+
build-global-reference
+
analyze-variable
+
build-lexical-assignment
+
build-lexical-reference
+
build-conditional
+
build-application
+
build-void
+
decorate-source
+
get-global-definition-hook
+
put-global-definition-hook
+
gensym-hook
+
local-eval-hook
+
top-level-eval-hook
+
fx<
+
fx=
+
fx-
+
fx+
+
*mode*
+
noexpand)
+
((top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(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"))
+
#(ribcage
+
(define-structure
+
and-map*)
+
((top)
+
(top))
+
("i"
+
"i")))
+
(hygiene
+
guile)))))
+
#{tmp\ 1227}#)
+ #f)
+ (apply
(lambda (#{r\ 1229}#)
+
(#{rest\ 1088}#
+
#{r\ 1229}#
+
#{req\ 1177}#
+
#{opt\ 1178}#
+
(cons #f
+
(reverse
+
#{rkey\ 1179}#))))
+
#{tmp\ 1227}#)
+
((lambda (#{else\ 1230}#)
+
(syntax-violation
+
'lambda*
+
"invalid argument list"
+
#{e\ 1080}#
+
#{args\ 1176}#))
+ #{tmp\
1180}#)))
+ (list
#{tmp\ 1180}#))))
+ ($sc-dispatch
+ #{tmp\ 1180}#
+ '(any any)))))
+ ($sc-dispatch
+ #{tmp\ 1180}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 1180}#
+ '(any any any)))))
+ ($sc-dispatch
+ #{tmp\ 1180}#
+ '(any)))))
+ ($sc-dispatch
+ #{tmp\ 1180}#
+ '((any any any) . any)))))
+ ($sc-dispatch
+ #{tmp\ 1180}#
+ '((any any) . any)))))
+ ($sc-dispatch
+ #{tmp\ 1180}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 1180}# (quote ()))))
+ #{args\ 1176}#)))
+ (#{opt\ 1086}#
+ (lambda (#{args\ 1231}# #{req\ 1232}# #{ropt\ 1233}#)
+ ((lambda (#{tmp\ 1234}#)
+ ((lambda (#{tmp\ 1235}#)
+ (if #{tmp\ 1235}#
+ (apply (lambda ()
+ (values
+ #{req\ 1232}#
+ (reverse #{ropt\ 1233}#)
+ #f
+ '()))
+ #{tmp\ 1235}#)
+ ((lambda (#{tmp\ 1236}#)
+ (if (if #{tmp\ 1236}#
+ (apply (lambda (#{a\ 1237}#
+ #{b\ 1238}#)
+ (symbol?
+ (syntax->datum
+ #{a\ 1237}#)))
+ #{tmp\ 1236}#)
+ #f)
+ (apply (lambda (#{a\ 1239}# #{b\ 1240}#)
+ (#{opt\ 1086}#
+ #{b\ 1240}#
+ #{req\ 1232}#
+ (cons (cons #{a\ 1239}#
+ '(#(syntax-object
+ #f
+ ((top)
+ #(ribcage
+ #(a b)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(args
+ req
+ ropt)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ (expand-body
+ expand-kw
+ expand-opt
+ expand-req
+ rest
+ key
+ opt
+ req)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ mod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+
(lambda-var-list
+ gen-var
+ strip
+ ellipsis?
+ chi-void
+
eval-local-transformer
+
chi-local-syntax
+ chi-body
+ chi-macro
+
chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+
chi-when-list
+
chi-install-global
+
chi-top-sequence
+
chi-sequence
+ source-wrap
+ wrap
+
bound-id-member?
+
distinct-bound-ids?
+
valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+
smart-append
+
make-binding-wrap
+
extend-ribcage!
+
make-empty-ribcage
+ new-mark
+ anti-mark
+
the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+
set-ribcage-labels!
+
set-ribcage-marks!
+
set-ribcage-symnames!
+
ribcage-labels
+
ribcage-marks
+
ribcage-symnames
+ ribcage?
+
make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+
rename-marks
+ rename-new
+ rename-old
+
subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+
id-sym-name&marks
+ id-sym-name
+ id?
+
nonsymbol-id?
+
global-extend
+ lookup
+
macros-only-env
+
extend-var-env
+ extend-env
+ null-env
+
binding-value
+
binding-type
+
make-binding
+ arg-check
+
source-annotation
+ no-source
+
set-syntax-object-module!
+
set-syntax-object-wrap!
+
set-syntax-object-expression!
+
syntax-object-module
+
syntax-object-wrap
+
syntax-object-expression
+
syntax-object?
+
make-syntax-object
+
build-lexical-var
+
build-letrec
+
build-named-let
+ build-let
+
build-sequence
+ build-data
+
build-primref
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
+
build-global-definition
+
maybe-name-value!
+
build-global-assignment
+
build-global-reference
+
analyze-variable
+
build-lexical-assignment
+
build-lexical-reference
+
build-conditional
+
build-application
+ build-void
+
decorate-source
+
get-global-definition-hook
+
put-global-definition-hook
+ gensym-hook
+
local-eval-hook
+
top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (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"))
+ #(ribcage
+
(define-structure
+ and-map*)
+ ((top) (top))
+ ("i" "i")))
+ (hygiene
+ guile))))
+ #{ropt\ 1233}#)))
+ #{tmp\ 1236}#)
+ ((lambda (#{tmp\ 1241}#)
+ (if (if #{tmp\ 1241}#
+ (apply (lambda (#{a\ 1242}#
+ #{init\ 1243}#
+ #{b\ 1244}#)
+ (symbol?
+ (syntax->datum
+ #{a\ 1242}#)))
+ #{tmp\ 1241}#)
+ #f)
+ (apply (lambda (#{a\ 1245}#
+ #{init\ 1246}#
+ #{b\ 1247}#)
+ (#{opt\ 1086}#
+ #{b\ 1247}#
+ #{req\ 1232}#
+ (cons (list #{a\ 1245}#
+ #{init\ 1246}#)
+ #{ropt\ 1233}#)))
+ #{tmp\ 1241}#)
+ ((lambda (#{tmp\ 1248}#)
+ (if (if #{tmp\ 1248}#
+ (apply (lambda (#{a\ 1249}#
+ #{b\ 1250}#)
+ (eq? (syntax->datum
+ #{a\ 1249}#)
+ #:key))
+ #{tmp\ 1248}#)
+ #f)
+ (apply (lambda (#{a\ 1251}#
+ #{b\ 1252}#)
+ (#{key\ 1087}#
+ #{b\ 1252}#
+ #{req\ 1232}#
+ (reverse
+ #{ropt\ 1233}#)
+ '()))
+ #{tmp\ 1248}#)
+ ((lambda (#{tmp\ 1253}#)
+ (if (if #{tmp\ 1253}#
+ (apply (lambda (#{a\
1254}#
+ #{b\
1255}#)
+ (eq?
(syntax->datum
+ #{a\
1254}#)
+ #:rest))
+ #{tmp\ 1253}#)
+ #f)
+ (apply (lambda (#{a\ 1256}#
+ #{b\ 1257}#)
+ (#{rest\ 1088}#
+ #{b\ 1257}#
+ #{req\ 1232}#
+ (reverse
+ #{ropt\ 1233}#)
+ '()))
+ #{tmp\ 1253}#)
+ ((lambda (#{tmp\ 1258}#)
+ (if (if #{tmp\ 1258}#
+ (apply (lambda
(#{r\ 1259}#)
+ (symbol?
+
(syntax->datum
+
'#(syntax-object
+ a
+
((top)
+
#(ribcage
+
#(r)
+
#((top))
+
#("i"))
+
#(ribcage
+
()
+
()
+
())
+
#(ribcage
+
#(args
+
req
+
ropt)
+
#((top)
+
(top)
+
(top))
+
#("i"
+
"i"
+
"i"))
+
#(ribcage
+
(expand-body
+
expand-kw
+
expand-opt
+
expand-req
+
rest
+
key
+
opt
+
req)
+
((top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top))
+
("i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"))
+
#(ribcage
+
#(e
+
r
+
w
+
s
+
mod)
+
#((top)
+
(top)
+
(top)
+
(top)
+
(top))
+
#("i"
+
"i"
+
"i"
+
"i"
+
"i"))
+
#(ribcage
+
(lambda-var-list
+
gen-var
+
strip
+
ellipsis?
+
chi-void
+
eval-local-transformer
+
chi-local-syntax
+
chi-body
+
chi-macro
+
chi-application
+
chi-expr
+
chi
+
chi-top
+
syntax-type
+
chi-when-list
+
chi-install-global
+
chi-top-sequence
+
chi-sequence
+
source-wrap
+
wrap
+
bound-id-member?
+
distinct-bound-ids?
+
valid-bound-ids?
+
bound-id=?
+
free-id=?
+
id-var-name
+
same-marks?
+
join-marks
+
join-wraps
+
smart-append
+
make-binding-wrap
+
extend-ribcage!
+
make-empty-ribcage
+
new-mark
+
anti-mark
+
the-anti-mark
+
top-marked?
+
top-wrap
+
empty-wrap
+
set-ribcage-labels!
+
set-ribcage-marks!
+
set-ribcage-symnames!
+
ribcage-labels
+
ribcage-marks
+
ribcage-symnames
+
ribcage?
+
make-ribcage
+
gen-labels
+
gen-label
+
make-rename
+
rename-marks
+
rename-new
+
rename-old
+
subst-rename?
+
wrap-subst
+
wrap-marks
+
make-wrap
+
id-sym-name&marks
+
id-sym-name
+
id?
+
nonsymbol-id?
+
global-extend
+
lookup
+
macros-only-env
+
extend-var-env
+
extend-env
+
null-env
+
binding-value
+
binding-type
+
make-binding
+
arg-check
+
source-annotation
+
no-source
+
set-syntax-object-module!
+
set-syntax-object-wrap!
+
set-syntax-object-expression!
+
syntax-object-module
+
syntax-object-wrap
+
syntax-object-expression
+
syntax-object?
+
make-syntax-object
+
build-lexical-var
+
build-letrec
+
build-named-let
+
build-let
+
build-sequence
+
build-data
+
build-primref
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
+
build-global-definition
+
maybe-name-value!
+
build-global-assignment
+
build-global-reference
+
analyze-variable
+
build-lexical-assignment
+
build-lexical-reference
+
build-conditional
+
build-application
+
build-void
+
decorate-source
+
get-global-definition-hook
+
put-global-definition-hook
+
gensym-hook
+
local-eval-hook
+
top-level-eval-hook
+
fx<
+
fx=
+
fx-
+
fx+
+
*mode*
+
noexpand)
+
((top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(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"))
+
#(ribcage
+
(define-structure
+
and-map*)
+
((top)
+
(top))
+
("i"
+
"i")))
+
(hygiene
+
guile)))))
+ #{tmp\
1258}#)
+ #f)
+ (apply (lambda (#{r\
1260}#)
+ (#{rest\
1088}#
+ #{r\ 1260}#
+ #{req\
1232}#
+ (reverse
+ #{ropt\
1233}#)
+ '()))
+ #{tmp\ 1258}#)
+ ((lambda (#{else\
1261}#)
+ (syntax-violation
+ 'lambda*
+ "invalid argument
list"
+ #{e\ 1080}#
+ #{args\ 1231}#))
+ #{tmp\ 1234}#)))
+ (list #{tmp\ 1234}#))))
+ ($sc-dispatch
+ #{tmp\ 1234}#
+ '(any any)))))
+ ($sc-dispatch
+ #{tmp\ 1234}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 1234}#
+ '((any any) . any)))))
+ ($sc-dispatch
+ #{tmp\ 1234}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 1234}# (quote ()))))
+ #{args\ 1231}#)))
+ (#{req\ 1085}#
+ (lambda (#{args\ 1262}# #{rreq\ 1263}#)
+ ((lambda (#{tmp\ 1264}#)
+ ((lambda (#{tmp\ 1265}#)
+ (if #{tmp\ 1265}#
+ (apply (lambda ()
+ (values
+ (reverse #{rreq\ 1263}#)
+ '()
+ #f
+ '()))
+ #{tmp\ 1265}#)
+ ((lambda (#{tmp\ 1266}#)
+ (if (if #{tmp\ 1266}#
+ (apply (lambda (#{a\ 1267}#
+ #{b\ 1268}#)
+ (symbol?
+ (syntax->datum
+ #{a\ 1267}#)))
+ #{tmp\ 1266}#)
+ #f)
+ (apply (lambda (#{a\ 1269}# #{b\ 1270}#)
+ (#{req\ 1085}#
+ #{b\ 1270}#
+ (cons #{a\ 1269}#
+ #{rreq\ 1263}#)))
+ #{tmp\ 1266}#)
+ ((lambda (#{tmp\ 1271}#)
+ (if (if #{tmp\ 1271}#
+ (apply (lambda (#{a\ 1272}#
+ #{b\ 1273}#)
+ (eq? (syntax->datum
+ #{a\ 1272}#)
+ #:optional))
+ #{tmp\ 1271}#)
+ #f)
+ (apply (lambda (#{a\ 1274}#
+ #{b\ 1275}#)
+ (#{opt\ 1086}#
+ #{b\ 1275}#
+ (reverse #{rreq\ 1263}#)
+ '()))
+ #{tmp\ 1271}#)
+ ((lambda (#{tmp\ 1276}#)
+ (if (if #{tmp\ 1276}#
+ (apply (lambda (#{a\ 1277}#
+ #{b\ 1278}#)
+ (eq? (syntax->datum
+ #{a\ 1277}#)
+ #:key))
+ #{tmp\ 1276}#)
+ #f)
+ (apply (lambda (#{a\ 1279}#
+ #{b\ 1280}#)
+ (#{key\ 1087}#
+ #{b\ 1280}#
+ (reverse
+ #{rreq\ 1263}#)
+ '()
+ '()))
+ #{tmp\ 1276}#)
+ ((lambda (#{tmp\ 1281}#)
+ (if (if #{tmp\ 1281}#
+ (apply (lambda (#{a\
1282}#
+ #{b\
1283}#)
+ (eq?
(syntax->datum
+ #{a\
1282}#)
+ #:rest))
+ #{tmp\ 1281}#)
+ #f)
+ (apply (lambda (#{a\ 1284}#
+ #{b\ 1285}#)
+ (#{rest\ 1088}#
+ #{b\ 1285}#
+ (reverse
+ #{rreq\ 1263}#)
+ '()
+ '()))
+ #{tmp\ 1281}#)
+ ((lambda (#{tmp\ 1286}#)
+ (if (if #{tmp\ 1286}#
+ (apply (lambda
(#{r\ 1287}#)
+ (symbol?
+
(syntax->datum
+
'#(syntax-object
+ a
+
((top)
+
#(ribcage
+
#(r)
+
#((top))
+
#("i"))
+
#(ribcage
+
()
+
()
+
())
+
#(ribcage
+
#(args
+
rreq)
+
#((top)
+
(top))
+
#("i"
+
"i"))
+
#(ribcage
+
(expand-body
+
expand-kw
+
expand-opt
+
expand-req
+
rest
+
key
+
opt
+
req)
+
((top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top))
+
("i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"
+
"i"))
+
#(ribcage
+
#(e
+
r
+
w
+
s
+
mod)
+
#((top)
+
(top)
+
(top)
+
(top)
+
(top))
+
#("i"
+
"i"
+
"i"
+
"i"
+
"i"))
+
#(ribcage
+
(lambda-var-list
+
gen-var
+
strip
+
ellipsis?
+
chi-void
+
eval-local-transformer
+
chi-local-syntax
+
chi-body
+
chi-macro
+
chi-application
+
chi-expr
+
chi
+
chi-top
+
syntax-type
+
chi-when-list
+
chi-install-global
+
chi-top-sequence
+
chi-sequence
+
source-wrap
+
wrap
+
bound-id-member?
+
distinct-bound-ids?
+
valid-bound-ids?
+
bound-id=?
+
free-id=?
+
id-var-name
+
same-marks?
+
join-marks
+
join-wraps
+
smart-append
+
make-binding-wrap
+
extend-ribcage!
+
make-empty-ribcage
+
new-mark
+
anti-mark
+
the-anti-mark
+
top-marked?
+
top-wrap
+
empty-wrap
+
set-ribcage-labels!
+
set-ribcage-marks!
+
set-ribcage-symnames!
+
ribcage-labels
+
ribcage-marks
+
ribcage-symnames
+
ribcage?
+
make-ribcage
+
gen-labels
+
gen-label
+
make-rename
+
rename-marks
+
rename-new
+
rename-old
+
subst-rename?
+
wrap-subst
+
wrap-marks
+
make-wrap
+
id-sym-name&marks
+
id-sym-name
+
id?
+
nonsymbol-id?
+
global-extend
+
lookup
+
macros-only-env
+
extend-var-env
+
extend-env
+
null-env
+
binding-value
+
binding-type
+
make-binding
+
arg-check
+
source-annotation
+
no-source
+
set-syntax-object-module!
+
set-syntax-object-wrap!
+
set-syntax-object-expression!
+
syntax-object-module
+
syntax-object-wrap
+
syntax-object-expression
+
syntax-object?
+
make-syntax-object
+
build-lexical-var
+
build-letrec
+
build-named-let
+
build-let
+
build-sequence
+
build-data
+
build-primref
+
build-lambda-case
+
build-case-lambda
+
build-simple-lambda
+
build-global-definition
+
maybe-name-value!
+
build-global-assignment
+
build-global-reference
+
analyze-variable
+
build-lexical-assignment
+
build-lexical-reference
+
build-conditional
+
build-application
+
build-void
+
decorate-source
+
get-global-definition-hook
+
put-global-definition-hook
+
gensym-hook
+
local-eval-hook
+
top-level-eval-hook
+
fx<
+
fx=
+
fx-
+
fx+
+
*mode*
+
noexpand)
+
((top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(top)
+
(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"))
+
#(ribcage
+
(define-structure
+
and-map*)
+
((top)
+
(top))
+
("i"
+
"i")))
+
(hygiene
+
guile)))))
+ #{tmp\
1286}#)
+ #f)
+ (apply (lambda (#{r\
1288}#)
+ (#{rest\
1088}#
+ #{r\ 1288}#
+ (reverse
+ #{rreq\
1263}#)
+ '()
+ '()))
+ #{tmp\ 1286}#)
+ ((lambda (#{else\
1289}#)
+ (syntax-violation
+ 'lambda*
+ "invalid argument
list"
+ #{e\ 1080}#
+ #{args\ 1262}#))
+ #{tmp\ 1264}#)))
+ (list #{tmp\ 1264}#))))
+ ($sc-dispatch
+ #{tmp\ 1264}#
+ '(any any)))))
+ ($sc-dispatch
+ #{tmp\ 1264}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 1264}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 1264}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 1264}# (quote ()))))
+ #{args\ 1262}#))))
+ ((lambda (#{tmp\ 1290}#)
+ ((lambda (#{tmp\ 1291}#)
+ (if #{tmp\ 1291}#
+ (apply (lambda (#{_\ 1292}#
+ #{args\ 1293}#
+ #{e1\ 1294}#
+ #{e2\ 1295}#)
+ (call-with-values
+ (lambda ()
+ (#{req\ 1085}# #{args\ 1293}# (quote ())))
+ (lambda (#{req\ 1296}#
+ #{opt\ 1297}#
+ #{rest\ 1298}#
+ #{kw\ 1299}#)
+ (if (not (#{valid-bound-ids?\ 156}#
+ (append
+ #{req\ 1296}#
+ (map car #{opt\ 1297}#)
+ (if #{rest\ 1298}#
+ (list #{rest\ 1298}#)
+ '())
+ (if (pair? #{kw\ 1299}#)
+ (map cadr (cdr #{kw\ 1299}#))
+ '()))))
+ (syntax-violation
+ 'lambda
+ "invalid parameter list"
+ #{e\ 1080}#
+ #{args\ 1293}#)
+ (call-with-values
+ (lambda ()
+ (#{expand-req\ 1089}#
+ #{req\ 1296}#
+ #{opt\ 1297}#
+ #{rest\ 1298}#
+ #{kw\ 1299}#
+ (cons #{e1\ 1294}# #{e2\ 1295}#)))
+ (lambda (#{docstring\ 1301}#
+ #{req\ 1302}#
+ #{opt\ 1303}#
+ #{rest\ 1304}#
+ #{kw\ 1305}#
+ #{inits\ 1306}#
+ #{vars\ 1307}#
+ #{pred\ 1308}#
+ #{body\ 1309}#)
+ (#{build-case-lambda\ 106}#
+ #{s\ 1083}#
+ #{docstring\ 1301}#
+ (#{build-lambda-case\ 107}#
+ #{s\ 1083}#
+ #{req\ 1302}#
+ #{opt\ 1303}#
+ #{rest\ 1304}#
+ #{kw\ 1305}#
+ #{inits\ 1306}#
+ #{vars\ 1307}#
+ #{pred\ 1308}#
+ #{body\ 1309}#
+ #f))))))))
+ #{tmp\ 1291}#)
+ ((lambda (#{_\ 1310}#)
+ (syntax-violation
+ 'lambda
+ "bad lambda*"
+ #{e\ 1080}#))
+ #{tmp\ 1290}#)))
+ ($sc-dispatch
+ #{tmp\ 1290}#
+ '(any any any . each-any))))
+ #{e\ 1080}#))))
+ (#{global-extend\ 129}#
'core
'let
- (letrec ((#{chi-let\ 1057}#
- (lambda (#{e\ 1058}#
- #{r\ 1059}#
- #{w\ 1060}#
- #{s\ 1061}#
- #{mod\ 1062}#
- #{constructor\ 1063}#
- #{ids\ 1064}#
- #{vals\ 1065}#
- #{exps\ 1066}#)
- (if (not (#{valid-bound-ids?\ 154}# #{ids\ 1064}#))
+ (letrec ((#{chi-let\ 1311}#
+ (lambda (#{e\ 1312}#
+ #{r\ 1313}#
+ #{w\ 1314}#
+ #{s\ 1315}#
+ #{mod\ 1316}#
+ #{constructor\ 1317}#
+ #{ids\ 1318}#
+ #{vals\ 1319}#
+ #{exps\ 1320}#)
+ (if (not (#{valid-bound-ids?\ 156}# #{ids\ 1318}#))
(syntax-violation
'let
"duplicate bound variable"
- #{e\ 1058}#)
- (let ((#{labels\ 1067}#
- (#{gen-labels\ 135}# #{ids\ 1064}#))
- (#{new-vars\ 1068}#
- (map #{gen-var\ 176}# #{ids\ 1064}#)))
- (let ((#{nw\ 1069}#
- (#{make-binding-wrap\ 146}#
- #{ids\ 1064}#
- #{labels\ 1067}#
- #{w\ 1060}#))
- (#{nr\ 1070}#
- (#{extend-var-env\ 124}#
- #{labels\ 1067}#
- #{new-vars\ 1068}#
- #{r\ 1059}#)))
- (#{constructor\ 1063}#
- #{s\ 1061}#
- (map syntax->datum #{ids\ 1064}#)
- #{new-vars\ 1068}#
- (map (lambda (#{x\ 1071}#)
- (#{chi\ 165}#
- #{x\ 1071}#
- #{r\ 1059}#
- #{w\ 1060}#
- #{mod\ 1062}#))
- #{vals\ 1065}#)
- (#{chi-body\ 169}#
- #{exps\ 1066}#
- (#{source-wrap\ 158}#
- #{e\ 1058}#
- #{nw\ 1069}#
- #{s\ 1061}#
- #{mod\ 1062}#)
- #{nr\ 1070}#
- #{nw\ 1069}#
- #{mod\ 1062}#))))))))
- (lambda (#{e\ 1072}#
- #{r\ 1073}#
- #{w\ 1074}#
- #{s\ 1075}#
- #{mod\ 1076}#)
- ((lambda (#{tmp\ 1077}#)
- ((lambda (#{tmp\ 1078}#)
- (if (if #{tmp\ 1078}#
- (apply (lambda (#{_\ 1079}#
- #{id\ 1080}#
- #{val\ 1081}#
- #{e1\ 1082}#
- #{e2\ 1083}#)
- (and-map #{id?\ 129}# #{id\ 1080}#))
- #{tmp\ 1078}#)
+ #{e\ 1312}#)
+ (let ((#{labels\ 1321}#
+ (#{gen-labels\ 137}# #{ids\ 1318}#))
+ (#{new-vars\ 1322}#
+ (map #{gen-var\ 177}# #{ids\ 1318}#)))
+ (let ((#{nw\ 1323}#
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 1318}#
+ #{labels\ 1321}#
+ #{w\ 1314}#))
+ (#{nr\ 1324}#
+ (#{extend-var-env\ 126}#
+ #{labels\ 1321}#
+ #{new-vars\ 1322}#
+ #{r\ 1313}#)))
+ (#{constructor\ 1317}#
+ #{s\ 1315}#
+ (map syntax->datum #{ids\ 1318}#)
+ #{new-vars\ 1322}#
+ (map (lambda (#{x\ 1325}#)
+ (#{chi\ 167}#
+ #{x\ 1325}#
+ #{r\ 1313}#
+ #{w\ 1314}#
+ #{mod\ 1316}#))
+ #{vals\ 1319}#)
+ (#{chi-body\ 171}#
+ #{exps\ 1320}#
+ (#{source-wrap\ 160}#
+ #{e\ 1312}#
+ #{nw\ 1323}#
+ #{s\ 1315}#
+ #{mod\ 1316}#)
+ #{nr\ 1324}#
+ #{nw\ 1323}#
+ #{mod\ 1316}#))))))))
+ (lambda (#{e\ 1326}#
+ #{r\ 1327}#
+ #{w\ 1328}#
+ #{s\ 1329}#
+ #{mod\ 1330}#)
+ ((lambda (#{tmp\ 1331}#)
+ ((lambda (#{tmp\ 1332}#)
+ (if (if #{tmp\ 1332}#
+ (apply (lambda (#{_\ 1333}#
+ #{id\ 1334}#
+ #{val\ 1335}#
+ #{e1\ 1336}#
+ #{e2\ 1337}#)
+ (and-map #{id?\ 131}# #{id\ 1334}#))
+ #{tmp\ 1332}#)
#f)
- (apply (lambda (#{_\ 1085}#
- #{id\ 1086}#
- #{val\ 1087}#
- #{e1\ 1088}#
- #{e2\ 1089}#)
- (#{chi-let\ 1057}#
- #{e\ 1072}#
- #{r\ 1073}#
- #{w\ 1074}#
- #{s\ 1075}#
- #{mod\ 1076}#
- #{build-let\ 109}#
- #{id\ 1086}#
- #{val\ 1087}#
- (cons #{e1\ 1088}# #{e2\ 1089}#)))
- #{tmp\ 1078}#)
- ((lambda (#{tmp\ 1093}#)
- (if (if #{tmp\ 1093}#
- (apply (lambda (#{_\ 1094}#
- #{f\ 1095}#
- #{id\ 1096}#
- #{val\ 1097}#
- #{e1\ 1098}#
- #{e2\ 1099}#)
- (if (#{id?\ 129}# #{f\ 1095}#)
- (and-map #{id?\ 129}# #{id\ 1096}#)
+ (apply (lambda (#{_\ 1339}#
+ #{id\ 1340}#
+ #{val\ 1341}#
+ #{e1\ 1342}#
+ #{e2\ 1343}#)
+ (#{chi-let\ 1311}#
+ #{e\ 1326}#
+ #{r\ 1327}#
+ #{w\ 1328}#
+ #{s\ 1329}#
+ #{mod\ 1330}#
+ #{build-let\ 111}#
+ #{id\ 1340}#
+ #{val\ 1341}#
+ (cons #{e1\ 1342}# #{e2\ 1343}#)))
+ #{tmp\ 1332}#)
+ ((lambda (#{tmp\ 1347}#)
+ (if (if #{tmp\ 1347}#
+ (apply (lambda (#{_\ 1348}#
+ #{f\ 1349}#
+ #{id\ 1350}#
+ #{val\ 1351}#
+ #{e1\ 1352}#
+ #{e2\ 1353}#)
+ (if (#{id?\ 131}# #{f\ 1349}#)
+ (and-map #{id?\ 131}# #{id\ 1350}#)
#f))
- #{tmp\ 1093}#)
+ #{tmp\ 1347}#)
#f)
- (apply (lambda (#{_\ 1101}#
- #{f\ 1102}#
- #{id\ 1103}#
- #{val\ 1104}#
- #{e1\ 1105}#
- #{e2\ 1106}#)
- (#{chi-let\ 1057}#
- #{e\ 1072}#
- #{r\ 1073}#
- #{w\ 1074}#
- #{s\ 1075}#
- #{mod\ 1076}#
- #{build-named-let\ 110}#
- (cons #{f\ 1102}# #{id\ 1103}#)
- #{val\ 1104}#
- (cons #{e1\ 1105}# #{e2\ 1106}#)))
- #{tmp\ 1093}#)
- ((lambda (#{_\ 1110}#)
+ (apply (lambda (#{_\ 1355}#
+ #{f\ 1356}#
+ #{id\ 1357}#
+ #{val\ 1358}#
+ #{e1\ 1359}#
+ #{e2\ 1360}#)
+ (#{chi-let\ 1311}#
+ #{e\ 1326}#
+ #{r\ 1327}#
+ #{w\ 1328}#
+ #{s\ 1329}#
+ #{mod\ 1330}#
+ #{build-named-let\ 112}#
+ (cons #{f\ 1356}# #{id\ 1357}#)
+ #{val\ 1358}#
+ (cons #{e1\ 1359}# #{e2\ 1360}#)))
+ #{tmp\ 1347}#)
+ ((lambda (#{_\ 1364}#)
(syntax-violation
'let
"bad let"
- (#{source-wrap\ 158}#
- #{e\ 1072}#
- #{w\ 1074}#
- #{s\ 1075}#
- #{mod\ 1076}#)))
- #{tmp\ 1077}#)))
+ (#{source-wrap\ 160}#
+ #{e\ 1326}#
+ #{w\ 1328}#
+ #{s\ 1329}#
+ #{mod\ 1330}#)))
+ #{tmp\ 1331}#)))
($sc-dispatch
- #{tmp\ 1077}#
+ #{tmp\ 1331}#
'(any any #(each (any any)) any . each-any)))))
($sc-dispatch
- #{tmp\ 1077}#
+ #{tmp\ 1331}#
'(any #(each (any any)) any . each-any))))
- #{e\ 1072}#))))
- (#{global-extend\ 127}#
+ #{e\ 1326}#))))
+ (#{global-extend\ 129}#
'core
'letrec
- (lambda (#{e\ 1111}#
- #{r\ 1112}#
- #{w\ 1113}#
- #{s\ 1114}#
- #{mod\ 1115}#)
- ((lambda (#{tmp\ 1116}#)
- ((lambda (#{tmp\ 1117}#)
- (if (if #{tmp\ 1117}#
- (apply (lambda (#{_\ 1118}#
- #{id\ 1119}#
- #{val\ 1120}#
- #{e1\ 1121}#
- #{e2\ 1122}#)
- (and-map #{id?\ 129}# #{id\ 1119}#))
- #{tmp\ 1117}#)
+ (lambda (#{e\ 1365}#
+ #{r\ 1366}#
+ #{w\ 1367}#
+ #{s\ 1368}#
+ #{mod\ 1369}#)
+ ((lambda (#{tmp\ 1370}#)
+ ((lambda (#{tmp\ 1371}#)
+ (if (if #{tmp\ 1371}#
+ (apply (lambda (#{_\ 1372}#
+ #{id\ 1373}#
+ #{val\ 1374}#
+ #{e1\ 1375}#
+ #{e2\ 1376}#)
+ (and-map #{id?\ 131}# #{id\ 1373}#))
+ #{tmp\ 1371}#)
#f)
- (apply (lambda (#{_\ 1124}#
- #{id\ 1125}#
- #{val\ 1126}#
- #{e1\ 1127}#
- #{e2\ 1128}#)
- (let ((#{ids\ 1129}# #{id\ 1125}#))
- (if (not (#{valid-bound-ids?\ 154}#
- #{ids\ 1129}#))
+ (apply (lambda (#{_\ 1378}#
+ #{id\ 1379}#
+ #{val\ 1380}#
+ #{e1\ 1381}#
+ #{e2\ 1382}#)
+ (let ((#{ids\ 1383}# #{id\ 1379}#))
+ (if (not (#{valid-bound-ids?\ 156}#
+ #{ids\ 1383}#))
(syntax-violation
'letrec
"duplicate bound variable"
- #{e\ 1111}#)
- (let ((#{labels\ 1131}#
- (#{gen-labels\ 135}# #{ids\ 1129}#))
- (#{new-vars\ 1132}#
- (map #{gen-var\ 176}# #{ids\ 1129}#)))
- (let ((#{w\ 1133}#
- (#{make-binding-wrap\ 146}#
- #{ids\ 1129}#
- #{labels\ 1131}#
- #{w\ 1113}#))
- (#{r\ 1134}#
- (#{extend-var-env\ 124}#
- #{labels\ 1131}#
- #{new-vars\ 1132}#
- #{r\ 1112}#)))
- (#{build-letrec\ 111}#
- #{s\ 1114}#
- (map syntax->datum #{ids\ 1129}#)
- #{new-vars\ 1132}#
- (map (lambda (#{x\ 1135}#)
- (#{chi\ 165}#
- #{x\ 1135}#
- #{r\ 1134}#
- #{w\ 1133}#
- #{mod\ 1115}#))
- #{val\ 1126}#)
- (#{chi-body\ 169}#
- (cons #{e1\ 1127}# #{e2\ 1128}#)
- (#{source-wrap\ 158}#
- #{e\ 1111}#
- #{w\ 1133}#
- #{s\ 1114}#
- #{mod\ 1115}#)
- #{r\ 1134}#
- #{w\ 1133}#
- #{mod\ 1115}#)))))))
- #{tmp\ 1117}#)
- ((lambda (#{_\ 1138}#)
+ #{e\ 1365}#)
+ (let ((#{labels\ 1385}#
+ (#{gen-labels\ 137}# #{ids\ 1383}#))
+ (#{new-vars\ 1386}#
+ (map #{gen-var\ 177}# #{ids\ 1383}#)))
+ (let ((#{w\ 1387}#
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 1383}#
+ #{labels\ 1385}#
+ #{w\ 1367}#))
+ (#{r\ 1388}#
+ (#{extend-var-env\ 126}#
+ #{labels\ 1385}#
+ #{new-vars\ 1386}#
+ #{r\ 1366}#)))
+ (#{build-letrec\ 113}#
+ #{s\ 1368}#
+ (map syntax->datum #{ids\ 1383}#)
+ #{new-vars\ 1386}#
+ (map (lambda (#{x\ 1389}#)
+ (#{chi\ 167}#
+ #{x\ 1389}#
+ #{r\ 1388}#
+ #{w\ 1387}#
+ #{mod\ 1369}#))
+ #{val\ 1380}#)
+ (#{chi-body\ 171}#
+ (cons #{e1\ 1381}# #{e2\ 1382}#)
+ (#{source-wrap\ 160}#
+ #{e\ 1365}#
+ #{w\ 1387}#
+ #{s\ 1368}#
+ #{mod\ 1369}#)
+ #{r\ 1388}#
+ #{w\ 1387}#
+ #{mod\ 1369}#)))))))
+ #{tmp\ 1371}#)
+ ((lambda (#{_\ 1392}#)
(syntax-violation
'letrec
"bad letrec"
- (#{source-wrap\ 158}#
- #{e\ 1111}#
- #{w\ 1113}#
- #{s\ 1114}#
- #{mod\ 1115}#)))
- #{tmp\ 1116}#)))
+ (#{source-wrap\ 160}#
+ #{e\ 1365}#
+ #{w\ 1367}#
+ #{s\ 1368}#
+ #{mod\ 1369}#)))
+ #{tmp\ 1370}#)))
($sc-dispatch
- #{tmp\ 1116}#
+ #{tmp\ 1370}#
'(any #(each (any any)) any . each-any))))
- #{e\ 1111}#)))
- (#{global-extend\ 127}#
+ #{e\ 1365}#)))
+ (#{global-extend\ 129}#
'core
'set!
- (lambda (#{e\ 1139}#
- #{r\ 1140}#
- #{w\ 1141}#
- #{s\ 1142}#
- #{mod\ 1143}#)
- ((lambda (#{tmp\ 1144}#)
- ((lambda (#{tmp\ 1145}#)
- (if (if #{tmp\ 1145}#
- (apply (lambda (#{_\ 1146}# #{id\ 1147}# #{val\ 1148}#)
- (#{id?\ 129}# #{id\ 1147}#))
- #{tmp\ 1145}#)
+ (lambda (#{e\ 1393}#
+ #{r\ 1394}#
+ #{w\ 1395}#
+ #{s\ 1396}#
+ #{mod\ 1397}#)
+ ((lambda (#{tmp\ 1398}#)
+ ((lambda (#{tmp\ 1399}#)
+ (if (if #{tmp\ 1399}#
+ (apply (lambda (#{_\ 1400}# #{id\ 1401}# #{val\ 1402}#)
+ (#{id?\ 131}# #{id\ 1401}#))
+ #{tmp\ 1399}#)
#f)
- (apply (lambda (#{_\ 1149}# #{id\ 1150}# #{val\ 1151}#)
- (let ((#{val\ 1152}#
- (#{chi\ 165}#
- #{val\ 1151}#
- #{r\ 1140}#
- #{w\ 1141}#
- #{mod\ 1143}#))
- (#{n\ 1153}#
- (#{id-var-name\ 151}#
- #{id\ 1150}#
- #{w\ 1141}#)))
- (let ((#{b\ 1154}#
- (#{lookup\ 126}#
- #{n\ 1153}#
- #{r\ 1140}#
- #{mod\ 1143}#)))
- (let ((#{atom-key\ 1155}#
- (#{binding-type\ 121}# #{b\ 1154}#)))
- (if (memv #{atom-key\ 1155}#
+ (apply (lambda (#{_\ 1403}# #{id\ 1404}# #{val\ 1405}#)
+ (let ((#{val\ 1406}#
+ (#{chi\ 167}#
+ #{val\ 1405}#
+ #{r\ 1394}#
+ #{w\ 1395}#
+ #{mod\ 1397}#))
+ (#{n\ 1407}#
+ (#{id-var-name\ 153}#
+ #{id\ 1404}#
+ #{w\ 1395}#)))
+ (let ((#{b\ 1408}#
+ (#{lookup\ 128}#
+ #{n\ 1407}#
+ #{r\ 1394}#
+ #{mod\ 1397}#)))
+ (let ((#{atom-key\ 1409}#
+ (#{binding-type\ 123}# #{b\ 1408}#)))
+ (if (memv #{atom-key\ 1409}#
'(lexical))
(#{build-lexical-assignment\ 99}#
- #{s\ 1142}#
- (syntax->datum #{id\ 1150}#)
- (#{binding-value\ 122}# #{b\ 1154}#)
- #{val\ 1152}#)
- (if (memv #{atom-key\ 1155}#
+ #{s\ 1396}#
+ (syntax->datum #{id\ 1404}#)
+ (#{binding-value\ 124}# #{b\ 1408}#)
+ #{val\ 1406}#)
+ (if (memv #{atom-key\ 1409}#
'(global))
(#{build-global-assignment\ 102}#
- #{s\ 1142}#
- #{n\ 1153}#
- #{val\ 1152}#
- #{mod\ 1143}#)
- (if (memv #{atom-key\ 1155}#
+ #{s\ 1396}#
+ #{n\ 1407}#
+ #{val\ 1406}#
+ #{mod\ 1397}#)
+ (if (memv #{atom-key\ 1409}#
'(displaced-lexical))
(syntax-violation
'set!
"identifier out of context"
- (#{wrap\ 157}#
- #{id\ 1150}#
- #{w\ 1141}#
- #{mod\ 1143}#))
+ (#{wrap\ 159}#
+ #{id\ 1404}#
+ #{w\ 1395}#
+ #{mod\ 1397}#))
(syntax-violation
'set!
"bad set!"
- (#{source-wrap\ 158}#
- #{e\ 1139}#
- #{w\ 1141}#
- #{s\ 1142}#
- #{mod\ 1143}#)))))))))
- #{tmp\ 1145}#)
- ((lambda (#{tmp\ 1156}#)
- (if #{tmp\ 1156}#
- (apply (lambda (#{_\ 1157}#
- #{head\ 1158}#
- #{tail\ 1159}#
- #{val\ 1160}#)
+ (#{source-wrap\ 160}#
+ #{e\ 1393}#
+ #{w\ 1395}#
+ #{s\ 1396}#
+ #{mod\ 1397}#)))))))))
+ #{tmp\ 1399}#)
+ ((lambda (#{tmp\ 1410}#)
+ (if #{tmp\ 1410}#
+ (apply (lambda (#{_\ 1411}#
+ #{head\ 1412}#
+ #{tail\ 1413}#
+ #{val\ 1414}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 163}#
- #{head\ 1158}#
- #{r\ 1140}#
+ (#{syntax-type\ 165}#
+ #{head\ 1412}#
+ #{r\ 1394}#
'(())
#f
#f
- #{mod\ 1143}#
+ #{mod\ 1397}#
#t))
- (lambda (#{type\ 1161}#
- #{value\ 1162}#
- #{ee\ 1163}#
- #{ww\ 1164}#
- #{ss\ 1165}#
- #{modmod\ 1166}#)
- (if (memv #{type\ 1161}#
+ (lambda (#{type\ 1415}#
+ #{value\ 1416}#
+ #{ee\ 1417}#
+ #{ww\ 1418}#
+ #{ss\ 1419}#
+ #{modmod\ 1420}#)
+ (if (memv #{type\ 1415}#
'(module-ref))
- (let ((#{val\ 1167}#
- (#{chi\ 165}#
- #{val\ 1160}#
- #{r\ 1140}#
- #{w\ 1141}#
- #{mod\ 1143}#)))
+ (let ((#{val\ 1421}#
+ (#{chi\ 167}#
+ #{val\ 1414}#
+ #{r\ 1394}#
+ #{w\ 1395}#
+ #{mod\ 1397}#)))
(call-with-values
(lambda ()
- (#{value\ 1162}#
- (cons #{head\ 1158}#
- #{tail\ 1159}#)))
- (lambda (#{id\ 1169}# #{mod\ 1170}#)
+ (#{value\ 1416}#
+ (cons #{head\ 1412}#
+ #{tail\ 1413}#)))
+ (lambda (#{id\ 1423}# #{mod\ 1424}#)
(#{build-global-assignment\ 102}#
- #{s\ 1142}#
- #{id\ 1169}#
- #{val\ 1167}#
- #{mod\ 1170}#))))
+ #{s\ 1396}#
+ #{id\ 1423}#
+ #{val\ 1421}#
+ #{mod\ 1424}#))))
(#{build-application\ 96}#
- #{s\ 1142}#
- (#{chi\ 165}#
+ #{s\ 1396}#
+ (#{chi\ 167}#
(list '#(syntax-object
setter
((top)
@@ -6842,7 +9930,6 @@
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -6924,7 +10011,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -7058,6 +10147,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -7170,6 +10260,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -7177,53 +10268,53 @@
((top) (top))
("i" "i")))
(hygiene guile))
- #{head\ 1158}#)
- #{r\ 1140}#
- #{w\ 1141}#
- #{mod\ 1143}#)
- (map (lambda (#{e\ 1171}#)
- (#{chi\ 165}#
- #{e\ 1171}#
- #{r\ 1140}#
- #{w\ 1141}#
- #{mod\ 1143}#))
+ #{head\ 1412}#)
+ #{r\ 1394}#
+ #{w\ 1395}#
+ #{mod\ 1397}#)
+ (map (lambda (#{e\ 1425}#)
+ (#{chi\ 167}#
+ #{e\ 1425}#
+ #{r\ 1394}#
+ #{w\ 1395}#
+ #{mod\ 1397}#))
(append
- #{tail\ 1159}#
- (list #{val\ 1160}#))))))))
- #{tmp\ 1156}#)
- ((lambda (#{_\ 1173}#)
+ #{tail\ 1413}#
+ (list #{val\ 1414}#))))))))
+ #{tmp\ 1410}#)
+ ((lambda (#{_\ 1427}#)
(syntax-violation
'set!
"bad set!"
- (#{source-wrap\ 158}#
- #{e\ 1139}#
- #{w\ 1141}#
- #{s\ 1142}#
- #{mod\ 1143}#)))
- #{tmp\ 1144}#)))
+ (#{source-wrap\ 160}#
+ #{e\ 1393}#
+ #{w\ 1395}#
+ #{s\ 1396}#
+ #{mod\ 1397}#)))
+ #{tmp\ 1398}#)))
($sc-dispatch
- #{tmp\ 1144}#
+ #{tmp\ 1398}#
'(any (any . each-any) any)))))
($sc-dispatch
- #{tmp\ 1144}#
+ #{tmp\ 1398}#
'(any any any))))
- #{e\ 1139}#)))
- (#{global-extend\ 127}#
+ #{e\ 1393}#)))
+ (#{global-extend\ 129}#
'module-ref
'@
- (lambda (#{e\ 1174}#)
- ((lambda (#{tmp\ 1175}#)
- ((lambda (#{tmp\ 1176}#)
- (if (if #{tmp\ 1176}#
- (apply (lambda (#{_\ 1177}# #{mod\ 1178}# #{id\ 1179}#)
- (if (and-map #{id?\ 129}# #{mod\ 1178}#)
- (#{id?\ 129}# #{id\ 1179}#)
+ (lambda (#{e\ 1428}#)
+ ((lambda (#{tmp\ 1429}#)
+ ((lambda (#{tmp\ 1430}#)
+ (if (if #{tmp\ 1430}#
+ (apply (lambda (#{_\ 1431}# #{mod\ 1432}# #{id\ 1433}#)
+ (if (and-map #{id?\ 131}# #{mod\ 1432}#)
+ (#{id?\ 131}# #{id\ 1433}#)
#f))
- #{tmp\ 1176}#)
+ #{tmp\ 1430}#)
#f)
- (apply (lambda (#{_\ 1181}# #{mod\ 1182}# #{id\ 1183}#)
+ (apply (lambda (#{_\ 1435}# #{mod\ 1436}# #{id\ 1437}#)
(values
- (syntax->datum #{id\ 1183}#)
+ (syntax->datum #{id\ 1437}#)
(syntax->datum
(cons '#(syntax-object
public
@@ -7242,7 +10333,6 @@
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -7324,7 +10414,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -7458,6 +10550,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -7570,38 +10663,39 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
((top) (top))
("i" "i")))
(hygiene guile))
- #{mod\ 1182}#))))
- #{tmp\ 1176}#)
+ #{mod\ 1436}#))))
+ #{tmp\ 1430}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1175}#)))
+ #{tmp\ 1429}#)))
($sc-dispatch
- #{tmp\ 1175}#
+ #{tmp\ 1429}#
'(any each-any any))))
- #{e\ 1174}#)))
- (#{global-extend\ 127}#
+ #{e\ 1428}#)))
+ (#{global-extend\ 129}#
'module-ref
'@@
- (lambda (#{e\ 1185}#)
- ((lambda (#{tmp\ 1186}#)
- ((lambda (#{tmp\ 1187}#)
- (if (if #{tmp\ 1187}#
- (apply (lambda (#{_\ 1188}# #{mod\ 1189}# #{id\ 1190}#)
- (if (and-map #{id?\ 129}# #{mod\ 1189}#)
- (#{id?\ 129}# #{id\ 1190}#)
+ (lambda (#{e\ 1439}#)
+ ((lambda (#{tmp\ 1440}#)
+ ((lambda (#{tmp\ 1441}#)
+ (if (if #{tmp\ 1441}#
+ (apply (lambda (#{_\ 1442}# #{mod\ 1443}# #{id\ 1444}#)
+ (if (and-map #{id?\ 131}# #{mod\ 1443}#)
+ (#{id?\ 131}# #{id\ 1444}#)
#f))
- #{tmp\ 1187}#)
+ #{tmp\ 1441}#)
#f)
- (apply (lambda (#{_\ 1192}# #{mod\ 1193}# #{id\ 1194}#)
+ (apply (lambda (#{_\ 1446}# #{mod\ 1447}# #{id\ 1448}#)
(values
- (syntax->datum #{id\ 1194}#)
+ (syntax->datum #{id\ 1448}#)
(syntax->datum
(cons '#(syntax-object
private
@@ -7620,7 +10714,6 @@
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -7702,7 +10795,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -7836,6 +10931,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -7948,129 +11044,130 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
((top) (top))
("i" "i")))
(hygiene guile))
- #{mod\ 1193}#))))
- #{tmp\ 1187}#)
+ #{mod\ 1447}#))))
+ #{tmp\ 1441}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1186}#)))
+ #{tmp\ 1440}#)))
($sc-dispatch
- #{tmp\ 1186}#
+ #{tmp\ 1440}#
'(any each-any any))))
- #{e\ 1185}#)))
- (#{global-extend\ 127}#
+ #{e\ 1439}#)))
+ (#{global-extend\ 129}#
'core
'if
- (lambda (#{e\ 1196}#
- #{r\ 1197}#
- #{w\ 1198}#
- #{s\ 1199}#
- #{mod\ 1200}#)
- ((lambda (#{tmp\ 1201}#)
- ((lambda (#{tmp\ 1202}#)
- (if #{tmp\ 1202}#
- (apply (lambda (#{_\ 1203}# #{test\ 1204}# #{then\ 1205}#)
+ (lambda (#{e\ 1450}#
+ #{r\ 1451}#
+ #{w\ 1452}#
+ #{s\ 1453}#
+ #{mod\ 1454}#)
+ ((lambda (#{tmp\ 1455}#)
+ ((lambda (#{tmp\ 1456}#)
+ (if #{tmp\ 1456}#
+ (apply (lambda (#{_\ 1457}# #{test\ 1458}# #{then\ 1459}#)
(#{build-conditional\ 97}#
- #{s\ 1199}#
- (#{chi\ 165}#
- #{test\ 1204}#
- #{r\ 1197}#
- #{w\ 1198}#
- #{mod\ 1200}#)
- (#{chi\ 165}#
- #{then\ 1205}#
- #{r\ 1197}#
- #{w\ 1198}#
- #{mod\ 1200}#)
+ #{s\ 1453}#
+ (#{chi\ 167}#
+ #{test\ 1458}#
+ #{r\ 1451}#
+ #{w\ 1452}#
+ #{mod\ 1454}#)
+ (#{chi\ 167}#
+ #{then\ 1459}#
+ #{r\ 1451}#
+ #{w\ 1452}#
+ #{mod\ 1454}#)
(#{build-void\ 95}# #f)))
- #{tmp\ 1202}#)
- ((lambda (#{tmp\ 1206}#)
- (if #{tmp\ 1206}#
- (apply (lambda (#{_\ 1207}#
- #{test\ 1208}#
- #{then\ 1209}#
- #{else\ 1210}#)
+ #{tmp\ 1456}#)
+ ((lambda (#{tmp\ 1460}#)
+ (if #{tmp\ 1460}#
+ (apply (lambda (#{_\ 1461}#
+ #{test\ 1462}#
+ #{then\ 1463}#
+ #{else\ 1464}#)
(#{build-conditional\ 97}#
- #{s\ 1199}#
- (#{chi\ 165}#
- #{test\ 1208}#
- #{r\ 1197}#
- #{w\ 1198}#
- #{mod\ 1200}#)
- (#{chi\ 165}#
- #{then\ 1209}#
- #{r\ 1197}#
- #{w\ 1198}#
- #{mod\ 1200}#)
- (#{chi\ 165}#
- #{else\ 1210}#
- #{r\ 1197}#
- #{w\ 1198}#
- #{mod\ 1200}#)))
- #{tmp\ 1206}#)
+ #{s\ 1453}#
+ (#{chi\ 167}#
+ #{test\ 1462}#
+ #{r\ 1451}#
+ #{w\ 1452}#
+ #{mod\ 1454}#)
+ (#{chi\ 167}#
+ #{then\ 1463}#
+ #{r\ 1451}#
+ #{w\ 1452}#
+ #{mod\ 1454}#)
+ (#{chi\ 167}#
+ #{else\ 1464}#
+ #{r\ 1451}#
+ #{w\ 1452}#
+ #{mod\ 1454}#)))
+ #{tmp\ 1460}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1201}#)))
+ #{tmp\ 1455}#)))
($sc-dispatch
- #{tmp\ 1201}#
+ #{tmp\ 1455}#
'(any any any any)))))
($sc-dispatch
- #{tmp\ 1201}#
+ #{tmp\ 1455}#
'(any any any))))
- #{e\ 1196}#)))
- (#{global-extend\ 127}#
+ #{e\ 1450}#)))
+ (#{global-extend\ 129}#
'begin
'begin
'())
- (#{global-extend\ 127}#
+ (#{global-extend\ 129}#
'define
'define
'())
- (#{global-extend\ 127}#
+ (#{global-extend\ 129}#
'define-syntax
'define-syntax
'())
- (#{global-extend\ 127}#
+ (#{global-extend\ 129}#
'eval-when
'eval-when
'())
- (#{global-extend\ 127}#
+ (#{global-extend\ 129}#
'core
'syntax-case
- (letrec ((#{gen-syntax-case\ 1214}#
- (lambda (#{x\ 1215}#
- #{keys\ 1216}#
- #{clauses\ 1217}#
- #{r\ 1218}#
- #{mod\ 1219}#)
- (if (null? #{clauses\ 1217}#)
+ (letrec ((#{gen-syntax-case\ 1468}#
+ (lambda (#{x\ 1469}#
+ #{keys\ 1470}#
+ #{clauses\ 1471}#
+ #{r\ 1472}#
+ #{mod\ 1473}#)
+ (if (null? #{clauses\ 1471}#)
(#{build-application\ 96}#
#f
- (#{build-primref\ 106}#
+ (#{build-primref\ 108}#
#f
'syntax-violation)
- (list (#{build-data\ 107}# #f #f)
- (#{build-data\ 107}#
+ (list (#{build-data\ 109}# #f #f)
+ (#{build-data\ 109}#
#f
"source expression failed to match any
pattern")
- #{x\ 1215}#))
- ((lambda (#{tmp\ 1220}#)
- ((lambda (#{tmp\ 1221}#)
- (if #{tmp\ 1221}#
- (apply (lambda (#{pat\ 1222}# #{exp\ 1223}#)
- (if (if (#{id?\ 129}# #{pat\ 1222}#)
+ #{x\ 1469}#))
+ ((lambda (#{tmp\ 1474}#)
+ ((lambda (#{tmp\ 1475}#)
+ (if #{tmp\ 1475}#
+ (apply (lambda (#{pat\ 1476}# #{exp\ 1477}#)
+ (if (if (#{id?\ 131}# #{pat\ 1476}#)
(and-map
- (lambda (#{x\ 1224}#)
- (not (#{free-id=?\ 152}#
- #{pat\ 1222}#
- #{x\ 1224}#)))
+ (lambda (#{x\ 1478}#)
+ (not (#{free-id=?\ 154}#
+ #{pat\ 1476}#
+ #{x\ 1478}#)))
(cons '#(syntax-object
...
((top)
@@ -8113,7 +11210,6 @@
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -8195,7 +11291,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+
build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -8329,6 +11427,7 @@
(top)
(top)
(top)
+ (top)
(top))
("i"
"i"
@@ -8441,6 +11540,7 @@
"i"
"i"
"i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -8448,730 +11548,734 @@
((top) (top))
("i" "i")))
(hygiene guile))
- #{keys\ 1216}#))
+ #{keys\ 1470}#))
#f)
- (let ((#{labels\ 1225}#
- (list (#{gen-label\ 134}#)))
- (#{var\ 1226}#
- (#{gen-var\ 176}#
- #{pat\ 1222}#)))
+ (let ((#{labels\ 1479}#
+ (list (#{gen-label\ 136}#)))
+ (#{var\ 1480}#
+ (#{gen-var\ 177}#
+ #{pat\ 1476}#)))
(#{build-application\ 96}#
#f
- (#{build-lambda\ 105}#
+ (#{build-simple-lambda\ 105}#
#f
(list (syntax->datum
- #{pat\ 1222}#))
- (list #{var\ 1226}#)
+ #{pat\ 1476}#))
+ #f
+ (list #{var\ 1480}#)
#f
- (#{chi\ 165}#
- #{exp\ 1223}#
- (#{extend-env\ 123}#
- #{labels\ 1225}#
+ (#{chi\ 167}#
+ #{exp\ 1477}#
+ (#{extend-env\ 125}#
+ #{labels\ 1479}#
(list (cons 'syntax
- (cons #{var\
1226}#
+ (cons #{var\
1480}#
0)))
- #{r\ 1218}#)
- (#{make-binding-wrap\ 146}#
- (list #{pat\ 1222}#)
- #{labels\ 1225}#
+ #{r\ 1472}#)
+ (#{make-binding-wrap\ 148}#
+ (list #{pat\ 1476}#)
+ #{labels\ 1479}#
'(()))
- #{mod\ 1219}#))
- (list #{x\ 1215}#)))
- (#{gen-clause\ 1213}#
- #{x\ 1215}#
- #{keys\ 1216}#
- (cdr #{clauses\ 1217}#)
- #{r\ 1218}#
- #{pat\ 1222}#
+ #{mod\ 1473}#))
+ (list #{x\ 1469}#)))
+ (#{gen-clause\ 1467}#
+ #{x\ 1469}#
+ #{keys\ 1470}#
+ (cdr #{clauses\ 1471}#)
+ #{r\ 1472}#
+ #{pat\ 1476}#
#t
- #{exp\ 1223}#
- #{mod\ 1219}#)))
- #{tmp\ 1221}#)
- ((lambda (#{tmp\ 1227}#)
- (if #{tmp\ 1227}#
- (apply (lambda (#{pat\ 1228}#
- #{fender\ 1229}#
- #{exp\ 1230}#)
- (#{gen-clause\ 1213}#
- #{x\ 1215}#
- #{keys\ 1216}#
- (cdr #{clauses\ 1217}#)
- #{r\ 1218}#
- #{pat\ 1228}#
- #{fender\ 1229}#
- #{exp\ 1230}#
- #{mod\ 1219}#))
- #{tmp\ 1227}#)
- ((lambda (#{_\ 1231}#)
+ #{exp\ 1477}#
+ #{mod\ 1473}#)))
+ #{tmp\ 1475}#)
+ ((lambda (#{tmp\ 1481}#)
+ (if #{tmp\ 1481}#
+ (apply (lambda (#{pat\ 1482}#
+ #{fender\ 1483}#
+ #{exp\ 1484}#)
+ (#{gen-clause\ 1467}#
+ #{x\ 1469}#
+ #{keys\ 1470}#
+ (cdr #{clauses\ 1471}#)
+ #{r\ 1472}#
+ #{pat\ 1482}#
+ #{fender\ 1483}#
+ #{exp\ 1484}#
+ #{mod\ 1473}#))
+ #{tmp\ 1481}#)
+ ((lambda (#{_\ 1485}#)
(syntax-violation
'syntax-case
"invalid clause"
- (car #{clauses\ 1217}#)))
- #{tmp\ 1220}#)))
+ (car #{clauses\ 1471}#)))
+ #{tmp\ 1474}#)))
($sc-dispatch
- #{tmp\ 1220}#
+ #{tmp\ 1474}#
'(any any any)))))
- ($sc-dispatch #{tmp\ 1220}# (quote (any any)))))
- (car #{clauses\ 1217}#)))))
- (#{gen-clause\ 1213}#
- (lambda (#{x\ 1232}#
- #{keys\ 1233}#
- #{clauses\ 1234}#
- #{r\ 1235}#
- #{pat\ 1236}#
- #{fender\ 1237}#
- #{exp\ 1238}#
- #{mod\ 1239}#)
+ ($sc-dispatch #{tmp\ 1474}# (quote (any any)))))
+ (car #{clauses\ 1471}#)))))
+ (#{gen-clause\ 1467}#
+ (lambda (#{x\ 1486}#
+ #{keys\ 1487}#
+ #{clauses\ 1488}#
+ #{r\ 1489}#
+ #{pat\ 1490}#
+ #{fender\ 1491}#
+ #{exp\ 1492}#
+ #{mod\ 1493}#)
(call-with-values
(lambda ()
- (#{convert-pattern\ 1211}#
- #{pat\ 1236}#
- #{keys\ 1233}#))
- (lambda (#{p\ 1240}# #{pvars\ 1241}#)
- (if (not (#{distinct-bound-ids?\ 155}#
- (map car #{pvars\ 1241}#)))
+ (#{convert-pattern\ 1465}#
+ #{pat\ 1490}#
+ #{keys\ 1487}#))
+ (lambda (#{p\ 1494}# #{pvars\ 1495}#)
+ (if (not (#{distinct-bound-ids?\ 157}#
+ (map car #{pvars\ 1495}#)))
(syntax-violation
'syntax-case
"duplicate pattern variable"
- #{pat\ 1236}#)
+ #{pat\ 1490}#)
(if (not (and-map
- (lambda (#{x\ 1242}#)
- (not (#{ellipsis?\ 174}#
- (car #{x\ 1242}#))))
- #{pvars\ 1241}#))
+ (lambda (#{x\ 1496}#)
+ (not (#{ellipsis?\ 175}#
+ (car #{x\ 1496}#))))
+ #{pvars\ 1495}#))
(syntax-violation
'syntax-case
"misplaced ellipsis"
- #{pat\ 1236}#)
- (let ((#{y\ 1243}#
- (#{gen-var\ 176}# (quote tmp))))
+ #{pat\ 1490}#)
+ (let ((#{y\ 1497}#
+ (#{gen-var\ 177}# (quote tmp))))
(#{build-application\ 96}#
#f
- (#{build-lambda\ 105}#
+ (#{build-simple-lambda\ 105}#
#f
(list (quote tmp))
- (list #{y\ 1243}#)
#f
- (let ((#{y\ 1244}#
+ (list #{y\ 1497}#)
+ #f
+ (let ((#{y\ 1498}#
(#{build-lexical-reference\ 98}#
'value
#f
'tmp
- #{y\ 1243}#)))
+ #{y\ 1497}#)))
(#{build-conditional\ 97}#
#f
- ((lambda (#{tmp\ 1245}#)
- ((lambda (#{tmp\ 1246}#)
- (if #{tmp\ 1246}#
- (apply (lambda () #{y\ 1244}#)
- #{tmp\ 1246}#)
- ((lambda (#{_\ 1247}#)
+ ((lambda (#{tmp\ 1499}#)
+ ((lambda (#{tmp\ 1500}#)
+ (if #{tmp\ 1500}#
+ (apply (lambda () #{y\ 1498}#)
+ #{tmp\ 1500}#)
+ ((lambda (#{_\ 1501}#)
(#{build-conditional\ 97}#
#f
- #{y\ 1244}#
- (#{build-dispatch-call\
1212}#
- #{pvars\ 1241}#
- #{fender\ 1237}#
- #{y\ 1244}#
- #{r\ 1235}#
- #{mod\ 1239}#)
- (#{build-data\ 107}#
+ #{y\ 1498}#
+ (#{build-dispatch-call\
1466}#
+ #{pvars\ 1495}#
+ #{fender\ 1491}#
+ #{y\ 1498}#
+ #{r\ 1489}#
+ #{mod\ 1493}#)
+ (#{build-data\ 109}#
#f
#f)))
- #{tmp\ 1245}#)))
+ #{tmp\ 1499}#)))
($sc-dispatch
- #{tmp\ 1245}#
+ #{tmp\ 1499}#
'#(atom #t))))
- #{fender\ 1237}#)
- (#{build-dispatch-call\ 1212}#
- #{pvars\ 1241}#
- #{exp\ 1238}#
- #{y\ 1244}#
- #{r\ 1235}#
- #{mod\ 1239}#)
- (#{gen-syntax-case\ 1214}#
- #{x\ 1232}#
- #{keys\ 1233}#
- #{clauses\ 1234}#
- #{r\ 1235}#
- #{mod\ 1239}#))))
- (list (if (eq? #{p\ 1240}# (quote any))
+ #{fender\ 1491}#)
+ (#{build-dispatch-call\ 1466}#
+ #{pvars\ 1495}#
+ #{exp\ 1492}#
+ #{y\ 1498}#
+ #{r\ 1489}#
+ #{mod\ 1493}#)
+ (#{gen-syntax-case\ 1468}#
+ #{x\ 1486}#
+ #{keys\ 1487}#
+ #{clauses\ 1488}#
+ #{r\ 1489}#
+ #{mod\ 1493}#))))
+ (list (if (eq? #{p\ 1494}# (quote any))
(#{build-application\ 96}#
#f
- (#{build-primref\ 106}#
+ (#{build-primref\ 108}#
#f
'list)
- (list #{x\ 1232}#))
+ (list #{x\ 1486}#))
(#{build-application\ 96}#
#f
- (#{build-primref\ 106}#
+ (#{build-primref\ 108}#
#f
'$sc-dispatch)
- (list #{x\ 1232}#
- (#{build-data\ 107}#
+ (list #{x\ 1486}#
+ (#{build-data\ 109}#
#f
- #{p\ 1240}#)))))))))))))
- (#{build-dispatch-call\ 1212}#
- (lambda (#{pvars\ 1248}#
- #{exp\ 1249}#
- #{y\ 1250}#
- #{r\ 1251}#
- #{mod\ 1252}#)
- (let ((#{ids\ 1253}# (map car #{pvars\ 1248}#))
- (#{levels\ 1254}# (map cdr #{pvars\ 1248}#)))
- (let ((#{labels\ 1255}#
- (#{gen-labels\ 135}# #{ids\ 1253}#))
- (#{new-vars\ 1256}#
- (map #{gen-var\ 176}# #{ids\ 1253}#)))
+ #{p\ 1494}#)))))))))))))
+ (#{build-dispatch-call\ 1466}#
+ (lambda (#{pvars\ 1502}#
+ #{exp\ 1503}#
+ #{y\ 1504}#
+ #{r\ 1505}#
+ #{mod\ 1506}#)
+ (let ((#{ids\ 1507}# (map car #{pvars\ 1502}#))
+ (#{levels\ 1508}# (map cdr #{pvars\ 1502}#)))
+ (let ((#{labels\ 1509}#
+ (#{gen-labels\ 137}# #{ids\ 1507}#))
+ (#{new-vars\ 1510}#
+ (map #{gen-var\ 177}# #{ids\ 1507}#)))
(#{build-application\ 96}#
#f
- (#{build-primref\ 106}# #f (quote apply))
- (list (#{build-lambda\ 105}#
+ (#{build-primref\ 108}# #f (quote apply))
+ (list (#{build-simple-lambda\ 105}#
+ #f
+ (map syntax->datum #{ids\ 1507}#)
#f
- (map syntax->datum #{ids\ 1253}#)
- #{new-vars\ 1256}#
+ #{new-vars\ 1510}#
#f
- (#{chi\ 165}#
- #{exp\ 1249}#
- (#{extend-env\ 123}#
- #{labels\ 1255}#
- (map (lambda (#{var\ 1257}#
- #{level\ 1258}#)
+ (#{chi\ 167}#
+ #{exp\ 1503}#
+ (#{extend-env\ 125}#
+ #{labels\ 1509}#
+ (map (lambda (#{var\ 1511}#
+ #{level\ 1512}#)
(cons 'syntax
- (cons #{var\ 1257}#
- #{level\ 1258}#)))
- #{new-vars\ 1256}#
- (map cdr #{pvars\ 1248}#))
- #{r\ 1251}#)
- (#{make-binding-wrap\ 146}#
- #{ids\ 1253}#
- #{labels\ 1255}#
+ (cons #{var\ 1511}#
+ #{level\ 1512}#)))
+ #{new-vars\ 1510}#
+ (map cdr #{pvars\ 1502}#))
+ #{r\ 1505}#)
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 1507}#
+ #{labels\ 1509}#
'(()))
- #{mod\ 1252}#))
- #{y\ 1250}#))))))
- (#{convert-pattern\ 1211}#
- (lambda (#{pattern\ 1259}# #{keys\ 1260}#)
- (letrec ((#{cvt\ 1261}#
- (lambda (#{p\ 1262}# #{n\ 1263}# #{ids\ 1264}#)
- (if (#{id?\ 129}# #{p\ 1262}#)
- (if (#{bound-id-member?\ 156}#
- #{p\ 1262}#
- #{keys\ 1260}#)
+ #{mod\ 1506}#))
+ #{y\ 1504}#))))))
+ (#{convert-pattern\ 1465}#
+ (lambda (#{pattern\ 1513}# #{keys\ 1514}#)
+ (letrec ((#{cvt\ 1515}#
+ (lambda (#{p\ 1516}# #{n\ 1517}# #{ids\ 1518}#)
+ (if (#{id?\ 131}# #{p\ 1516}#)
+ (if (#{bound-id-member?\ 158}#
+ #{p\ 1516}#
+ #{keys\ 1514}#)
(values
- (vector (quote free-id) #{p\ 1262}#)
- #{ids\ 1264}#)
+ (vector (quote free-id) #{p\ 1516}#)
+ #{ids\ 1518}#)
(values
'any
- (cons (cons #{p\ 1262}# #{n\ 1263}#)
- #{ids\ 1264}#)))
- ((lambda (#{tmp\ 1265}#)
- ((lambda (#{tmp\ 1266}#)
- (if (if #{tmp\ 1266}#
- (apply (lambda (#{x\ 1267}#
- #{dots\ 1268}#)
- (#{ellipsis?\ 174}#
- #{dots\ 1268}#))
- #{tmp\ 1266}#)
+ (cons (cons #{p\ 1516}# #{n\ 1517}#)
+ #{ids\ 1518}#)))
+ ((lambda (#{tmp\ 1519}#)
+ ((lambda (#{tmp\ 1520}#)
+ (if (if #{tmp\ 1520}#
+ (apply (lambda (#{x\ 1521}#
+ #{dots\ 1522}#)
+ (#{ellipsis?\ 175}#
+ #{dots\ 1522}#))
+ #{tmp\ 1520}#)
#f)
- (apply (lambda (#{x\ 1269}#
- #{dots\ 1270}#)
+ (apply (lambda (#{x\ 1523}#
+ #{dots\ 1524}#)
(call-with-values
(lambda ()
- (#{cvt\ 1261}#
- #{x\ 1269}#
+ (#{cvt\ 1515}#
+ #{x\ 1523}#
(#{fx+\ 86}#
- #{n\ 1263}#
+ #{n\ 1517}#
1)
- #{ids\ 1264}#))
- (lambda (#{p\ 1271}#
- #{ids\ 1272}#)
+ #{ids\ 1518}#))
+ (lambda (#{p\ 1525}#
+ #{ids\ 1526}#)
(values
- (if (eq? #{p\ 1271}#
+ (if (eq? #{p\ 1525}#
'any)
'each-any
(vector
'each
- #{p\ 1271}#))
- #{ids\ 1272}#))))
- #{tmp\ 1266}#)
- ((lambda (#{tmp\ 1273}#)
- (if #{tmp\ 1273}#
- (apply (lambda (#{x\ 1274}#
- #{y\ 1275}#)
+ #{p\ 1525}#))
+ #{ids\ 1526}#))))
+ #{tmp\ 1520}#)
+ ((lambda (#{tmp\ 1527}#)
+ (if #{tmp\ 1527}#
+ (apply (lambda (#{x\ 1528}#
+ #{y\ 1529}#)
(call-with-values
(lambda ()
- (#{cvt\ 1261}#
- #{y\ 1275}#
- #{n\ 1263}#
- #{ids\ 1264}#))
- (lambda (#{y\
1276}#
- #{ids\
1277}#)
+ (#{cvt\ 1515}#
+ #{y\ 1529}#
+ #{n\ 1517}#
+ #{ids\ 1518}#))
+ (lambda (#{y\
1530}#
+ #{ids\
1531}#)
(call-with-values
(lambda ()
- (#{cvt\
1261}#
- #{x\ 1274}#
- #{n\ 1263}#
- #{ids\
1277}#))
- (lambda (#{x\
1278}#
-
#{ids\ 1279}#)
+ (#{cvt\
1515}#
+ #{x\ 1528}#
+ #{n\ 1517}#
+ #{ids\
1531}#))
+ (lambda (#{x\
1532}#
+
#{ids\ 1533}#)
(values
- (cons #{x\
1278}#
- #{y\
1276}#)
- #{ids\
1279}#))))))
- #{tmp\ 1273}#)
- ((lambda (#{tmp\ 1280}#)
- (if #{tmp\ 1280}#
+ (cons #{x\
1532}#
+ #{y\
1530}#)
+ #{ids\
1533}#))))))
+ #{tmp\ 1527}#)
+ ((lambda (#{tmp\ 1534}#)
+ (if #{tmp\ 1534}#
(apply (lambda ()
(values
'()
- #{ids\
1264}#))
- #{tmp\ 1280}#)
- ((lambda (#{tmp\ 1281}#)
- (if #{tmp\ 1281}#
- (apply (lambda
(#{x\ 1282}#)
+ #{ids\
1518}#))
+ #{tmp\ 1534}#)
+ ((lambda (#{tmp\ 1535}#)
+ (if #{tmp\ 1535}#
+ (apply (lambda
(#{x\ 1536}#)
(call-with-values
(lambda
()
-
(#{cvt\ 1261}#
- #{x\
1282}#
- #{n\
1263}#
-
#{ids\ 1264}#))
- (lambda
(#{p\ 1284}#
-
#{ids\ 1285}#)
+
(#{cvt\ 1515}#
+ #{x\
1536}#
+ #{n\
1517}#
+
#{ids\ 1518}#))
+ (lambda
(#{p\ 1538}#
+
#{ids\ 1539}#)
(values
(vector
'vector
-
#{p\ 1284}#)
-
#{ids\ 1285}#))))
- #{tmp\
1281}#)
- ((lambda (#{x\
1286}#)
+
#{p\ 1538}#)
+
#{ids\ 1539}#))))
+ #{tmp\
1535}#)
+ ((lambda (#{x\
1540}#)
(values
(vector
'atom
- (#{strip\
175}#
- #{p\ 1262}#
+ (#{strip\
176}#
+ #{p\ 1516}#
'(())))
- #{ids\ 1264}#))
- #{tmp\ 1265}#)))
+ #{ids\ 1518}#))
+ #{tmp\ 1519}#)))
($sc-dispatch
- #{tmp\ 1265}#
+ #{tmp\ 1519}#
'#(vector
each-any)))))
($sc-dispatch
- #{tmp\ 1265}#
+ #{tmp\ 1519}#
'()))))
($sc-dispatch
- #{tmp\ 1265}#
+ #{tmp\ 1519}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 1265}#
+ #{tmp\ 1519}#
'(any any))))
- #{p\ 1262}#)))))
- (#{cvt\ 1261}# #{pattern\ 1259}# 0 (quote ()))))))
- (lambda (#{e\ 1287}#
- #{r\ 1288}#
- #{w\ 1289}#
- #{s\ 1290}#
- #{mod\ 1291}#)
- (let ((#{e\ 1292}#
- (#{source-wrap\ 158}#
- #{e\ 1287}#
- #{w\ 1289}#
- #{s\ 1290}#
- #{mod\ 1291}#)))
- ((lambda (#{tmp\ 1293}#)
- ((lambda (#{tmp\ 1294}#)
- (if #{tmp\ 1294}#
- (apply (lambda (#{_\ 1295}#
- #{val\ 1296}#
- #{key\ 1297}#
- #{m\ 1298}#)
+ #{p\ 1516}#)))))
+ (#{cvt\ 1515}# #{pattern\ 1513}# 0 (quote ()))))))
+ (lambda (#{e\ 1541}#
+ #{r\ 1542}#
+ #{w\ 1543}#
+ #{s\ 1544}#
+ #{mod\ 1545}#)
+ (let ((#{e\ 1546}#
+ (#{source-wrap\ 160}#
+ #{e\ 1541}#
+ #{w\ 1543}#
+ #{s\ 1544}#
+ #{mod\ 1545}#)))
+ ((lambda (#{tmp\ 1547}#)
+ ((lambda (#{tmp\ 1548}#)
+ (if #{tmp\ 1548}#
+ (apply (lambda (#{_\ 1549}#
+ #{val\ 1550}#
+ #{key\ 1551}#
+ #{m\ 1552}#)
(if (and-map
- (lambda (#{x\ 1299}#)
- (if (#{id?\ 129}# #{x\ 1299}#)
- (not (#{ellipsis?\ 174}# #{x\ 1299}#))
+ (lambda (#{x\ 1553}#)
+ (if (#{id?\ 131}# #{x\ 1553}#)
+ (not (#{ellipsis?\ 175}# #{x\ 1553}#))
#f))
- #{key\ 1297}#)
- (let ((#{x\ 1301}#
- (#{gen-var\ 176}# (quote tmp))))
+ #{key\ 1551}#)
+ (let ((#{x\ 1555}#
+ (#{gen-var\ 177}# (quote tmp))))
(#{build-application\ 96}#
- #{s\ 1290}#
- (#{build-lambda\ 105}#
+ #{s\ 1544}#
+ (#{build-simple-lambda\ 105}#
#f
(list (quote tmp))
- (list #{x\ 1301}#)
#f
- (#{gen-syntax-case\ 1214}#
+ (list #{x\ 1555}#)
+ #f
+ (#{gen-syntax-case\ 1468}#
(#{build-lexical-reference\ 98}#
'value
#f
'tmp
- #{x\ 1301}#)
- #{key\ 1297}#
- #{m\ 1298}#
- #{r\ 1288}#
- #{mod\ 1291}#))
- (list (#{chi\ 165}#
- #{val\ 1296}#
- #{r\ 1288}#
+ #{x\ 1555}#)
+ #{key\ 1551}#
+ #{m\ 1552}#
+ #{r\ 1542}#
+ #{mod\ 1545}#))
+ (list (#{chi\ 167}#
+ #{val\ 1550}#
+ #{r\ 1542}#
'(())
- #{mod\ 1291}#))))
+ #{mod\ 1545}#))))
(syntax-violation
'syntax-case
"invalid literals list"
- #{e\ 1292}#)))
- #{tmp\ 1294}#)
+ #{e\ 1546}#)))
+ #{tmp\ 1548}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1293}#)))
+ #{tmp\ 1547}#)))
($sc-dispatch
- #{tmp\ 1293}#
+ #{tmp\ 1547}#
'(any any each-any . each-any))))
- #{e\ 1292}#)))))
+ #{e\ 1546}#)))))
(set! sc-expand
- (lambda (#{x\ 1305}# . #{rest\ 1304}#)
- (if (if (pair? #{x\ 1305}#)
- (equal? (car #{x\ 1305}#) #{noexpand\ 84}#)
+ (lambda (#{x\ 1558}# . #{rest\ 1559}#)
+ (if (if (pair? #{x\ 1558}#)
+ (equal? (car #{x\ 1558}#) #{noexpand\ 84}#)
#f)
- (cadr #{x\ 1305}#)
- (let ((#{m\ 1306}#
- (if (null? #{rest\ 1304}#)
+ (cadr #{x\ 1558}#)
+ (let ((#{m\ 1560}#
+ (if (null? #{rest\ 1559}#)
'e
- (car #{rest\ 1304}#)))
- (#{esew\ 1307}#
- (if (let ((#{t\ 1308}# (null? #{rest\ 1304}#)))
- (if #{t\ 1308}#
- #{t\ 1308}#
- (null? (cdr #{rest\ 1304}#))))
+ (car #{rest\ 1559}#)))
+ (#{esew\ 1561}#
+ (if (let ((#{t\ 1562}# (null? #{rest\ 1559}#)))
+ (if #{t\ 1562}#
+ #{t\ 1562}#
+ (null? (cdr #{rest\ 1559}#))))
'(eval)
- (cadr #{rest\ 1304}#))))
+ (cadr #{rest\ 1559}#))))
(with-fluid*
#{*mode*\ 85}#
- #{m\ 1306}#
+ #{m\ 1560}#
(lambda ()
- (#{chi-top\ 164}#
- #{x\ 1305}#
+ (#{chi-top\ 166}#
+ #{x\ 1558}#
'()
'((top))
- #{m\ 1306}#
- #{esew\ 1307}#
+ #{m\ 1560}#
+ #{esew\ 1561}#
(cons 'hygiene
(module-name (current-module))))))))))
(set! identifier?
- (lambda (#{x\ 1309}#)
- (#{nonsymbol-id?\ 128}# #{x\ 1309}#)))
+ (lambda (#{x\ 1563}#)
+ (#{nonsymbol-id?\ 130}# #{x\ 1563}#)))
(set! datum->syntax
- (lambda (#{id\ 1310}# #{datum\ 1311}#)
- (#{make-syntax-object\ 112}#
- #{datum\ 1311}#
- (#{syntax-object-wrap\ 115}# #{id\ 1310}#)
+ (lambda (#{id\ 1564}# #{datum\ 1565}#)
+ (#{make-syntax-object\ 114}#
+ #{datum\ 1565}#
+ (#{syntax-object-wrap\ 117}# #{id\ 1564}#)
#f)))
(set! syntax->datum
- (lambda (#{x\ 1312}#)
- (#{strip\ 175}# #{x\ 1312}# (quote (())))))
+ (lambda (#{x\ 1566}#)
+ (#{strip\ 176}# #{x\ 1566}# (quote (())))))
(set! generate-temporaries
- (lambda (#{ls\ 1313}#)
+ (lambda (#{ls\ 1567}#)
(begin
- (let ((#{x\ 1314}# #{ls\ 1313}#))
- (if (not (list? #{x\ 1314}#))
+ (let ((#{x\ 1568}# #{ls\ 1567}#))
+ (if (not (list? #{x\ 1568}#))
(syntax-violation
'generate-temporaries
"invalid argument"
- #{x\ 1314}#)))
- (map (lambda (#{x\ 1315}#)
- (#{wrap\ 157}# (gensym) (quote ((top))) #f))
- #{ls\ 1313}#))))
+ #{x\ 1568}#)))
+ (map (lambda (#{x\ 1569}#)
+ (#{wrap\ 159}# (gensym) (quote ((top))) #f))
+ #{ls\ 1567}#))))
(set! free-identifier=?
- (lambda (#{x\ 1316}# #{y\ 1317}#)
+ (lambda (#{x\ 1570}# #{y\ 1571}#)
(begin
- (let ((#{x\ 1318}# #{x\ 1316}#))
- (if (not (#{nonsymbol-id?\ 128}# #{x\ 1318}#))
+ (let ((#{x\ 1572}# #{x\ 1570}#))
+ (if (not (#{nonsymbol-id?\ 130}# #{x\ 1572}#))
(syntax-violation
'free-identifier=?
"invalid argument"
- #{x\ 1318}#)))
- (let ((#{x\ 1319}# #{y\ 1317}#))
- (if (not (#{nonsymbol-id?\ 128}# #{x\ 1319}#))
+ #{x\ 1572}#)))
+ (let ((#{x\ 1573}# #{y\ 1571}#))
+ (if (not (#{nonsymbol-id?\ 130}# #{x\ 1573}#))
(syntax-violation
'free-identifier=?
"invalid argument"
- #{x\ 1319}#)))
- (#{free-id=?\ 152}# #{x\ 1316}# #{y\ 1317}#))))
+ #{x\ 1573}#)))
+ (#{free-id=?\ 154}# #{x\ 1570}# #{y\ 1571}#))))
(set! bound-identifier=?
- (lambda (#{x\ 1320}# #{y\ 1321}#)
+ (lambda (#{x\ 1574}# #{y\ 1575}#)
(begin
- (let ((#{x\ 1322}# #{x\ 1320}#))
- (if (not (#{nonsymbol-id?\ 128}# #{x\ 1322}#))
+ (let ((#{x\ 1576}# #{x\ 1574}#))
+ (if (not (#{nonsymbol-id?\ 130}# #{x\ 1576}#))
(syntax-violation
'bound-identifier=?
"invalid argument"
- #{x\ 1322}#)))
- (let ((#{x\ 1323}# #{y\ 1321}#))
- (if (not (#{nonsymbol-id?\ 128}# #{x\ 1323}#))
+ #{x\ 1576}#)))
+ (let ((#{x\ 1577}# #{y\ 1575}#))
+ (if (not (#{nonsymbol-id?\ 130}# #{x\ 1577}#))
(syntax-violation
'bound-identifier=?
"invalid argument"
- #{x\ 1323}#)))
- (#{bound-id=?\ 153}# #{x\ 1320}# #{y\ 1321}#))))
+ #{x\ 1577}#)))
+ (#{bound-id=?\ 155}# #{x\ 1574}# #{y\ 1575}#))))
(set! syntax-violation
- (lambda (#{who\ 1327}#
- #{message\ 1326}#
- #{form\ 1325}#
+ (lambda (#{who\ 1578}#
+ #{message\ 1579}#
+ #{form\ 1580}#
.
- #{subform\ 1324}#)
+ #{subform\ 1581}#)
(begin
- (let ((#{x\ 1328}# #{who\ 1327}#))
- (if (not ((lambda (#{x\ 1329}#)
- (let ((#{t\ 1330}# (not #{x\ 1329}#)))
- (if #{t\ 1330}#
- #{t\ 1330}#
- (let ((#{t\ 1331}# (string? #{x\ 1329}#)))
- (if #{t\ 1331}#
- #{t\ 1331}#
- (symbol? #{x\ 1329}#))))))
- #{x\ 1328}#))
+ (let ((#{x\ 1582}# #{who\ 1578}#))
+ (if (not ((lambda (#{x\ 1583}#)
+ (let ((#{t\ 1584}# (not #{x\ 1583}#)))
+ (if #{t\ 1584}#
+ #{t\ 1584}#
+ (let ((#{t\ 1585}# (string? #{x\ 1583}#)))
+ (if #{t\ 1585}#
+ #{t\ 1585}#
+ (symbol? #{x\ 1583}#))))))
+ #{x\ 1582}#))
(syntax-violation
'syntax-violation
"invalid argument"
- #{x\ 1328}#)))
- (let ((#{x\ 1332}# #{message\ 1326}#))
- (if (not (string? #{x\ 1332}#))
+ #{x\ 1582}#)))
+ (let ((#{x\ 1586}# #{message\ 1579}#))
+ (if (not (string? #{x\ 1586}#))
(syntax-violation
'syntax-violation
"invalid argument"
- #{x\ 1332}#)))
+ #{x\ 1586}#)))
(scm-error
'syntax-error
'sc-expand
(string-append
- (if #{who\ 1327}# "~a: " "")
+ (if #{who\ 1578}# "~a: " "")
"~a "
- (if (null? #{subform\ 1324}#)
+ (if (null? #{subform\ 1581}#)
"in ~a"
"in subform `~s' of `~s'"))
- (let ((#{tail\ 1333}#
- (cons #{message\ 1326}#
- (map (lambda (#{x\ 1334}#)
- (#{strip\ 175}# #{x\ 1334}# (quote (()))))
+ (let ((#{tail\ 1587}#
+ (cons #{message\ 1579}#
+ (map (lambda (#{x\ 1588}#)
+ (#{strip\ 176}# #{x\ 1588}# (quote (()))))
(append
- #{subform\ 1324}#
- (list #{form\ 1325}#))))))
- (if #{who\ 1327}#
- (cons #{who\ 1327}# #{tail\ 1333}#)
- #{tail\ 1333}#))
+ #{subform\ 1581}#
+ (list #{form\ 1580}#))))))
+ (if #{who\ 1578}#
+ (cons #{who\ 1578}# #{tail\ 1587}#)
+ #{tail\ 1587}#))
#f))))
- (letrec ((#{match\ 1339}#
- (lambda (#{e\ 1340}#
- #{p\ 1341}#
- #{w\ 1342}#
- #{r\ 1343}#
- #{mod\ 1344}#)
- (if (not #{r\ 1343}#)
+ (letrec ((#{match\ 1593}#
+ (lambda (#{e\ 1594}#
+ #{p\ 1595}#
+ #{w\ 1596}#
+ #{r\ 1597}#
+ #{mod\ 1598}#)
+ (if (not #{r\ 1597}#)
#f
- (if (eq? #{p\ 1341}# (quote any))
- (cons (#{wrap\ 157}#
- #{e\ 1340}#
- #{w\ 1342}#
- #{mod\ 1344}#)
- #{r\ 1343}#)
- (if (#{syntax-object?\ 113}# #{e\ 1340}#)
- (#{match*\ 1338}#
- (#{syntax-object-expression\ 114}# #{e\ 1340}#)
- #{p\ 1341}#
- (#{join-wraps\ 148}#
- #{w\ 1342}#
- (#{syntax-object-wrap\ 115}# #{e\ 1340}#))
- #{r\ 1343}#
- (#{syntax-object-module\ 116}# #{e\ 1340}#))
- (#{match*\ 1338}#
- #{e\ 1340}#
- #{p\ 1341}#
- #{w\ 1342}#
- #{r\ 1343}#
- #{mod\ 1344}#))))))
- (#{match*\ 1338}#
- (lambda (#{e\ 1345}#
- #{p\ 1346}#
- #{w\ 1347}#
- #{r\ 1348}#
- #{mod\ 1349}#)
- (if (null? #{p\ 1346}#)
- (if (null? #{e\ 1345}#) #{r\ 1348}# #f)
- (if (pair? #{p\ 1346}#)
- (if (pair? #{e\ 1345}#)
- (#{match\ 1339}#
- (car #{e\ 1345}#)
- (car #{p\ 1346}#)
- #{w\ 1347}#
- (#{match\ 1339}#
- (cdr #{e\ 1345}#)
- (cdr #{p\ 1346}#)
- #{w\ 1347}#
- #{r\ 1348}#
- #{mod\ 1349}#)
- #{mod\ 1349}#)
+ (if (eq? #{p\ 1595}# (quote any))
+ (cons (#{wrap\ 159}#
+ #{e\ 1594}#
+ #{w\ 1596}#
+ #{mod\ 1598}#)
+ #{r\ 1597}#)
+ (if (#{syntax-object?\ 115}# #{e\ 1594}#)
+ (#{match*\ 1592}#
+ (#{syntax-object-expression\ 116}# #{e\ 1594}#)
+ #{p\ 1595}#
+ (#{join-wraps\ 150}#
+ #{w\ 1596}#
+ (#{syntax-object-wrap\ 117}# #{e\ 1594}#))
+ #{r\ 1597}#
+ (#{syntax-object-module\ 118}# #{e\ 1594}#))
+ (#{match*\ 1592}#
+ #{e\ 1594}#
+ #{p\ 1595}#
+ #{w\ 1596}#
+ #{r\ 1597}#
+ #{mod\ 1598}#))))))
+ (#{match*\ 1592}#
+ (lambda (#{e\ 1599}#
+ #{p\ 1600}#
+ #{w\ 1601}#
+ #{r\ 1602}#
+ #{mod\ 1603}#)
+ (if (null? #{p\ 1600}#)
+ (if (null? #{e\ 1599}#) #{r\ 1602}# #f)
+ (if (pair? #{p\ 1600}#)
+ (if (pair? #{e\ 1599}#)
+ (#{match\ 1593}#
+ (car #{e\ 1599}#)
+ (car #{p\ 1600}#)
+ #{w\ 1601}#
+ (#{match\ 1593}#
+ (cdr #{e\ 1599}#)
+ (cdr #{p\ 1600}#)
+ #{w\ 1601}#
+ #{r\ 1602}#
+ #{mod\ 1603}#)
+ #{mod\ 1603}#)
#f)
- (if (eq? #{p\ 1346}# (quote each-any))
- (let ((#{l\ 1350}#
- (#{match-each-any\ 1336}#
- #{e\ 1345}#
- #{w\ 1347}#
- #{mod\ 1349}#)))
- (if #{l\ 1350}#
- (cons #{l\ 1350}# #{r\ 1348}#)
+ (if (eq? #{p\ 1600}# (quote each-any))
+ (let ((#{l\ 1604}#
+ (#{match-each-any\ 1590}#
+ #{e\ 1599}#
+ #{w\ 1601}#
+ #{mod\ 1603}#)))
+ (if #{l\ 1604}#
+ (cons #{l\ 1604}# #{r\ 1602}#)
#f))
- (let ((#{atom-key\ 1351}# (vector-ref #{p\ 1346}# 0)))
- (if (memv #{atom-key\ 1351}# (quote (each)))
- (if (null? #{e\ 1345}#)
- (#{match-empty\ 1337}#
- (vector-ref #{p\ 1346}# 1)
- #{r\ 1348}#)
- (let ((#{l\ 1352}#
- (#{match-each\ 1335}#
- #{e\ 1345}#
- (vector-ref #{p\ 1346}# 1)
- #{w\ 1347}#
- #{mod\ 1349}#)))
- (if #{l\ 1352}#
- (letrec ((#{collect\ 1353}#
- (lambda (#{l\ 1354}#)
- (if (null? (car #{l\ 1354}#))
- #{r\ 1348}#
- (cons (map car #{l\ 1354}#)
- (#{collect\ 1353}#
+ (let ((#{atom-key\ 1605}# (vector-ref #{p\ 1600}# 0)))
+ (if (memv #{atom-key\ 1605}# (quote (each)))
+ (if (null? #{e\ 1599}#)
+ (#{match-empty\ 1591}#
+ (vector-ref #{p\ 1600}# 1)
+ #{r\ 1602}#)
+ (let ((#{l\ 1606}#
+ (#{match-each\ 1589}#
+ #{e\ 1599}#
+ (vector-ref #{p\ 1600}# 1)
+ #{w\ 1601}#
+ #{mod\ 1603}#)))
+ (if #{l\ 1606}#
+ (letrec ((#{collect\ 1607}#
+ (lambda (#{l\ 1608}#)
+ (if (null? (car #{l\ 1608}#))
+ #{r\ 1602}#
+ (cons (map car #{l\ 1608}#)
+ (#{collect\ 1607}#
(map cdr
- #{l\
1354}#)))))))
- (#{collect\ 1353}# #{l\ 1352}#))
+ #{l\
1608}#)))))))
+ (#{collect\ 1607}# #{l\ 1606}#))
#f)))
- (if (memv #{atom-key\ 1351}# (quote (free-id)))
- (if (#{id?\ 129}# #{e\ 1345}#)
- (if (#{free-id=?\ 152}#
- (#{wrap\ 157}#
- #{e\ 1345}#
- #{w\ 1347}#
- #{mod\ 1349}#)
- (vector-ref #{p\ 1346}# 1))
- #{r\ 1348}#
+ (if (memv #{atom-key\ 1605}# (quote (free-id)))
+ (if (#{id?\ 131}# #{e\ 1599}#)
+ (if (#{free-id=?\ 154}#
+ (#{wrap\ 159}#
+ #{e\ 1599}#
+ #{w\ 1601}#
+ #{mod\ 1603}#)
+ (vector-ref #{p\ 1600}# 1))
+ #{r\ 1602}#
#f)
#f)
- (if (memv #{atom-key\ 1351}# (quote (atom)))
+ (if (memv #{atom-key\ 1605}# (quote (atom)))
(if (equal?
- (vector-ref #{p\ 1346}# 1)
- (#{strip\ 175}#
- #{e\ 1345}#
- #{w\ 1347}#))
- #{r\ 1348}#
+ (vector-ref #{p\ 1600}# 1)
+ (#{strip\ 176}#
+ #{e\ 1599}#
+ #{w\ 1601}#))
+ #{r\ 1602}#
#f)
- (if (memv #{atom-key\ 1351}# (quote (vector)))
- (if (vector? #{e\ 1345}#)
- (#{match\ 1339}#
- (vector->list #{e\ 1345}#)
- (vector-ref #{p\ 1346}# 1)
- #{w\ 1347}#
- #{r\ 1348}#
- #{mod\ 1349}#)
+ (if (memv #{atom-key\ 1605}# (quote (vector)))
+ (if (vector? #{e\ 1599}#)
+ (#{match\ 1593}#
+ (vector->list #{e\ 1599}#)
+ (vector-ref #{p\ 1600}# 1)
+ #{w\ 1601}#
+ #{r\ 1602}#
+ #{mod\ 1603}#)
#f)))))))))))
- (#{match-empty\ 1337}#
- (lambda (#{p\ 1355}# #{r\ 1356}#)
- (if (null? #{p\ 1355}#)
- #{r\ 1356}#
- (if (eq? #{p\ 1355}# (quote any))
- (cons (quote ()) #{r\ 1356}#)
- (if (pair? #{p\ 1355}#)
- (#{match-empty\ 1337}#
- (car #{p\ 1355}#)
- (#{match-empty\ 1337}#
- (cdr #{p\ 1355}#)
- #{r\ 1356}#))
- (if (eq? #{p\ 1355}# (quote each-any))
- (cons (quote ()) #{r\ 1356}#)
- (let ((#{atom-key\ 1357}#
- (vector-ref #{p\ 1355}# 0)))
- (if (memv #{atom-key\ 1357}# (quote (each)))
- (#{match-empty\ 1337}#
- (vector-ref #{p\ 1355}# 1)
- #{r\ 1356}#)
- (if (memv #{atom-key\ 1357}#
+ (#{match-empty\ 1591}#
+ (lambda (#{p\ 1609}# #{r\ 1610}#)
+ (if (null? #{p\ 1609}#)
+ #{r\ 1610}#
+ (if (eq? #{p\ 1609}# (quote any))
+ (cons (quote ()) #{r\ 1610}#)
+ (if (pair? #{p\ 1609}#)
+ (#{match-empty\ 1591}#
+ (car #{p\ 1609}#)
+ (#{match-empty\ 1591}#
+ (cdr #{p\ 1609}#)
+ #{r\ 1610}#))
+ (if (eq? #{p\ 1609}# (quote each-any))
+ (cons (quote ()) #{r\ 1610}#)
+ (let ((#{atom-key\ 1611}#
+ (vector-ref #{p\ 1609}# 0)))
+ (if (memv #{atom-key\ 1611}# (quote (each)))
+ (#{match-empty\ 1591}#
+ (vector-ref #{p\ 1609}# 1)
+ #{r\ 1610}#)
+ (if (memv #{atom-key\ 1611}#
'(free-id atom))
- #{r\ 1356}#
- (if (memv #{atom-key\ 1357}# (quote (vector)))
- (#{match-empty\ 1337}#
- (vector-ref #{p\ 1355}# 1)
- #{r\ 1356}#)))))))))))
- (#{match-each-any\ 1336}#
- (lambda (#{e\ 1358}# #{w\ 1359}# #{mod\ 1360}#)
- (if (pair? #{e\ 1358}#)
- (let ((#{l\ 1361}#
- (#{match-each-any\ 1336}#
- (cdr #{e\ 1358}#)
- #{w\ 1359}#
- #{mod\ 1360}#)))
- (if #{l\ 1361}#
- (cons (#{wrap\ 157}#
- (car #{e\ 1358}#)
- #{w\ 1359}#
- #{mod\ 1360}#)
- #{l\ 1361}#)
+ #{r\ 1610}#
+ (if (memv #{atom-key\ 1611}# (quote (vector)))
+ (#{match-empty\ 1591}#
+ (vector-ref #{p\ 1609}# 1)
+ #{r\ 1610}#)))))))))))
+ (#{match-each-any\ 1590}#
+ (lambda (#{e\ 1612}# #{w\ 1613}# #{mod\ 1614}#)
+ (if (pair? #{e\ 1612}#)
+ (let ((#{l\ 1615}#
+ (#{match-each-any\ 1590}#
+ (cdr #{e\ 1612}#)
+ #{w\ 1613}#
+ #{mod\ 1614}#)))
+ (if #{l\ 1615}#
+ (cons (#{wrap\ 159}#
+ (car #{e\ 1612}#)
+ #{w\ 1613}#
+ #{mod\ 1614}#)
+ #{l\ 1615}#)
#f))
- (if (null? #{e\ 1358}#)
+ (if (null? #{e\ 1612}#)
'()
- (if (#{syntax-object?\ 113}# #{e\ 1358}#)
- (#{match-each-any\ 1336}#
- (#{syntax-object-expression\ 114}# #{e\ 1358}#)
- (#{join-wraps\ 148}#
- #{w\ 1359}#
- (#{syntax-object-wrap\ 115}# #{e\ 1358}#))
- #{mod\ 1360}#)
+ (if (#{syntax-object?\ 115}# #{e\ 1612}#)
+ (#{match-each-any\ 1590}#
+ (#{syntax-object-expression\ 116}# #{e\ 1612}#)
+ (#{join-wraps\ 150}#
+ #{w\ 1613}#
+ (#{syntax-object-wrap\ 117}# #{e\ 1612}#))
+ #{mod\ 1614}#)
#f)))))
- (#{match-each\ 1335}#
- (lambda (#{e\ 1362}#
- #{p\ 1363}#
- #{w\ 1364}#
- #{mod\ 1365}#)
- (if (pair? #{e\ 1362}#)
- (let ((#{first\ 1366}#
- (#{match\ 1339}#
- (car #{e\ 1362}#)
- #{p\ 1363}#
- #{w\ 1364}#
+ (#{match-each\ 1589}#
+ (lambda (#{e\ 1616}#
+ #{p\ 1617}#
+ #{w\ 1618}#
+ #{mod\ 1619}#)
+ (if (pair? #{e\ 1616}#)
+ (let ((#{first\ 1620}#
+ (#{match\ 1593}#
+ (car #{e\ 1616}#)
+ #{p\ 1617}#
+ #{w\ 1618}#
'()
- #{mod\ 1365}#)))
- (if #{first\ 1366}#
- (let ((#{rest\ 1367}#
- (#{match-each\ 1335}#
- (cdr #{e\ 1362}#)
- #{p\ 1363}#
- #{w\ 1364}#
- #{mod\ 1365}#)))
- (if #{rest\ 1367}#
- (cons #{first\ 1366}# #{rest\ 1367}#)
+ #{mod\ 1619}#)))
+ (if #{first\ 1620}#
+ (let ((#{rest\ 1621}#
+ (#{match-each\ 1589}#
+ (cdr #{e\ 1616}#)
+ #{p\ 1617}#
+ #{w\ 1618}#
+ #{mod\ 1619}#)))
+ (if #{rest\ 1621}#
+ (cons #{first\ 1620}# #{rest\ 1621}#)
#f))
#f))
- (if (null? #{e\ 1362}#)
+ (if (null? #{e\ 1616}#)
'()
- (if (#{syntax-object?\ 113}# #{e\ 1362}#)
- (#{match-each\ 1335}#
- (#{syntax-object-expression\ 114}# #{e\ 1362}#)
- #{p\ 1363}#
- (#{join-wraps\ 148}#
- #{w\ 1364}#
- (#{syntax-object-wrap\ 115}# #{e\ 1362}#))
- (#{syntax-object-module\ 116}# #{e\ 1362}#))
+ (if (#{syntax-object?\ 115}# #{e\ 1616}#)
+ (#{match-each\ 1589}#
+ (#{syntax-object-expression\ 116}# #{e\ 1616}#)
+ #{p\ 1617}#
+ (#{join-wraps\ 150}#
+ #{w\ 1618}#
+ (#{syntax-object-wrap\ 117}# #{e\ 1616}#))
+ (#{syntax-object-module\ 118}# #{e\ 1616}#))
#f))))))
(set! $sc-dispatch
- (lambda (#{e\ 1368}# #{p\ 1369}#)
- (if (eq? #{p\ 1369}# (quote any))
- (list #{e\ 1368}#)
- (if (#{syntax-object?\ 113}# #{e\ 1368}#)
- (#{match*\ 1338}#
- (#{syntax-object-expression\ 114}# #{e\ 1368}#)
- #{p\ 1369}#
- (#{syntax-object-wrap\ 115}# #{e\ 1368}#)
+ (lambda (#{e\ 1622}# #{p\ 1623}#)
+ (if (eq? #{p\ 1623}# (quote any))
+ (list #{e\ 1622}#)
+ (if (#{syntax-object?\ 115}# #{e\ 1622}#)
+ (#{match*\ 1592}#
+ (#{syntax-object-expression\ 116}# #{e\ 1622}#)
+ #{p\ 1623}#
+ (#{syntax-object-wrap\ 117}# #{e\ 1622}#)
'()
- (#{syntax-object-module\ 116}# #{e\ 1368}#))
- (#{match*\ 1338}#
- #{e\ 1368}#
- #{p\ 1369}#
+ (#{syntax-object-module\ 118}# #{e\ 1622}#))
+ (#{match*\ 1592}#
+ #{e\ 1622}#
+ #{p\ 1623}#
'(())
'()
#f)))))))))
@@ -9179,11 +12283,11 @@
(define with-syntax
(make-syncase-macro
'macro
- (lambda (#{x\ 1370}#)
- ((lambda (#{tmp\ 1371}#)
- ((lambda (#{tmp\ 1372}#)
- (if #{tmp\ 1372}#
- (apply (lambda (#{_\ 1373}# #{e1\ 1374}# #{e2\ 1375}#)
+ (lambda (#{x\ 1624}#)
+ ((lambda (#{tmp\ 1625}#)
+ ((lambda (#{tmp\ 1626}#)
+ (if #{tmp\ 1626}#
+ (apply (lambda (#{_\ 1627}# #{e1\ 1628}# #{e2\ 1629}#)
(cons '#(syntax-object
begin
((top)
@@ -9194,15 +12298,15 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- (cons #{e1\ 1374}# #{e2\ 1375}#)))
- #{tmp\ 1372}#)
- ((lambda (#{tmp\ 1377}#)
- (if #{tmp\ 1377}#
- (apply (lambda (#{_\ 1378}#
- #{out\ 1379}#
- #{in\ 1380}#
- #{e1\ 1381}#
- #{e2\ 1382}#)
+ (cons #{e1\ 1628}# #{e2\ 1629}#)))
+ #{tmp\ 1626}#)
+ ((lambda (#{tmp\ 1631}#)
+ (if #{tmp\ 1631}#
+ (apply (lambda (#{_\ 1632}#
+ #{out\ 1633}#
+ #{in\ 1634}#
+ #{e1\ 1635}#
+ #{e2\ 1636}#)
(list '#(syntax-object
syntax-case
((top)
@@ -9213,9 +12317,9 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- #{in\ 1380}#
+ #{in\ 1634}#
'()
- (list #{out\ 1379}#
+ (list #{out\ 1633}#
(cons '#(syntax-object
begin
((top)
@@ -9233,16 +12337,16 @@
#((top))
#("i")))
(hygiene guile))
- (cons #{e1\ 1381}#
- #{e2\ 1382}#)))))
- #{tmp\ 1377}#)
- ((lambda (#{tmp\ 1384}#)
- (if #{tmp\ 1384}#
- (apply (lambda (#{_\ 1385}#
- #{out\ 1386}#
- #{in\ 1387}#
- #{e1\ 1388}#
- #{e2\ 1389}#)
+ (cons #{e1\ 1635}#
+ #{e2\ 1636}#)))))
+ #{tmp\ 1631}#)
+ ((lambda (#{tmp\ 1638}#)
+ (if #{tmp\ 1638}#
+ (apply (lambda (#{_\ 1639}#
+ #{out\ 1640}#
+ #{in\ 1641}#
+ #{e1\ 1642}#
+ #{e2\ 1643}#)
(list '#(syntax-object
syntax-case
((top)
@@ -9270,9 +12374,9 @@
#((top))
#("i")))
(hygiene guile))
- #{in\ 1387}#)
+ #{in\ 1641}#)
'()
- (list #{out\ 1386}#
+ (list #{out\ 1640}#
(cons '#(syntax-object
begin
((top)
@@ -9294,36 +12398,36 @@
#((top))
#("i")))
(hygiene guile))
- (cons #{e1\ 1388}#
- #{e2\ 1389}#)))))
- #{tmp\ 1384}#)
+ (cons #{e1\ 1642}#
+ #{e2\ 1643}#)))))
+ #{tmp\ 1638}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1371}#)))
+ #{tmp\ 1625}#)))
($sc-dispatch
- #{tmp\ 1371}#
+ #{tmp\ 1625}#
'(any #(each (any any)) any . each-any)))))
($sc-dispatch
- #{tmp\ 1371}#
+ #{tmp\ 1625}#
'(any ((any any)) any . each-any)))))
($sc-dispatch
- #{tmp\ 1371}#
+ #{tmp\ 1625}#
'(any () any . each-any))))
- #{x\ 1370}#))))
+ #{x\ 1624}#))))
(define syntax-rules
(make-syncase-macro
'macro
- (lambda (#{x\ 1393}#)
- ((lambda (#{tmp\ 1394}#)
- ((lambda (#{tmp\ 1395}#)
- (if #{tmp\ 1395}#
- (apply (lambda (#{_\ 1396}#
- #{k\ 1397}#
- #{keyword\ 1398}#
- #{pattern\ 1399}#
- #{template\ 1400}#)
+ (lambda (#{x\ 1647}#)
+ ((lambda (#{tmp\ 1648}#)
+ ((lambda (#{tmp\ 1649}#)
+ (if #{tmp\ 1649}#
+ (apply (lambda (#{_\ 1650}#
+ #{k\ 1651}#
+ #{keyword\ 1652}#
+ #{pattern\ 1653}#
+ #{template\ 1654}#)
(list '#(syntax-object
lambda
((top)
@@ -9364,9 +12468,9 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- (cons #{k\ 1397}#
- (map (lambda (#{tmp\ 1403}#
- #{tmp\ 1402}#)
+ (cons #{k\ 1651}#
+ (map (lambda (#{tmp\ 1657}#
+ #{tmp\ 1656}#)
(list (cons
'#(syntax-object
dummy
((top)
@@ -9396,7 +12500,7 @@
#("i")))
(hygiene
guile))
- #{tmp\
1402}#)
+ #{tmp\
1656}#)
(list
'#(syntax-object
syntax
((top)
@@ -9426,43 +12530,43 @@
#("i")))
(hygiene
guile))
- #{tmp\
1403}#)))
- #{template\ 1400}#
- #{pattern\ 1399}#))))))
- #{tmp\ 1395}#)
+ #{tmp\
1657}#)))
+ #{template\ 1654}#
+ #{pattern\ 1653}#))))))
+ #{tmp\ 1649}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1394}#)))
+ #{tmp\ 1648}#)))
($sc-dispatch
- #{tmp\ 1394}#
+ #{tmp\ 1648}#
'(any each-any . #(each ((any . any) any))))))
- #{x\ 1393}#))))
+ #{x\ 1647}#))))
(define let*
(make-extended-syncase-macro
(module-ref (current-module) (quote let*))
'macro
- (lambda (#{x\ 1404}#)
- ((lambda (#{tmp\ 1405}#)
- ((lambda (#{tmp\ 1406}#)
- (if (if #{tmp\ 1406}#
- (apply (lambda (#{let*\ 1407}#
- #{x\ 1408}#
- #{v\ 1409}#
- #{e1\ 1410}#
- #{e2\ 1411}#)
- (and-map identifier? #{x\ 1408}#))
- #{tmp\ 1406}#)
+ (lambda (#{x\ 1658}#)
+ ((lambda (#{tmp\ 1659}#)
+ ((lambda (#{tmp\ 1660}#)
+ (if (if #{tmp\ 1660}#
+ (apply (lambda (#{let*\ 1661}#
+ #{x\ 1662}#
+ #{v\ 1663}#
+ #{e1\ 1664}#
+ #{e2\ 1665}#)
+ (and-map identifier? #{x\ 1662}#))
+ #{tmp\ 1660}#)
#f)
- (apply (lambda (#{let*\ 1413}#
- #{x\ 1414}#
- #{v\ 1415}#
- #{e1\ 1416}#
- #{e2\ 1417}#)
- (letrec ((#{f\ 1418}#
- (lambda (#{bindings\ 1419}#)
- (if (null? #{bindings\ 1419}#)
+ (apply (lambda (#{let*\ 1667}#
+ #{x\ 1668}#
+ #{v\ 1669}#
+ #{e1\ 1670}#
+ #{e2\ 1671}#)
+ (letrec ((#{f\ 1672}#
+ (lambda (#{bindings\ 1673}#)
+ (if (null? #{bindings\ 1673}#)
(cons '#(syntax-object
let
((top)
@@ -9486,13 +12590,13 @@
#("i")))
(hygiene guile))
(cons '()
- (cons #{e1\ 1416}#
- #{e2\ 1417}#)))
- ((lambda (#{tmp\ 1423}#)
- ((lambda (#{tmp\ 1424}#)
- (if #{tmp\ 1424}#
- (apply (lambda (#{body\ 1425}#
- #{binding\
1426}#)
+ (cons #{e1\ 1670}#
+ #{e2\ 1671}#)))
+ ((lambda (#{tmp\ 1677}#)
+ ((lambda (#{tmp\ 1678}#)
+ (if #{tmp\ 1678}#
+ (apply (lambda (#{body\ 1679}#
+ #{binding\
1680}#)
(list '#(syntax-object
let
((top)
@@ -9538,52 +12642,52 @@
#("i")))
(hygiene
guile))
- (list #{binding\
1426}#)
- #{body\ 1425}#))
- #{tmp\ 1424}#)
+ (list #{binding\
1680}#)
+ #{body\ 1679}#))
+ #{tmp\ 1678}#)
(syntax-violation
#f
"source expression failed to
match any pattern"
- #{tmp\ 1423}#)))
+ #{tmp\ 1677}#)))
($sc-dispatch
- #{tmp\ 1423}#
+ #{tmp\ 1677}#
'(any any))))
- (list (#{f\ 1418}#
- (cdr #{bindings\ 1419}#))
- (car #{bindings\ 1419}#)))))))
- (#{f\ 1418}# (map list #{x\ 1414}# #{v\ 1415}#))))
- #{tmp\ 1406}#)
+ (list (#{f\ 1672}#
+ (cdr #{bindings\ 1673}#))
+ (car #{bindings\ 1673}#)))))))
+ (#{f\ 1672}# (map list #{x\ 1668}# #{v\ 1669}#))))
+ #{tmp\ 1660}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1405}#)))
+ #{tmp\ 1659}#)))
($sc-dispatch
- #{tmp\ 1405}#
+ #{tmp\ 1659}#
'(any #(each (any any)) any . each-any))))
- #{x\ 1404}#))))
+ #{x\ 1658}#))))
(define do
(make-extended-syncase-macro
(module-ref (current-module) (quote do))
'macro
- (lambda (#{orig-x\ 1427}#)
- ((lambda (#{tmp\ 1428}#)
- ((lambda (#{tmp\ 1429}#)
- (if #{tmp\ 1429}#
- (apply (lambda (#{_\ 1430}#
- #{var\ 1431}#
- #{init\ 1432}#
- #{step\ 1433}#
- #{e0\ 1434}#
- #{e1\ 1435}#
- #{c\ 1436}#)
- ((lambda (#{tmp\ 1437}#)
- ((lambda (#{tmp\ 1438}#)
- (if #{tmp\ 1438}#
- (apply (lambda (#{step\ 1439}#)
- ((lambda (#{tmp\ 1440}#)
- ((lambda (#{tmp\ 1441}#)
- (if #{tmp\ 1441}#
+ (lambda (#{orig-x\ 1681}#)
+ ((lambda (#{tmp\ 1682}#)
+ ((lambda (#{tmp\ 1683}#)
+ (if #{tmp\ 1683}#
+ (apply (lambda (#{_\ 1684}#
+ #{var\ 1685}#
+ #{init\ 1686}#
+ #{step\ 1687}#
+ #{e0\ 1688}#
+ #{e1\ 1689}#
+ #{c\ 1690}#)
+ ((lambda (#{tmp\ 1691}#)
+ ((lambda (#{tmp\ 1692}#)
+ (if #{tmp\ 1692}#
+ (apply (lambda (#{step\ 1693}#)
+ ((lambda (#{tmp\ 1694}#)
+ ((lambda (#{tmp\ 1695}#)
+ (if #{tmp\ 1695}#
(apply (lambda ()
(list '#(syntax-object
let
@@ -9664,8 +12768,8 @@
(hygiene
guile))
(map list
- #{var\
1431}#
- #{init\
1432}#)
+ #{var\
1685}#
+ #{init\
1686}#)
(list
'#(syntax-object
if
((top)
@@ -9744,7 +12848,7 @@
#("i")))
(hygiene
guile))
-
#{e0\ 1434}#)
+
#{e0\ 1688}#)
(cons
'#(syntax-object
begin
((top)
@@ -9785,7 +12889,7 @@
(hygiene
guile))
(append
-
#{c\ 1436}#
+
#{c\ 1690}#
(list (cons '#(syntax-object
doloop
((top)
@@ -9825,12 +12929,12 @@
#("i")))
(hygiene
guile))
-
#{step\ 1439}#)))))))
- #{tmp\ 1441}#)
- ((lambda (#{tmp\ 1446}#)
- (if #{tmp\ 1446}#
- (apply (lambda (#{e1\
1447}#
- #{e2\
1448}#)
+
#{step\ 1693}#)))))))
+ #{tmp\ 1695}#)
+ ((lambda (#{tmp\ 1700}#)
+ (if #{tmp\ 1700}#
+ (apply (lambda (#{e1\
1701}#
+ #{e2\
1702}#)
(list
'#(syntax-object
let
((top)
@@ -9924,8 +13028,8 @@
(hygiene
guile))
(map list
-
#{var\ 1431}#
-
#{init\ 1432}#)
+
#{var\ 1685}#
+
#{init\ 1686}#)
(list
'#(syntax-object
if
((top)
@@ -9972,7 +13076,7 @@
#("i")))
(hygiene
guile))
-
#{e0\ 1434}#
+
#{e0\ 1688}#
(cons '#(syntax-object
begin
((top)
@@ -10019,8 +13123,8 @@
#("i")))
(hygiene
guile))
-
(cons #{e1\ 1447}#
-
#{e2\ 1448}#))
+
(cons #{e1\ 1701}#
+
#{e2\ 1702}#))
(cons '#(syntax-object
begin
((top)
@@ -10068,7 +13172,7 @@
(hygiene
guile))
(append
-
#{c\ 1436}#
+
#{c\ 1690}#
(list (cons '#(syntax-object
doloop
((top)
@@ -10115,81 +13219,81 @@
#("i")))
(hygiene
guile))
-
#{step\ 1439}#)))))))
- #{tmp\ 1446}#)
+
#{step\ 1693}#)))))))
+ #{tmp\ 1700}#)
(syntax-violation
#f
"source expression
failed to match any pattern"
- #{tmp\ 1440}#)))
+ #{tmp\ 1694}#)))
($sc-dispatch
- #{tmp\ 1440}#
+ #{tmp\ 1694}#
'(any . each-any)))))
($sc-dispatch
- #{tmp\ 1440}#
+ #{tmp\ 1694}#
'())))
- #{e1\ 1435}#))
- #{tmp\ 1438}#)
+ #{e1\ 1689}#))
+ #{tmp\ 1692}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 1437}#)))
- ($sc-dispatch #{tmp\ 1437}# (quote each-any))))
- (map (lambda (#{v\ 1455}# #{s\ 1456}#)
- ((lambda (#{tmp\ 1457}#)
- ((lambda (#{tmp\ 1458}#)
- (if #{tmp\ 1458}#
- (apply (lambda () #{v\ 1455}#)
- #{tmp\ 1458}#)
- ((lambda (#{tmp\ 1459}#)
- (if #{tmp\ 1459}#
- (apply (lambda (#{e\ 1460}#)
- #{e\ 1460}#)
- #{tmp\ 1459}#)
- ((lambda (#{_\ 1461}#)
+ #{tmp\ 1691}#)))
+ ($sc-dispatch #{tmp\ 1691}# (quote each-any))))
+ (map (lambda (#{v\ 1709}# #{s\ 1710}#)
+ ((lambda (#{tmp\ 1711}#)
+ ((lambda (#{tmp\ 1712}#)
+ (if #{tmp\ 1712}#
+ (apply (lambda () #{v\ 1709}#)
+ #{tmp\ 1712}#)
+ ((lambda (#{tmp\ 1713}#)
+ (if #{tmp\ 1713}#
+ (apply (lambda (#{e\ 1714}#)
+ #{e\ 1714}#)
+ #{tmp\ 1713}#)
+ ((lambda (#{_\ 1715}#)
(syntax-violation
'do
"bad step expression"
- #{orig-x\ 1427}#
- #{s\ 1456}#))
- #{tmp\ 1457}#)))
+ #{orig-x\ 1681}#
+ #{s\ 1710}#))
+ #{tmp\ 1711}#)))
($sc-dispatch
- #{tmp\ 1457}#
+ #{tmp\ 1711}#
'(any)))))
- ($sc-dispatch #{tmp\ 1457}# (quote ()))))
- #{s\ 1456}#))
- #{var\ 1431}#
- #{step\ 1433}#)))
- #{tmp\ 1429}#)
+ ($sc-dispatch #{tmp\ 1711}# (quote ()))))
+ #{s\ 1710}#))
+ #{var\ 1685}#
+ #{step\ 1687}#)))
+ #{tmp\ 1683}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1428}#)))
+ #{tmp\ 1682}#)))
($sc-dispatch
- #{tmp\ 1428}#
+ #{tmp\ 1682}#
'(any #(each (any any . any))
(any . each-any)
.
each-any))))
- #{orig-x\ 1427}#))))
+ #{orig-x\ 1681}#))))
(define quasiquote
(make-extended-syncase-macro
(module-ref (current-module) (quote quasiquote))
'macro
- (letrec ((#{quasicons\ 1464}#
- (lambda (#{x\ 1468}# #{y\ 1469}#)
- ((lambda (#{tmp\ 1470}#)
- ((lambda (#{tmp\ 1471}#)
- (if #{tmp\ 1471}#
- (apply (lambda (#{x\ 1472}# #{y\ 1473}#)
- ((lambda (#{tmp\ 1474}#)
- ((lambda (#{tmp\ 1475}#)
- (if #{tmp\ 1475}#
- (apply (lambda (#{dy\ 1476}#)
- ((lambda (#{tmp\ 1477}#)
- ((lambda (#{tmp\ 1478}#)
- (if #{tmp\ 1478}#
- (apply (lambda
(#{dx\ 1479}#)
+ (letrec ((#{quasicons\ 1718}#
+ (lambda (#{x\ 1722}# #{y\ 1723}#)
+ ((lambda (#{tmp\ 1724}#)
+ ((lambda (#{tmp\ 1725}#)
+ (if #{tmp\ 1725}#
+ (apply (lambda (#{x\ 1726}# #{y\ 1727}#)
+ ((lambda (#{tmp\ 1728}#)
+ ((lambda (#{tmp\ 1729}#)
+ (if #{tmp\ 1729}#
+ (apply (lambda (#{dy\ 1730}#)
+ ((lambda (#{tmp\ 1731}#)
+ ((lambda (#{tmp\ 1732}#)
+ (if #{tmp\ 1732}#
+ (apply (lambda
(#{dx\ 1733}#)
(list
'#(syntax-object
quote
((top)
@@ -10238,11 +13342,11 @@
"i")))
(hygiene
guile))
-
(cons #{dx\ 1479}#
-
#{dy\ 1476}#)))
- #{tmp\
1478}#)
- ((lambda (#{_\
1480}#)
- (if (null? #{dy\
1476}#)
+
(cons #{dx\ 1733}#
+
#{dy\ 1730}#)))
+ #{tmp\
1732}#)
+ ((lambda (#{_\
1734}#)
+ (if (null? #{dy\
1730}#)
(list
'#(syntax-object
list
((top)
@@ -10291,7 +13395,7 @@
"i")))
(hygiene
guile))
- #{x\
1472}#)
+ #{x\
1726}#)
(list
'#(syntax-object
cons
((top)
@@ -10340,11 +13444,11 @@
"i")))
(hygiene
guile))
- #{x\
1472}#
- #{y\
1473}#)))
- #{tmp\ 1477}#)))
+ #{x\
1726}#
+ #{y\
1727}#)))
+ #{tmp\ 1731}#)))
($sc-dispatch
- #{tmp\ 1477}#
+ #{tmp\ 1731}#
'(#(free-id
#(syntax-object
quote
@@ -10387,11 +13491,11 @@
(hygiene
guile)))
any))))
- #{x\ 1472}#))
- #{tmp\ 1475}#)
- ((lambda (#{tmp\ 1481}#)
- (if #{tmp\ 1481}#
- (apply (lambda (#{stuff\ 1482}#)
+ #{x\ 1726}#))
+ #{tmp\ 1729}#)
+ ((lambda (#{tmp\ 1735}#)
+ (if #{tmp\ 1735}#
+ (apply (lambda (#{stuff\ 1736}#)
(cons '#(syntax-object
list
((top)
@@ -10432,10 +13536,10 @@
"i")))
(hygiene
guile))
- (cons #{x\ 1472}#
- #{stuff\
1482}#)))
- #{tmp\ 1481}#)
- ((lambda (#{else\ 1483}#)
+ (cons #{x\ 1726}#
+ #{stuff\
1736}#)))
+ #{tmp\ 1735}#)
+ ((lambda (#{else\ 1737}#)
(list '#(syntax-object
cons
((top)
@@ -10467,11 +13571,11 @@
"i"
"i")))
(hygiene guile))
- #{x\ 1472}#
- #{y\ 1473}#))
- #{tmp\ 1474}#)))
+ #{x\ 1726}#
+ #{y\ 1727}#))
+ #{tmp\ 1728}#)))
($sc-dispatch
- #{tmp\ 1474}#
+ #{tmp\ 1728}#
'(#(free-id
#(syntax-object
list
@@ -10500,7 +13604,7 @@
.
any)))))
($sc-dispatch
- #{tmp\ 1474}#
+ #{tmp\ 1728}#
'(#(free-id
#(syntax-object
quote
@@ -10524,26 +13628,26 @@
#("i" "i" "i" "i")))
(hygiene guile)))
any))))
- #{y\ 1473}#))
- #{tmp\ 1471}#)
+ #{y\ 1727}#))
+ #{tmp\ 1725}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1470}#)))
- ($sc-dispatch #{tmp\ 1470}# (quote (any any)))))
- (list #{x\ 1468}# #{y\ 1469}#))))
- (#{quasiappend\ 1465}#
- (lambda (#{x\ 1484}# #{y\ 1485}#)
- ((lambda (#{tmp\ 1486}#)
- ((lambda (#{tmp\ 1487}#)
- (if #{tmp\ 1487}#
- (apply (lambda (#{x\ 1488}# #{y\ 1489}#)
- ((lambda (#{tmp\ 1490}#)
- ((lambda (#{tmp\ 1491}#)
- (if #{tmp\ 1491}#
- (apply (lambda () #{x\ 1488}#)
- #{tmp\ 1491}#)
- ((lambda (#{_\ 1492}#)
+ #{tmp\ 1724}#)))
+ ($sc-dispatch #{tmp\ 1724}# (quote (any any)))))
+ (list #{x\ 1722}# #{y\ 1723}#))))
+ (#{quasiappend\ 1719}#
+ (lambda (#{x\ 1738}# #{y\ 1739}#)
+ ((lambda (#{tmp\ 1740}#)
+ ((lambda (#{tmp\ 1741}#)
+ (if #{tmp\ 1741}#
+ (apply (lambda (#{x\ 1742}# #{y\ 1743}#)
+ ((lambda (#{tmp\ 1744}#)
+ ((lambda (#{tmp\ 1745}#)
+ (if #{tmp\ 1745}#
+ (apply (lambda () #{x\ 1742}#)
+ #{tmp\ 1745}#)
+ ((lambda (#{_\ 1746}#)
(list '#(syntax-object
append
((top)
@@ -10572,11 +13676,11 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile))
- #{x\ 1488}#
- #{y\ 1489}#))
- #{tmp\ 1490}#)))
+ #{x\ 1742}#
+ #{y\ 1743}#))
+ #{tmp\ 1744}#)))
($sc-dispatch
- #{tmp\ 1490}#
+ #{tmp\ 1744}#
'(#(free-id
#(syntax-object
quote
@@ -10600,22 +13704,22 @@
#("i" "i" "i" "i")))
(hygiene guile)))
()))))
- #{y\ 1489}#))
- #{tmp\ 1487}#)
+ #{y\ 1743}#))
+ #{tmp\ 1741}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1486}#)))
- ($sc-dispatch #{tmp\ 1486}# (quote (any any)))))
- (list #{x\ 1484}# #{y\ 1485}#))))
- (#{quasivector\ 1466}#
- (lambda (#{x\ 1493}#)
- ((lambda (#{tmp\ 1494}#)
- ((lambda (#{x\ 1495}#)
- ((lambda (#{tmp\ 1496}#)
- ((lambda (#{tmp\ 1497}#)
- (if #{tmp\ 1497}#
- (apply (lambda (#{x\ 1498}#)
+ #{tmp\ 1740}#)))
+ ($sc-dispatch #{tmp\ 1740}# (quote (any any)))))
+ (list #{x\ 1738}# #{y\ 1739}#))))
+ (#{quasivector\ 1720}#
+ (lambda (#{x\ 1747}#)
+ ((lambda (#{tmp\ 1748}#)
+ ((lambda (#{x\ 1749}#)
+ ((lambda (#{tmp\ 1750}#)
+ ((lambda (#{tmp\ 1751}#)
+ (if #{tmp\ 1751}#
+ (apply (lambda (#{x\ 1752}#)
(list '#(syntax-object
quote
((top)
@@ -10641,11 +13745,11 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile))
- (list->vector #{x\ 1498}#)))
- #{tmp\ 1497}#)
- ((lambda (#{tmp\ 1500}#)
- (if #{tmp\ 1500}#
- (apply (lambda (#{x\ 1501}#)
+ (list->vector #{x\ 1752}#)))
+ #{tmp\ 1751}#)
+ ((lambda (#{tmp\ 1754}#)
+ (if #{tmp\ 1754}#
+ (apply (lambda (#{x\ 1755}#)
(cons '#(syntax-object
vector
((top)
@@ -10674,9 +13778,9 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile))
- #{x\ 1501}#))
- #{tmp\ 1500}#)
- ((lambda (#{_\ 1503}#)
+ #{x\ 1755}#))
+ #{tmp\ 1754}#)
+ ((lambda (#{_\ 1757}#)
(list '#(syntax-object
list->vector
((top)
@@ -10702,10 +13806,10 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile))
- #{x\ 1495}#))
- #{tmp\ 1496}#)))
+ #{x\ 1749}#))
+ #{tmp\ 1750}#)))
($sc-dispatch
- #{tmp\ 1496}#
+ #{tmp\ 1750}#
'(#(free-id
#(syntax-object
list
@@ -10725,7 +13829,7 @@
.
each-any)))))
($sc-dispatch
- #{tmp\ 1496}#
+ #{tmp\ 1750}#
'(#(free-id
#(syntax-object
quote
@@ -10743,18 +13847,18 @@
#("i" "i" "i" "i")))
(hygiene guile)))
each-any))))
- #{x\ 1495}#))
- #{tmp\ 1494}#))
- #{x\ 1493}#)))
- (#{quasi\ 1467}#
- (lambda (#{p\ 1504}# #{lev\ 1505}#)
- ((lambda (#{tmp\ 1506}#)
- ((lambda (#{tmp\ 1507}#)
- (if #{tmp\ 1507}#
- (apply (lambda (#{p\ 1508}#)
- (if (= #{lev\ 1505}# 0)
- #{p\ 1508}#
- (#{quasicons\ 1464}#
+ #{x\ 1749}#))
+ #{tmp\ 1748}#))
+ #{x\ 1747}#)))
+ (#{quasi\ 1721}#
+ (lambda (#{p\ 1758}# #{lev\ 1759}#)
+ ((lambda (#{tmp\ 1760}#)
+ ((lambda (#{tmp\ 1761}#)
+ (if #{tmp\ 1761}#
+ (apply (lambda (#{p\ 1762}#)
+ (if (= #{lev\ 1759}# 0)
+ #{p\ 1762}#
+ (#{quasicons\ 1718}#
'(#(syntax-object
quote
((top)
@@ -10789,21 +13893,21 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile)))
- (#{quasi\ 1467}#
- (list #{p\ 1508}#)
- (- #{lev\ 1505}# 1)))))
- #{tmp\ 1507}#)
- ((lambda (#{tmp\ 1509}#)
- (if (if #{tmp\ 1509}#
- (apply (lambda (#{args\ 1510}#)
- (= #{lev\ 1505}# 0))
- #{tmp\ 1509}#)
+ (#{quasi\ 1721}#
+ (list #{p\ 1762}#)
+ (- #{lev\ 1759}# 1)))))
+ #{tmp\ 1761}#)
+ ((lambda (#{tmp\ 1763}#)
+ (if (if #{tmp\ 1763}#
+ (apply (lambda (#{args\ 1764}#)
+ (= #{lev\ 1759}# 0))
+ #{tmp\ 1763}#)
#f)
- (apply (lambda (#{args\ 1511}#)
+ (apply (lambda (#{args\ 1765}#)
(syntax-violation
'unquote
"unquote takes exactly one argument"
- #{p\ 1504}#
+ #{p\ 1758}#
(cons '#(syntax-object
unquote
((top)
@@ -10824,19 +13928,19 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile))
- #{args\ 1511}#)))
- #{tmp\ 1509}#)
- ((lambda (#{tmp\ 1512}#)
- (if #{tmp\ 1512}#
- (apply (lambda (#{p\ 1513}# #{q\ 1514}#)
- (if (= #{lev\ 1505}# 0)
- (#{quasiappend\ 1465}#
- #{p\ 1513}#
- (#{quasi\ 1467}#
- #{q\ 1514}#
- #{lev\ 1505}#))
- (#{quasicons\ 1464}#
- (#{quasicons\ 1464}#
+ #{args\ 1765}#)))
+ #{tmp\ 1763}#)
+ ((lambda (#{tmp\ 1766}#)
+ (if #{tmp\ 1766}#
+ (apply (lambda (#{p\ 1767}# #{q\ 1768}#)
+ (if (= #{lev\ 1759}# 0)
+ (#{quasiappend\ 1719}#
+ #{p\ 1767}#
+ (#{quasi\ 1721}#
+ #{q\ 1768}#
+ #{lev\ 1759}#))
+ (#{quasicons\ 1718}#
+ (#{quasicons\ 1718}#
'(#(syntax-object
quote
((top)
@@ -10883,26 +13987,26 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile)))
- (#{quasi\ 1467}#
- (list #{p\ 1513}#)
- (- #{lev\ 1505}# 1)))
- (#{quasi\ 1467}#
- #{q\ 1514}#
- #{lev\ 1505}#))))
- #{tmp\ 1512}#)
- ((lambda (#{tmp\ 1515}#)
- (if (if #{tmp\ 1515}#
- (apply (lambda (#{args\ 1516}#
- #{q\ 1517}#)
- (= #{lev\ 1505}# 0))
- #{tmp\ 1515}#)
+ (#{quasi\ 1721}#
+ (list #{p\ 1767}#)
+ (- #{lev\ 1759}# 1)))
+ (#{quasi\ 1721}#
+ #{q\ 1768}#
+ #{lev\ 1759}#))))
+ #{tmp\ 1766}#)
+ ((lambda (#{tmp\ 1769}#)
+ (if (if #{tmp\ 1769}#
+ (apply (lambda (#{args\ 1770}#
+ #{q\ 1771}#)
+ (= #{lev\ 1759}# 0))
+ #{tmp\ 1769}#)
#f)
- (apply (lambda (#{args\ 1518}#
- #{q\ 1519}#)
+ (apply (lambda (#{args\ 1772}#
+ #{q\ 1773}#)
(syntax-violation
'unquote-splicing
"unquote-splicing takes
exactly one argument"
- #{p\ 1504}#
+ #{p\ 1758}#
(cons '#(syntax-object
unquote-splicing
((top)
@@ -10932,12 +14036,12 @@
"i"
"i")))
(hygiene guile))
- #{args\ 1518}#)))
- #{tmp\ 1515}#)
- ((lambda (#{tmp\ 1520}#)
- (if #{tmp\ 1520}#
- (apply (lambda (#{p\ 1521}#)
- (#{quasicons\ 1464}#
+ #{args\ 1772}#)))
+ #{tmp\ 1769}#)
+ ((lambda (#{tmp\ 1774}#)
+ (if #{tmp\ 1774}#
+ (apply (lambda (#{p\ 1775}#)
+ (#{quasicons\ 1718}#
'(#(syntax-object
quote
((top)
@@ -10996,32 +14100,32 @@
"i"
"i")))
(hygiene guile)))
- (#{quasi\ 1467}#
- (list #{p\ 1521}#)
- (+ #{lev\ 1505}#
+ (#{quasi\ 1721}#
+ (list #{p\ 1775}#)
+ (+ #{lev\ 1759}#
1))))
- #{tmp\ 1520}#)
- ((lambda (#{tmp\ 1522}#)
- (if #{tmp\ 1522}#
- (apply (lambda (#{p\ 1523}#
- #{q\ 1524}#)
- (#{quasicons\ 1464}#
- (#{quasi\ 1467}#
- #{p\ 1523}#
- #{lev\ 1505}#)
- (#{quasi\ 1467}#
- #{q\ 1524}#
- #{lev\ 1505}#)))
- #{tmp\ 1522}#)
- ((lambda (#{tmp\ 1525}#)
- (if #{tmp\ 1525}#
- (apply (lambda (#{x\
1526}#)
-
(#{quasivector\ 1466}#
- (#{quasi\
1467}#
- #{x\ 1526}#
- #{lev\
1505}#)))
- #{tmp\ 1525}#)
- ((lambda (#{p\ 1528}#)
+ #{tmp\ 1774}#)
+ ((lambda (#{tmp\ 1776}#)
+ (if #{tmp\ 1776}#
+ (apply (lambda (#{p\ 1777}#
+ #{q\ 1778}#)
+ (#{quasicons\ 1718}#
+ (#{quasi\ 1721}#
+ #{p\ 1777}#
+ #{lev\ 1759}#)
+ (#{quasi\ 1721}#
+ #{q\ 1778}#
+ #{lev\ 1759}#)))
+ #{tmp\ 1776}#)
+ ((lambda (#{tmp\ 1779}#)
+ (if #{tmp\ 1779}#
+ (apply (lambda (#{x\
1780}#)
+
(#{quasivector\ 1720}#
+ (#{quasi\
1721}#
+ #{x\ 1780}#
+ #{lev\
1759}#)))
+ #{tmp\ 1779}#)
+ ((lambda (#{p\ 1782}#)
(list
'#(syntax-object
quote
((top)
@@ -11054,16 +14158,16 @@
"i")))
(hygiene
guile))
- #{p\ 1528}#))
- #{tmp\ 1506}#)))
+ #{p\ 1782}#))
+ #{tmp\ 1760}#)))
($sc-dispatch
- #{tmp\ 1506}#
+ #{tmp\ 1760}#
'#(vector each-any)))))
($sc-dispatch
- #{tmp\ 1506}#
+ #{tmp\ 1760}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 1506}#
+ #{tmp\ 1760}#
'(#(free-id
#(syntax-object
quasiquote
@@ -11083,7 +14187,7 @@
(hygiene guile)))
any)))))
($sc-dispatch
- #{tmp\ 1506}#
+ #{tmp\ 1760}#
'((#(free-id
#(syntax-object
unquote-splicing
@@ -11106,7 +14210,7 @@
.
any)))))
($sc-dispatch
- #{tmp\ 1506}#
+ #{tmp\ 1760}#
'((#(free-id
#(syntax-object
unquote-splicing
@@ -11128,7 +14232,7 @@
.
any)))))
($sc-dispatch
- #{tmp\ 1506}#
+ #{tmp\ 1760}#
'(#(free-id
#(syntax-object
unquote
@@ -11146,7 +14250,7 @@
.
any)))))
($sc-dispatch
- #{tmp\ 1506}#
+ #{tmp\ 1760}#
'(#(free-id
#(syntax-object
unquote
@@ -11159,49 +14263,49 @@
#("i" "i" "i" "i")))
(hygiene guile)))
any))))
- #{p\ 1504}#))))
- (lambda (#{x\ 1529}#)
- ((lambda (#{tmp\ 1530}#)
- ((lambda (#{tmp\ 1531}#)
- (if #{tmp\ 1531}#
- (apply (lambda (#{_\ 1532}# #{e\ 1533}#)
- (#{quasi\ 1467}# #{e\ 1533}# 0))
- #{tmp\ 1531}#)
+ #{p\ 1758}#))))
+ (lambda (#{x\ 1783}#)
+ ((lambda (#{tmp\ 1784}#)
+ ((lambda (#{tmp\ 1785}#)
+ (if #{tmp\ 1785}#
+ (apply (lambda (#{_\ 1786}# #{e\ 1787}#)
+ (#{quasi\ 1721}# #{e\ 1787}# 0))
+ #{tmp\ 1785}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1530}#)))
- ($sc-dispatch #{tmp\ 1530}# (quote (any any)))))
- #{x\ 1529}#)))))
+ #{tmp\ 1784}#)))
+ ($sc-dispatch #{tmp\ 1784}# (quote (any any)))))
+ #{x\ 1783}#)))))
(define include
(make-syncase-macro
'macro
- (lambda (#{x\ 1534}#)
- (letrec ((#{read-file\ 1535}#
- (lambda (#{fn\ 1536}# #{k\ 1537}#)
- (let ((#{p\ 1538}# (open-input-file #{fn\ 1536}#)))
- (letrec ((#{f\ 1539}#
- (lambda (#{x\ 1540}#)
- (if (eof-object? #{x\ 1540}#)
+ (lambda (#{x\ 1788}#)
+ (letrec ((#{read-file\ 1789}#
+ (lambda (#{fn\ 1790}# #{k\ 1791}#)
+ (let ((#{p\ 1792}# (open-input-file #{fn\ 1790}#)))
+ (letrec ((#{f\ 1793}#
+ (lambda (#{x\ 1794}#)
+ (if (eof-object? #{x\ 1794}#)
(begin
- (close-input-port #{p\ 1538}#)
+ (close-input-port #{p\ 1792}#)
'())
(cons (datum->syntax
- #{k\ 1537}#
- #{x\ 1540}#)
- (#{f\ 1539}# (read #{p\ 1538}#)))))))
- (#{f\ 1539}# (read #{p\ 1538}#)))))))
- ((lambda (#{tmp\ 1541}#)
- ((lambda (#{tmp\ 1542}#)
- (if #{tmp\ 1542}#
- (apply (lambda (#{k\ 1543}# #{filename\ 1544}#)
- (let ((#{fn\ 1545}#
- (syntax->datum #{filename\ 1544}#)))
- ((lambda (#{tmp\ 1546}#)
- ((lambda (#{tmp\ 1547}#)
- (if #{tmp\ 1547}#
- (apply (lambda (#{exp\ 1548}#)
+ #{k\ 1791}#
+ #{x\ 1794}#)
+ (#{f\ 1793}# (read #{p\ 1792}#)))))))
+ (#{f\ 1793}# (read #{p\ 1792}#)))))))
+ ((lambda (#{tmp\ 1795}#)
+ ((lambda (#{tmp\ 1796}#)
+ (if #{tmp\ 1796}#
+ (apply (lambda (#{k\ 1797}# #{filename\ 1798}#)
+ (let ((#{fn\ 1799}#
+ (syntax->datum #{filename\ 1798}#)))
+ ((lambda (#{tmp\ 1800}#)
+ ((lambda (#{tmp\ 1801}#)
+ (if #{tmp\ 1801}#
+ (apply (lambda (#{exp\ 1802}#)
(cons '#(syntax-object
begin
((top)
@@ -11228,76 +14332,76 @@
#((top))
#("i")))
(hygiene guile))
- #{exp\ 1548}#))
- #{tmp\ 1547}#)
+ #{exp\ 1802}#))
+ #{tmp\ 1801}#)
(syntax-violation
#f
"source expression failed to match any
pattern"
- #{tmp\ 1546}#)))
- ($sc-dispatch #{tmp\ 1546}# (quote each-any))))
- (#{read-file\ 1535}# #{fn\ 1545}# #{k\ 1543}#))))
- #{tmp\ 1542}#)
+ #{tmp\ 1800}#)))
+ ($sc-dispatch #{tmp\ 1800}# (quote each-any))))
+ (#{read-file\ 1789}# #{fn\ 1799}# #{k\ 1797}#))))
+ #{tmp\ 1796}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1541}#)))
- ($sc-dispatch #{tmp\ 1541}# (quote (any any)))))
- #{x\ 1534}#)))))
+ #{tmp\ 1795}#)))
+ ($sc-dispatch #{tmp\ 1795}# (quote (any any)))))
+ #{x\ 1788}#)))))
(define unquote
(make-syncase-macro
'macro
- (lambda (#{x\ 1550}#)
- ((lambda (#{tmp\ 1551}#)
- ((lambda (#{tmp\ 1552}#)
- (if #{tmp\ 1552}#
- (apply (lambda (#{_\ 1553}# #{e\ 1554}#)
+ (lambda (#{x\ 1804}#)
+ ((lambda (#{tmp\ 1805}#)
+ ((lambda (#{tmp\ 1806}#)
+ (if #{tmp\ 1806}#
+ (apply (lambda (#{_\ 1807}# #{e\ 1808}#)
(syntax-violation
'unquote
"expression not valid outside of quasiquote"
- #{x\ 1550}#))
- #{tmp\ 1552}#)
+ #{x\ 1804}#))
+ #{tmp\ 1806}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1551}#)))
- ($sc-dispatch #{tmp\ 1551}# (quote (any any)))))
- #{x\ 1550}#))))
+ #{tmp\ 1805}#)))
+ ($sc-dispatch #{tmp\ 1805}# (quote (any any)))))
+ #{x\ 1804}#))))
(define unquote-splicing
(make-syncase-macro
'macro
- (lambda (#{x\ 1555}#)
- ((lambda (#{tmp\ 1556}#)
- ((lambda (#{tmp\ 1557}#)
- (if #{tmp\ 1557}#
- (apply (lambda (#{_\ 1558}# #{e\ 1559}#)
+ (lambda (#{x\ 1809}#)
+ ((lambda (#{tmp\ 1810}#)
+ ((lambda (#{tmp\ 1811}#)
+ (if #{tmp\ 1811}#
+ (apply (lambda (#{_\ 1812}# #{e\ 1813}#)
(syntax-violation
'unquote-splicing
"expression not valid outside of quasiquote"
- #{x\ 1555}#))
- #{tmp\ 1557}#)
+ #{x\ 1809}#))
+ #{tmp\ 1811}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1556}#)))
- ($sc-dispatch #{tmp\ 1556}# (quote (any any)))))
- #{x\ 1555}#))))
+ #{tmp\ 1810}#)))
+ ($sc-dispatch #{tmp\ 1810}# (quote (any any)))))
+ #{x\ 1809}#))))
(define case
(make-extended-syncase-macro
(module-ref (current-module) (quote case))
'macro
- (lambda (#{x\ 1560}#)
- ((lambda (#{tmp\ 1561}#)
- ((lambda (#{tmp\ 1562}#)
- (if #{tmp\ 1562}#
- (apply (lambda (#{_\ 1563}#
- #{e\ 1564}#
- #{m1\ 1565}#
- #{m2\ 1566}#)
- ((lambda (#{tmp\ 1567}#)
- ((lambda (#{body\ 1568}#)
+ (lambda (#{x\ 1814}#)
+ ((lambda (#{tmp\ 1815}#)
+ ((lambda (#{tmp\ 1816}#)
+ (if #{tmp\ 1816}#
+ (apply (lambda (#{_\ 1817}#
+ #{e\ 1818}#
+ #{m1\ 1819}#
+ #{m2\ 1820}#)
+ ((lambda (#{tmp\ 1821}#)
+ ((lambda (#{body\ 1822}#)
(list '#(syntax-object
let
((top)
@@ -11326,17 +14430,17 @@
#((top))
#("i")))
(hygiene guile))
- #{e\ 1564}#))
- #{body\ 1568}#))
- #{tmp\ 1567}#))
- (letrec ((#{f\ 1569}#
- (lambda (#{clause\ 1570}# #{clauses\ 1571}#)
- (if (null? #{clauses\ 1571}#)
- ((lambda (#{tmp\ 1573}#)
- ((lambda (#{tmp\ 1574}#)
- (if #{tmp\ 1574}#
- (apply (lambda (#{e1\ 1575}#
- #{e2\ 1576}#)
+ #{e\ 1818}#))
+ #{body\ 1822}#))
+ #{tmp\ 1821}#))
+ (letrec ((#{f\ 1823}#
+ (lambda (#{clause\ 1824}# #{clauses\ 1825}#)
+ (if (null? #{clauses\ 1825}#)
+ ((lambda (#{tmp\ 1827}#)
+ ((lambda (#{tmp\ 1828}#)
+ (if #{tmp\ 1828}#
+ (apply (lambda (#{e1\ 1829}#
+ #{e2\ 1830}#)
(cons '#(syntax-object
begin
((top)
@@ -11382,14 +14486,14 @@
#("i")))
(hygiene
guile))
- (cons #{e1\
1575}#
- #{e2\
1576}#)))
- #{tmp\ 1574}#)
- ((lambda (#{tmp\ 1578}#)
- (if #{tmp\ 1578}#
- (apply (lambda (#{k\ 1579}#
- #{e1\
1580}#
- #{e2\
1581}#)
+ (cons #{e1\
1829}#
+ #{e2\
1830}#)))
+ #{tmp\ 1828}#)
+ ((lambda (#{tmp\ 1832}#)
+ (if #{tmp\ 1832}#
+ (apply (lambda (#{k\ 1833}#
+ #{e1\
1834}#
+ #{e2\
1835}#)
(list
'#(syntax-object
if
((top)
@@ -11590,7 +14694,7 @@
#("i")))
(hygiene
guile))
-
#{k\ 1579}#))
+
#{k\ 1833}#))
(cons
'#(syntax-object
begin
((top)
@@ -11641,24 +14745,24 @@
#("i")))
(hygiene
guile))
- (cons
#{e1\ 1580}#
-
#{e2\ 1581}#))))
- #{tmp\ 1578}#)
- ((lambda (#{_\ 1584}#)
+ (cons
#{e1\ 1834}#
+
#{e2\ 1835}#))))
+ #{tmp\ 1832}#)
+ ((lambda (#{_\ 1838}#)
(syntax-violation
'case
"bad clause"
- #{x\ 1560}#
- #{clause\ 1570}#))
- #{tmp\ 1573}#)))
+ #{x\ 1814}#
+ #{clause\ 1824}#))
+ #{tmp\ 1827}#)))
($sc-dispatch
- #{tmp\ 1573}#
+ #{tmp\ 1827}#
'(each-any
any
.
each-any)))))
($sc-dispatch
- #{tmp\ 1573}#
+ #{tmp\ 1827}#
'(#(free-id
#(syntax-object
else
@@ -11684,15 +14788,15 @@
any
.
each-any))))
- #{clause\ 1570}#)
- ((lambda (#{tmp\ 1585}#)
- ((lambda (#{rest\ 1586}#)
- ((lambda (#{tmp\ 1587}#)
- ((lambda (#{tmp\ 1588}#)
- (if #{tmp\ 1588}#
- (apply (lambda (#{k\
1589}#
- #{e1\
1590}#
- #{e2\
1591}#)
+ #{clause\ 1824}#)
+ ((lambda (#{tmp\ 1839}#)
+ ((lambda (#{rest\ 1840}#)
+ ((lambda (#{tmp\ 1841}#)
+ ((lambda (#{tmp\ 1842}#)
+ (if #{tmp\ 1842}#
+ (apply (lambda (#{k\
1843}#
+ #{e1\
1844}#
+ #{e2\
1845}#)
(list
'#(syntax-object
if
((top)
@@ -11909,7 +15013,7 @@
#("i")))
(hygiene
guile))
-
#{k\ 1589}#))
+
#{k\ 1843}#))
(cons
'#(syntax-object
begin
((top)
@@ -11964,47 +15068,47 @@
#("i")))
(hygiene
guile))
-
(cons #{e1\ 1590}#
-
#{e2\ 1591}#))
- #{rest\
1586}#))
- #{tmp\ 1588}#)
- ((lambda (#{_\ 1594}#)
+
(cons #{e1\ 1844}#
+
#{e2\ 1845}#))
+ #{rest\
1840}#))
+ #{tmp\ 1842}#)
+ ((lambda (#{_\ 1848}#)
(syntax-violation
'case
"bad clause"
- #{x\ 1560}#
- #{clause\ 1570}#))
- #{tmp\ 1587}#)))
+ #{x\ 1814}#
+ #{clause\ 1824}#))
+ #{tmp\ 1841}#)))
($sc-dispatch
- #{tmp\ 1587}#
+ #{tmp\ 1841}#
'(each-any
any
.
each-any))))
- #{clause\ 1570}#))
- #{tmp\ 1585}#))
- (#{f\ 1569}#
- (car #{clauses\ 1571}#)
- (cdr #{clauses\ 1571}#)))))))
- (#{f\ 1569}# #{m1\ 1565}# #{m2\ 1566}#))))
- #{tmp\ 1562}#)
+ #{clause\ 1824}#))
+ #{tmp\ 1839}#))
+ (#{f\ 1823}#
+ (car #{clauses\ 1825}#)
+ (cdr #{clauses\ 1825}#)))))))
+ (#{f\ 1823}# #{m1\ 1819}# #{m2\ 1820}#))))
+ #{tmp\ 1816}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1561}#)))
+ #{tmp\ 1815}#)))
($sc-dispatch
- #{tmp\ 1561}#
+ #{tmp\ 1815}#
'(any any any . each-any))))
- #{x\ 1560}#))))
+ #{x\ 1814}#))))
(define identifier-syntax
(make-syncase-macro
'macro
- (lambda (#{x\ 1595}#)
- ((lambda (#{tmp\ 1596}#)
- ((lambda (#{tmp\ 1597}#)
- (if #{tmp\ 1597}#
- (apply (lambda (#{_\ 1598}# #{e\ 1599}#)
+ (lambda (#{x\ 1849}#)
+ ((lambda (#{tmp\ 1850}#)
+ ((lambda (#{tmp\ 1851}#)
+ (if #{tmp\ 1851}#
+ (apply (lambda (#{_\ 1852}# #{e\ 1853}#)
(list '#(syntax-object
lambda
((top)
@@ -12093,8 +15197,8 @@
#((top))
#("i")))
(hygiene guile))
- #{e\ 1599}#))
- (list (cons #{_\ 1598}#
+ #{e\ 1853}#))
+ (list (cons #{_\ 1852}#
'(#(syntax-object
x
((top)
@@ -12134,7 +15238,7 @@
#((top))
#("i")))
(hygiene guile))
- (cons #{e\ 1599}#
+ (cons #{e\ 1853}#
'(#(syntax-object
x
((top)
@@ -12162,11 +15266,11 @@
#("i")))
(hygiene
guile)))))))))
- #{tmp\ 1597}#)
+ #{tmp\ 1851}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1596}#)))
- ($sc-dispatch #{tmp\ 1596}# (quote (any any)))))
- #{x\ 1595}#))))
+ #{tmp\ 1850}#)))
+ ($sc-dispatch #{tmp\ 1850}# (quote (any any)))))
+ #{x\ 1849}#))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 1b5addd..c2bebe0 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -448,17 +448,89 @@
((@ (language tree-il) make-toplevel-define) source var exp))
(else (decorate-source `(define ,var ,exp) source)))))
-(define build-lambda
- (lambda (src ids vars docstring exp)
+;; Ideally we would have all lambdas be case lambdas, but that would
+;; need special support in the interpreter for the full capabilities of
+;; case-lambda, with optional and keyword args, predicates, and else
+;; clauses. This will come with the new interpreter, but for now we
+;; separate the cases.
+(define build-simple-lambda
+ (lambda (src req rest vars docstring exp)
(case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-lambda) src ids vars
+ ((c) ((@ (language tree-il) make-lambda) src
(if docstring `((documentation . ,docstring)) '())
- exp))
+ ;; hah, a case in which kwargs would be nice.
+ ((@ (language tree-il) make-lambda-case)
+ ;; src req opt rest kw inits vars predicate body else
+ src req #f rest #f '() vars #f exp #f)))
(else (decorate-source
- `(lambda ,vars ,@(if docstring (list docstring) '())
- ,exp)
+ `(lambda ,(if rest (apply cons* vars) vars)
+ ,@(if docstring (list docstring) '())
+ ,exp)
src)))))
+(define build-case-lambda
+ (lambda (src docstring body)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src
+ (if docstring `((documentation . ,docstring)) '())
+ body))
+ (else (decorate-source
+ ;; really gross hack
+ `(lambda %%args
+ ,@(if docstring (list docstring) '())
+ (cond ,@body))
+ src)))))
+
+(define build-lambda-case
+ ;; req := (name ...)
+ ;; opt := (name ...) | #f
+ ;; rest := name | #f
+ ;; kw := (allow-other-keys? (keyword name var [init]) ...) | #f
+ ;; inits: (init ...)
+ ;; vars: (sym ...)
+ ;; vars map to named arguments in the following order:
+ ;; required, optional (positional), rest, keyword.
+ ;; predicate: something you can stuff in a (lambda ,vars ,pred), already
expanded
+ ;; the body of a lambda: anything, already expanded
+ ;; else: lambda-case | #f
+ (lambda (src req opt rest kw inits vars predicate body else-case)
+ (case (fluid-ref *mode*)
+ ((c)
+ ((@ (language tree-il) make-lambda-case)
+ src req opt rest kw inits vars predicate body else-case))
+ (else
+ ;; Very much like the logic of (language tree-il compile-glil).
+ (let* ((nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (rest-idx (and rest (+ nreq nopt)))
+ (allow-other-keys? (if kw (car kw) #f))
+ (kw-indices (map (lambda (x)
+ ;; (,key ,name ,var)
+ (cons (car x) (list-index vars (caddr x))))
+ (if kw (cdr kw) '())))
+ (nargs (apply max (+ nreq nopt (if rest 1 0))
+ (map 1+ (map cdr kw-indices)))))
+ (or (= nargs
+ (length vars)
+ (+ nreq (length inits) (if rest 1 0)))
+ (error "something went wrong"
+ req opt rest kw inits vars nreq nopt kw-indices nargs))
+ (decorate-source
+ `((((@@ (ice-9 optargs) parse-lambda-case)
+ '(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
+ (list ,@(map (lambda (i) `(lambda ,vars ,i)) inits))
+ ,(if predicate `(lambda ,vars ,predicate) #f)
+ %%args)
+ ;; FIXME: This _ is here to work around a bug in the
+ ;; memoizer. The %%% makes it different from %%, also a
+ ;; memoizer workaround. See the "interesting bug" mail from
+ ;; 23 oct 2009. As soon as we change the evaluator, this
+ ;; can be removed.
+ => (lambda (%%%args . _) (apply (lambda ,vars ,body) %%%args)))
+ ,@(or else-case
+ `((%%args (error "wrong number of arguments" %%args)))))
+ src))))))
+
(define build-primref
(lambda (src name)
(if (equal? (module-name (current-module)) '(guile))
@@ -506,7 +578,7 @@
(ids (cdr ids)))
(case (fluid-ref *mode*)
((c)
- (let ((proc (build-lambda src ids vars #f body-exp)))
+ (let ((proc (build-simple-lambda src ids #f vars #f body-exp)))
(maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps)
((@ (language tree-il) make-letrec) src
@@ -1455,48 +1527,6 @@
(cons (cons er (source-wrap e w s mod))
(cdr body)))))))))))))))))
-(define chi-lambda-clause
- (lambda (e docstring c r w mod k)
- (syntax-case c ()
- ((args doc e1 e2 ...)
- (and (string? (syntax->datum (syntax doc))) (not docstring))
- (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
- (((id ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (syntax-violation 'lambda "invalid parameter list" e)
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (k (map syntax->datum ids)
- new-vars
- (and docstring (syntax->datum docstring))
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env labels new-vars r)
- (make-binding-wrap ids labels w)
- mod))))))
- ((ids e1 e2 ...)
- (let ((old-ids (lambda-var-list (syntax ids))))
- (if (not (valid-bound-ids? old-ids))
- (syntax-violation 'lambda "invalid parameter list" e)
- (let ((labels (gen-labels old-ids))
- (new-vars (map gen-var old-ids)))
- (k (let f ((ls1 (cdr old-ids)) (ls2 (car old-ids)))
- (if (null? ls1)
- (syntax->datum ls2)
- (f (cdr ls1) (cons (syntax->datum (car ls1)) ls2))))
- (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
- (if (null? ls1)
- ls2
- (f (cdr ls1) (cons (car ls1) ls2))))
- (and docstring (syntax->datum docstring))
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env labels new-vars r)
- (make-binding-wrap old-ids labels w)
- mod))))))
- (_ (syntax-violation 'lambda "bad lambda" e)))))
-
(define chi-local-syntax
(lambda (rec? e r w s mod k)
(syntax-case e ()
@@ -1574,6 +1604,7 @@
(let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
(build-lexical-var no-source id))))
+;; appears to return a reversed list
(define lambda-var-list
(lambda (vars)
(let lvl ((vars vars) (ls '()) (w empty-wrap))
@@ -1777,7 +1808,10 @@
((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
- ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr
x))))
+ ((lambda)
+ (if (list? (cadr x))
+ (build-simple-lambda no-source (cadr x) #f (cadr x) #f (regen
(caddr x)))
+ (error "how did we get here" x)))
(else (build-application no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
@@ -1794,12 +1828,208 @@
(global-extend 'core 'lambda
(lambda (e r w s mod)
- (syntax-case e ()
- ((_ . c)
- (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
- (lambda (names vars docstring body)
- (build-lambda s names vars docstring body)))))))
+ (define (docstring&body ids vars labels c)
+ (syntax-case c ()
+ ((docstring e1 e2 ...)
+ (string? (syntax->datum (syntax docstring)))
+ (values (syntax->datum (syntax docstring))
+ (chi-body (syntax (e1 e2 ...))
+ (source-wrap e w s mod)
+ (extend-var-env labels vars r)
+ (make-binding-wrap ids labels w)
+ mod)))
+ ((e1 e2 ...)
+ (values #f
+ (chi-body (syntax (e1 e2 ...))
+ (source-wrap e w s mod)
+ (extend-var-env labels vars r)
+ (make-binding-wrap ids labels w)
+ mod)))))
+ (syntax-case e ()
+ ((_ (id ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation 'lambda "invalid parameter list" e)
+ (let ((vars (map gen-var ids))
+ (labels (gen-labels ids)))
+ (call-with-values
+ (lambda ()
+ (docstring&body ids vars labels
+ (syntax (e1 e2 ...))))
+ (lambda (docstring body)
+ (build-simple-lambda s (map syntax->datum ids) #f
+ vars docstring body)))))))
+ ((_ ids e1 e2 ...)
+ (let ((rids (lambda-var-list (syntax ids))))
+ (if (not (valid-bound-ids? rids))
+ (syntax-violation 'lambda "invalid parameter list" e)
+ (let* ((req (reverse (cdr rids)))
+ (rest (car rids))
+ (rrids (reverse rids))
+ (vars (map gen-var rrids))
+ (labels (gen-labels rrids)))
+ (call-with-values
+ (lambda ()
+ (docstring&body rrids vars labels
+ (syntax (e1 e2 ...))))
+ (lambda (docstring body)
+ (build-simple-lambda s (map syntax->datum req)
+ (syntax->datum rest)
+ vars docstring body)))))))
+ (_ (syntax-violation 'lambda "bad lambda" e)))))
+
+(global-extend 'core 'lambda*
+ (lambda (e r w s mod)
+ ;; arg parsing state machine
+ (define (req args rreq)
+ (syntax-case args ()
+ (()
+ (values (reverse rreq) '() #f '()))
+ ((a . b) (symbol? (syntax->datum #'a))
+ (req #'b (cons #'a rreq)))
+ ((a . b) (eq? (syntax->datum #'a) #:optional)
+ (opt #'b (reverse rreq) '()))
+ ((a . b) (eq? (syntax->datum #'a) #:key)
+ (key #'b (reverse rreq) '() '()))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b (reverse rreq) '() '()))
+ (r (symbol? (syntax->datum #'a))
+ (rest #'r (reverse rreq) '() '()))
+ (else
+ (syntax-violation 'lambda* "invalid argument list" e args))))
+ (define (opt args req ropt)
+ (syntax-case args ()
+ (()
+ (values req (reverse ropt) #f '()))
+ ((a . b) (symbol? (syntax->datum #'a))
+ (opt #'b req (cons #'(a #f) ropt)))
+ (((a init) . b) (symbol? (syntax->datum #'a))
+ (opt #'b req (cons #'(a init) ropt)))
+ ((a . b) (eq? (syntax->datum #'a) #:key)
+ (key #'b req (reverse ropt) '()))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b req (reverse ropt) '()))
+ (r (symbol? (syntax->datum #'a))
+ (rest #'r req (reverse ropt) '()))
+ (else
+ (syntax-violation 'lambda* "invalid argument list" e args))))
+ (define (key args req opt rkey)
+ (syntax-case args ()
+ (()
+ (values req opt #f (cons #f (reverse rkey))))
+ ((a . b) (symbol? (syntax->datum #'a))
+ (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+ (key #'b req opt (cons #'(k a #f) rkey))))
+ (((a init) . b) (symbol? (syntax->datum #'a))
+ (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+ (key #'b req opt (cons #'(k a init) rkey))))
+ (((a init k) . b) (and (symbol? (syntax->datum #'a))
+ (keyword? (syntax->datum #'k)))
+ (key #'b req opt (cons #'(k a init) rkey)))
+ ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (values req opt #f (cons #t (reverse rkey))))
+ ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (eq? (syntax->datum #'a) #:rest))
+ (rest #'b req opt (cons #t (reverse rkey))))
+ ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (symbol? (syntax->datum #'r)))
+ (rest #'r req opt (cons #t (reverse rkey))))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b req opt (cons #f (reverse rkey))))
+ (r (symbol? (syntax->datum #'a))
+ (rest #'r req opt (cons #f (reverse rkey))))
+ (else
+ (syntax-violation 'lambda* "invalid argument list" e args))))
+ (define (rest args req opt kw)
+ (syntax-case args ()
+ (r (symbol? (syntax->datum #'r))
+ (values req opt #'r kw))
+ (else
+ (syntax-violation 'lambda* "invalid rest argument" e args))))
+ (define (expand-req req opt rest kw body)
+ (let ((vars (map gen-var req))
+ (labels (gen-labels req)))
+ (let ((r* (extend-var-env labels vars r))
+ (w* (make-binding-wrap req labels w)))
+ (expand-opt (map syntax->datum req)
+ opt rest kw body (reverse vars) r* w* '() '()))))
+ (define (expand-opt req opt rest kw body vars r* w* out inits)
+ (cond
+ ((pair? opt)
+ (syntax-case (car opt) ()
+ ((id i)
+ (let* ((v (gen-var #'id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list #'id) l w*)))
+ (expand-opt req (cdr opt) rest kw body (cons v vars)
+ r** w** (cons (syntax->datum #'id) out)
+ (cons (chi #'i r* w* mod) inits))))))
+ (rest
+ (let* ((v (gen-var rest))
+ (l (gen-labels (list v)))
+ (r* (extend-var-env l (list v) r*))
+ (w* (make-binding-wrap (list rest) l w*)))
+ (expand-kw req (if (pair? out) (reverse out) #f)
+ (syntax->datum rest)
+ (if (pair? kw) (cdr kw) kw)
+ body (cons v vars) r* w*
+ (if (pair? kw) (car kw) #f)
+ '() inits)))
+ (else
+ (expand-kw req (if (pair? out) (reverse out) #f) #f
+ (if (pair? kw) (cdr kw) kw)
+ body vars r* w*
+ (if (pair? kw) (car kw) #f)
+ '() inits))))
+ (define (expand-kw req opt rest kw body vars r* w* aok out inits)
+ (cond
+ ((pair? kw)
+ (syntax-case (car kw) ()
+ ((k id i)
+ (let* ((v (gen-var #'id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list #'id) l w*)))
+ (expand-kw req opt rest (cdr kw) body (cons v vars)
+ r** w** aok
+ (cons (list (syntax->datum #'k)
+ (syntax->datum #'id)
+ v)
+ out)
+ (cons (chi #'i r* w* mod) inits))))))
+ (else
+ (expand-body req opt rest
+ (if (or aok (pair? out)) (cons aok (reverse out)) #f)
+ body (reverse vars) r* w* (reverse inits)))))
+ (define (expand-body req opt rest kw body vars r* w* inits)
+ (syntax-case body ()
+ ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
+ (values (syntax->datum #'docstring) req opt rest kw inits vars #f
+ (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
+ r* w* mod)))
+ ((e1 e2 ...)
+ (values #f req opt rest kw inits vars #f
+ (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
+ r* w* mod)))))
+ ;; whew.
+
+ (syntax-case e ()
+ ((_ args e1 e2 ...)
+ (call-with-values (lambda () (req #'args '()))
+ (lambda (req opt rest kw)
+ (if (not (valid-bound-ids?
+ (append req (map car opt) (if rest (list rest) '())
+ (if (pair? kw) (map cadr (cdr kw)) '()))))
+ (syntax-violation 'lambda "invalid parameter list" e #'args)
+ (call-with-values (lambda ()
+ (expand-req req opt rest kw #'(e1 e2 ...)))
+ (lambda (docstring req opt rest kw inits vars pred body)
+ (build-case-lambda
+ s docstring
+ (build-lambda-case s req opt rest kw inits vars pred body
#f))))))))
+ (_ (syntax-violation 'lambda "bad lambda*" e)))))
(global-extend 'core 'let
(let ()
@@ -1975,7 +2205,7 @@
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source
(build-primref no-source 'apply)
- (list (build-lambda no-source (map syntax->datum ids) new-vars #f
+ (list (build-simple-lambda no-source (map syntax->datum ids) #f
new-vars #f
(chi exp
(extend-env
labels
@@ -2002,7 +2232,7 @@
(let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y
(build-application no-source
- (build-lambda no-source (list 'tmp) (list y) #f
+ (build-simple-lambda no-source (list 'tmp) #f (list y) #f
(let ((y (build-lexical-reference 'value no-source
'tmp y)))
(build-conditional no-source
@@ -2039,16 +2269,16 @@
(let ((labels (list (gen-label)))
(var (gen-var (syntax pat))))
(build-application no-source
- (build-lambda no-source
- (list (syntax->datum (syntax pat))) (list
var)
- #f
- (chi (syntax exp)
- (extend-env labels
- (list (make-binding 'syntax `(,var . 0)))
- r)
- (make-binding-wrap (syntax (pat))
- labels empty-wrap)
- mod))
+ (build-simple-lambda
+ no-source (list (syntax->datum (syntax pat))) #f (list
var)
+ #f
+ (chi (syntax exp)
+ (extend-env labels
+ (list (make-binding 'syntax `(,var .
0)))
+ r)
+ (make-binding-wrap (syntax (pat))
+ labels empty-wrap)
+ mod))
(list x)))
(gen-clause x keys (cdr clauses) r
(syntax pat) #t (syntax exp) mod)))
@@ -2067,7 +2297,7 @@
(let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x
(build-application s
- (build-lambda no-source (list 'tmp) (list x) #f
+ (build-simple-lambda no-source (list 'tmp) #f (list x) #f
(gen-syntax-case (build-lexical-reference 'value no-source
'tmp x)
(syntax (key ...)) (syntax (m ...))
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 2b22fd8..a7c4749 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -28,8 +28,8 @@
assembly-pack assembly-unpack
object->assembly assembly->object))
-;; nargs, nrest, nlocs, len, metalen, padding
-(define *program-header-len* (+ 1 1 2 4 4 4))
+;; len, metalen
+(define *program-header-len* (+ 4 4))
;; lengths are encoded in 3 bytes
(define *len-len* 3)
@@ -49,7 +49,7 @@
(+ 1 *len-len* (string-length str)))
((load-array ,bv)
(+ 1 *len-len* (bytevector-length bv)))
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
+ ((load-program ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
diff --git a/module/language/assembly/compile-bytecode.scm
b/module/language/assembly/compile-bytecode.scm
index 5a80981..d92821c 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -104,13 +104,9 @@
(len (instruction-length inst)))
(write-byte opcode)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
- (write-byte nargs)
- (write-byte nrest)
- (write-uint16 nlocs)
+ ((load-program ,labels ,length ,meta . ,code)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
- (write-uint32 0) ; padding
(letrec ((i 0)
(write (lambda (x) (set! i (1+ i)) (write-byte x)))
(get-addr (lambda () i)))
diff --git a/module/language/assembly/decompile-bytecode.scm
b/module/language/assembly/decompile-bytecode.scm
index 559abea..6c929cb 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -51,13 +51,10 @@
;; FIXME: this is a little-endian disassembly!!!
(define (decode-load-program pop)
- (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop))
- (nlocs (+ nlocs0 (ash nlocs1 8)))
- (a (pop)) (b (pop)) (c (pop)) (d (pop))
+ (let* ((a (pop)) (b (pop)) (c (pop)) (d (pop))
(e (pop)) (f (pop)) (g (pop)) (h (pop))
(len (+ a (ash b 8) (ash c 16) (ash d 24)))
(metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
- (%unused-pad (begin (pop) (pop) (pop) (pop)))
(labels '())
(i 0))
(define (ensure-label rel1 rel2 rel3)
@@ -77,8 +74,7 @@
(cond ((> i len)
(error "error decoding program -- read too many bytes" out))
((= i len)
- `(load-program ,nargs ,nrest ,nlocs
- ,(map (lambda (x) (cons (cdr x) (car x)))
+ `(load-program ,(map (lambda (x) (cons (cdr x) (car x)))
(reverse labels))
,len
,(if (zero? metalen) #f (decode-load-program pop))
diff --git a/module/language/assembly/disassemble.scm
b/module/language/assembly/disassemble.scm
index c7b9df9..ae2d327 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -35,7 +35,7 @@
(define (disassemble-load-program asm env)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
+ ((load-program ,labels ,len ,meta . ,code)
(let ((objs (and env (assq-ref env 'objects)))
(free-vars (and env (assq-ref env 'free-vars)))
(meta (and env (assq-ref env 'meta)))
@@ -64,7 +64,9 @@
(lp (+ pos (byte-length asm)) (cdr code) programs))
(else
(print-info pos asm
- (code-annotation end asm objs nargs blocs
+ ;; FIXME: code-annotation for whether it's
+ ;; an arg or not, currently passing nargs=-1
+ (code-annotation end asm objs -1 blocs
labels)
(and=> (and srcs (assq end srcs)) source->string))
(lp (+ pos (byte-length asm)) (cdr code) programs)))))))
diff --git a/module/language/brainfuck/compile-tree-il.scm
b/module/language/brainfuck/compile-tree-il.scm
index 0aaa112..4cd6316 100644
--- a/module/language/brainfuck/compile-tree-il.scm
+++ b/module/language/brainfuck/compile-tree-il.scm
@@ -168,14 +168,17 @@
((<bf-loop> . ,body)
(let ((iterate (gensym)))
(emit `(letrec (iterate) (,iterate)
- ((lambda () ()
- (if (apply (primitive =)
- (apply (primitive vector-ref)
- (lexical tape) (lexical
pointer))
- (const 0))
- (void)
- (begin ,(compile-body body)
- (apply (lexical ,iterate))))))
+ ((lambda ()
+ (lambda-case
+ ((() #f #f #f () () #f)
+ (if (apply (primitive =)
+ (apply (primitive vector-ref)
+ (lexical tape) (lexical
pointer))
+ (const 0))
+ (void)
+ (begin ,(compile-body body)
+ (apply (lexical ,iterate)))))
+ #f)))
(apply (lexical ,iterate))))))
(else (error "unknown brainfuck instruction" (car in))))))))
diff --git a/module/language/brainfuck/parse.scm
b/module/language/brainfuck/parse.scm
index 0a71638..81dbdd9 100644
--- a/module/language/brainfuck/parse.scm
+++ b/module/language/brainfuck/parse.scm
@@ -66,9 +66,16 @@
(define (read-brainfuck p)
(let iterate ((parsed '()))
(let ((chr (read-char p)))
- (if (or (eof-object? chr) (eq? #\] chr))
- (reverse-without-nops parsed)
- (iterate (cons (process-input-char chr p) parsed))))))
+ (cond
+ ((eof-object? chr)
+ (let ((parsed (reverse-without-nops parsed)))
+ (if (null? parsed)
+ chr ;; pass on the EOF object
+ parsed)))
+ ((eqv? chr #\])
+ (reverse-without-nops parsed))
+ (else
+ (iterate (cons (process-input-char chr p) parsed)))))))
; This routine processes a single character of input and builds the
diff --git a/module/language/ecmascript/compile-tree-il.scm
b/module/language/ecmascript/compile-tree-il.scm
index 88f3db7..a820baf 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -326,14 +326,20 @@
((begin . ,forms)
`(begin ,@(map (lambda (x) (comp x e)) forms)))
((lambda ,formals ,body)
- (let ((%args (gensym "%args ")))
- (-> (lambda '%args %args '()
- (comp-body (econs '%args %args e) body formals '%args)))))
+ (let ((syms (map (lambda (x)
+ (gensym (string-append (symbol->string x) " ")))
+ formals)))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() ,formals #f #f () ,syms #f)
+ ,(comp-body e body formals syms))))))))
((call/this ,obj ,prop . ,args)
(@impl call/this*
obj
- (-> (lambda '() '() '()
- `(apply ,(@impl pget obj prop) ,@args)))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ (apply ,(@impl pget obj prop) ,@args))))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
@@ -433,40 +439,46 @@
(%continue (gensym "%continue ")))
(let ((e (econs '%loop %loop (econs '%continue %continue e))))
(-> (letrec '(%loop %continue) (list %loop %continue)
- (list (-> (lambda '() '() '()
- (-> (begin
- (comp statement e)
- (-> (apply (-> (lexical
'%continue %continue)))
- )))))
-
- (-> (lambda '() '() '()
- (-> (if (@impl ->boolean (comp test
e))
- (-> (apply (-> (lexical
'%loop %loop))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ ,(-> (begin
+ (comp statement e)
+ (-> (apply (-> (lexical
'%continue %continue)))))))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ ,(-> (if (@impl ->boolean (comp test
e))
+ (-> (apply (-> (lexical
'%loop %loop))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%loop %loop)))))))))
((while ,test ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
(-> (letrec '(%continue) (list %continue)
- (list (-> (lambda '() '() '()
- (-> (if (@impl ->boolean (comp test
e))
- (-> (begin (comp statement e)
- (-> (apply (->
(lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ ,(-> (if (@impl ->boolean (comp test
e))
+ (-> (begin (comp statement
e)
+ (-> (apply (->
(lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
(-> (letrec '(%continue) (list %continue)
- (list (-> (lambda '() '() '()
- (-> (if (if test
- (@impl ->boolean (comp
test e))
- (comp 'true e))
- (-> (begin (comp statement e)
- (comp (or inc
'(begin)) e)
- (-> (apply (->
(lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ ,(-> (if (if test
+ (@impl ->boolean (comp
test e))
+ (comp 'true e))
+ (-> (begin (comp statement
e)
+ (comp (or inc
'(begin)) e)
+ (-> (apply (->
(lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e)
(-> (apply (-> (lexical '%continue
%continue)))))))))))
@@ -476,18 +488,20 @@
(let ((e (econs '%enum %enum (econs '%continue %continue e))))
(-> (letrec '(%enum %continue) (list %enum %continue)
(list (@impl make-enumerator (comp object e))
- (-> (lambda '() '() '()
- (-> (if (@impl ->boolean
- (@impl pget
- (-> (lexical
'%enum %enum))
- (-> (const
'length))))
- (-> (begin
- (comp `(= ,var
(call/this ,(-> (lexical '%enum %enum))
-
,(-> (const 'pop))))
- e)
- (comp statement e)
- (-> (apply (-> (lexical
'%continue %continue))))))
- (@implv *undefined*))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ (-> (if (@impl ->boolean
+ (@impl pget
+ (-> (lexical
'%enum %enum))
+ (-> (const
'length))))
+ (-> (begin
+ (comp `(= ,var
(call/this ,(-> (lexical '%enum %enum))
+
,(-> (const 'pop))))
+ e)
+ (comp statement e)
+ (-> (apply (->
(lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%continue %continue)))))))))
((block ,x)
@@ -495,18 +509,22 @@
(else
(error "compilation not yet implemented:" x)))))
-(define (comp-body e body formals %args)
+(define (comp-body e body formals formal-syms)
(define (process)
- (let lp ((in body) (out '()) (rvars (reverse formals)))
+ (let lp ((in body) (out '()) (rvars '()))
(pmatch in
(((var (,x) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
out
- (if (memq x rvars) rvars (cons x rvars))))
+ (if (or (memq x rvars) (memq x formals))
+ rvars
+ (cons x rvars))))
(((var (,x ,y) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
`((= (ref ,x) ,y) . ,out)
- (if (memq x rvars) rvars (cons x rvars))))
+ (if (or (memq x rvars) (memq x formals))
+ rvars
+ (cons x rvars))))
(((var) . ,rest)
(lp rest out rvars))
((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
@@ -532,18 +550,6 @@
(syms (map (lambda (x)
(gensym (string-append (symbol->string x) " ")))
names))
- (e (fold acons e names syms)))
- (let ((%argv (lookup %args e)))
- (let lp ((names names) (syms syms))
- (if (null? names)
- ;; fixme: here check for too many args
- (comp out e)
- (-> (let (list (car names)) (list (car syms))
- (list (-> (if (-> (apply (-> (primitive 'null?)) %argv))
- (-> (@implv *undefined*))
- (-> (let1 (-> (apply (-> (primitive
'car)) %argv))
- (lambda (v)
- (-> (set! %argv
- (-> (apply (-> (primitive
'cdr)) %argv))))
- (-> (lexical v v))))))))
- (lp (cdr names) (cdr syms))))))))))
+ (e (fold econs (fold econs e formals formal-syms) names syms)))
+ (-> (let names syms (map (lambda (x) (->@implv *undefined*)) names)
+ (comp out e))))))
diff --git a/module/language/glil.scm b/module/language/glil.scm
index bfe81ef..1c46541 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -24,9 +24,20 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:export
(<glil-program> make-glil-program glil-program?
- glil-program-nargs glil-program-nrest glil-program-nlocs
glil-program-meta glil-program-body
+ <glil-std-prelude> make-glil-std-prelude glil-std-prelude?
+ glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label
+
+ <glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
+ glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest
+ glil-opt-prelude-nlocs glil-opt-prelude-else-label
+
+ <glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
+ glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
+ glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest
+ glil-kw-prelude-nlocs glil-kw-prelude-else-label
+
<glil-bind> make-glil-bind glil-bind?
glil-bind-vars
@@ -71,7 +82,10 @@
(define-type (<glil> #:printer print-glil)
;; Meta operations
- (<glil-program> nargs nrest nlocs meta body)
+ (<glil-program> meta body)
+ (<glil-std-prelude> nreq nlocs else-label)
+ (<glil-opt-prelude> nreq nopt rest nlocs else-label)
+ (<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
(<glil-unbind>)
@@ -93,8 +107,14 @@
(define (parse-glil x)
(pmatch x
- ((program ,nargs ,nrest ,nlocs ,meta . ,body)
- (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
+ ((program ,meta . ,body)
+ (make-glil-program meta (map parse-glil body)))
+ ((std-prelude ,nreq ,nlocs ,else-label)
+ (make-glil-std-prelude nreq nlocs else-label))
+ ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)
+ (make-glil-opt-prelude nreq nopt rest nlocs else-label))
+ ((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)
+ (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs
else-label))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind))
@@ -114,8 +134,14 @@
(define (unparse-glil glil)
(record-case glil
;; meta
- ((<glil-program> nargs nrest nlocs meta body)
- `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
+ ((<glil-program> meta body)
+ `(program ,meta ,@(map unparse-glil body)))
+ ((<glil-std-prelude> nreq nlocs else-label)
+ `(std-prelude ,nreq ,nlocs ,else-label))
+ ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
+ `(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label))
+ ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
+ `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind))
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index 1bae321..171032b 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -68,13 +68,13 @@
(else
(lp (cdr in) out filename)))))))
-(define (make-meta bindings sources tail)
+(define (make-meta bindings sources arities tail)
(if (and (null? bindings) (null? sources) (null? tail))
#f
(compile-assembly
- (make-glil-program 0 0 0 '()
+ (make-glil-program '()
(list
- (make-glil-const `(,bindings ,sources ,@tail))
+ (make-glil-const `(,bindings ,sources ,arities
,@tail))
(make-glil-call 'return 1))))))
;; A functional stack of names of live variables.
@@ -128,24 +128,39 @@
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil #t '(()) '() '() #f -1)
+ (glil->assembly glil #t '(()) '() '() #f '() -1)
(car code)))
(define (make-object-table objects)
(and (not (null? objects))
(list->vector (cons #f objects))))
+;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
+(define (begin-arity addr nreq nopt rest kw arities)
+ (cons
+ (cond
+ (kw (list addr nreq nopt rest kw))
+ (rest (list addr nreq nopt rest))
+ (nopt (list addr nreq nopt))
+ (nreq (list addr nreq))
+ (else (list addr)))
+ arities))
+
(define (glil->assembly glil toplevel? bindings
- source-alist label-alist object-alist addr)
+ source-alist label-alist object-alist arities addr)
(define (emit-code x)
- (values x bindings source-alist label-alist object-alist))
+ (values x bindings source-alist label-alist object-alist arities))
(define (emit-code/object x object-alist)
- (values x bindings source-alist label-alist object-alist))
-
+ (values x bindings source-alist label-alist object-alist arities))
+ (define (emit-code/arity x nreq nopt rest kw)
+ (values x bindings source-alist label-alist object-alist
+ (begin-arity (addr+ addr x) nreq nopt rest kw arities)))
+
(record-case glil
- ((<glil-program> nargs nrest nlocs meta body)
+ ((<glil-program> meta body)
(define (process-body)
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
- (label-alist '()) (object-alist (if toplevel? #f '())) (addr
0))
+ (label-alist '()) (object-alist (if toplevel? #f '()))
+ (arities '()) (addr 0))
(cond
((null? body)
(values (reverse code)
@@ -153,20 +168,23 @@
(limn-sources (reverse! source-alist))
(reverse label-alist)
(and object-alist (map car (reverse object-alist)))
+ (reverse arities)
addr))
(else
- (receive (subcode bindings source-alist label-alist object-alist)
+ (receive (subcode bindings source-alist label-alist object-alist
+ arities)
(glil->assembly (car body) #f bindings
- source-alist label-alist object-alist addr)
+ source-alist label-alist object-alist
+ arities addr)
(lp (cdr body) (append (reverse subcode) code)
- bindings source-alist label-alist object-alist
+ bindings source-alist label-alist object-alist arities
(addr+ addr subcode)))))))
- (receive (code bindings sources labels objects len)
+ (receive (code bindings sources labels objects arities len)
(process-body)
- (let* ((meta (make-meta bindings sources meta))
+ (let* ((meta (make-meta bindings sources arities meta))
(meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
- (prog `(load-program ,nargs ,nrest ,nlocs ,labels
+ (prog `(load-program ,labels
,(+ len meta-pad)
,meta
,@code
@@ -200,33 +218,132 @@
`(,@table-code
,@(align-program prog (addr+ addr table-code)))))))))))))
+ ((<glil-std-prelude> nreq nlocs else-label)
+ (emit-code/arity
+ `(,(if else-label
+ `(br-if-nargs-ne ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,else-label)
+ `(assert-nargs-ee ,(quotient nreq 256)
+ ,(modulo nreq 256)))
+ (reserve-locals ,(quotient nlocs 256)
+ ,(modulo nlocs 256)))
+ nreq #f #f #f))
+
+ ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
+ (let ((bind-required
+ (if else-label
+ `((br-if-nargs-lt ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,else-label))
+ `((assert-nargs-ge ,(quotient nreq 256)
+ ,(modulo nreq 256)))))
+ (bind-optionals
+ (if (zero? nopt)
+ '()
+ `((bind-optionals ,(quotient (+ nopt nreq) 256)
+ ,(modulo (+ nreq nopt) 256)))))
+ (bind-rest
+ (cond
+ (rest
+ `((push-rest ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256))))
+ (else
+ (if else-label
+ `((br-if-nargs-gt ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256)
+ ,else-label))
+ `((assert-nargs-ee ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256))))))))
+ (emit-code/arity
+ `(,@bind-required
+ ,@bind-optionals
+ ,@bind-rest
+ (reserve-locals ,(quotient nlocs 256)
+ ,(modulo nlocs 256)))
+ nreq nopt rest #f)))
+
+ ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
+ (receive (kw-idx object-alist)
+ (object-index-and-alist kw object-alist)
+ (let* ((bind-required
+ (if else-label
+ `((br-if-nargs-lt ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,else-label))
+ `((assert-nargs-ge ,(quotient nreq 256)
+ ,(modulo nreq 256)))))
+ (ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw))))
+ (bind-optionals-and-shuffle
+ `((bind-optionals/shuffle
+ ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256)
+ ,(quotient ntotal 256)
+ ,(modulo ntotal 256))))
+ (bind-kw
+ ;; when this code gets called, all optionals are filled
+ ;; in, space has been made for kwargs, and the kwargs
+ ;; themselves have been shuffled above the slots for all
+ ;; req/opt/kwargs locals.
+ `((bind-kwargs
+ ,(quotient kw-idx 256)
+ ,(modulo kw-idx 256)
+ ,(quotient ntotal 256)
+ ,(modulo ntotal 256)
+ ,(logior (if rest 2 0)
+ (if allow-other-keys? 1 0)))))
+ (bind-rest
+ (if rest
+ `((bind-rest ,(quotient ntotal 256)
+ ,(modulo ntotal 256)
+ ,(quotient rest 256)
+ ,(modulo rest 256)))
+ '())))
+
+ (let ((code `(,@bind-required
+ ,@bind-optionals-and-shuffle
+ ,@bind-kw
+ ,@bind-rest
+ (reserve-locals ,(quotient nlocs 256)
+ ,(modulo nlocs 256)))))
+ (values code bindings source-alist label-alist object-alist
+ (begin-arity (addr+ addr code) nreq nopt rest
+ (and kw (cons allow-other-keys? kw))
+ arities))))))
+
((<glil-bind> vars)
(values '()
(open-binding bindings vars addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
(open-binding bindings vars addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-unbind>)
(values '()
(close-binding bindings addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-source> props)
(values '()
bindings
(acons addr props source-alist)
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-void>)
(emit-code '((void))))
@@ -261,6 +378,10 @@
((box) `((box ,index)))
((empty-box) `((empty-box ,index)))
((fix) `((fix-closure 0 ,index)))
+ ((bound?) (if boxed?
+ `((local-ref ,index)
+ (variable-bound?))
+ `((local-bound? ,index))))
(else (error "what" op)))
(let ((a (quotient index 256))
(b (modulo index 256)))
@@ -284,6 +405,11 @@
(long-local-set ,a ,b)))
((fix)
`((fix-closure ,a ,b)))
+ ((bound?)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-bound?))
+ `((long-local-bound? ,a ,b))))
(else (error "what" op)))
,index))))
`((,(case op
@@ -351,7 +477,8 @@
bindings
source-alist
(acons label (addr+ addr code) label-alist)
- object-alist)))
+ object-alist
+ arities)))
((<glil-branch> inst label)
(emit-code `((,inst ,label))))
diff --git a/module/language/glil/decompile-assembly.scm
b/module/language/glil/decompile-assembly.scm
index 3cb887d..937a678 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -31,9 +31,8 @@
(define (decompile-toplevel x)
(pmatch x
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
- (decompile-load-program nargs nrest nlocs
- (decompile-meta meta)
+ ((load-program ,labels ,len ,meta . ,body)
+ (decompile-load-program (decompile-meta meta)
body labels #f))
(else
(error "invalid assembly" x))))
@@ -56,7 +55,7 @@
((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
(else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
-(define (decompile-load-program nargs nrest nlocs meta body labels
+(define (decompile-load-program meta body labels
objects)
(let ((glil-labels (sort (map (lambda (x)
(cons (cdr x) (make-glil-label (car x))))
@@ -100,7 +99,7 @@
(cond
((null? in)
(or (null? stack) (error "leftover stack insts" stack body))
- (make-glil-program nargs nrest nlocs props (reverse out) #f))
+ (make-glil-program props (reverse out)))
((pop-bindings! pos)
=> (lambda (bindings)
(lp in stack
@@ -123,9 +122,9 @@
(lp (cdr in) stack out (1+ pos)))
((make-false)
(lp (cdr in) (cons #f stack) out (1+ pos)))
- ((load-program ,a ,b ,c ,d ,labels ,sublen ,meta . ,body)
+ ((load-program ,labels ,sublen ,meta . ,body)
(lp (cdr in)
- (cons (decompile-load-program a b c d (decompile-meta meta)
+ (cons (decompile-load-program (decompile-meta meta)
body labels (car stack))
(cdr stack))
out
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1233632..e6a8213 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -36,11 +36,15 @@
<conditional> conditional? make-conditional conditional-src
conditional-test conditional-then conditional-else
<application> application? make-application application-src
application-proc application-args
<sequence> sequence? make-sequence sequence-src sequence-exps
- <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars
lambda-meta lambda-body
+ <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
+ <lambda-case> lambda-case? make-lambda-case lambda-case-src
+ lambda-case-req lambda-case-opt lambda-case-rest
lambda-case-kw
+ lambda-case-inits lambda-case-vars
+ lambda-case-predicate lambda-case-body
lambda-case-else
<let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars
letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
- <let-values> let-values? make-let-values let-values-src
let-values-names let-values-vars let-values-exp let-values-body
+ <let-values> let-values? make-let-values let-values-src
let-values-exp let-values-body
parse-tree-il
unparse-tree-il
@@ -65,11 +69,12 @@
(<conditional> test then else)
(<application> proc args)
(<sequence> exps)
- (<lambda> names vars meta body)
+ (<lambda> meta body)
+ (<lambda-case> req opt rest kw inits vars predicate body else)
(<let> names vars vals body)
(<letrec> names vars vals body)
(<fix> names vars vals body)
- (<let-values> names vars exp body))
+ (<let-values> exp body))
@@ -127,11 +132,22 @@
((define ,name ,exp) (guard (symbol? name))
(make-toplevel-define loc name (retrans exp)))
- ((lambda ,names ,vars ,exp)
- (make-lambda loc names vars '() (retrans exp)))
+ ((lambda ,meta ,body)
+ (make-lambda loc meta (retrans body)))
- ((lambda ,names ,vars ,meta ,exp)
- (make-lambda loc names vars meta (retrans exp)))
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars ,predicate) ,body) ,else)
+ (make-lambda-case loc req opt rest kw
+ (map retrans inits) vars
+ (and=> predicate retrans)
+ (retrans body)
+ (and=> else retrans)))
+
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars ,predicate) ,body))
+ (make-lambda-case loc req opt rest kw
+ (map retrans inits) vars
+ (and=> predicate retrans)
+ (retrans body)
+ #f))
((const ,exp)
(make-const loc exp))
@@ -148,8 +164,8 @@
((fix ,names ,vars ,vals ,body)
(make-fix loc names vars (map retrans vals) (retrans body)))
- ((let-values ,names ,vars ,exp ,body)
- (make-let-values loc names vars (retrans exp) (retrans body)))
+ ((let-values ,exp ,body)
+ (make-let-values loc (retrans exp) (retrans body)))
(else
(error "unrecognized tree-il" exp)))))
@@ -189,8 +205,14 @@
((<toplevel-define> name exp)
`(define ,name ,(unparse-tree-il exp)))
- ((<lambda> names vars meta body)
- `(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
+ ((<lambda> meta body)
+ `(lambda ,meta ,(unparse-tree-il body)))
+
+ ((<lambda-case> req opt rest kw inits vars predicate body else)
+ `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars
+ ,(and=> predicate unparse-tree-il))
+ ,(unparse-tree-il body))
+ . ,(if else (list (unparse-tree-il else)) '())))
((<const> exp)
`(const ,exp))
@@ -207,8 +229,8 @@
((<fix> names vars vals body)
`(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<let-values> names vars exp body)
- `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il
body)))))
+ ((<let-values> exp body)
+ `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
(define (tree-il->scheme e)
(record-case e
@@ -247,10 +269,18 @@
((<toplevel-define> name exp)
`(define ,name ,(tree-il->scheme exp)))
- ((<lambda> vars meta body)
- `(lambda ,vars
- ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
- ,(tree-il->scheme body)))
+ ((<lambda> meta body)
+ ;; fixme: put in docstring
+ (if (and (lambda-case? body)
+ (not (lambda-case-else body)))
+ `(lambda ,@(car (tree-il->scheme body)))
+ `(case-lambda ,@(tree-il->scheme body))))
+
+ ((<lambda-case> req opt rest kw inits vars predicate body else)
+ ;; FIXME! use parse-lambda-case?
+ `((,(if rest (apply cons* vars) vars)
+ ,(tree-il->scheme body))
+ ,@(if else (tree-il->scheme else) '())))
((<const> exp)
(if (and (self-evaluating? exp) (not (vector? exp)))
@@ -272,7 +302,7 @@
((<let-values> vars exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
- (lambda ,vars ,(tree-il->scheme body))))))
+ ,(tree-il->scheme (make-lambda #f '() body))))))
(define (tree-il-fold leaf down up seed tree)
@@ -306,6 +336,15 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(up tree (loop exps (down tree result))))
((<lambda> body)
(up tree (loop body (down tree result))))
+ ((<lambda-case> inits predicate body else)
+ (up tree (if else
+ (loop else
+ (if predicate
+ (loop body (loop predicate (loop inits (down
tree result))))
+ (loop body (loop inits (down tree result)))))
+ (if predicate
+ (loop body (loop predicate (loop inits (down tree
result))))
+ (loop body (loop inits (down tree result)))))))
((<let> vals body)
(up tree (loop body
(loop vals
@@ -357,6 +396,19 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(fold-values foldts exps seed ...))
((<lambda> body)
(foldts body seed ...))
+ ((<lambda-case> inits predicate body else)
+ (let-values (((seed ...) (fold-values foldts inits seed
...)))
+ (if predicate
+ (if else
+ (let*-values (((seed ...) (foldts predicate seed
...))
+ ((seed ...) (foldts body seed ...)))
+ (foldts else seed ...))
+ (let-values (((seed ...) (foldts predicate seed
...)))
+ (foldts body seed ...)))
+ (if else
+ (let-values (((seed ...) (foldts body seed ...)))
+ (foldts else seed ...))
+ (foldts body seed ...)))))
((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed
...)))
(foldts body seed ...)))
@@ -397,9 +449,17 @@ This is an implementation of `foldts' as described by Andy
Wingo in
((<toplevel-define> name exp)
(set! (toplevel-define-exp x) (lp exp)))
- ((<lambda> vars meta body)
+ ((<lambda> body)
(set! (lambda-body x) (lp body)))
+ ((<lambda-case> inits predicate body else)
+ (set! inits (map lp inits))
+ (if predicate
+ (set! (lambda-case-predicate x) (lp predicate)))
+ (set! (lambda-case-body x) (lp body))
+ (if else
+ (set! (lambda-case-else x) (lp else))))
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
@@ -415,7 +475,7 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
- ((<let-values> vars exp body)
+ ((<let-values> exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
@@ -451,6 +511,12 @@ This is an implementation of `foldts' as described by Andy
Wingo in
((<lambda> body)
(set! (lambda-body x) (lp body)))
+ ((<lambda-case> inits predicate body else)
+ (set! inits (map lp inits))
+ (if predicate (set! (lambda-case-predicate x) (lp predicate)))
+ (set! (lambda-case-body x) (lp body))
+ (if else (set! (lambda-case-else x) (lp else))))
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index d689559..5faed6f 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -112,13 +112,20 @@
;; translated into labels, and information on what free variables to
;; capture from its lexical parent procedure.
;;
+;; In addition, we have a conflation: while we're traversing the code,
+;; recording information to pass to the compiler, we take the
+;; opportunity to generate labels for each lambda-case clause, so that
+;; generated code can skip argument checks at runtime if they match at
+;; compile-time.
+;;
;; That is:
;;
;; sym -> {lambda -> address}
-;; lambda -> (nlocs labels . free-locs)
+;; lambda -> (labels . free-locs)
+;; lambda-case -> (gensym . nlocs)
;;
;; address ::= (local? boxed? . index)
-;; labels ::= ((sym . lambda-vars) ...)
+;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
@@ -141,9 +148,9 @@
;; refcounts: sym -> count
;; allows us to detect the or-expansion in O(1) time
(define refcounts (make-hash-table))
- ;; labels: sym -> lambda-vars
+ ;; labels: sym -> lambda
;; for determining if fixed-point procedures can be rendered as
- ;; labels. lambda-vars may be an improper list.
+ ;; labels.
(define labels (make-hash-table))
;; returns variables referenced in expr
@@ -167,9 +174,21 @@
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(if (not (and tail-call-args
(memq gensym labels-in-proc)
- (let ((args (hashq-ref labels gensym)))
- (and (list? args)
- (= (length args) (length tail-call-args))))))
+ (let ((p (hashq-ref labels gensym)))
+ (and p
+ (let lp ((c (lambda-body p)))
+ (and c (lambda-case? c)
+ (or
+ ;; for now prohibit optional &
+ ;; keyword arguments; can relax this
+ ;; restriction later
+ (and (= (length (lambda-case-req c))
+ (length tail-call-args))
+ (not (lambda-case-opt c))
+ (not (lambda-case-kw c))
+ (not (lambda-case-rest c))
+ (not (lambda-case-predicate c)))
+ (lp (lambda-case-else c)))))))))
(hashq-set! labels gensym #f))
(list gensym))
@@ -195,19 +214,26 @@
(else
(lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
- ((<lambda> vars body)
- (let ((locally-bound (let rev* ((vars vars) (out '()))
- (cond ((null? vars) out)
- ((pair? vars) (rev* (cdr vars)
- (cons (car vars) out)))
- (else (cons vars out))))))
- (hashq-set! bound-vars x locally-bound)
- (let* ((referenced (recur body x))
- (free (lset-difference eq? referenced locally-bound))
- (all-bound (reverse! (hashq-ref bound-vars x))))
- (hashq-set! bound-vars x all-bound)
- (hashq-set! free-vars x free)
- free)))
+ ((<lambda> body)
+ ;; order is important here
+ (hashq-set! bound-vars x '())
+ (let ((free (recur body x)))
+ (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
+ (hashq-set! free-vars x free)
+ free))
+
+ ((<lambda-case> opt kw inits vars predicate body else)
+ (hashq-set! bound-vars proc
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ (lset-union
+ eq?
+ (lset-difference eq?
+ (lset-union eq?
+ (apply lset-union eq? (map step inits))
+ (if predicate (step predicate) '())
+ (step-tail body))
+ vars)
+ (if else (step-tail else) '())))
((<let> vars vals body)
(hashq-set! bound-vars proc
@@ -226,7 +252,7 @@
((<fix> vars vals body)
;; Try to allocate these procedures as labels.
- (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val)))
+ (for-each (lambda (sym val) (hashq-set! labels sym val))
vars vals)
(hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc)))
@@ -240,21 +266,14 @@
;; prevent label allocation.)
(lambda (x)
(record-case x
- ((<lambda> (lvars vars) body)
- (let ((locally-bound
- (let rev* ((lvars lvars) (out '()))
- (cond ((null? lvars) out)
- ((pair? lvars) (rev* (cdr lvars)
- (cons (car lvars)
out)))
- (else (cons lvars out))))))
- (hashq-set! bound-vars x locally-bound)
- ;; recur/labels, the difference from the closure case
- (let* ((referenced (recur/labels body x vars))
- (free (lset-difference eq? referenced
locally-bound))
- (all-bound (reverse! (hashq-ref bound-vars x))))
- (hashq-set! bound-vars x all-bound)
- (hashq-set! free-vars x free)
- free)))))
+ ((<lambda> body)
+ ;; just like the closure case, except here we use
+ ;; recur/labels instead of recur
+ (hashq-set! bound-vars x '())
+ (let ((free (recur/labels body x vars)))
+ (hashq-set! bound-vars x (reverse! (hashq-ref
bound-vars x)))
+ (hashq-set! free-vars x free)
+ free))))
vals))
(vars-with-refs (map cons vars var-refs))
(body-refs (recur/labels body proc vars)))
@@ -302,15 +321,8 @@
(apply lset-union eq? body-refs var-refs)
vars)))
- ((<let-values> vars exp body)
- (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
- (if (pair? in)
- (lp (cons (car in) out) (cdr in))
- (if (null? in) out (cons in out))))))
- (hashq-set! bound-vars proc bound)
- (lset-difference eq?
- (lset-union eq? (step exp) (step-tail body))
- bound)))
+ ((<let-values> exp body)
+ (lset-union eq? (step exp) (step body)))
(else '())))
@@ -342,7 +354,7 @@
((<sequence> exps)
(apply max (map recur exps)))
- ((<lambda> vars body)
+ ((<lambda> body)
;; allocate closure vars in order
(let lp ((c (hashq-ref free-vars x)) (n 0))
(if (pair? c)
@@ -352,17 +364,7 @@
`(#f ,(hashq-ref assigned (car c)) . ,n))
(lp (cdr c) (1+ n)))))
- (let ((nlocs
- (let lp ((vars vars) (n 0))
- (if (not (null? vars))
- ;; allocate args
- (let ((v (if (pair? vars) (car vars) vars)))
- (hashq-set! allocation v
- (make-hashq
- x `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
- ;; allocate body, return number of additional locals
- (- (allocate! body x n) n))))
+ (let ((nlocs (allocate! body x 0))
(free-addresses
(map (lambda (v)
(hashq-ref (hashq-ref allocation v) proc))
@@ -372,9 +374,30 @@
(cons sym (hashq-ref labels sym)))
(hashq-ref bound-vars x)))))
;; set procedure allocations
- (hashq-set! allocation x (cons* nlocs labels free-addresses)))
+ (hashq-set! allocation x (cons labels free-addresses)))
n)
+ ((<lambda-case> opt kw inits vars predicate body else)
+ (max
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (let ((nlocs (apply
+ max
+ (if predicate (allocate! predicate body n) n)
+ (allocate! body proc n)
+ ;; inits not logically at the end, but they
+ ;; are the list...
+ (map (lambda (x) (allocate! x body n)) inits))))
+ ;; label and nlocs for the case
+ (hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
+ nlocs)
+ (begin
+ (hashq-set! allocation (car vars)
+ (make-hashq
+ proc `(#t ,(hashq-ref assigned (car vars)) . ,n)))
+ (lp (cdr vars) (1+ n)))))
+ (if else (allocate! else proc n) n)))
+
((<let> vars vals body)
(let ((nmax (apply max (map recur vals))))
(cond
@@ -426,22 +449,12 @@
((null? vars)
(max nmax (allocate! body proc n)))
((hashq-ref labels (car vars))
- ;; allocate label bindings & body inline to proc
+ ;; allocate lambda body inline to proc
(lp (cdr vars)
(cdr vals)
(record-case (car vals)
- ((<lambda> vars body)
- (let lp ((vars vars) (n n))
- (if (not (null? vars))
- ;; allocate bindings
- (let ((v (if (pair? vars) (car vars) vars)))
- (hashq-set!
- allocation v
- (make-hashq
- proc `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
- ;; allocate body
- (max nmax (allocate! body proc n))))))))
+ ((<lambda> body)
+ (max nmax (allocate! body proc n))))))
(else
;; allocate closure
(lp (cdr vars)
@@ -460,25 +473,8 @@
(hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
(lp (cdr in) (1+ n))))))))
- ((<let-values> vars exp body)
- (let ((nmax (recur exp)))
- (let lp ((vars vars) (n n))
- (cond
- ((null? vars)
- (max nmax (allocate! body proc n)))
- ((not (pair? vars))
- (hashq-set! allocation vars
- (make-hashq proc
- `(#t ,(hashq-ref assigned vars) . ,n)))
- ;; the 1+ for this var
- (max nmax (allocate! body proc (1+ n))))
- (else
- (let ((v (car vars)))
- (hashq-set!
- allocation v
- (make-hashq proc
- `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (cdr vars) (1+ n))))))))
+ ((<let-values> exp body)
+ (max (recur exp) (recur body)))
(else n)))
@@ -503,21 +499,10 @@
(refs binding-info-refs) ;; (GENSYM ...)
(locs binding-info-locs)) ;; (LOCATION ...)
+;; FIXME!!
(define (report-unused-variables tree env)
"Report about unused variables in TREE. Return TREE."
- (define (dotless-list lst)
- ;; If LST is a dotted list, return a proper list equal to LST except that
- ;; the very last element is a pair; otherwise return LST.
- (let loop ((lst lst)
- (result '()))
- (cond ((null? lst)
- (reverse result))
- ((pair? lst)
- (loop (cdr lst) (cons (car lst) result)))
- (else
- (loop '() (cons lst result))))))
-
(tree-il-fold (lambda (x info)
;; X is a leaf: extend INFO's refs accordingly.
(let ((refs (binding-info-refs info))
@@ -545,9 +530,12 @@
((<lexical-set> gensym)
(make-binding-info vars (cons gensym refs)
(cons src locs)))
- ((<lambda> vars names)
- (let ((vars (dotless-list vars))
- (names (dotless-list names)))
+ ((<lambda-case> req opt inits rest kw vars)
+ ;; FIXME keywords.
+ (let ((names `(,@req
+ ,@(map car (or opt '()))
+ ,@(if rest (list rest) '())
+ ,@(if kw (map cadr (cdr kw)) '()))))
(make-binding-info (extend vars names) refs
(cons src locs))))
((<let> vars names)
@@ -559,9 +547,6 @@
((<fix> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
- ((<let-values> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
(else info))))
(lambda (x info)
@@ -576,7 +561,7 @@
;; Don't report lambda parameters as
;; unused.
(if (and (not (memq gensym refs))
- (not (and (lambda? x)
+ (not (and (lambda-case? x)
(memq gensym
inner-vars))))
(let ((name (cadr var))
@@ -596,10 +581,9 @@
;; It doesn't hurt as these are unique names, it just
;; makes REFS unnecessarily fat.
(record-case x
- ((<lambda> vars)
- (let ((vars (dotless-list vars)))
- (make-binding-info (shrink vars refs) refs
- (cdr locs))))
+ ((<lambda-case> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
((<let> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
@@ -609,9 +593,6 @@
((<fix> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
- ((<let-values> vars)
- (make-binding-info (shrink vars refs) refs
- (cdr locs)))
(else info))))
(make-binding-info '() '() '())
tree)
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 94e1904..191f1bf 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -32,9 +32,11 @@
;; allocation:
;; sym -> {lambda -> address}
-;; lambda -> (nlocs labels . free-locs)
+;; lambda -> (labels . free-locs)
+;; lambda-case -> (gensym . nlocs)
;;
-;; address := (local? boxed? . index)
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
@@ -56,7 +58,8 @@
(warn x e))))
warnings)
- (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+ (let* ((x (make-lambda (tree-il-src x) '()
+ (make-lambda-case #f '() #f #f #f '() '() #f x #f)))
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
@@ -173,41 +176,21 @@
(reverse out)))
(define (flatten-lambda x self-label allocation)
- (receive (ids vars nargs nrest)
- (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
- (oids '()) (ovars '()) (n 0))
- (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
- ((pair? vars) (lp (cdr ids) (cdr vars)
- (cons (car ids) oids) (cons (car vars) ovars)
- (1+ n)))
- (else (values (reverse (cons ids oids))
- (reverse (cons vars ovars))
- (1+ n) 1))))
- (let ((nlocs (car (hashq-ref allocation x)))
- (labels (cadr (hashq-ref allocation x))))
- (make-glil-program
- nargs nrest nlocs (lambda-meta x)
- (with-output-to-code
- (lambda (emit-code)
- ;; emit label for self tail calls
- (if self-label
- (emit-code #f (make-glil-label self-label)))
- ;; write bindings and source debugging info
- (if (not (null? ids))
- (emit-bindings #f ids vars allocation x emit-code))
- (if (lambda-src x)
- (emit-code #f (make-glil-source (lambda-src x))))
- ;; box args if necessary
- (for-each
- (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) x)
- ((#t #t . ,n)
- (emit-code #f (make-glil-lexical #t #f 'ref n))
- (emit-code #f (make-glil-lexical #t #t 'box n)))))
- vars)
- ;; and here, here, dear reader: we compile.
- (flatten (lambda-body x) allocation x self-label
- labels emit-code)))))))
+ (record-case x
+ ((<lambda> src meta body)
+ (make-glil-program
+ meta
+ (with-output-to-code
+ (lambda (emit-code)
+ ;; write source info for proc
+ (if src (emit-code #f (make-glil-source src)))
+ ;; emit pre-prelude label for self tail calls in which the
+ ;; number of arguments doesn't check out at compile time
+ (if self-label
+ (emit-code #f (make-glil-label self-label)))
+ ;; compile the body, yo
+ (flatten body allocation x self-label (car (hashq-ref allocation x))
+ emit-code)))))))
(define (flatten x allocation self self-label fix-labels emit-code)
(define (emit-label label)
@@ -404,43 +387,78 @@
(error "bad primitive op: too many pushes"
op (instruction-pushes op))))))
- ;; da capo al fine
+ ;; self-call in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
- ;; self-call in tail position is a goto
- (eq? context 'tail)
- ;; make sure the arity is right
- (list? (lambda-vars self))
- (= (length args) (length (lambda-vars self))))
- ;; evaluate new values
+ (eq? context 'tail))
+ ;; first, evaluate new values, pushing them on the stack
(for-each comp-push args)
- ;; rename & goto
- (for-each (lambda (sym)
- (pmatch (hashq-ref (hashq-ref allocation sym) self)
- ((#t ,boxed? . ,index)
- ;; set unboxed, as the proc prelude will box if needed
- (emit-code #f (make-glil-lexical #t #f 'set index)))
- (,x (error "what" x))))
- (reverse (lambda-vars self)))
- (emit-branch src 'br self-label))
+ (let lp ((lcase (lambda-body self)))
+ (cond
+ ((and (lambda-case? lcase)
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-opt lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args) (length (lambda-case-req lcase))))
+ ;; we have a case that matches the args; rename variables
+ ;; and goto the case label
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index) ; unboxed
+ (emit-code #f (make-glil-lexical #t #f 'set
index)))
+ ((#t #t . ,index) ; boxed
+ ;; new box
+ (emit-code #f (make-glil-lexical #t #t 'box
index)))
+ (,x (error "what" x))))
+ (reverse (lambda-case-vars lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
+ ((lambda-case? lcase)
+ ;; no match, try next case
+ (lp (lambda-case-else lcase)))
+ (else
+ ;; no cases left; shuffle args down and jump before the prelude.
+ (for-each (lambda (i)
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ (reverse (iota (length args))))
+ (emit-branch src 'br self-label)))))
;; lambda, the ultimate goto
((and (lexical-ref? proc)
(assq (lexical-ref-gensym proc) fix-labels))
- ;; evaluate new values, assuming that analyze-lexicals did its
- ;; job, and that the arity was right
+ ;; like the self-tail-call case, though we can handle "drop"
+ ;; contexts too. first, evaluate new values, pushing them on
+ ;; the stack
(for-each comp-push args)
- ;; rename
- (for-each (lambda (sym)
- (pmatch (hashq-ref (hashq-ref allocation sym) self)
- ((#t #f . ,index)
- (emit-code #f (make-glil-lexical #t #f 'set index)))
- ((#t #t . ,index)
- (emit-code #f (make-glil-lexical #t #t 'box index)))
- (,x (error "what" x))))
- (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
- ;; goto!
- (emit-branch src 'br (lexical-ref-gensym proc)))
+ ;; find the specific case, rename args, and goto the case label
+ (let lp ((lcase (lambda-body
+ (assq-ref fix-labels (lexical-ref-gensym proc)))))
+ (cond
+ ((and (lambda-case? lcase)
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-opt lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args) (length (lambda-case-req lcase))))
+ ;; we have a case that matches the args; rename variables
+ ;; and goto the case label
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index) ; unboxed
+ (emit-code #f (make-glil-lexical #t #f 'set
index)))
+ ((#t #t . ,index) ; boxed
+ (emit-code #f (make-glil-lexical #t #t 'box
index)))
+ (,x (error "what" x))))
+ (reverse (lambda-case-vars lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
+ ((lambda-case? lcase)
+ ;; no match, try next case
+ (lp (lambda-case-else lcase)))
+ (else
+ ;; no cases left. we can't really handle this currently.
+ ;; ideally we would push on a new frame, then do a "local
+ ;; call" -- which doesn't require consing up a program
+ ;; object. but for now error, as this sort of case should
+ ;; preclude label allocation.
+ (error "couldn't find matching case for label call" x)))))
(else
(if (not (eq? context 'tail))
@@ -564,7 +582,7 @@
(maybe-emit-return))
((<lambda>)
- (let ((free-locs (cddr (hashq-ref allocation x))))
+ (let ((free-locs (cdr (hashq-ref allocation x))))
(case context
((push vals tail)
(emit-code #f (flatten-lambda x #f allocation))
@@ -581,6 +599,110 @@
(emit-code #f (make-glil-call 'make-closure 2)))))))
(maybe-emit-return))
+ ((<lambda-case> src req opt rest kw inits vars predicate else body)
+ ;; o/~ feature on top of feature o/~
+ ;; req := (name ...)
+ ;; opt := (name ...) | #f
+ ;; rest := name | #f
+ ;; kw: (allow-other-keys? (keyword name var) ...) | #f
+ ;; vars: (sym ...)
+ ;; predicate: tree-il in context of vars
+ ;; init: tree-il in context of vars
+ ;; vars map to named arguments in the following order:
+ ;; required, optional (positional), rest, keyword.
+ (let* ((nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (rest-idx (and rest (+ nreq nopt)))
+ (opt-names (or opt '()))
+ (allow-other-keys? (if kw (car kw) #f))
+ (kw-indices (map (lambda (x)
+ (pmatch x
+ ((,key ,name ,var)
+ (cons key (list-index vars var)))
+ (else (error "bad kwarg" x))))
+ (if kw (cdr kw) '())))
+ (nargs (apply max (+ nreq nopt (if rest 1 0))
+ (map 1+ (map cdr kw-indices))))
+ (nlocs (cdr (hashq-ref allocation x)))
+ (else-label (and else (make-label))))
+ (or (= nargs
+ (length vars)
+ (+ nreq (length inits) (if rest 1 0)))
+ (error "something went wrong"
+ req opt rest kw inits vars nreq nopt kw-indices nargs))
+ ;; the prelude, to check args & reset the stack pointer,
+ ;; allowing room for locals
+ (emit-code
+ src
+ (cond
+ (kw
+ (make-glil-kw-prelude nreq nopt rest-idx kw-indices
+ allow-other-keys? nlocs else-label))
+ ((or rest opt)
+ (make-glil-opt-prelude nreq nopt rest-idx nlocs else-label))
+ (#t
+ (make-glil-std-prelude nreq nlocs else-label))))
+ ;; box args if necessary
+ (for-each
+ (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'ref n))
+ (emit-code #f (make-glil-lexical #t #t 'box n)))))
+ vars)
+ ;; write bindings info
+ (if (not (null? vars))
+ (emit-bindings
+ #f
+ (let lp ((kw (if kw (cdr kw) '()))
+ (names (append (reverse opt-names) (reverse req)))
+ (vars (list-tail vars (+ nreq nopt
+ (if rest 1 0)))))
+ (pmatch kw
+ (()
+ ;; fixme: check that vars is empty
+ (reverse (if rest (cons rest names) names)))
+ (((,key ,name ,var) . ,kw)
+ (if (memq var vars)
+ (lp kw (cons name names) (delq var vars))
+ (lp kw names vars)))
+ (,kw (error "bad keywords, yo" kw))))
+ vars allocation self emit-code))
+ ;; init optional/kw args
+ (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq)))
+ (cond
+ ((null? inits)) ; done
+ ((and rest-idx (= n rest-idx))
+ (lp inits (1+ n) (cdr vars)))
+ (#t
+ (pmatch (hashq-ref (hashq-ref allocation (car vars)) self)
+ ((#t ,boxed? . ,n*) (guard (= n* n))
+ (let ((L (make-label)))
+ (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
+ (emit-code #f (make-glil-branch 'br-if L))
+ (comp-push (car inits))
+ (emit-code #f (make-glil-lexical #t boxed? 'set n))
+ (emit-label L)
+ (lp (cdr inits) (1+ n) (cdr vars))))
+ (#t (error "what" inits))))))
+ ;; post-prelude case label for label calls
+ (emit-label (car (hashq-ref allocation x)))
+ (if predicate
+ (begin
+ (comp-push predicate)
+ (if else-label
+ ;; fixme: debox if necessary
+ (emit-branch src 'br-if-not else-label)
+ ;; fixme: better error
+ (emit-code src (make-glil-call 'assert-true 0)))))
+ (comp-tail body)
+ (if (not (null? vars))
+ (emit-code #f (make-glil-unbind)))
+ (if else-label
+ (begin
+ (emit-label else-label)
+ (comp-tail else)))))
+
((<let> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation self emit-code)
@@ -631,7 +753,7 @@
((hashq-ref allocation x)
;; allocating a closure
(emit-code #f (flatten-lambda x v allocation))
- (if (not (null? (cddr (hashq-ref allocation x))))
+ (if (not (null? (cdr (hashq-ref allocation x))))
;; Need to make-closure first, but with a temporary #f
;; free-variables vector, so we are mutating fresh
;; closures on the heap.
@@ -646,15 +768,19 @@
;; labels allocation: emit label & body, but jump over it
(let ((POST (make-label)))
(emit-branch #f 'br POST)
- (emit-label v)
- ;; we know the lambda vars are a list
- (emit-bindings #f (lambda-names x) (lambda-vars x)
- allocation self emit-code)
- (if (lambda-src x)
- (emit-code #f (make-glil-source (lambda-src x))))
- (comp-fix (lambda-body x) (or RA new-RA))
- (emit-code #f (make-glil-unbind))
- (emit-label POST)))))
+ (let lp ((lcase (lambda-body x)))
+ (if lcase
+ (record-case lcase
+ ((<lambda-case> src req vars body else)
+ (emit-label (car (hashq-ref allocation lcase)))
+ ;; FIXME: opt & kw args in the bindings
+ (emit-bindings #f req vars allocation self emit-code)
+ (if src
+ (emit-code #f (make-glil-source src)))
+ (comp-fix body (or RA new-RA))
+ (emit-code #f (make-glil-unbind))
+ (lp else)))
+ (emit-label POST)))))))
vals
vars)
;; Emit bindings metadata for closures
@@ -671,7 +797,7 @@
(for-each
(lambda (x v)
(let ((free-locs (if (hashq-ref allocation x)
- (cddr (hashq-ref allocation x))
+ (cdr (hashq-ref allocation x))
;; can hit this latter case for labels
allocation
'())))
(if (not (null? free-locs))
@@ -695,31 +821,27 @@
(emit-label new-RA))
(emit-code #f (make-glil-unbind))))
- ((<let-values> src names vars exp body)
- (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
- (cond
- ((pair? inames)
- (lp (cons (car inames) names) (cons (car ivars) vars)
- (cdr inames) (cdr ivars) #f))
- ((not (null? inames))
- (lp (cons inames names) (cons ivars vars) '() '() #t))
- (else
- (let ((names (reverse! names))
- (vars (reverse! vars))
- (MV (make-label)))
- (comp-vals exp MV)
- (emit-code #f (make-glil-const 1))
- (emit-label MV)
- (emit-code src (make-glil-mv-bind
- (vars->bind-list names vars allocation self)
- rest?))
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
- (reverse vars))
- (comp-tail body)
- (emit-code #f (make-glil-unbind))))))))))
+ ((<let-values> src exp body)
+ (record-case body
+ ((<lambda-case> req opt kw rest vars predicate body else)
+ (if (or opt kw predicate else)
+ (error "unexpected lambda-case in let-values" x))
+ (let ((MV (make-label)))
+ (comp-vals exp MV)
+ (emit-code #f (make-glil-const 1))
+ (emit-label MV)
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list
+ (append req (if rest (list rest) '()))
+ vars allocation self)
+ (and rest #t)))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "badness" x loc))))
+ (reverse vars))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind)))))))))
diff --git a/module/language/tree-il/inline.scm
b/module/language/tree-il/inline.scm
index adc3f18..9b53ec6 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -17,6 +17,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (language tree-il inline)
+ #:use-module (system base pmatch)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:export (inline!))
@@ -34,16 +35,21 @@
;; This is a completely brain-dead optimization pass whose sole claim to
;; fame is ((lambda () x)) => x.
(define (inline! x)
- (post-order!
- (lambda (x)
- (record-case x
- ((<application> src proc args)
- (cond
-
- ;; ((lambda () x)) => x
- ((and (lambda? proc) (null? (lambda-vars proc))
- (null? args))
- (lambda-body proc))
+ (define (inline1 x)
+ (record-case x
+ ((<application> src proc args)
+ (record-case proc
+ ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
+ ((<lambda> body)
+ (let lp ((lcase body))
+ (and lcase
+ (record-case lcase
+ ((<lambda-case> req opt rest kw inits vars predicate body
else)
+ (if (and (= (length vars) (length req) (length args))
+ (not predicate))
+ (let ((x (make-let src req vars args body)))
+ (or (inline1 x) x))
+ (lp else)))))))
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar)
@@ -51,31 +57,33 @@
;; Note that this is a singly-binding form of let-values. Also
;; note that Scheme's let-values expands into call-with-values,
;; then here we reduce it to tree-il's let-values.
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2)
- (lambda? (cadr args)))
- (let ((producer (car args))
- (consumer (cadr args)))
- (make-let-values src
- (lambda-names consumer)
- (lambda-vars consumer)
- (if (and (lambda? producer)
- (null? (lambda-names producer)))
- (lambda-body producer)
- (make-application src producer '()))
- (lambda-body consumer))))
+ ((<primitive-ref> name)
+ (and (eq? name '@call-with-values)
+ (pmatch args
+ ((,producer ,consumer)
+ (guard (lambda? consumer)
+ (lambda-case? (lambda-body consumer))
+ (not (lambda-case-opt (lambda-body consumer)))
+ (not (lambda-case-kw (lambda-body consumer)))
+ (not (lambda-case-predicate (lambda-body consumer)))
+ (not (lambda-case-else (lambda-body consumer))))
+ (make-let-values
+ src
+ (let ((x (make-application src producer '())))
+ (or (inline1 x) x))
+ (lambda-body consumer)))
+ (else #f))))
(else #f)))
- ((<let> vars body)
- (if (null? vars) body x))
+ ((<let> vars body)
+ (if (null? vars) body x))
- ((<letrec> vars body)
- (if (null? vars) body x))
+ ((<letrec> vars body)
+ (if (null? vars) body x))
- ((<fix> vars body)
- (if (null? vars) body x))
+ ((<fix> vars body)
+ (if (null? vars) body x))
- (else #f)))
- x))
+ (else #f)))
+ (post-order! inline1 x))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 98633f0..8d93760 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -210,11 +210,15 @@
(let ((y (const-exp y)))
(and (number? y) (exact? y) (= y 1))))
(1+ x)
- (if (and (const? x)
- (let ((x (const-exp x)))
- (and (number? y) (exact? x) (= x 1))))
- (1+ y)
- (+ x y)))
+ (if (and (const? y)
+ (let ((y (const-exp y)))
+ (and (number? y) (exact? y) (= y -1))))
+ (1- x)
+ (if (and (const? x)
+ (let ((x (const-exp x)))
+ (and (number? y) (exact? x) (= x 1))))
+ (1+ y)
+ (+ x y))))
(x y z . rest) (+ x (+ y z . rest)))
(define-primitive-expander *
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index c47134e..b2ebcfc 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -20,6 +20,7 @@
(define-module (language tree-il spec)
#:use-module (system base language)
+ #:use-module (system base pmatch)
#:use-module (language glil)
#:use-module (language tree-il)
#:use-module (language tree-il compile-glil)
@@ -29,7 +30,10 @@
(apply write (unparse-tree-il exp) port))
(define (join exps env)
- (make-sequence #f exps))
+ (pmatch exps
+ (() (make-void #f))
+ ((,x) x)
+ (else (make-sequence #f exps))))
(define-language tree-il
#:title "Tree Intermediate Language"
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 4d1c92f..da3f7cd 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -28,7 +28,10 @@
#:use-module (ice-9 receive)
#:export (syntax-error
*current-language*
- compiled-file-name compile-file compile-and-load
+ compiled-file-name
+ compile-file
+ compile-and-load
+ read-and-compile
compile
decompile)
#:export-syntax (call-with-compile-error-catch))
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index be85fb7..2f1da97 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -19,6 +19,7 @@
;;; Code:
(define-module (system vm frame)
+ #:use-module (system base pmatch)
#:use-module (system vm program)
#:use-module (system vm instruction)
#:use-module (system vm objcode)
@@ -26,10 +27,13 @@
#:export (vm-frame?
vm-frame-program
vm-frame-local-ref vm-frame-local-set!
+ vm-frame-instruction-pointer
vm-frame-return-address vm-frame-mv-return-address
vm-frame-dynamic-link
- vm-frame-stack
+ vm-frame-num-locals
+ vm-frame-bindings vm-frame-binding-ref vm-frame-binding-set!
+ vm-frame-arguments
vm-frame-number vm-frame-address
make-frame-chain
@@ -44,6 +48,61 @@
(load-extension "libguile" "scm_init_frames")
+(define (vm-frame-bindings frame)
+ (map (lambda (b)
+ (cons (binding:name b) (binding:index b)))
+ (program-bindings-for-ip (vm-frame-program frame)
+ (vm-frame-instruction-pointer frame))))
+
+(define (vm-frame-binding-set! frame var val)
+ (let ((i (assq-ref (vm-frame-bindings frame) var)))
+ (if i
+ (vm-frame-local-set! frame i val)
+ (error "variable not bound in frame" var frame))))
+
+(define (vm-frame-binding-ref frame var)
+ (let ((i (assq-ref (vm-frame-bindings frame) var)))
+ (if i
+ (vm-frame-local-ref frame i)
+ (error "variable not bound in frame" var frame))))
+
+;; Basically there are two cases to deal with here:
+;;
+;; 1. We've already parsed the arguments, and bound them to local
+;; variables. In a standard (lambda (a b c) ...) call, this doesn't
+;; involve any argument shuffling; but with rest, optional, or
+;; keyword arguments, the arguments as given to the procedure may
+;; not correspond to what's on the stack. We reconstruct the
+;; arguments using e.g. for the case above: `(,a ,b ,c). This works
+;; for rest arguments too: (a b . c) => `(,a ,b . ,c)
+;;
+;; 2. We have failed to parse the arguments. Perhaps it's the wrong
+;; number of arguments, or perhaps we're doing a typed dispatch and
+;; the types don't match. In that case the arguments are all on the
+;; stack, and nothing else is on the stack.
+(define (vm-frame-arguments frame)
+ (cond
+ ((program-lambda-list (vm-frame-program frame)
+ (vm-frame-instruction-pointer frame))
+ ;; case 1
+ => (lambda (formals)
+ (let lp ((formals formals))
+ (pmatch formals
+ (() '())
+ ((,x . ,rest) (guard (symbol? x))
+ (cons (vm-frame-binding-ref frame x) (lp rest)))
+ ((,x . ,rest)
+ ;; could be a keyword
+ (cons x (lp rest)))
+ (,rest (guard (symbol? rest))
+ (vm-frame-binding-ref frame rest))
+ (else (error "bad formals" formals))))))
+ (else
+ ;; case 2
+ (map (lambda (i)
+ (vm-frame-local-ref frame i))
+ (iota (vm-frame-num-locals frame))))))
+
;;;
;;; Frame chain
;;;
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 72ec479..823b2a0 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -19,28 +19,27 @@
;;; Code:
(define-module (system vm program)
+ #:use-module (system base pmatch)
+ #:use-module (ice-9 optargs)
#:export (make-program
- arity:nargs arity:nrest arity:nlocs
-
make-binding binding:name binding:boxed? binding:index
binding:start binding:end
source:addr source:line source:column source:file
- program-bindings program-sources program-source
+ program-sources program-source
program-properties program-property program-documentation
- program-name program-arguments
+ program-name
+
+ program-bindings program-bindings-by-index program-bindings-for-ip
+ program-arities program-arguments program-lambda-list
- program-arity program-meta
+ program-meta
program-objcode program? program-objects
program-module program-base program-free-variables))
(load-extension "libguile" "scm_init_programs")
-(define arity:nargs car)
-(define arity:nrest cadr)
-(define arity:nlocs caddr)
-
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
@@ -64,31 +63,125 @@
(define (program-documentation prog)
(assq-ref (program-properties prog) 'documentation))
-(define (program-arguments prog)
- (let ((bindings (program-bindings prog))
- (nargs (arity:nargs (program-arity prog)))
- (rest? (not (zero? (arity:nrest (program-arity prog))))))
- (if bindings
- (let ((args (map binding:name (list-head bindings nargs))))
- (if rest?
- `((required . ,(list-head args (1- (length args))))
- (rest . ,(car (last-pair args))))
- `((required . ,args))))
- #f)))
-
-(define (program-bindings-as-lambda-list prog)
- (let ((bindings (program-bindings prog))
- (nargs (arity:nargs (program-arity prog)))
- (rest? (not (zero? (arity:nrest (program-arity prog))))))
- (if (not bindings)
- (if rest? (cons (1- nargs) 1) (list nargs))
- (let ((args (map binding:name (list-head bindings nargs))))
- (if rest?
- (apply cons* args)
- args)))))
+(define (collapse-locals locs)
+ (let lp ((ret '()) (locs locs))
+ (if (null? locs)
+ (map cdr (sort! ret
+ (lambda (x y) (< (car x) (car y)))))
+ (let ((b (car locs)))
+ (cond
+ ((assv-ref ret (binding:index b))
+ => (lambda (bindings)
+ (append! bindings (list b))
+ (lp ret (cdr locs))))
+ (else
+ (lp (acons (binding:index b) (list b) ret)
+ (cdr locs))))))))
+
+;; returns list of list of bindings
+;; (list-ref ret N) == bindings bound to the Nth local slot
+(define (program-bindings-by-index prog)
+ (cond ((program-bindings prog) => collapse-locals)
+ (else '())))
+
+(define (program-bindings-for-ip prog ip)
+ (let lp ((in (program-bindings-by-index prog)) (out '()))
+ (if (null? in)
+ (reverse out)
+ (lp (cdr in)
+ (let inner ((binds (car in)))
+ (cond ((null? binds) out)
+ ((<= (binding:start (car binds))
+ ip
+ (binding:end (car binds)))
+ (cons (car binds) out))
+ (else (inner (cdr binds)))))))))
+
+;; not exported; should it be?
+(define (program-arity prog ip)
+ (let ((arities (program-arities prog)))
+ (and arities
+ (let lp ((arities arities))
+ (cond ((null? arities) #f)
+ ((<= (caar arities) ip) (car arities))
+ (else (lp (cdr arities))))))))
+
+(define (arglist->arguments arglist)
+ (pmatch arglist
+ ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
+ `((required . ,req)
+ (optional . ,opt)
+ (keyword . ,keyword)
+ (allow-other-keys? . ,allow-other-keys?)
+ (rest . ,rest)
+ (extents . ,extents)))
+ (else #f)))
+
+(define (arity:start a)
+ (pmatch a ((,ip . _) ip) (else (error "bad arity" a))))
+(define (arity:nreq a)
+ (pmatch a ((_ ,nreq . _) nreq) (else 0)))
+(define (arity:nopt a)
+ (pmatch a ((_ ,nreq ,nopt . _) nopt) (else 0)))
+(define (arity:rest? a)
+ (pmatch a ((_ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
+(define (arity:kw a)
+ (pmatch a ((_ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
+(define (arity:allow-other-keys? a)
+ (pmatch a ((_ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
+
+(define (arity->arguments prog arity)
+ (define var-by-index
+ (let ((rbinds (map (lambda (x)
+ (cons (binding:index x) (binding:name x)))
+ (program-bindings-for-ip prog
+ (arity:start arity)))))
+ (lambda (i)
+ (assv-ref rbinds i))))
+
+ (let lp ((nreq (arity:nreq arity)) (req '())
+ (nopt (arity:nopt arity)) (opt '())
+ (rest? (arity:rest? arity)) (rest #f)
+ (n 0))
+ (cond
+ ((< 0 nreq)
+ (lp (1- nreq) (cons (var-by-index n) req)
+ nopt opt rest? rest (1+ n)))
+ ((< 0 nopt)
+ (lp nreq req
+ (1- nopt) (cons (var-by-index n) opt)
+ rest? rest (1+ n)))
+ (rest?
+ (lp nreq req nopt opt
+ #f (var-by-index n)
+ (1+ n)))
+ (else
+ `((required . ,(reverse req))
+ (optional . ,(reverse opt))
+ (keyword . ,(arity:kw arity))
+ (allow-other-keys? . ,(arity:allow-other-keys? arity))
+ (rest . ,rest))))))
+
+(define* (program-arguments prog #:optional ip)
+ (let ((arity (program-arity prog ip)))
+ (and arity
+ (arity->arguments prog arity))))
+
+(define* (program-lambda-list prog #:optional ip)
+ (and=> (program-arguments prog ip) arguments->lambda-list))
+
+(define (arguments->lambda-list arguments)
+ (let ((req (or (assq-ref arguments 'required) '()))
+ (opt (or (assq-ref arguments 'optional) '()))
+ (key (or (assq-ref arguments 'keyword) '()))
+ (rest (or (assq-ref arguments 'rest) '())))
+ `(,@req
+ ,@(if (pair? opt) (cons #:optional opt) '())
+ ,@(if (pair? key) (cons #:key key) '())
+ . ,rest)))
(define (write-program prog port)
- (format port "#<program ~a ~a>"
+ (format port "#<program ~a~a>"
(or (program-name prog)
(and=> (program-source prog 0)
(lambda (s)
@@ -97,4 +190,14 @@
(or (source:file s) "<unknown port>")
(source:line s) (source:column s))))
(number->string (object-address prog) 16))
- (program-bindings-as-lambda-list prog)))
+ (let ((arities (program-arities prog)))
+ (if (null? arities)
+ ""
+ (string-append
+ " " (string-join (map (lambda (a)
+ (object->string
+ (arguments->lambda-list
+ (arity->arguments prog a))))
+ arities)
+ " | "))))))
+
diff --git a/module/system/xref.scm b/module/system/xref.scm
index 906ec8e..94ecb5b 100644
--- a/module/system/xref.scm
+++ b/module/system/xref.scm
@@ -35,7 +35,7 @@
(progv (make-vector (vector-length objects) #f))
(asm (decompile (program-objcode prog) #:to 'assembly)))
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len . ,body)
+ ((load-program ,labels ,len . ,body)
(for-each
(lambda (x)
(pmatch x
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index f47ccba..145975c 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test \
tests/arbiters.test \
tests/asm-to-bytecode.test \
tests/bit-operations.test \
+ tests/brainfuck.test \
tests/bytevectors.test \
tests/c-api.test \
tests/chars.test \
diff --git a/test-suite/tests/asm-to-bytecode.test
b/test-suite/tests/asm-to-bytecode.test
index a8e251b..304a84d 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -77,34 +77,28 @@
(vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer
#\o)
(char->integer #\o)))
- (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
+ (comp-test '(load-program () 3 #f (make-int8 3) (return))
#(load-program
- 3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 3) ;; len
(uint32 0) ;; metalen
- (uint32 0) ;; padding
make-int8 3
return))
;; the nops are to pad meta to an 8-byte alignment. not strictly
;; necessary for this test, but representative of the common case.
- (comp-test '(load-program 3 2 1 () 8
- (load-program 3 2 1 () 3
+ (comp-test '(load-program () 8
+ (load-program () 3
#f
(make-int8 3) (return))
(make-int8 3) (return)
(nop) (nop) (nop) (nop) (nop))
#(load-program
- 3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 8) ;; len
- (uint32 19) ;; metalen
- (uint32 0) ;; padding
+ (uint32 11) ;; metalen
make-int8 3
return
nop nop nop nop nop
- 3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 3) ;; len
(uint32 0) ;; metalen
- (uint32 0) ;; padding
make-int8 3
return))))
diff --git a/test-suite/tests/brainfuck.test b/test-suite/tests/brainfuck.test
new file mode 100644
index 0000000..f612fb5
--- /dev/null
+++ b/test-suite/tests/brainfuck.test
@@ -0,0 +1,51 @@
+;;;; test brainfuck compilation -*- scheme -*-
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-suite tests brainfuck)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile))
+
+;; This program taken from Wikipedia's brainfuck introduction page.
+(define prog "
+ +++ +++ +++ + initialize counter (cell #0) to 10
+ [ use loop to set the next four cells to 70/100/30/10
+ > +++ +++ + add 7 to cell #1
+ > +++ +++ +++ + add 10 to cell #2
+ > +++ add 3 to cell #3
+ > + add 1 to cell #4
+ <<< < - decrement counter (cell #0)
+ ]
+ >++ . print 'H'
+ >+. print 'e'
+ +++ +++ +. print 'l'
+ . print 'l'
+ +++ . print 'o'
+ >++ . print ' '
+ <<+ +++ +++ +++ +++ ++. print 'W'
+ >. print 'o'
+ +++ . print 'r'
+ --- --- . print 'l'
+ --- --- --. print 'd'
+ >+. print '!'")
+
+(pass-if
+ (equal? (with-output-to-string
+ (lambda ()
+ (call-with-input-string
+ prog
+ (lambda (port)
+ (read-and-compile port #:from 'brainfuck #:to 'value)))))
+ "Hello World!"))
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index 5929ce9..f8459ba 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -1,7 +1,7 @@
;;;; optargs.test --- test suite for optional arg processing -*- scheme -*-
;;;; Matthias Koeppe <address@hidden> --- June 2001
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,10 +18,30 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-suite test-optargs)
- :use-module (test-suite lib)
- :use-module (ice-9 optargs))
-
-(with-test-prefix "optional argument processing"
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (ice-9 optargs))
+
+(define-syntax c&e
+ (syntax-rules (pass-if pass-if-exception)
+ ((_ (pass-if test-name exp))
+ (begin (pass-if (string-append test-name " (eval)")
+ (primitive-eval 'exp))
+ (pass-if (string-append test-name " (compile)")
+ (compile 'exp #:to 'value #:env (current-module)))))
+ ((_ (pass-if-exception test-name exc exp))
+ (begin (pass-if-exception (string-append test-name " (eval)")
+ exc (primitive-eval 'exp))
+ (pass-if-exception (string-append test-name " (compile)")
+ exc (compile 'exp #:to 'value
+ #:env (current-module)))))))
+
+(define-syntax with-test-prefix/c&e
+ (syntax-rules ()
+ ((_ section-name exp ...)
+ (with-test-prefix section-name (c&e exp) ...))))
+
+(with-test-prefix/c&e "optional argument processing"
(pass-if "local defines work with optional arguments"
(eval '(begin
(define* (test-1 #:optional (x 0))
@@ -34,7 +54,7 @@
;;; let-keywords
;;;
-(with-test-prefix "let-keywords"
+(with-test-prefix/c&e "let-keywords"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
@@ -55,7 +75,7 @@
;;; let-keywords*
;;;
-(with-test-prefix "let-keywords*"
+(with-test-prefix/c&e "let-keywords*"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
@@ -76,7 +96,7 @@
;;; let-optional
;;;
-(with-test-prefix "let-optional"
+(with-test-prefix/c&e "let-optional"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
@@ -98,7 +118,7 @@
;;; let-optional*
;;;
-(with-test-prefix "let-optional*"
+(with-test-prefix/c&e "let-optional*"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
@@ -115,3 +135,15 @@
(let ((rest '(123)))
(let-optional* rest ((foo 999))
(= foo 123)))))
+
+(define* (foo a b #:optional c (d 1) (e c) f #:key g (h a) (i r) #:rest r)
+ (list a b c d e f g h i r))
+
+;; So we could use lots more tests here, but the fact that lambda* is in
+;; the compiler, and the compiler compiles itself, using the evaluator
+;; (when bootstrapping) and compiled code (when doing a partial rebuild)
+;; makes me a bit complacent.
+(with-test-prefix/c&e "define*"
+ (pass-if "the whole enchilada"
+ (equal? (foo 1 2)
+ '(1 2 #f 1 #f #f #f 1 () ()))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 90dde7d..2e78a1a 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -48,14 +48,6 @@
(define-syntax assert-tree-il->glil
(syntax-rules ()
- ((_ in out)
- (pass-if 'in
- (let ((tree-il (strip-source (parse-tree-il 'in))))
- (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to
'glil))
- 'out))))))
-
-(define-syntax assert-tree-il->glil/pmatch
- (syntax-rules ()
((_ in pat test ...)
(let ((exp 'in))
(pass-if 'in
@@ -69,21 +61,21 @@
(with-test-prefix "void"
(assert-tree-il->glil
(void)
- (program 0 0 0 () (void) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
(assert-tree-il->glil
(begin (void) (const 1))
- (program 0 0 0 () (const 1) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
(assert-tree-il->glil
(apply (primitive +) (void) (const 1))
- (program 0 0 0 () (void) (call add1 1) (call return 1))))
+ (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call
return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
(apply (toplevel foo) (const 1))
- (program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
- (assert-tree-il->glil/pmatch
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1)
(call goto/args 1)))
+ (assert-tree-il->glil
(begin (apply (toplevel foo) (const 1)) (void))
- (program 0 0 0 () (call new-frame 0) (toplevel ref foo) (const 1) (mv-call
1 ,l1)
+ (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref
foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2)
(label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
@@ -91,26 +83,26 @@
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar)))
- (program 0 0 0 () (toplevel ref foo) (call new-frame 0) (toplevel ref bar)
(call call 0)
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call
new-frame 0) (toplevel ref bar) (call call 0)
(call goto/args 1))))
(with-test-prefix "conditional"
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(if (const #t) (const 1) (const 2))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1)
(const 1) (call return 1)
(label ,l2) (const 2) (call return 1))
(eq? l1 l2))
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(begin (if (const #t) (const 1) (const 2)) (const #f))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
+ (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not
,l1) (branch br ,l2)
(label ,l3) (label ,l4) (const #f) (call return 1))
(eq? l1 l3) (eq? l2 l4))
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(apply (primitive null?) (if (const #t) (const 1) (const 2)))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1)
(const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4)
(call null? 1) (call return 1))
@@ -119,35 +111,35 @@
(with-test-prefix "primitive-ref"
(assert-tree-il->glil
(primitive +)
- (program 0 0 0 () (toplevel ref +) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return
1)))
(assert-tree-il->glil
(begin (primitive +) (const #f))
- (program 0 0 0 () (const #f) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (primitive +))
- (program 0 0 0 () (toplevel ref +) (call null? 1)
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
(call return 1))))
(with-test-prefix "lexical refs"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1)
(unbind))))
@@ -157,7 +149,7 @@
;; unreferenced sets may be optimized away -- make sure they are ref'd
(let (x) (y) ((const 1))
(set! (lexical x y) (apply (primitive 1+) (lexical x y))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(void) (call return 1)
@@ -167,7 +159,7 @@
(let (x) (y) ((const 1))
(begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
(lexical x y)))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(lexical #t #t ref 0) (call return 1)
@@ -177,7 +169,7 @@
(let (x) (y) ((const 1))
(apply (primitive null?)
(set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
(call null? 1) (call return 1)
@@ -186,234 +178,259 @@
(with-test-prefix "module refs"
(assert-tree-il->glil
(@ (foo) bar)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@ (foo) bar) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@ (foo) bar))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar)
(call null? 1) (call return 1)))
(assert-tree-il->glil
(@@ (foo) bar)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@@ (foo) bar) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@@ (foo) bar))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar)
(call null? 1) (call return 1))))
(with-test-prefix "module sets"
(assert-tree-il->glil
(set! (@ (foo) bar) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@ (foo) bar) (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@ (foo) bar) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1)))
(assert-tree-il->glil
(set! (@@ (foo) bar) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@@ (foo) bar) (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel refs"
(assert-tree-il->glil
(toplevel bar)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar)
(call return 1)))
(assert-tree-il->glil
(begin (toplevel bar) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (toplevel bar))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar)
(call null? 1) (call return 1))))
(with-test-prefix "toplevel sets"
(assert-tree-il->glil
(set! (toplevel bar) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (toplevel bar) (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (toplevel bar) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel defines"
(assert-tree-il->glil
(define bar (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (define bar (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (define bar (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "constants"
(assert-tree-il->glil
(const 2)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (call return 1)))
(assert-tree-il->glil
(begin (const 2) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1))))
(with-test-prefix "lambda"
(assert-tree-il->glil
- (lambda (x) (y) () (const 2))
- (program 0 0 0 ()
- (program 1 0 0 ()
- (bind (x #f 0))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f #f #f () (y) #f) (const 2)) #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (std-prelude 1 1 #f)
+ (bind (x #f 0)) (label _)
+ (const 2) (call return 1) (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x x1) (y y1) () (const 2))
- (program 0 0 0 ()
- (program 2 0 0 ()
- (bind (x #f 0) (x1 #f 1))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case (((x y) #f #f #f () (x1 y1) #f)
+ (const 2))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (std-prelude 2 2 #f)
+ (bind (x #f 0) (y #f 1)) (label _)
+ (const 2) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda x y () (const 2))
- (program 0 0 0 ()
- (program 1 1 0 ()
- (bind (x #f 0))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case ((() #f x #f () (y) #f) (const 2))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 0 0 0 1 #f)
+ (bind (x #f 0)) (label _)
+ (const 2) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x . x1) (y . y1) () (const 2))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f x1 #f () (y y1) #f) (const 2))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 1 0 1 2 #f)
+ (bind (x #f 0) (x1 #f 1)) (label _)
+ (const 2) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x . x1) (y . y1) () (lexical x y))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (lexical #t #f ref 0) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f x1 #f () (y y1) #f) (lexical x y))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 1 0 1 2 #f)
+ (bind (x #f 0) (x1 #f 1)) (label _)
+ (lexical #t #f ref 0) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x . x1) (y . y1) () (lexical x1 y1))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (lexical #t #f ref 1) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f x1 #f () (y y1) #f) (lexical x1 y1))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 1 0 1 2 #f)
+ (bind (x #f 0) (x1 #f 1)) (label _)
+ (lexical #t #f ref 1) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
- (program 0 0 0 ()
- (program 1 0 0 ()
- (bind (x #f 0))
- (program 1 0 0 ()
- (bind (y #f 0))
- (lexical #f #f ref 0) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f #f #f () (x1) #f)
+ (lambda ()
+ (lambda-case (((y) #f #f #f () (y1) #f)
+ (lexical x x1))
+ #f)))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (std-prelude 1 1 #f)
+ (bind (x #f 0)) (label _)
+ (program () (std-prelude 1 1 #f)
+ (bind (y #f 0)) (label _)
+ (lexical #f #f ref 0) (call return 1)
+ (unbind))
(lexical #t #f ref 0)
(call vector 1)
(call make-closure 2)
- (call return 1))
+ (call return 1)
+ (unbind))
(call return 1))))
(with-test-prefix "sequence"
(assert-tree-il->glil
(begin (begin (const 2) (const #f)) (const #t))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const #t) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1))))
;; FIXME: binding info for or-hacked locals might bork the disassembler,
;; and could be tightened in any case
(with-test-prefix "the or hack"
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical a b))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1)
@@ -425,13 +442,13 @@
(eq? l1 l2))
;; second bound var is unreferenced
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical x y))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1)
@@ -443,10 +460,10 @@
(with-test-prefix "apply"
(assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar))
- (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply
2)))
- (assert-tree-il->glil/pmatch
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref
bar) (call goto/apply 2)))
+ (assert-tree-il->glil
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo)
(toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
@@ -454,7 +471,7 @@
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel
baz)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call
apply 2)
(call goto/args 1))))
@@ -462,10 +479,10 @@
(with-test-prefix "call/cc"
(assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo))
- (program 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
- (assert-tree-il->glil/pmatch
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call goto/cc
1)))
+ (assert-tree-il->glil
(begin (apply (primitive @call-with-current-continuation) (toplevel foo))
(void))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref call-with-current-continuation)
(toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
@@ -474,7 +491,7 @@
(assert-tree-il->glil
(apply (toplevel foo)
(apply (toplevel @call-with-current-continuation) (toplevel bar)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))
@@ -507,15 +524,18 @@
(1+ y))
0
(parse-tree-il
- '(lambda (x y) (x1 y1)
- (apply (toplevel +)
- (lexical x x1)
- (lexical y y1)))))))
+ '(lambda ()
+ (lambda-case
+ (((x y) #f #f #f () (x1 y1) #f)
+ (apply (toplevel +)
+ (lexical x x1)
+ (lexical y y1)))
+ #f))))))
(and (equal? (map strip-source leaves)
(list (make-lexical-ref #f 'y 'y1)
(make-lexical-ref #f 'x 'x1)
(make-toplevel-ref #f '+)))
- (= (length downs) 2)
+ (= (length downs) 3)
(equal? (reverse (map strip-source ups))
(map strip-source downs))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] | Current Thread | [Next in Thread] |