[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. e3c5df5396
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. e3c5df539640a36eb1493f581087d54a4714f337 |
|
Date: |
Tue, 02 Jun 2009 09:14:17 +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=e3c5df539640a36eb1493f581087d54a4714f337
The branch, syncase-in-boot-9 has been updated
via e3c5df539640a36eb1493f581087d54a4714f337 (commit)
via 6ed0c41a2d621c485a0b0e1b39535fd5a1e9bd20 (commit)
via 34f3d47df9311852ba7eab6f8d1c36535c3774dd (commit)
via 560b9c256d9cd5f80dead6ddb0d747a21c6c003a (commit)
via 1351c2dba5ce54aeeae41cb2322ad39cd29510b0 (commit)
via 9d07bb7276d1be078c5933645897694035ecdcfe (commit)
via 73643339527d27a09d62424428b67417ca627bf5 (commit)
via 81fd3152992c8ef62e1ec036f5a39443c8f8d0aa (commit)
via a755136ba8469fdccbcac956b4f5d8c6f4ec2a4e (commit)
via 0e7b72a8fefc27d67623b11659372b7ac37b7a58 (commit)
via b40d023067b54f1085f194c521c2d046fceb9444 (commit)
via 39a2eca2ce7461108ddc595cb74a6bf47c456bd8 (commit)
via 55ae815b62c5d4bf324351d64919bdb8d4070148 (commit)
via e0c90f9084914956d90db73b21ef2ab32d1a477a (commit)
via e6b94431794ad5cffedfbdbe949789d04ef97761 (commit)
via 7902c547130235438fa170d94c43e0c271adb71d (commit)
via 9ecac781bf3b33abca137c242ceaa7c49f604958 (commit)
via dc1eed52f71004bca74028d03ae35bbf569be709 (commit)
via 0260421208267eb202f9c9628cdaf39b531a5129 (commit)
via 40b36cfbbe4676f52bd4d6b45ae1642756642907 (commit)
via 2032f3d1db09aa63de4ec060081a5bf9053f0d3c (commit)
via 0f423f20aae6228431d3695e60ade937858110b8 (commit)
via 30a5e062d022aafdb72cea648f3a4de0e72feb6d (commit)
via a48358b38fed9486cebf7f8338dc05adc770fc0f (commit)
via d63927150aa22bb7e57125ed50e5ecbe11765fba (commit)
via 47c8983f08157865a3937722c06acbbb3cbd7621 (commit)
via 8bb0b3cc9d582c48ed6cb5d123168ffd27ac7cf8 (commit)
via 68623e8e7883077dbb26521fe6d9c185df3138ce (commit)
via 9806a548fe1a9cca0f82ef4f2f08fbcba5eccfaa (commit)
via ad9b8c451b82f74cf88c5a6207ed3ea72c86f93e (commit)
via c11f46afe113f50e34af33ad3055b3da66e4b71f (commit)
via 5af166bda2f1d89525add147a9e3d2d6867d03a5 (commit)
via e32a1792de84c20eaaae6ea7f33048b6eef2c9d8 (commit)
via a1a482e0e9518b5711bc2734aa014254f9207919 (commit)
via ce09ee19892d391f3b2ca13e0616d343929c2c14 (commit)
via dce042f1f74f8ef5ca5089beb50fd7496feae5da (commit)
via 112edbaea3e48e002261c72064d6602d661c3df4 (commit)
via 1eec95f8def91bcb6f9f22c21c6d27ec2a7175ac (commit)
via 2ce77f2d95271887b54d0c56d1e81d7f472ae1ae (commit)
via 696495f4d21fc8bc479b50588c08ea55e7c6e3a7 (commit)
via 547a602d1ef4d3622cf2d476ff311957b447eaba (commit)
via cf10678fe7014a67020c45ee02f2aabb44598adc (commit)
via 073bb617eb7e5f76269ca6dba0fe498baff6f058 (commit)
via cb28c08537790b49f7bc94f2f6b426497152bbe7 (commit)
via 9efc833d65adef11e76410fee7ea548143131417 (commit)
via b81d329e449420b6abaa2b689d7107b862111cbf (commit)
via 06656e06d454f16694d0b550fb339efb0c36123a (commit)
via 982a1c205d2ff1dc61a2ff56ba2e6491974f9303 (commit)
via 811d10f5a2297e2fe6a881d02c67c45bf4311a27 (commit)
via 1aeb082b8281eb12640d7a42c88a566418c64782 (commit)
via f27e9e11cd01eefa9eab3cfd277120ce73e3355a (commit)
via f4a644ee886903df43810f1a0e65ce2ef891999f (commit)
via 71f46dbd5ecf62809c2aa475b6f5742993ada0b9 (commit)
via 123f8abb2da5ed7b2d8ccd67b3bd3532aa9d257e (commit)
via 41af238146428f5841880f26d84b5dc9ddfad2c4 (commit)
via 6a952e0ee9093424cdc8f300406d09ce195ebf5c (commit)
via 4d24854111110b44a28a4d46242bac1285de387a (commit)
via 12eae603c76edc8affc0e8331df7f22a4d8a8b2c (commit)
via 3d5f3091e100550052abc698e980b3e86cc01b65 (commit)
via 5a0132b3375b35c69c6afb735acbaa8619237fb5 (commit)
from 5f1a2fb10f5eb97e302c50f5b62d6df28f73d97a (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 e3c5df539640a36eb1493f581087d54a4714f337
Author: Andy Wingo <address@hidden>
Date: Thu May 28 15:01:30 2009 +0200
add tests for #' etc
* test-suite/tests/reader.test ("#'"): Add tests for the hash-syntax
reader macros.
commit 6ed0c41a2d621c485a0b0e1b39535fd5a1e9bd20
Author: Andy Wingo <address@hidden>
Date: Thu May 28 14:59:47 2009 +0200
add reader tests for #;
* test-suite/tests/reader.test ("#;"): Add reader tests for #;.
commit 34f3d47df9311852ba7eab6f8d1c36535c3774dd
Author: Andy Wingo <address@hidden>
Date: Thu May 28 14:49:33 2009 +0200
add reader support for #; #` #' #, and #,@. fix bug in compile-and-load.
* libguile/read.c (flush_ws, scm_read_commented_expression)
(scm_read_sharp): Add support for commenting out expressions with #;.
(scm_read_syntax, scm_read_sharp): Add support for #', #`, #, and #,@.
* module/ice-9/boot-9.scm: Remove #' read-hash extension, which actually
didn't do anything at all. It's been there since 1997, but no Guile
code I've ever seen uses it, and it conflicts with #'x => (syntax x)
from modern Scheme.
* module/system/base/compile.scm (compile-and-load): Whoops, fix a number
of bugs here.
commit 560b9c256d9cd5f80dead6ddb0d747a21c6c003a
Author: Andy Wingo <address@hidden>
Date: Tue May 26 22:23:44 2009 +0200
adjust VM copyright notices to LGPL, use SCM_INTERNAL/API properly
* libguile/frames.c:
* libguile/frames.h:
* libguile/instructions.c:
* libguile/instructions.h:
* libguile/objcodes.c:
* libguile/objcodes.h:
* libguile/programs.c:
* libguile/programs.h:
* libguile/vm-bootstrap.h:
* libguile/vm-engine.c:
* libguile/vm-engine.h:
* libguile/vm-expand.h:
* libguile/vm-i-scheme.c:
* libguile/vm.c:
* libguile/vm.h: Update to use SCM_API and SCM_INTERNAL correctly. Adjust
copyright to be the same as the copyright of Guile itself, which should
be fine given that the FSF holds the whole thing.
commit 1351c2dba5ce54aeeae41cb2322ad39cd29510b0
Author: Andy Wingo <address@hidden>
Date: Tue May 26 21:47:45 2009 +0200
fix backtraces with compiled boot-9
* module/ice-9/boot-9.scm (default-pre-unwind-handler): Since we were
tail-called by pre-unwind-handler-dispatch, we can't use
pre-unwind-handler-dispatch as a narrowing argument. Instead just
narrow by one frame.
(pre-unwind-handler-dispatch): Deprecate.
(error-catching-loop): Remove crack comment and code, and just use
default-pre-unwind-handler as our pre-unwind handler.
* module/ice-9/stack-catch.scm (stack-catch):
* module/system/repl/repl.scm (call-with-backtrace): Use
default-pre-unwind-handler directly.
commit 9d07bb7276d1be078c5933645897694035ecdcfe
Author: Andy Wingo <address@hidden>
Date: Tue May 26 16:03:37 2009 +0200
distcheck fix, fix (ice-9 time)
* lang/Makefile.am (elisp_sources): Add elisp/expand.scm.
* module/ice-9/time.scm (time): Fix for new macro expander. Ew.
commit 73643339527d27a09d62424428b67417ca627bf5
Author: Andy Wingo <address@hidden>
Date: Mon May 25 22:45:42 2009 +0200
update docs -- sections on assembly and objcode
* doc/ref/api-procedures.texi:
* doc/ref/compiler.texi:
* doc/ref/vm.texi: Update the docs some more.
commit 81fd3152992c8ef62e1ec036f5a39443c8f8d0aa
Author: Andy Wingo <address@hidden>
Date: Sun May 24 13:09:01 2009 +0200
update docs, clean up VM vestiges, macro docs, fix (/ a b c)
* doc/ref/api-procedures.texi (Compiled Procedures): Fix for API changes.
* doc/ref/compiler.texi (Compiling to the Virtual Machine): Replace GHIL
docs with Tree-IL docs. Update the bits about the Scheme compiler to
talk about Tree-IL and the expander instead of GHIL. Remove
<glil-argument>. Add placeholder sections for assembly and bytecode.
* doc/ref/vm.texi: Update examples with what currently happens. Reword
some things. Fix a couple errors.
* libguile/vm-i-system.c (externals): Remove this instruction, it's not
used.
* module/ice-9/documentation.scm (object-documentation): If the object is
a macro, try to return documentation on the macro transformer.
* module/language/assembly/disassemble.scm (disassemble-load-program):
Fix problem in which we skipped the first element of the object vector,
because of changes to procedure layouts a few months ago.
* module/language/scheme/spec.scm (read-file): Remove read-file
definition.
* module/language/tree-il.scm: Reorder exports. Remove <lexical>, it was
a compat shim to something that was never released. Fix `location'.
* module/language/tree-il/primitives.scm (/): Fix expander for more than
two args to /.
* module/system/base/compile.scm (read-file-in): Remove unused
definition.
* module/system/base/language.scm (system): Remove language-read-file.
* module/language/ecmascript/spec.scm (ecmascript): Remove read-file
definition.
commit a755136ba8469fdccbcac956b4f5d8c6f4ec2a4e
Author: Andy Wingo <address@hidden>
Date: Fri May 22 21:14:48 2009 +0200
fix (oop goops) compilation for (language tree-il primitives)
* module/oop/goops.scm (compile): Whoop-dee, fix up (oop goops) for
(language tree-il primitives) change.
commit 0e7b72a8fefc27d67623b11659372b7ac37b7a58
Author: Andy Wingo <address@hidden>
Date: Fri May 22 21:12:42 2009 +0200
source location tracking in psyntax, booya!
* module/ice-9/psyntax.scm (source-annotation): Return #f if
source-properties returns null.
(source-wrap): Rework a bit.
(syntax-type): Don't throw away source info for wrapped expressions.
Can has source location info, fools!
(chi-body): Correctly propagate source info for body subforms.
(syntax): Remove special case for map, it doesn't apply (ahem) for
Guile.
* module/ice-9/psyntax-pp.scm: Regenerate.
commit b40d023067b54f1085f194c521c2d046fceb9444
Author: Andy Wingo <address@hidden>
Date: Fri May 22 19:48:14 2009 +0200
remove annotations in psyntax in favor of guile's source properties
* module/ice-9/psyntax.scm: Remove references to annotation objects,
we're just going to try and use Guile's source properties now. It works
until `syntax' reconstructs output, at which point it seems we lose it.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 39a2eca2ce7461108ddc595cb74a6bf47c456bd8
Author: Andy Wingo <address@hidden>
Date: Fri May 22 19:26:58 2009 +0200
fix problem naming internal definitions
* module/ice-9/psyntax.scm (chi-body): Fix a problem introduced in
dc1eed52f71, that internal syntax definitions were included in the id
lis along with value definitions. Only showed up on a second bootstrap.
Psyntax, how I love thee.
* module/ice-9/psyntax-pp.scm
commit 55ae815b62c5d4bf324351d64919bdb8d4070148
Author: Andy Wingo <address@hidden>
Date: Fri May 22 16:07:41 2009 +0200
move things to (language tree-il primitives)
* module/language/tree-il/optimize.scm:
* module/language/tree-il/primitives.scm: Move primitive-related things
to primitive.scm from inline.scm and optimize.scm.
* module/Makefile.am: Update for inventory changes.
commit e0c90f9084914956d90db73b21ef2ab32d1a477a
Author: Andy Wingo <address@hidden>
Date: Fri May 22 13:00:23 2009 +0200
fix tree-il test to work if source info happens to be present
* module/language/tree-il/compile-glil.scm (flatten-lambda): Fix source
emission.
* test-suite/tests/tree-il.test (strip-source): Strip source info on
tree-il before compiling, so we don't get extraneous source info in the
glil. Make check passes!
commit e6b94431794ad5cffedfbdbe949789d04ef97761
Author: Andy Wingo <address@hidden>
Date: Fri May 22 12:48:45 2009 +0200
fix bad call to make-glil-src
* module/language/tree-il/compile-glil.scm (flatten-lambda): Fix bad call
to make-glil-src, unfortunately not hit during production because
psyntax doesn't yet understand source locations.
commit 7902c547130235438fa170d94c43e0c271adb71d
Author: Andy Wingo <address@hidden>
Date: Fri May 22 12:45:49 2009 +0200
fix expansion of (ice-9 threads)
* module/ice-9/threads.scm: Move syntax definitions before the procedures
that use them, and rewrite as hygienic macros since they are so much
nicer that way. Fixes the thread tests.
commit 9ecac781bf3b33abca137c242ceaa7c49f604958
Author: Andy Wingo <address@hidden>
Date: Fri May 22 12:22:39 2009 +0200
syntax.test is passing, yay
* test-suite/tests/syntax.test ("top-level define"): Remove the test for
currying, as we don't do that any more by default. It should be easy
for the user to add in if she wants it, though.
("do"): Remove unmemoization tests, as sc-expand fully expands `do'.
("while"): Remove while tests in empty environments. They have been
throwing 'unresolved, and the problem they seek to test is fully
handled by hygiene anyway.
And otherwise tweak expected exception strings, and everything passes!
commit dc1eed52f71004bca74028d03ae35bbf569be709
Author: Andy Wingo <address@hidden>
Date: Fri May 22 12:08:50 2009 +0200
residualize names into procedures. re-implement srfi-61. module naming foo.
* module/ice-9/boot-9.scm (cond): Implement srfi-61; most of the code is
from the SRFI itself. Yuk.
(%print-module, make-modules-in, %app, (%app modules))
(module-name): Syncase needs to get at the names of modules, even at
anonymous modules. So lazily assign gensyms as module names. Name %app
as (%app), but since (%app modules) is at the top of the module
hierarchy, name it ().
* module/ice-9/psyntax.scm: When building tree-il, try to name lambdas in
definitions and in lets.
(let, letrec): Give more specific errors in a couple of cases.
* module/ice-9/psyntax-pp.scm: Regenerated.
* test-suite/tests/syntax.test: More work. Many exceptions have different
messages than they used to, many more generic; we can roll this back to
be faithful to the original strings, but it doesn't seem necessary to
me.
commit 0260421208267eb202f9c9628cdaf39b531a5129
Author: Andy Wingo <address@hidden>
Date: Thu May 21 22:43:07 2009 +0200
some work on syntax.test
* module/language/tree-il.scm (tree-il->scheme):
* module/ice-9/psyntax.scm (build-conditional): Attempt to not generate
(if #f #f) as the second arm of an if, but it doesn't seem to be
successful.
* module/ice-9/psyntax-pp.scm (syntax-rules): Regenerate.
* test-suite/tests/syntax.test (exception:unexpected-syntax): Change
capitalization.
("unquote-splicing"): Update test.
("begin"): Add in second arms on these ifs, to avoid the strange though
harmless expansion of `if'.
(matches?): New helper macro.
("lambda"): Match on lexically bound symbols, as they will be
alpha-renamed.
commit 40b36cfbbe4676f52bd4d6b45ae1642756642907
Author: Andy Wingo <address@hidden>
Date: Thu May 21 22:11:48 2009 +0200
catch syntax errors in unquote and unquote-splicing
* module/ice-9/psyntax.scm (quasiquote): Catch syntax errors in unquote
and unquote-splicing.
* module/ice-9/psytax-pp.scm: Regenerated.
commit 2032f3d1db09aa63de4ec060081a5bf9053f0d3c
Author: Andy Wingo <address@hidden>
Date: Thu May 21 21:39:37 2009 +0200
fix multiple values returning from srfi-18's `with-exception-handler'
* module/srfi/srfi-18.scm (with-exception-handler): Hah! Fixed a
scurrilous bug in which we assumed that the thunk returned one or more
values. Hah.
commit 0f423f20aae6228431d3695e60ade937858110b8
Author: Andy Wingo <address@hidden>
Date: Thu May 21 21:13:24 2009 +0200
fix apply and call/cc in drop contexts
* module/language/tree-il/compile-glil.scm (flatten): Actually apply only
needs one arg after the proc. And shit, call/cc and apply in drop
contexts also need to be able to return arbitrary numbers of values;
work it by trampolining through their applicative (non-@) definitions.
Also, simplify the single-valued drop case to avoid the
truncate-values.
* module/language/tree-il/inline.scm (call/cc):
* module/language/tree-il/optimize.scm (*interesting-primitive-names*):
Define call/cc as "interesting". Perhaps we should be hashing on value
and not on variable.
* test-suite/tests/tree-il.test ("application"): Fix up test for new,
sleeker output. (Actually the GLIL is more verbose, but the assembly is
better.)
("apply", "call/cc"): Add some more tests.
commit 30a5e062d022aafdb72cea648f3a4de0e72feb6d
Author: Andy Wingo <address@hidden>
Date: Thu May 21 17:22:58 2009 +0200
procedures in "drop" contexts can return unspecified values
* module/language/tree-il/compile-glil.scm (flatten): For applications in
"drop" context, allow the procedure to return unspecified values
(including 0 values).
* test-suite/tests/tree-il.test ("application"): Adapt test.
* module/srfi/srfi-18.scm (wrap): Clarify.
* test-suite/tests/srfi-18.test: Fix so that the expression importing
srfi-18 is expanded before the tests. However the tests are still
failing, something about 0-valued returns...
commit a48358b38fed9486cebf7f8338dc05adc770fc0f
Author: Andy Wingo <address@hidden>
Date: Thu May 21 16:04:14 2009 +0200
fix srfi-17.test
* test-suite/tests/srfi-17.test (exception:bad-quote): Change the
expected exception for (set! (quote foo) ...) errors.
commit d63927150aa22bb7e57125ed50e5ecbe11765fba
Author: Andy Wingo <address@hidden>
Date: Thu May 21 15:34:29 2009 +0200
just parse method arguments once.
* module/oop/goops.scm (method): Tweak to just run through the arguments
once. Thanks to Eli Barzilay for the tip.
commit 47c8983f08157865a3937722c06acbbb3cbd7621
Author: Andy Wingo <address@hidden>
Date: Thu May 21 13:49:00 2009 +0200
rewrite `method' as a hygienic macro to re-allow lexical specializers
* module/oop/goops.scm (method): Reimplement as a hygienic macro. This
seriously took me like 6 hours to figure out. Allows for lexical
specializers: (let ((<x> ...)) (define-method (foo (arg <x>)) ...)).
* module/oop/goops/compile.scm (next-method?, compile-make-procedure):
Remove these, as `method' does it all now, hygienically.
commit 8bb0b3cc9d582c48ed6cb5d123168ffd27ac7cf8
Author: Andy Wingo <address@hidden>
Date: Wed May 20 18:11:23 2009 +0200
fix failing macro-as-parameter tests in eval.test
* module/ice-9/psyntax.scm (chi-lambda-clause): Strip the docstring
before passing it on to the continuation.
* module/ice-9/psyntax-pp.scm: Regenerated.
* test-suite/tests/eval.test (exception:failed-match): New exception, for
syntax-case failed matches.
("evaluator"): Fix macro-as-parameter tests. They pass now :)
commit 68623e8e7883077dbb26521fe6d9c185df3138ce
Author: Andy Wingo <address@hidden>
Date: Wed May 20 17:41:21 2009 +0200
remove compile-time-environment
* module/ice-9/boot-9.scm (guile-user): Move the `compile' autoload to
the guile-user module. Remove reference to compile-time-environment.
* module/language/scheme/compile-ghil.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/optimize.scm:
* module/system/base/compile.scm:
* test-suite/tests/compiler.test: Remove definition of and references to
compile-time-environment. While I do think that recompilation based on
a lexical environment can be useful, I think it needs to be implemented
differently. So for now we've lost nothing if we take it away, as it
doesn't work with syncase anyway.
commit 9806a548fe1a9cca0f82ef4f2f08fbcba5eccfaa
Author: Andy Wingo <address@hidden>
Date: Wed May 20 17:28:59 2009 +0200
Fix a bug in the (ice-9 match) test
* testsuite/t-match.scm (matches?): Fix match invocation. As far as I can
tell, although (ice-9 match) does advertise a => form of clauses, it
requires that the end of the => be a symbol. For some reason this
works in the interpreter:
((lambda () (begin => #t)))
It's part of the expansion of matches?. It also worked in the old
compiler. Thinking that maybe toplevel references could cause side
effects, I made the new compiler actually ref =>, which brought this to
light.
commit ad9b8c451b82f74cf88c5a6207ed3ea72c86f93e
Author: Andy Wingo <address@hidden>
Date: Wed May 20 13:59:42 2009 +0200
fix @slot-ref / @slot-set! compilation
* module/language/tree-il/compile-glil.scm: Add primcall compilers for
@slot-ref and @slot-set.
* module/language/tree-il/optimize.scm (add-interesting-primitive!): New
export. Creates an association between a variable in the current module
and a primitive name.
* module/oop/goops.scm: Rework compiler hooks to work with tree-il and
not ghil.
commit c11f46afe113f50e34af33ad3055b3da66e4b71f
Author: Andy Wingo <address@hidden>
Date: Wed May 20 13:33:44 2009 +0200
compile `list' and `vector' to their associated opcodes
* module/language/glil/compile-assembly.scm (glil->assembly): Check the
length when emitting calls to variable-argument stack instructions.
Allow two-byte lengths -- allows e.g. calls to `list' with more than
256 arguments.
* module/language/tree-il/compile-glil.scm: Add primcall associations for
`list' and `vector', with any number of arguments. Necessary because
syncase's quasiquote expansions will produce calls to `list' with many
arguments.
* module/language/tree-il/optimize.scm (*interesting-primitive-names*):
Add `list' and `vector' to the set of primitives to resolve.
commit 5af166bda2f1d89525add147a9e3d2d6867d03a5
Author: Andy Wingo <address@hidden>
Date: Wed May 20 12:46:23 2009 +0200
don't allocate too many locals for expansions of `or'
* module/language/tree-il/analyze.scm (analyze-lexicals): Add in a hack
to avoid allocating more locals than necessary for expansions of `or'.
Documented in the source.
* test-suite/tests/tree-il.test: Add a test case.
commit e32a1792de84c20eaaae6ea7f33048b6eef2c9d8
Author: Andy Wingo <address@hidden>
Date: Wed May 20 11:59:41 2009 +0200
a few fixups
* module/ice-9/psyntax.scm (chi-install-global, syntax-case): Fix a
couple of cases in which bare datums were passed to output
constructors.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/scheme/spec.scm (scheme): Clean up the #:compilers
list.
* module/language/tree-il/compile-glil.scm (flatten): Fix call to
`length' in call/cc compiler.
commit a1a482e0e9518b5711bc2734aa014254f9207919
Author: Andy Wingo <address@hidden>
Date: Wed May 20 11:15:22 2009 +0200
and, or, cond etc use syntax-rules, compile scheme through tree-il
* libguile/vm-i-system.c:
* libguile/vm-engine.h (ASSERT_BOUND): New assertion, that a value is
bound. Used by local-ref and external-ref in paranoid mode.
* module/ice-9/boot-9.scm (and, or, cond, case, do): Since we are
switching to use psyntax as the first pass of the compiler, and perhaps
soon of the interpreter too, we need to make sure it expands out all
forms to primitive expressions. So define expanders for these derived
syntax forms, as in the R5RS report.
* module/ice-9/psyntax-pp.scm: Regenerate, with core forms fully
expanded.
* module/ice-9/psyntax.scm (build-void): New constructor, for making
undefined values.
(build-primref): Add in a hack so that primitive refs in the boot
module expand out to toplevel refs, not module refs.
(chi-void): Use build-void.
(if): Define an expander for if that calls build-conditional.
* module/language/scheme/compile-tree-il.scm (compile-tree-il): Use let*
so as not to depend on binding order for the result of
(current-module).
* module/language/scheme/spec.scm (scheme): Switch over to tree-il as the
primary intermediate language. Not yet fully tested, but at least it
can compile psyntax-pp.scm.
* module/language/tree-il/analyze.scm (analyze-lexicals): Arguments don't
count towards a function's nlocs.
* module/language/tree-il/compile-glil.scm (*comp-module*, compile-glil):
Define a "compilation module" fluid.
(flatten-lambda): Fix a call to make-glil-argument. Fix bug in
heapifying arguments.
(flatten): Fix number of arguments passed to apply instruction. Add a
special case for `(values ...)'. If inlining primitive-refs fails,
try expanding into toplevel-refs if the comp-module's variable is the
same as the root variable.
* module/language/tree-il/optimize.scm (resolve-primitives!): Add missing
src variable for <module-ref>.
* test-suite/tests/tree-il.test ("lambda"): Fix nlocs counts. Add a
closure test case.
commit ce09ee19892d391f3b2ca13e0616d343929c2c14
Author: Andy Wingo <address@hidden>
Date: Mon May 18 23:45:35 2009 +0200
add tree-il->glil compilation test suite
* module/language/tree-il.scm (parse-tree-il): Fix a number of bugs.
(unparse-tree-il): Apply takes rest args now.
* module/language/tree-il/analyze.scm (analyze-lexicals)
(analyze-lexicals): Heap vars shouldn't increment the number of locals.
* module/language/tree-il/optimize.scm (resolve-primitives!): Don't
resolve public refs to primitives, not at the moment anyway.
* test-suite/Makefile.am (SCM_TESTS): Add tree-il test.
* test-suite/lib.scm (pass-if, expect-fail, pass-if-exception)
(expect-fail-exception): Rewrite as syntax-rules macros. In a very
amusing turn of events, it turns out that bindings introduced by
hygienic macros are not visible inside expansions produced by
defmacros. This seems to be expected, so go ahead and work around the
problem.
* test-suite/tests/srfi-31.test ("rec special form"): Expand in eval.
* test-suite/tests/syntax.test ("begin"): Do some more expanding in eval,
though all is not yet well.
* test-suite/tests/tree-il.test: New test suite, for tree-il->glil
compilation.
commit dce042f1f74f8ef5ca5089beb50fd7496feae5da
Author: Andy Wingo <address@hidden>
Date: Mon May 18 01:08:34 2009 +0200
special cases for more types of known applications
* module/language/tree-il/compile-glil.scm (flatten): Handle a number of
interesting applications, and fix a bug for calls in `drop' contexts.
* module/language/tree-il/inline.scm: Define expanders for apply,
call-with-values, call-with-current-continuation, and values.
commit 112edbaea3e48e002261c72064d6602d661c3df4
Author: Andy Wingo <address@hidden>
Date: Sun May 17 23:24:26 2009 +0200
inline calls to some primitives
* module/system/base/pmatch.scm: Wrap consequents in (let () ) instead of
(begin ) so that they can have local definitions.
* module/language/tree-il/compile-glil.scm: Inline some calls to
primitives.
commit 1eec95f8def91bcb6f9f22c21c6d27ec2a7175ac
Author: Andy Wingo <address@hidden>
Date: Sun May 17 18:04:36 2009 +0200
define `delay' in terms of make-promise
* module/ice-9/boot-9.scm (delay): Define `delay' in terms of
make-promise.
* module/ice-9/psyntax-pp.scm (compile): Regenerated with a fully
compiled Guile, so that the gensym numbers are the same.
* module/language/tree-il/compile-glil.scm: Add some notes about what
needs doing to catch up to the old compiler.
commit 2ce77f2d95271887b54d0c56d1e81d7f472ae1ae
Author: Andy Wingo <address@hidden>
Date: Sun May 17 16:46:46 2009 +0200
and now, we residualize the original names into the metadata. yay!
* module/language/tree-il/compile-glil.scm (vars->bind-list)
(emit-bindings, flatten-lambda, flatten): Write the original names into
<glil-bind> structures. Yaaaaay!
commit 696495f4d21fc8bc479b50588c08ea55e7c6e3a7
Author: Andy Wingo <address@hidden>
Date: Sun May 17 16:39:55 2009 +0200
actually pass original ids on to tree-il data types
* module/ice-9/psyntax.scm (build-lambda, build-let, build-named-let)
(build-letrec): Actually pass along the original ids to tree-il
constructors.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/tree-il.scm: Add fields in <lambda>, <let>, and
<letrec> for the original variable names.
* module/language/tree-il/compile-glil.scm (compile-glil): Adapt for new
make-lambda arg.
commit 547a602d1ef4d3622cf2d476ff311957b447eaba
Author: Andy Wingo <address@hidden>
Date: Sun May 17 16:27:18 2009 +0200
preserve original var names in lets and lambdas
* module/ice-9/psyntax.scm (build-letrec, build-let, build-lambda)
(build-named-let): Take extra args for the original names of the
gensyms. Not used yet. Callers adapted.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit cf10678fe7014a67020c45ee02f2aabb44598adc
Author: Andy Wingo <address@hidden>
Date: Fri May 15 23:44:14 2009 +0200
tree-il -> glil compiler works now, at least in initial tests
* module/language/tree-il/analyze.scm: Break analyzer out into its own
file.
* module/language/tree-il/compile-glil.scm: Port the GHIL->GLIL compiler
over to work on tree-il. Works, but still misses a number of important
optimizations.
* module/language/tree-il.scm: Add <void>. Not used quite yet.
* module/language/glil.scm: Remove <glil-argument>, as it is the same as
<glil-local> (minus an offset).
* module/language/glil/compile-assembly.scm:
* module/language/glil/decompile-assembly.scm:
* module/language/ghil/compile-glil.scm: Adapt for <glil-argument>
* removal.
* module/Makefile.am (TREE_IL_LANG_SOURCES): Reorder, and add
analyze.scm.
commit 073bb617eb7e5f76269ca6dba0fe498baff6f058
Author: Andy Wingo <address@hidden>
Date: Thu May 14 00:11:25 2009 +0200
add lexical analyzer and allocator
* module/language/tree-il/optimize.scm: Rework to just export the
optimize! procedure.
* module/language/tree-il/compile-glil.scm (analyze-lexicals): New
function, analyzes and allocates lexical variables. Almost ready to
compile now.
(codegen): Dedent.
commit cb28c08537790b49f7bc94f2f6b426497152bbe7
Author: Andy Wingo <address@hidden>
Date: Tue May 12 22:29:34 2009 +0200
add primitive expander for tree-il
* module/Makefile.am: Add inline.scm.
* module/language/tree-il.scm (pre-order!, post-order!): pre-order! is
new. post-order! existed but was not public. They do destructive tree
traversals of tree-il, and need more documentation. Also, add
predicates to tree-il's export list.
* module/language/tree-il/inline.scm: New file, which expands primitives
into more primitive primitives. In the future perhaps it will not be
necessary, as the general inlining infrastructure will handle these
cases, but for now it's useful.
* module/language/tree-il/optimize.scm: Move post-order! out to better
pastures.
commit 9efc833d65adef11e76410fee7ea548143131417
Author: Andy Wingo <address@hidden>
Date: Mon May 11 23:23:34 2009 +0200
add tree-il optimizer
* module/language/tree-il/optimize.scm: New module, for optimizations.
Currently all we have is resolving some toplevel refs to primitive
refs.
* module/Makefile.am: Add new module.
* module/language/tree-il.scm: Fix exports for accessors for `src'.
* module/language/tree-il/compile-glil.scm: Tweaks, things still aren't
working yet.
commit b81d329e449420b6abaa2b689d7107b862111cbf
Author: Andy Wingo <address@hidden>
Date: Fri May 8 12:56:18 2009 +0200
more work on tree-il compilation
* module/language/scheme/amatch.scm: Remove, this approach won't be used.
* module/Makefile.am: Adjust for additions and removals.
* module/language/scheme/compile-ghil.scm: Remove an vestigial debugging
statement.
* module/language/scheme/spec.scm:
* module/language/scheme/compile-tree-il.scm:
* module/language/scheme/decompile-tree-il.scm: Add tree-il compiler and
decompiler.
* module/language/tree-il/compile-glil.scm: Add some notes.
* module/language/tree-il/spec.scm: No need to wrap expressions in
lambdas -- GHIL needs somewhere to put its variables, we don't.
commit 06656e06d454f16694d0b550fb339efb0c36123a
Author: Andy Wingo <address@hidden>
Date: Thu May 7 17:44:51 2009 +0200
go ahead and regenerate psyntax-pp.scm
commit 982a1c205d2ff1dc61a2ff56ba2e6491974f9303
Author: Andy Wingo <address@hidden>
Date: Thu May 7 17:38:40 2009 +0200
remove (ice-9 expand-support)
* module/ice-9/Makefile.am:
* module/ice-9/expand-support.scm: Remove module, no longer used.
* module/ice-9/psyntax.scm: Fix a comment.
commit 811d10f5a2297e2fe6a881d02c67c45bf4311a27
Author: Andy Wingo <address@hidden>
Date: Thu May 7 13:45:03 2009 +0200
new language: tree-il. psyntax generates it when run in compile mode.
* module/Makefile.am: Add tree-il sources.
* module/ice-9/compile-psyntax.scm: Adjust for sc-expand producing
tree-il in compile mode.
* module/ice-9/psyntax.scm: Switch from expand-support to tree-il for
generating output in compile mode. Completely generate tree-il -- the
output wasn't Scheme before, but now it's completely not Scheme.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/scheme/compile-ghil.scm: Strip structures using
tree-il, not expand-support.
* module/language/tree-il.scm:
* module/language/tree-il/spec.scm
* module/language/tree-il/compile-glil.scm: New language. It will compile
to GLIL, though it doesn't yet.
commit 1aeb082b8281eb12640d7a42c88a566418c64782
Author: Andy Wingo <address@hidden>
Date: Thu May 7 11:02:10 2009 +0200
make expand-support structure constructors take a source argument
* module/ice-9/expand-support.scm (make-module-ref, make-lexical): Add
source arguments to these constructors.
* module/ice-9/psyntax.scm:
* module/ice-9/psyntax-pp.scm: Adapt to match, though we don't wire
everything up yet.
commit f27e9e11cd01eefa9eab3cfd277120ce73e3355a
Author: Andy Wingo <address@hidden>
Date: Thu May 7 10:27:53 2009 +0200
fix install-global construction of `define' forms
* module/ice-9/psyntax.scm (build-global-definition): Remove mod
argument, as it does not seem we could ever define something in another
module.
(chi-install-global): Build the define as a definition, not an
application. Doesn't matter now, but it will later.
(chi-top): Fix build-global-definition call.
* module/ice-9/psyntax.scm: Regenerated.
commit f4a644ee886903df43810f1a0e65ce2ef891999f
Author: Andy Wingo <address@hidden>
Date: Mon May 4 12:18:14 2009 +0200
when compiling, use make-lexical to residualize original var names
* module/ice-9/psyntax.scm (build-lexical-reference): Change to be a
function. Take an extra arg, the original name of the variable. If we
are compiling, make a #<lexical>, annotated with the original var name.
All callers changed.
(build-lexical-assignment): Also a function, taking also the original
var name, using build-lexical-reference to build its output.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 71f46dbd5ecf62809c2aa475b6f5742993ada0b9
Author: Andy Wingo <address@hidden>
Date: Mon May 4 11:57:36 2009 +0200
sc-expand in compile mode produces (ice-9 expand-support) structures
* module/ice-9/psyntax.scm (*mode*): New moving part, a fluid.
(sc-expand): Dynamically bind *mode* to the expansion mode.
(build-global-reference): Change to be a procedure instead of local
syntax. Import the logic about when to make a @ or @@ form to here,
from boot-9.scm. If we are compiling, build output using (ice-9
expand-support)'s make-module-ref, otherwise just making the familiar
s-expressions. (This will allow us to correctly expand in modules in
which @ or @@ are not bound, at least when we are compiling.)
(build-global-assignment): Use the result of build-global-reference. A
bit hacky, but hey.
(top-level-eval-hook, local-eval-hook): Strip expansion structures
before evalling.
* module/ice-9/boot-9.scm (make-module-ref): Remove, this logic is now
back in psyntax.scm.
* module/ice-9/compile-psyntax.scm (source): Since we expand in compile
mode, we need to strip expansion structures.
* module/ice-9/expand-support.scm (strip-expansion-structures): Remove
the logic about whether and how to strip @/@@ from here, as it's part
of psyntax now.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/scheme/compile-ghil.scm (compile-ghil): Strip expansion
structures -- for now. In the future, we might translate directly from
these structures into GHIL.
commit 123f8abb2da5ed7b2d8ccd67b3bd3532aa9d257e
Author: Andy Wingo <address@hidden>
Date: Mon May 4 10:47:31 2009 +0200
replace sc-expand with sc-expand3, removing binding for sc-expand3
* module/ice-9/boot-9.scm (sc-expand3):
* module/ice-9/psyntax.scm (sc-expand3): Replace sc-expand with
sc-expand3, as expand3 with one argument is the same as sc-expand.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/ice-9/compile-psyntax.scm:
* module/language/scheme/compile-ghil.scm: Change callers to sc-expand3
to use sc-expand.
commit 41af238146428f5841880f26d84b5dc9ddfad2c4
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 23:57:31 2009 +0200
remove (void) from boot-9 and psyntax
* module/ice-9/psyntax.scm: Tweak comments. Remove references to `void';
just produce (if #f #f) instead of (void).
* module/ice-9/psyntax-pp.scm: Regenerated, twice.
* module/ice-9/boot-9.scm (void): Remove this binding.
commit 6a952e0ee9093424cdc8f300406d09ce195ebf5c
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 23:39:09 2009 +0200
more cleanups to boot-9/psyntax
* module/ice-9/boot-9.scm: Comment some more things.
* module/ice-9/psyntax.scm: Remove error-hook -- callers should just use
syntax-violation. Change all callers.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 4d24854111110b44a28a4d46242bac1285de387a
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 23:12:12 2009 +0200
remove andmap from public API (we still have and-map)
* module/ice-9/boot-9.scm (and-map, or-map): Move these definitions up so
psyntax can use them.
(andmap): Remove, yay.
* module/ice-9/psyntax.scm: Remove notes about andmap, and just use
Guile's and-map -- except in cases that need the multiple list support,
in which case we have a private and-map*.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 12eae603c76edc8affc0e8331df7f22a4d8a8b2c
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 22:50:45 2009 +0200
cleanups to boot-9
* module/ice-9/boot-9.scm: Shuffle around some definitions.
(module-add!): Removed stub definition, no longer used.
(install-global-transformer): Removed, no longer used (yay!).
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/ice-9/psyntax.scm: Remove install-global-transformer.
commit 3d5f3091e100550052abc698e980b3e86cc01b65
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 21:19:23 2009 +0200
first-class macro representation (no bits on variables)
* libguile/macros.c (scm_macro_p): Update docs.
* module/ice-9/boot-9.scm (module-define!, module-ref): Define pre-boot
forms of these functions as well. I suspect module-add! can go soon.
(module-lookup-keyword, module-define-keyword!)
(module-undefine-keyword!) Remove these.
* module/ice-9/psyntax-pp.scm: Regenerate. Notice the difference?
* module/ice-9/psyntax.scm (put-global-definition-hook)
(get-global-definition-hook): Rework to expect first-class macros. Heh
heh.
(remove-global-definition-hook): Pleasantly, this hook can go away.
(chi-install-global): Terrorism to generate the right kind of output --
will clean up.
(chi-top): Unify definition handling for all kinds of values.
commit 5a0132b3375b35c69c6afb735acbaa8619237fb5
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 00:38:12 2009 +0200
a different tack for syncase macro representation
* libguile/macros.c (macro_print): Show syntax-case bindings, if present.
(macro_mark): Mark the extra two words if they're there.
(scm_make_syncase_macro, scm_make_extended_syncase_macro): OK! A new
take at the "how do we represent syncase macros in Guile" problem.
Whereas we need a disjoint type, but would like it to be compatible
with old predicates (e.g. `macro?'), and need to be able to extend
existing syntax definitions (e.g. `cond'), let's add a bit to macros to
indicate whether they have syncase macro bindings or not, and a fourth
macro type for native syncase macros.
(scm_macro_type): Return 'syntax-case for native syntax-case macros.
Note that other macro types may have syntax-case bindings.
(scm_macro_name): Return #f if the transformer is not a procedure.
(scm_syncase_macro_type, scm_syncase_macro_binding): New accessors for
the syncase macro bindings.
* libguile/macros.h: Add API for syncase macros.
* module/ice-9/boot-9.scm (module-define-keyword!): Adapt to use syncase
macros, though they are not yet used. Reorder other syncase API.
* module/ice-9/psyntax.scm (chi-expr): Fix syntax-violation invocation.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-procedures.texi | 28 +-
doc/ref/compiler.texi | 761 ++++++++++---------
doc/ref/vm.texi | 166 ++---
lang/Makefile.am | 1 +
libguile/frames.c | 49 +-
libguile/frames.h | 84 +--
libguile/instructions.c | 50 +-
libguile/instructions.h | 66 +--
libguile/macros.c | 113 +++-
libguile/macros.h | 13 +-
libguile/objcodes.c | 49 +-
libguile/objcodes.h | 66 +--
libguile/programs.c | 49 +-
libguile/programs.h | 86 +--
libguile/read.c | 83 ++
libguile/vm-bootstrap.h | 50 +-
libguile/vm-engine.c | 48 +-
libguile/vm-engine.h | 52 +-
libguile/vm-expand.h | 48 +-
libguile/vm-i-scheme.c | 48 +-
libguile/vm-i-system.c | 8 +-
libguile/vm.c | 49 +-
libguile/vm.h | 110 ++--
module/Makefile.am | 18 +-
module/ice-9/boot-9.scm | 327 +++++----
module/ice-9/compile-psyntax.scm | 4 +-
module/ice-9/documentation.scm | 2 +
module/ice-9/expand-support.scm | 169 -----
module/ice-9/psyntax-pp.scm | 24 +-
module/ice-9/psyntax.scm | 791 +++++++++++---------
module/ice-9/stack-catch.scm | 2 +-
module/ice-9/threads.scm | 114 ++--
module/ice-9/time.scm | 2 +-
module/language/assembly/disassemble.scm | 2 +-
module/language/ecmascript/spec.scm | 1 -
module/language/ghil/compile-glil.scm | 14 +-
module/language/glil.scm | 7 -
module/language/glil/compile-assembly.scm | 31 +-
module/language/glil/decompile-assembly.scm | 8 +-
module/language/scheme/amatch.scm | 35 -
module/language/scheme/compile-ghil.scm | 16 +-
module/language/scheme/compile-tree-il.scm | 64 ++
.../{r5rs/null.il => scheme/decompile-tree-il.scm} | 11 +-
module/language/scheme/spec.scm | 13 +-
module/language/tree-il.scm | 359 +++++++++
module/language/tree-il/analyze.scm | 235 ++++++
module/language/tree-il/compile-glil.scm | 448 +++++++++++
.../{ecmascript/spec.scm => tree-il/optimize.scm} | 42 +-
module/language/tree-il/primitives.scm | 206 +++++
module/language/{ecmascript => tree-il}/spec.scm | 35 +-
module/oop/goops.scm | 163 +++--
module/oop/goops/compile.scm | 32 +-
module/srfi/srfi-18.scm | 10 +-
module/system/base/compile.scm | 20 +-
module/system/base/language.scm | 3 +-
module/system/base/pmatch.scm | 6 +-
module/system/repl/repl.scm | 2 +-
test-suite/Makefile.am | 1 +
test-suite/lib.scm | 40 +-
test-suite/tests/compiler.test | 43 +-
test-suite/tests/eval.test | 27 +-
test-suite/tests/reader.test | 35 +
test-suite/tests/srfi-17.test | 7 +-
test-suite/tests/srfi-18.test | 9 +-
test-suite/tests/srfi-31.test | 2 +-
test-suite/tests/syntax.test | 414 +++++------
test-suite/tests/tree-il.test | 467 ++++++++++++
testsuite/t-match.scm | 2 +-
68 files changed, 3932 insertions(+), 2408 deletions(-)
delete mode 100644 module/ice-9/expand-support.scm
delete mode 100644 module/language/scheme/amatch.scm
create mode 100644 module/language/scheme/compile-tree-il.scm
copy module/language/{r5rs/null.il => scheme/decompile-tree-il.scm} (72%)
create mode 100644 module/language/tree-il.scm
create mode 100644 module/language/tree-il/analyze.scm
create mode 100644 module/language/tree-il/compile-glil.scm
copy module/language/{ecmascript/spec.scm => tree-il/optimize.scm} (57%)
create mode 100644 module/language/tree-il/primitives.scm
copy module/language/{ecmascript => tree-il}/spec.scm (60%)
create mode 100644 test-suite/tests/tree-il.test
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index e3cf258..8098b4f 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -162,18 +162,10 @@ appropriate module first, though:
Returns @code{#t} iff @var{obj} is a compiled procedure.
@end deffn
address@hidden {Scheme Procedure} program-bytecode program
address@hidden {C Function} scm_program_bytecode (program)
-Returns the object code associated with this program, as a
address@hidden
address@hidden deffn
-
address@hidden {Scheme Procedure} program-base program
address@hidden {C Function} scm_program_base (program)
-Returns the address in memory corresponding to the start of
address@hidden's object code, as an integer. This is useful mostly when
-you map the value of an instruction pointer from the VM to actual
-instructions.
address@hidden {Scheme Procedure} program-objcode program
address@hidden {C Function} scm_program_objcode (program)
+Returns the object code associated with this program. @xref{Bytecode
+and Objcode}, for more information.
@end deffn
@deffn {Scheme Procedure} program-objects program
@@ -184,9 +176,9 @@ vector. @xref{VM Programs}, for more information.
@deffn {Scheme Procedure} program-module program
@deffnx {C Function} scm_program_module (program)
-Returns the module that was current when this program was created.
-Free variables in this program are looked up with respect to this
-module.
+Returns the module that was current when this program was created. Can
+return @code{#f} if the compiler could determine that this information
+was unnecessary.
@end deffn
@deffn {Scheme Procedure} program-external program
@@ -250,9 +242,9 @@ REPL. The only tricky bit is that @var{extp} is a boolean,
declaring
whether the binding is heap-allocated or not. @xref{VM Concepts}, for
more information.
-Note that bindings information are stored in a program as part of its
-metadata thunk, so including them in the generated object code does
-not impose a runtime performance penalty.
+Note that bindings information is stored in a program as part of its
+metadata thunk, so including it in the generated object code does not
+impose a runtime performance penalty.
@end deffn
@deffn {Scheme Procedure} program-sources program
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 27d8f79..0d68abf 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -22,9 +22,10 @@ know how to compile your .scm file.
@menu
* Compiler Tower::
* The Scheme Compiler::
-* GHIL::
+* Tree-IL::
* GLIL::
-* Object Code::
+* Assembly::
+* Bytecode and Objcode::
* Extending the Compiler::
@end menu
@@ -52,7 +53,7 @@ They are registered with the @code{define-language} form.
@deffn {Scheme Syntax} define-language @
name title version reader printer @
-[parser=#f] [read-file=#f] [compilers='()] [evaluator=#f]
+[parser=#f] [compilers='()] [decompilers='()] [evaluator=#f]
Define a language.
This syntax defines a @code{#<language>} object, bound to @var{name}
@@ -62,17 +63,15 @@ for Scheme:
@example
(define-language scheme
- #:title "Guile Scheme"
- #:version "0.5"
- #:reader read
- #:read-file read-file
- #:compilers `((,ghil . ,compile-ghil))
- #:evaluator (lambda (x module) (primitive-eval x))
- #:printer write)
+ #:title "Guile Scheme"
+ #:version "0.5"
+ #:reader read
+ #:compilers `((tree-il . ,compile-tree-il)
+ (ghil . ,compile-ghil))
+ #:decompilers `((tree-il . ,decompile-tree-il))
+ #:evaluator (lambda (x module) (primitive-eval x))
+ #:printer write)
@end example
-
-In this example, from @code{(language scheme spec)}, @code{read-file}
-reads expressions from a port and wraps them in a @code{begin} block.
@end deffn
The interesting thing about having languages defined this way is that
@@ -85,12 +84,12 @@ Guile Scheme interpreter 0.5 on Guile 1.9.0
Copyright (C) 2001-2008 Free Software Foundation, Inc.
Enter `,help' for help.
-scheme@@(guile-user)> ,language ghil
-Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0
+scheme@@(guile-user)> ,language tree-il
+Tree Intermediate Language interpreter 1.0 on Guile 1.9.0
Copyright (C) 2001-2008 Free Software Foundation, Inc.
Enter `,help' for help.
-ghil@@(guile-user)>
+tree-il@@(guile-user)>
@end example
Languages can be looked up by name, as they were above.
@@ -128,17 +127,25 @@ The normal tower of languages when compiling Scheme goes
like this:
@itemize
@item Scheme, which we know and love
address@hidden Guile High Intermediate Language (GHIL)
address@hidden Tree Intermediate Language (Tree-IL)
@item Guile Low Intermediate Language (GLIL)
address@hidden Object code
address@hidden Assembly
address@hidden Bytecode
address@hidden Objcode
@end itemize
Object code may be serialized to disk directly, though it has a cookie
-and version prepended to the front. But when compiling Scheme at
-run time, you want a Scheme value, e.g. a compiled procedure. For this
-reason, so as not to break the abstraction, Guile defines a fake
-language, @code{value}. Compiling to @code{value} loads the object
-code into a procedure, and wakes the sleeping giant.
+and version prepended to the front. But when compiling Scheme at run
+time, you want a Scheme value: for example, a compiled procedure. For
+this reason, so as not to break the abstraction, Guile defines a fake
+language at the bottom of the tower:
+
address@hidden
address@hidden Value
address@hidden itemize
+
+Compiling to @code{value} loads the object code into a procedure, and
+wakes the sleeping giant.
Perhaps this strangeness can be explained by example:
@code{compile-file} defaults to compiling to object code, because it
@@ -156,340 +163,254 @@ different worlds indefinitely, as shown by the
following quine:
@node The Scheme Compiler
@subsection The Scheme Compiler
-The job of the Scheme compiler is to expand all macros and to resolve
-all symbols to lexical variables. Its target language, GHIL, is fairly
-close to Scheme itself, so this process is not very complicated.
-
-The Scheme compiler is driven by a table of @dfn{translators},
-declared with the @code{define-scheme-translator} form, defined in the
-module, @code{(language scheme compile-ghil)}.
-
address@hidden {Scheme Syntax} define-scheme-translator head clause1 clause2...
-The best documentation of this form is probably an example. Here is
-the translator for @code{if}:
-
address@hidden
-(define-scheme-translator if
- ;; (if TEST THEN [ELSE])
- ((,test ,then)
- (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
- ((,test ,then ,else)
- (make-ghil-if e l (retrans test) (retrans then) (retrans else))))
address@hidden example
-
-The match syntax is from the @code{pmatch} macro, defined in
address@hidden(system base pmatch)}. The result of a clause should be a valid
-GHIL value. If no clause matches, a syntax error is signalled.
-
-In the body of the clauses, the following bindings are introduced:
address@hidden
address@hidden @code{e}, the current environment
address@hidden @code{l}, the current source location (or @code{#f})
address@hidden @code{retrans}, a procedure that may be called to compile
-subexpressions
address@hidden itemize
-
-Note that translators are looked up by @emph{value}, not by name. That
-is to say, the translator is keyed under the @emph{value} of
address@hidden, which normally prints as @code{#<primitive-builtin-macro!
-if>}.
address@hidden deffn
-
-Users can extend the compiler by defining new translators.
-Additionally, some forms can be inlined directly to
-instructions -- @xref{Inlined Scheme Instructions}, for a list. The
-actual inliners are defined in @code{(language scheme inline)}:
-
address@hidden {Scheme Syntax} define-inline head arity1 result1 arity2
result2...
-Defines an inliner for @code{head}. As in
address@hidden, inliners are keyed by value and not
-by name.
-
-Expressions are matched on their arities. For example:
-
address@hidden
-(define-inline eq?
- (x y) (eq? x y))
address@hidden example
-
-This inlines calls to the Scheme procedure, @code{eq?}, to the
-instruction @code{eq?}.
-
-A more complicated example would be:
-
address@hidden
-(define-inline +
- () 0
- (x) x
- (x y) (add x y)
- (x y . rest) (add x (+ y . rest)))
address@hidden example
address@hidden deffn
-
-Compilers take two arguments, an expression and an environment, and
-return two values as well: an expression in the target language, and
-an environment suitable for the target language. The format of the
-environment is language-dependent.
-
-For Scheme, an environment may be one of three things:
+The job of the Scheme compiler is to expand all macros and all of
+Scheme to its most primitive expressions. The definition of
+``primitive'' is given by the inventory of constructs provided by
+Tree-IL, the target language of the Scheme compiler: procedure
+applications, conditionals, lexical references, etc. This is described
+more fully in the next section.
+
+The tricky and amusing thing about the Scheme-to-Tree-IL compiler is
+that it is completely implemented by the macro expander. Since the
+macro expander has to run over all of the source code already in order
+to expand macros, it might as well do the analysis at the same time,
+producing Tree-IL expressions directly.
+
+Because this compiler is actually the macro expander, it is
+extensible. Any macro which the user writes becomes part of the
+compiler.
+
+The Scheme-to-Tree-IL expander may be invoked using the generic
address@hidden procedure:
+
address@hidden
+(compile '(+ 1 2) #:from 'scheme #:to 'tree-il)
address@hidden
+ #<<application> src: #f
+ proc: #<<toplevel-ref> src: #f name: +>
+ args: (#<<const> src: #f exp: 1>
+ #<<const> src: #f exp: 2>)>
address@hidden lisp
+
+Or, since Tree-IL is so close to Scheme, it is often useful to expand
+Scheme to Tree-IL, then translate back to Scheme. For that reason the
+expander provides two interfaces. The former is equivalent to calling
address@hidden(sc-expand '(+ 1 2) 'c)}, where the @code{'c} is for
+``compile''. With @code{'e} (the default), the result is translated
+back to Scheme:
+
address@hidden
+(sc-expand '(+ 1 2))
address@hidden (+ 1 2)
+(sc-expand '(let ((x 10)) (* x x)))
address@hidden (let ((x84 10)) (* x84 x84))
address@hidden lisp
+
+The second example shows that as part of its job, the macro expander
+renames lexically-bound variables. The original names are preserved
+when compiling to Tree-IL, but can't be represented in Scheme: a
+lexical binding only has one name. It is for this reason that the
address@hidden output of the expander is @emph{not} Scheme. There's too
+much information we would lose if we translated to Scheme directly:
+lexical variable names, source locations, and module hygiene.
+
+Note however that @code{sc-expand} does not have the same signature as
address@hidden @code{compile-tree-il} is a small wrapper
+around @code{sc-expand}, to make it conform to the general form of
+compiler procedures in Guile's language tower.
+
+Compiler procedures take two arguments, an expression and an
+environment. They return three values: the compiled expression, the
+corresponding environment for the target language, and a
+``continuation environment''. The compiled expression and environment
+will serve as input to the next language's compiler. The
+``continuation environment'' can be used to compile another expression
+from the same source language within the same module.
+
+For example, you might compile the expression, @code{(define-module
+(foo))}. This will result in a Tree-IL expression and environment. But
+if you compiled a second expression, you would want to take into
+account the compile-time effect of compiling the previous expression,
+which puts the user in the @code{(foo)} module. That is purpose of the
+``continuation environment''; you would pass it as the environment
+when compiling the subsequent expression.
+
+For Scheme, an environment may be one of two things:
@itemize
@item @code{#f}, in which case compilation is performed in the context
-of the current module;
address@hidden a module, which specifies the context of the compilation; or
address@hidden a @dfn{compile environment}, which specifies lexical variables
-as well.
+of the current module; or
address@hidden a module, which specifies the context of the compilation.
@end itemize
-The format of a compile environment for scheme is @code{(@var{module}
address@hidden . @var{externals})}, though users are strongly
-discouraged from constructing these environments themselves. Instead,
-if you need this functionality -- as in GOOPS' dynamic method compiler
--- capture an environment with @code{compile-time-environment}, then
-pass that environment to @code{compile}.
-
address@hidden {Scheme Procedure} compile-time-environment
-A special function known to the compiler that, when compiled, will
-return a representation of the lexical environment in place at compile
-time. Useful for supporting some forms of dynamic compilation. Returns
address@hidden if called from the interpreter.
address@hidden deffn
-
address@hidden GHIL
address@hidden GHIL
address@hidden Tree-IL
address@hidden Tree-IL
-Guile High Intermediate Language (GHIL) is a structured intermediate
+Tree Intermediate Language (Tree-IL) is a structured intermediate
language that is close in expressive power to Scheme. It is an
expanded, pre-analyzed Scheme.
-GHIL is ``structured'' in the sense that its representation is based
-on records, not S-expressions. This gives a rigidity to the language
-that ensures that compiling to a lower-level language only requires a
-limited set of transformations. Practically speaking, consider the
-GHIL type, @code{<ghil-quote>}, which has fields named @code{env},
address@hidden, and @code{exp}. Instances of this type are records created
-via @code{make-ghil-quote}, and whose fields are accessed as
address@hidden, @code{ghil-quote-loc}, and
address@hidden There is also a predicate, @code{ghil-quote?}.
address@hidden, for more information on records.
-
-Expressions of GHIL name their environments explicitly, and all
-variables are referenced by identity in addition to by name.
address@hidden(language ghil)} defines a number of routines to deal explicitly
-with variables and environments:
-
address@hidden {Scheme Variable} <ghil-toplevel-env> [table='()]
-A toplevel environment. The @var{table} holds all toplevel variables
-that have been resolved in this environment.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-env> parent [table='()] [variables='()]
-A lexical environment. @var{parent} will be the enclosing lexical
-environment, or a toplevel environment. @var{table} holds an alist
-mapping symbols to variables bound in this environment, while
address@hidden holds a cumulative list of all variables ever defined
-in this environment.
-
-Lexical environments correspond to procedures. Bindings introduced
-e.g. by Scheme's @code{let} add to the bindings in a lexical
-environment. An example of a case in which a variable might be in
address@hidden but not in @var{table} would be a variable that is in
-the same procedure, but is out of scope.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-var> env name kind [index=#f]
-A variable. @var{kind} is one of @code{argument}, @code{local},
address@hidden, @code{toplevel}, @code{public}, or @code{private};
-see the procedures below for more information. @var{index} is used in
-compilation.
address@hidden deftp
-
address@hidden {Scheme Procedure} ghil-var-is-bound? env sym
-Recursively look up a variable named @var{sym} in @var{env}, and
-return it or @code{#f} if none is found.
address@hidden deffn
address@hidden {Scheme Procedure} ghil-var-for-ref! env sym
-Recursively look up a variable named @var{sym} in @var{env}, and
-return it. If the symbol was not bound, return a new toplevel
-variable.
address@hidden deffn
address@hidden {Scheme Procedure} ghil-var-for-set! env sym
-Like @code{ghil-var-for-ref!}, except that the returned variable will
-be marked as @code{external}. @xref{Variables and the VM}.
address@hidden deffn
address@hidden {Scheme Procedure} ghil-var-define! toplevel-env sym
-Return an existing or new toplevel variable named @var{sym}.
address@hidden must be a toplevel environment.
address@hidden deffn
address@hidden {Scheme Procedure} ghil-var-at-module! env modname sym interface?
-Return a variable that will be resolved at run-time with respect to a
-specific module named @var{modname}. If @var{interface?} is true, the
-variable will be of type @code{public}, otherwise @code{private}.
address@hidden deffn
address@hidden {Scheme Procedure} call-with-ghil-environment env syms func
-Bind @var{syms} to fresh variables within a new lexical environment
-whose parent is @var{env}, and call @var{func} as @code{(@var{func}
address@hidden @var{new-vars})}.
address@hidden deffn
address@hidden {Scheme Procedure} call-with-ghil-bindings env syms func
-Like @code{call-with-ghil-environment}, except the existing
-environment @var{env} is re-used. For that reason, @var{func} is
-invoked as @code{(@var{func} @var{new-vars})}
address@hidden deffn
-
-In the aforementioned @code{<ghil-quote>} type, the @var{env} slot
-holds a pointer to the environment in which the expression occurs. The
address@hidden slot holds source location information, so that errors
-corresponding to this expression can be mapped back to the initial
-expression in the higher-level language, e.g. Scheme. @xref{Compiled
-Procedures}, for more information on source location objects.
-
-GHIL also has a declarative serialization format, which makes writing
-and reading it a tractable problem for the human mind. Since all GHIL
-language constructs contain @code{env} and @code{loc} pointers, they
-are left out of the serialization. (Serializing @code{env} structures
-would be difficult, as they are often circular.) What is left is the
-type of expression, and the remaining slots defined in the expression
-type.
-
-For example, an S-expression representation of the @code{<ghil-quote>}
-expression would be:
+Tree-IL is ``structured'' in the sense that its representation is
+based on records, not S-expressions. This gives a rigidity to the
+language that ensures that compiling to a lower-level language only
+requires a limited set of transformations. Practically speaking,
+consider the Tree-IL type, @code{<const>}, which has two fields,
address@hidden and @code{exp}. Instances of this type are records created
+via @code{make-const}, and whose fields are accessed as
address@hidden, and @code{const-exp}. There is also a predicate,
address@hidden @xref{Records}, for more information on records.
+
address@hidden alpha renaming
+
+All Tree-IL types have a @code{src} slot, which holds source location
+information for the expression. This information, if present, will be
+residualized into the compiled object code, allowing backtraces to
+show source information. The format of @code{src} is the same as that
+returned by Guile's @code{source-properties} function. @xref{Source
+Properties}, for more information.
+
+Although Tree-IL objects are represented internally using records,
+there is also an equivalent S-expression external representation for
+each kind of Tree-IL. For example, an the S-expression representation
+of @code{#<const src: #f exp: 3>} expression would be:
@example
-(quote 3)
+(const 3)
@end example
-It's deceptively like Scheme. The general rule is, for a type defined
-as @code{<address@hidden> env loc @var{slot1} @var{slot2}...}, the
-S-expression representation will be @code{(@var{foo} @var{slot1}
address@hidden)}. Users may program with this format directly at the
-REPL:
+Users may program with this format directly at the REPL:
@example
-scheme@@(guile-user)> ,language ghil
-Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0
+scheme@@(guile-user)> ,language tree-il
+Tree Intermediate Language interpreter 1.0 on Guile 1.9.0
Copyright (C) 2001-2008 Free Software Foundation, Inc.
Enter `,help' for help.
-ghil@@(guile-user)> (call (ref +) (quote 32) (quote 10))
+tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10))
@result{} 42
@end example
-For convenience, some slots are serialized as rest arguments; those
-are noted below. The other caveat is that variables are serialized as
-their names only, and not their identities.
-
address@hidden {Scheme Variable} <ghil-void> env loc
-The unspecified value.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-quote> env loc exp
-A quoted expression.
-
-Note that unlike in Scheme, there are no self-quoting expressions; all
-constants must come from @code{quote} expressions.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-quasiquote> env loc exp
-A quasiquoted expression. The expression is treated as a constant,
-except for embedded @code{unquote} and @code{unquote-splicing} forms.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-unquote> env loc exp
-Like Scheme's @code{unquote}; only valid within a quasiquote.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-unquote-splicing> env loc exp
-Like Scheme's @code{unquote-splicing}; only valid within a quasiquote.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-ref> env loc var
-A variable reference. Note that for purposes of serialization,
address@hidden is serialized as its name, as a symbol.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-set> env loc var val
-A variable mutation. @var{var} is serialized as a symbol.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-define> env loc var val
-A toplevel variable definition. See @code{ghil-var-define!}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-if> env loc test then else
+The @code{src} fields are left out of the external representation.
+
address@hidden {Scheme Variable} <void> src
address@hidden {External Representation} (void)
+An empty expression. In practice, equivalent to Scheme's @code{(if #f
+#f)}.
address@hidden deftp
address@hidden {Scheme Variable} <const> src exp
address@hidden {External Representation} (const @var{exp})
+A constant.
address@hidden deftp
address@hidden {Scheme Variable} <primitive-ref> src name
address@hidden {External Representation} (primitive @var{name})
+A reference to a ``primitive''. A primitive is a procedure that, when
+compiled, may be open-coded. For example, @code{cons} is usually
+recognized as a primitive, so that it compiles down to a single
+instruction.
+
+Compilation of Tree-IL usually begins with a pass that resolves some
address@hidden<module-ref>} and @code{<toplevel-ref>} expressions to
address@hidden<primitive-ref>} expressions. The actual compilation pass
+has special cases for applications of certain primitives, like
address@hidden or @code{cons}.
address@hidden deftp
address@hidden {Scheme Variable} <lexical-ref> src name gensym
address@hidden {External Representation} (lexical @var{name} @var{gensym})
+A reference to a lexically-bound variable. The @var{name} is the
+original name of the variable in the source program. @var{gensym} is a
+unique identifier for this variable.
address@hidden deftp
address@hidden {Scheme Variable} <lexical-set> src name gensym exp
address@hidden {External Representation} (set! (lexical @var{name}
@var{gensym}) @var{exp})
+Sets a lexically-bound variable.
address@hidden deftp
address@hidden {Scheme Variable} <module-ref> src mod name public?
address@hidden {External Representation} (@@ @var{mod} @var{name})
address@hidden {External Representation} (@@@@ @var{mod} @var{name})
+A reference to a variable in a specific module. @var{mod} should be
+the name of the module, e.g. @code{(guile-user)}.
+
+If @var{public?} is true, the variable named @var{name} will be looked
+up in @var{mod}'s public interface, and serialized with @code{@@};
+otherwise it will be looked up among the module's private bindings,
+and is serialized with @code{@@@@}.
address@hidden deftp
address@hidden {Scheme Variable} <module-set> src mod name public? exp
address@hidden {External Representation} (set! (@@ @var{mod} @var{name})
@var{exp})
address@hidden {External Representation} (set! (@@@@ @var{mod} @var{name})
@var{exp})
+Sets a variable in a specific module.
address@hidden deftp
address@hidden {Scheme Variable} <toplevel-ref> src name
address@hidden {External Representation} (toplevel @var{name})
+References a variable from the current procedure's module.
address@hidden deftp
address@hidden {Scheme Variable} <toplevel-set> src name exp
address@hidden {External Representation} (set! (toplevel @var{name}) @var{exp})
+Sets a variable in the current procedure's module.
address@hidden deftp
address@hidden {Scheme Variable} <toplevel-define> src name exp
address@hidden {External Representation} (define (toplevel @var{name})
@var{exp})
+Defines a new top-level variable in the current procedure's module.
address@hidden deftp
address@hidden {Scheme Variable} <conditional> src test then else
address@hidden {External Representation} (if @var{test} @var{then} @var{else})
A conditional. Note that @var{else} is not optional.
@end deftp
address@hidden {Scheme Variable} <ghil-and> env loc . exps
-Like Scheme's @code{and}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-or> env loc . exps
-Like Scheme's @code{or}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-begin> env loc . body
-Like Scheme's @code{begin}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-bind> env loc vars exprs . body
-Like a deconstructed @code{let}: each element of @var{vars} will be
-bound to the corresponding GHIL expression in @var{exprs}.
-
-Note that for purposes of the serialization format, @var{exprs} are
-evaluated before the new bindings are added to the environment. For
address@hidden semantics, there also exists a @code{bindrec} parse
-flavor. This is useful for writing GHIL at the REPL, but the
-serializer does not currently have the cleverness needed to determine
-whether a @code{<ghil-bind>} has @code{let} or @code{letrec}
-semantics, and thus only serializes @code{<ghil-bind>} as @code{bind}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-mv-bind> env loc vars rest producer .
body
-Like Scheme's @code{receive} -- binds the values returned by
-applying @code{producer}, which should be a thunk, to the
address@hidden bindings described by @var{vars} and @var{rest}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-lambda> env loc vars rest meta . body
-A closure. @var{vars} is the argument list, serialized as a list of
-symbols. @var{rest} is a boolean, which is @code{#t} iff the last
-argument is a rest argument. @var{meta} is an association list of
-properties. The actual @var{body} should be a list of GHIL
-expressions.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-call> env loc proc . args
address@hidden {Scheme Variable} <application> src proc args
address@hidden {External Representation} (apply @var{proc} . @var{args})
A procedure call.
@end deftp
address@hidden {Scheme Variable} <ghil-mv-call> env loc producer consumer
-Like Scheme's @code{call-with-values}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-inline> env loc op . args
-An inlined VM instruction. @var{op} should be the instruction name as
-a symbol, and @var{args} should be its arguments, as GHIL expressions.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-values> env loc . values
-Like Scheme's @code{values}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-values*> env loc . values
address@hidden are as in the Scheme expression, @code{(apply values .
address@hidden)}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-reified-env> env loc
-Produces, at run-time, a reification of the environment at compile
-time. Used in the implementation of Scheme's
address@hidden
address@hidden {Scheme Variable} <sequence> src exps
address@hidden {External Representation} (begin . @var{exps})
+Like Scheme's @code{begin}.
@end deftp
-
-GHIL implements a compiler to GLIL that recursively traverses GHIL
-expressions, writing out GLIL expressions into a linear list. The
-compiler also keeps some state as to whether the current expression is
-in tail context, and whether its value will be used in future
-computations. This state allows the compiler not to emit code for
-constant expressions that will not be used (e.g. docstrings), and to
-perform tail calls when in tail position.
-
-Just as the Scheme to GHIL compiler introduced new hidden state---the
-environment---the GHIL to GLIL compiler introduces more state, the
-stack. While not represented explicitly, the stack is present in the
-compilation of each GHIL expression: compiling a GHIL expression
-should leave the run-time value stack in the same state. For example,
-if the intermediate value stack has two elements before evaluating an
address@hidden expression, it should have two elements after that
-expression.
address@hidden {Scheme Variable} <lambda> src names vars meta body
address@hidden {External Representation} (lambda @var{names} @var{vars}
@var{meta} @var{body})
+A closure. @var{names} is original binding form, as given in the
+source code, which may be an improper list. @var{vars} are gensyms
+corresponding to the @var{names}. @var{meta} is an association list of
+properties. The actual @var{body} is a single Tree-IL expression.
address@hidden deftp
address@hidden {Scheme Variable} <let> src names vars vals exp
address@hidden {External Representation} (let @var{names} @var{vars} @var{vals}
@var{exp})
+Lexical binding, like Scheme's @code{let}. @var{names} are the
+original binding names, @var{vars} are gensyms corresponding to the
address@hidden, and @var{vals} are Tree-IL expressions for the values.
address@hidden is a single Tree-IL expression.
address@hidden deftp
address@hidden {Scheme Variable} <letrec> src names vars vals exp
address@hidden {External Representation} (letrec @var{names} @var{vars}
@var{vals} @var{exp})
+A version of @code{<let>} that creates recursive bindings, like
+Scheme's @code{letrec}.
address@hidden deftp
+
address@hidden FIXME -- need to revive this one
address@hidden @deftp {Scheme Variable} <ghil-mv-bind> src vars rest producer .
body
address@hidden Like Scheme's @code{receive} -- binds the values returned by
address@hidden applying @code{producer}, which should be a thunk, to the
address@hidden @code{lambda}-like bindings described by @var{vars} and
@var{rest}.
address@hidden @end deftp
+
+Tree-IL implements a compiler to GLIL that recursively traverses
+Tree-IL expressions, writing out GLIL expressions into a linear list.
+The compiler also keeps some state as to whether the current
+expression is in tail context, and whether its value will be used in
+future computations. This state allows the compiler not to emit code
+for constant expressions that will not be used (e.g. docstrings), and
+to perform tail calls when in tail position.
+
+In the future, there will be a pass at the beginning of the
+Tree-IL->GLIL compilation step to perform inlining, copy propagation,
+dead code elimination, and constant folding.
Interested readers are encouraged to read the implementation in
address@hidden(language ghil compile-glil)} for more details.
address@hidden(language tree-il compile-glil)} for more details.
@node GLIL
@subsection GLIL
Guile Low Intermediate Language (GLIL) is a structured intermediate
-language whose expressions closely mirror the functionality of Guile's
-VM instruction set.
+language whose expressions more closely approximate Guile's VM
+instruction set.
Its expression types are defined in @code{(language glil)}, and as
with GHIL, some of its fields parse as rest arguments.
@@ -499,8 +420,8 @@ A unit of code that at run-time will correspond to a
compiled
procedure. @var{nargs} @var{nrest} @var{nlocs}, and @var{nexts}
collectively define the program's arity; see @ref{Compiled
Procedures}, for more information. @var{meta} should be an alist of
-properties, as in @code{<ghil-lambda>}. @var{body} is a list of GLIL
-expressions.
+properties, as in Tree IL's @code{<lambda>}. @var{body} is a list of
+GLIL expressions.
@end deftp
@deftp {Scheme Variable} <glil-bind> . vars
An advisory expression that notes a liveness extent for a set of
@@ -534,24 +455,23 @@ offset within a VM program.
@end deftp
@deftp {Scheme Variable} <glil-source> loc
Records source information for the preceding expression. @var{loc}
-should be a vector, @code{#(@var{line} @var{column} @var{filename})}.
+should be an association list of containing @code{line} @code{column},
+and @code{filename} keys, e.g. as returned by
address@hidden
@end deftp
@deftp {Scheme Variable} <glil-void>
Pushes the unspecified value on the stack.
@end deftp
@deftp {Scheme Variable} <glil-const> obj
Pushes a constant value onto the stack. @var{obj} must be a number,
-string, symbol, keyword, boolean, character, or a pair or vector or
-list thereof, or the empty list.
address@hidden deftp
address@hidden {Scheme Variable} <glil-argument> op index
-Accesses an argument on the stack. If @var{op} is @code{ref}, the
-argument is pushed onto the stack; if it is @code{set}, the argument
-is set from the top value on the stack, which is popped off.
+string, symbol, keyword, boolean, character, the empty list, or a pair
+or vector of constants.
@end deftp
@deftp {Scheme Variable} <glil-local> op index
-Like @code{<glil-argument>}, but for local variables. @xref{Stack
-Layout}, for more information.
+Accesses a lexically bound variable from the stack. If @var{op} is
address@hidden, the value is pushed onto the stack; if it is @code{set},
+the variable is set from the top value on the stack, which is popped
+off. @xref{Stack Layout}, for more information.
@end deftp
@deftp {Scheme Variable} <glil-external> op depth index
Accesses a heap-allocated variable, addressed by @var{depth}, the nth
@@ -563,8 +483,8 @@ Accesses a toplevel variable. @var{op} may be @code{ref},
@code{set},
or @code{define}.
@end deftp
@deftp {Scheme Variable} <glil-module> op mod name public?
-Accesses a variable within a specific module. See
address@hidden, for more information.
+Accesses a variable within a specific module. See Tree-IL's
address@hidden<module-ref>}, for more information.
@end deftp
@deftp {Scheme Variable} <glil-label> label
Creates a new label. @var{label} can be any Scheme value, and should
@@ -607,23 +527,143 @@ Just as in all of Guile's compilers, an environment is
passed to the
GLIL-to-object code compiler, and one is returned as well, along with
the object code.
address@hidden Object Code
address@hidden Object Code
address@hidden Assembly
address@hidden Assembly
+
+Assembly is an S-expression-based, human-readable representation of
+the actual bytecodes that will be emitted for the VM. As such, it is a
+useful intermediate language both for compilation and for
+decompilation.
-Object code is the serialization of the raw instruction stream of a
-program, ready for interpretation by the VM. Procedures related to
-object code are defined in the @code{(system vm objcode)} module.
+Besides the fact that it is not a record-based language, assembly
+differs from GLIL in four main ways:
+
address@hidden
address@hidden Labels have been resolved to byte offsets in the program.
address@hidden Constants inside procedures have either been expressed as inline
+instructions, and possibly cached in object arrays.
address@hidden Procedures with metadata (source location information, liveness
+extents, procedure names, generic properties, etc) have had their
+metadata serialized out to thunks.
address@hidden All expressions correspond directly to VM instructions -- i.e.,
+there is no @code{<glil-local>} which can be a ref or a set.
address@hidden itemize
+
+Assembly is isomorphic to the bytecode that it compiles to. You can
+compile to bytecode, then decompile back to assembly, and you have the
+same assembly code.
+
+The general form of assembly instructions is the following:
+
address@hidden
+(@var{inst} @var{arg} ...)
address@hidden lisp
+
+The @var{inst} names a VM instruction, and its @var{arg}s will be
+embedded in the instruction stream. The easiest way to see assembly is
+to play around with it at the REPL, as can be seen in this annotated
+example:
+
address@hidden
+scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly)
+(load-program 0 0 0 0
+ () ; Labels
+ 60 ; Length
+ #f ; Metadata
+ (make-false) ; object table for the returned lambda
+ (nop)
+ (nop) ; Alignment. Since assembly has already resolved its labels
+ (nop) ; to offsets, and programs must be 8-byte aligned since their
+ (nop) ; object code is mmap'd directly to structures, assembly
+ (nop) ; has to have the alignment embedded in it.
+ (nop)
+ (load-program 1 0 0 0
+ ()
+ 6
+ ; This is the metadata thunk for the returned procedure.
+ (load-program 0 0 0 0 () 21 #f
+ (load-symbol "x") ; Name and liveness extent for @code{x}.
+ (make-false)
+ (make-int8:0) ; Some instruction+arg combinations
+ (make-int8:0) ; have abbreviations.
+ (make-int8 6)
+ (list 0 5)
+ (list 0 1)
+ (make-eol)
+ (list 0 2)
+ (return))
+ ; And here, the actual code.
+ (local-ref 0)
+ (local-ref 0)
+ (add)
+ (return))
+ ; Return our new procedure.
+ (return))
address@hidden example
+
+Of course you can switch the REPL to assembly and enter in assembly
+S-expressions directly, like with other languages, though it is more
+difficult, given that the length fields have to be correct.
+
address@hidden Bytecode and Objcode
address@hidden Bytecode and Objcode
+
+Finally, the raw bytes. There are actually two different ``languages''
+here, corresponding to two different ways to represent the bytes.
+
+``Bytecode'' represents code as uniform byte vectors, useful for
+structuring and destructuring code on the Scheme level. Bytecode is
+the next step down from assembly:
+
address@hidden
+scheme@@(guile-user)> (compile '(+ 32 10) #:to 'assembly)
address@hidden (load-program 0 0 0 0 () 6 #f
+ (make-int8 32) (make-int8 10) (add) (return))
+scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode)
address@hidden #u8(0 0 0 0 6 0 0 0 0 0 0 0 10 32 10 10 100 48)
address@hidden example
+
+``Objcode'' is bytecode, but mapped directly to a C structure,
address@hidden scm_objcode}:
+
address@hidden
+struct scm_objcode @{
+ scm_t_uint8 nargs;
+ scm_t_uint8 nrest;
+ scm_t_uint8 nlocs;
+ scm_t_uint8 nexts;
+ scm_t_uint32 len;
+ scm_t_uint32 metalen;
+ scm_t_uint8 base[0];
address@hidden;
address@hidden example
+
+As one might imagine, objcode imposes a minimum length on the
+bytecode. Also, the multibyte fields are in native endianness, which
+makes objcode (and bytecode) system-dependent. Indeed, in the short
+example above, all but the last 5 bytes were the program's header.
+
+Objcode also has a couple of important efficiency hacks. First,
+objcode may be mapped directly from disk, allowing compiled code to be
+loaded quickly, often from the system's disk cache, and shared among
+multiple processes. Secondly, objcode may be embedded in other
+objcode, allowing procedures to have the text of other procedures
+inlined into their bodies, without the need for separate allocation of
+the code. Of course, the objcode object itself does need to be
+allocated.
+
+Procedures related to objcode are defined in the @code{(system vm
+objcode)} module.
@deffn {Scheme Procedure} objcode? obj
@deffnx {C Function} scm_objcode_p (obj)
Returns @code{#f} iff @var{obj} is object code, @code{#f} otherwise.
@end deffn
address@hidden {Scheme Procedure} bytecode->objcode bytecode nlocs nexts
address@hidden {C Function} scm_bytecode_to_objcode (bytecode, nlocs, nexts)
address@hidden {Scheme Procedure} bytecode->objcode bytecode
address@hidden {C Function} scm_bytecode_to_objcode (bytecode,)
Makes a bytecode object from @var{bytecode}, which should be a
address@hidden @var{nlocs} and @var{nexts} denote the number of
-stack and heap variables to reserve when this objcode is executed.
address@hidden
@end deffn
@deffn {Scheme Variable} load-objcode file
@@ -631,21 +671,28 @@ stack and heap variables to reserve when this objcode is
executed.
Load object code from a file named @var{file}. The file will be mapped
into memory via @code{mmap}, so this is a very fast operation.
-On disk, object code has an eight-byte cookie prepended to it, so that
-we will not execute arbitrary garbage. In addition, two more bytes are
-reserved for @var{nlocs} and @var{nexts}.
+On disk, object code has an eight-byte cookie prepended to it, to
+prevent accidental loading of arbitrary garbage.
address@hidden deffn
+
address@hidden {Scheme Variable} write-objcode objcode file
address@hidden {C Function} scm_write_objcode (objcode)
+Write object code out to a file, prepending the eight-byte cookie.
@end deffn
@deffn {Scheme Variable} objcode->u8vector objcode
@deffnx {C Function} scm_objcode_to_u8vector (objcode)
-Copy object code out to a @code{u8vector} for analysis by Scheme. The
-ten-byte header is included.
+Copy object code out to a @code{u8vector} for analysis by Scheme.
@end deffn
address@hidden {Scheme Variable} objcode->program objcode [external='()]
address@hidden {C Function} scm_objcode_to_program (objcode, external)
+The following procedure is actually in @code{(system vm program)}, but
+we'll mention it here:
+
address@hidden {Scheme Variable} make-program objcode objtable [external='()]
address@hidden {C Function} scm_make_program (objcode, objtable, external)
Load up object code into a Scheme program. The resulting program will
-be a thunk that captures closure variables from @var{external}.
+have @var{objtable} as its object table, which should be a vector or
address@hidden, and will capture the closure variables from @var{external}.
@end deffn
Object code from a file may be disassembled at the REPL via the
@@ -689,7 +736,7 @@ fruit, running programs of interest under a system-level
profiler and
determining which improvements would give the most bang for the buck.
There are many well-known efficiency hacks in the literature: Dybvig's
letrec optimization, individual boxing of heap-allocated values (and
-then store the boxes on the stack directory), optimized case-lambda
+then store the boxes on the stack directly), optimized case-lambda
expressions, stack underflow and overflow handlers, etc. Highly
recommended papers: Dybvig's HOCS, Ghuloum's compiler paper.
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 0426452..49b420c 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -111,7 +111,7 @@ The registers that a VM has are as follows:
In other architectures, the instruction pointer is sometimes called
the ``program counter'' (pc). This set of registers is pretty typical
for stack machines; their exact meanings in the context of Guile's VM
-is described in the next section.
+are described in the next section.
A virtual machine executes by loading a compiled procedure, and
executing the object code associated with that procedure. Of course,
@@ -119,14 +119,17 @@ that procedure may call other procedures, tail-call
others, ad
infinitum---indeed, within a guile whose modules have all been
compiled to object code, one might never leave the virtual machine.
address@hidden wingo: I wish the following were true, but currently we just use
address@hidden the one engine. This kind of thing is possible tho.
address@hidden wingo: The following is true, but I don't know in what context to
address@hidden describe it. A documentation FIXME.
@c A VM may have one of three engines: reckless, regular, or debugging.
@c Reckless engine is fastest but dangerous. Regular engine is normally
@c fail-safe and reasonably fast. Debugging engine is safest and
@c functional but very slow.
address@hidden (Actually we have just a regular and a debugging engine; normally
address@hidden we use the latter, it's almost as fast as the ``regular''
engine.)
+
@node Stack Layout
@subsection Stack Layout
@@ -174,7 +177,7 @@ The structure of the fixed part of an application frame is
as follows:
In the above drawing, the stack grows upward. The intermediate values
stored in the application of this frame are stored above
@code{SCM_FRAME_UPPER_ADDRESS (fp)}. @code{bp} refers to the
address@hidden scm_program*} data associated with the program at
address@hidden scm_objcode} data associated with the program at
@code{fp - 1}. @code{nargs} and @code{nlocs} are properties of the
compiled procedure, which will be discussed later.
@@ -226,7 +229,7 @@ programs are implemented, @xref{VM Programs}.
@node Variables and the VM
@subsection Variables and the VM
-Let's think about the following Scheme code as an example:
+Consider the following Scheme code as an example:
@example
(define (foo a)
@@ -236,22 +239,15 @@ Let's think about the following Scheme code as an example:
Within the lambda expression, "foo" is a top-level variable, "a" is a
lexically captured variable, and "b" is a local variable.
-That is to say: @code{b} may safely be allocated on the stack, as
-there is no enclosed procedure that references it, nor is it ever
-mutated.
address@hidden may safely be allocated on the stack, as there is no enclosed
+procedure that references it, nor is it ever mutated.
@code{a}, on the other hand, is referenced by an enclosed procedure,
that of the lambda. Thus it must be allocated on the heap, as it may
(and will) outlive the dynamic extent of the invocation of @code{foo}.
address@hidden is a toplevel variable, as mandated by Scheme's semantics:
-
address@hidden
- (define proc (foo 'bar)) ; assuming prev. definition of @code{foo}
- (define foo 42) ; redefinition
- (proc 'baz)
- @result{} (42 bar baz)
address@hidden example
address@hidden is a top-level variable, because it names the procedure
address@hidden, which is here defined at the top-level.
Note that variables that are mutated (via @code{set!}) must be
allocated on the heap, even if they are local variables. This is
@@ -276,6 +272,7 @@ You can pick apart these pieces with the accessors in
@code{(system vm
program)}. @xref{Compiled Procedures}, for a full API reference.
@cindex object table
address@hidden object array
The object array of a compiled procedure, also known as the
@dfn{object table}, holds all Scheme objects whose values are known
not to change across invocations of the procedure: constant strings,
@@ -293,31 +290,27 @@ instruction, which uses the object vector, and are almost
as fast as
local variable references.
We can see how these concepts tie together by disassembling the
address@hidden function to see what is going on:
address@hidden function we defined earlier to see what is going on:
@smallexample
scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b)))
scheme@@(guile-user)> ,x foo
Disassembly of #<program foo (a)>:
-Bytecode:
-
0 (local-ref 0) ;; `a' (arg)
2 (external-set 0) ;; `a' (arg)
- 4 (object-ref 0) ;; #<program #(0 28 #f) (b)>
- 6 (make-closure) at (unknown
file):0:16
+ 4 (object-ref 1) ;; #<program b70d2910 at <unknown
port>:0:16 (b)>
+ 6 (make-closure)
7 (return)
----------------------------------------
-Disassembly of #<program #(0 28 #f) (b)>:
+Disassembly of #<program b70d2910 at <unknown port>:0:16 (b)>:
-Bytecode:
-
- 0 (toplevel-ref 0) ;; `list'
- 2 (toplevel-ref 1) ;; `foo'
- 4 (external-ref 0) ;; (closure variable)
- 6 (local-ref 0) ;; `b' (arg)
- 8 (goto/args 3) at (unknown
file):0:28
+ 0 (toplevel-ref 1) ;; `foo'
+ 2 (external-ref 0) ;; (closure variable)
+ 4 (local-ref 0) ;; `b' (arg)
+ 6 (list 0 3) ;; 3 elements at (unknown
file):0:28
+ 9 (return)
@end smallexample
At @code{ip} 0 and 2, we do the copy from argument to heap for
@@ -336,8 +329,9 @@ Control Instructions}, for more details.
Then we see a reference to an external variable, corresponding to
@code{a}. The disassembler doesn't have enough information to give a
name to that variable, so it just marks it as being a ``closure
-variable''. Finally we see the reference to @code{b}, then a tail call
-(@code{goto/args}) with three arguments.
+variable''. Finally we see the reference to @code{b}, then the
address@hidden opcode, an inline implementation of the @code{list} scheme
+routine.
@node Instruction Set
@subsection Instruction Set
@@ -365,7 +359,8 @@ their own test-and-branch instructions:
@end example
In addition, some Scheme primitives have their own inline
-implementations, e.g. @code{cons}.
+implementations, e.g. @code{cons}, and @code{list}, as we saw in the
+previous section.
So Guile's instruction set is a @emph{complete} instruction set, in
that it provides the instructions that are suited to the problem, and
@@ -421,12 +416,6 @@ efficient in the future via addressing by frame and index.
Currently,
external variables are all consed onto a list, which results in O(N)
lookup time.
address@hidden Instruction externals
-Pushes the current list of external variables onto the stack. This
-instruction is used in the implementation of
address@hidden @xref{The Scheme Compiler}.
address@hidden deffn
-
@deffn Instruction toplevel-ref index
Push the value of the toplevel binding whose location is stored in at
position @var{index} in the object table.
@@ -440,11 +429,11 @@ created.
Alternately, the lookup may be performed relative to a particular
module, determined at compile-time (e.g. via @code{@@} or
@code{@@@@}). In that case, the cell in the object table holds a list:
address@hidden(@var{modname} @var{sym} @var{interface?})}. The symbol
address@hidden will be looked up in the module named @var{modname} (a list
-of symbols). The lookup will be performed against the module's public
-interface, unless @var{interface?} is @code{#f}, which it is for
-example when compiling @code{@@@@}.
address@hidden(@var{modname} @var{sym} @var{public?})}. The symbol @var{sym}
+will be looked up in the module named @var{modname} (a list of
+symbols). The lookup will be performed against the module's public
+interface, unless @var{public?} is @code{#f}, which it is for example
+when compiling @code{@@@@}.
In any case, if the symbol is unbound, an error is signalled.
Otherwise the initial form is replaced with the looked-up variable, an
@@ -550,8 +539,9 @@ may be encoded in 1, 2, or 4 bytes.
@deffn Instruction load-integer length
@deffnx Instruction load-unsigned-integer length
-Load a 32-bit integer (respectively unsigned integer) from the
-instruction stream.
+Load a 32-bit integer or unsigned integer from the instruction stream.
+The bytes of the integer are read in order of decreasing significance
+(i.e., big-endian).
@end deffn
@deffn Instruction load-number length
Load an arbitrary number from the instruction stream. The number is
@@ -573,43 +563,23 @@ the current toplevel environment, creating the binding if
necessary.
Push the variable corresponding to the binding.
@end deffn
address@hidden Instruction load-program length
address@hidden Instruction load-program
Load bytecode from the instruction stream, and push a compiled
-procedure. This instruction pops the following values from the stack:
+procedure.
address@hidden
address@hidden Optionally, a thunk, which when called should return metadata
-associated with this program---for example its name, the names of its
-arguments, its documentation string, debugging information, etc.
-
-Normally, this thunk its itself a compiled procedure (with no
-metadata). Metadata is represented this way so that the initial load
-of a procedure is fast: the VM just mmap's the thunk and goes. The
-symbols and pairs associated with the metadata are only created if the
-user asks for them.
-
-For information on the format of the thunk's return value,
address@hidden Procedures}.
address@hidden Optionally, the program's object table, as a vector.
-
-A program that does not reference toplevel bindings and does not use
address@hidden does not need an object table.
address@hidden Finally, either one immediate integer or four immediate integers
-representing the arity of the program.
-
-In the four-fixnum case, the values are respectively the number of
-arguments taken by the function (@var{nargs}), the number of @dfn{rest
-arguments} (@var{nrest}, 0 or 1), the number of local variables
-(@var{nlocs}) and the number of external variables (@var{nexts})
-(@pxref{Environment Control Instructions}).
-
-The common single-fixnum case represents all of these values within a
-16-bit bitmask.
address@hidden itemize
+This instruction pops one value from the stack: the program's object
+table, as a vector, or @code{#f} in the case that the program has no
+object table. A program that does not reference toplevel bindings and
+does not use @code{object-ref} does not need an object table.
+
+This instruction is unlike the rest of the loading instructions,
+because instead of parsing its data, it directly maps the instruction
+stream onto a C structure, @code{struct scm_objcode}. @xref{Bytecode
+and Objcode}, for more information.
The resulting compiled procedure will not have any ``external''
-variables captured, so it will be loaded only once but may be used
-many times to create closures.
+variables captured, so it may be loaded only once but used many times
+to create closures.
@end deffn
Finally, while this instruction is not strictly a ``loading''
@@ -620,7 +590,10 @@ here:
Pop the program object from the stack, capture the current set of
``external'' variables, and assign those external variables to a copy
of the program. Push the new program object, which shares state with
-the original program. Also captures the current module.
+the original program.
+
+At the time of this writing, the space overhead of closures is 4 words
+per closure.
@end deffn
@node Procedural Instructions
@@ -640,22 +613,24 @@ set to the returned value.
@deffn Instruction call nargs
Call the procedure located at @code{sp[-nargs]} with the @var{nargs}
-arguments located from @code{sp[0]} to @code{sp[-nargs + 1]}.
+arguments located from @code{sp[-nargs + 1]} to @code{sp[0]}.
+
+For compiled procedures, this instruction sets up a new stack frame,
+as described in @ref{Stack Layout}, and then dispatches to the first
+instruction in the called procedure, relying on the called procedure
+to return one value to the newly-created continuation. Because the new
+frame pointer will point to sp[-nargs + 1], the arguments don't have
+to be shuffled around -- they are already in place.
For non-compiled procedures (continuations, primitives, and
interpreted procedures), @code{call} will pop the procedure and
arguments off the stack, and push the result of calling
@code{scm_apply}.
-
-For compiled procedures, this instruction sets up a new stack frame,
-as described in @ref{Stack Layout}, and then dispatches to the first
-instruction in the called procedure, relying on the called procedure
-to return one value to the newly-created continuation.
@end deffn
@deffn Instruction goto/args nargs
Like @code{call}, but reusing the current continuation. This
-instruction implements tail calling as required by RnRS.
+instruction implements tail calls as required by RnRS.
For compiled procedures, that means that @code{goto/args} reuses the
current frame instead of building a new one. The @code{goto/*}
@@ -726,14 +701,14 @@ values. This is an optimization for the common
@code{(apply values
@deffn Instruction truncate-values nbinds nrest
Used in multiple-value continuations, this instruction takes the
-values that are on the stack (including the number-of-value marker)
+values that are on the stack (including the number-of-values marker)
and truncates them for a binding construct.
For example, a call to @code{(receive (x y . z) (foo) ...)} would,
logically speaking, pop off the values returned from @code{(foo)} and
push them as three values, corresponding to @code{x}, @code{y}, and
@code{z}. In that case, @var{nbinds} would be 3, and @var{nrest} would
-be 1 (to indicate that one of the bindings was a rest arguments).
+be 1 (to indicate that one of the bindings was a rest argument).
Signals an error if there is an insufficient number of values.
@end deffn
@@ -779,12 +754,14 @@ Push @var{value}, an 8-bit character, onto the stack.
@deffn Instruction list n
Pops off the top @var{n} values off of the stack, consing them up into
a list, then pushes that list on the stack. What was the topmost value
-will be the last element in the list.
+will be the last element in the list. @var{n} is a two-byte value,
+most significant byte first.
@end deffn
@deffn Instruction vector n
Create and fill a vector with the top @var{n} values from the stack,
-popping off those values and pushing on the resulting vector.
+popping off those values and pushing on the resulting vector. @var{n}
+is a two-byte value, like in @code{vector}.
@end deffn
@deffn Instruction mark
@@ -850,9 +827,8 @@ Pushes ``the unspecified value'' onto the stack.
@subsubsection Inlined Scheme Instructions
The Scheme compiler can recognize the application of standard Scheme
-procedures, or unbound variables that look like they are bound to
-standard Scheme procedures. It tries to inline these small operations
-to avoid the overhead of creating new stack frames.
+procedures. It tries to inline these small operations to avoid the
+overhead of creating new stack frames.
Since most of these operations are historically implemented as C
primitives, not inlining them would entail constantly calling out from
@@ -876,12 +852,12 @@ stream.
@deffnx Instruction eqv? x y
@deffnx Instruction equal? x y
@deffnx Instruction pair? x y
address@hidden Instruction list? x y
address@hidden Instruction list? x
@deffnx Instruction set-car! pair x
@deffnx Instruction set-cdr! pair x
@deffnx Instruction slot-ref struct n
@deffnx Instruction slot-set struct n x
address@hidden Instruction cons x
address@hidden Instruction cons x y
@deffnx Instruction car x
@deffnx Instruction cdr x
Inlined implementations of their Scheme equivalents.
diff --git a/lang/Makefile.am b/lang/Makefile.am
index 6dc2e29..97c440d 100644
--- a/lang/Makefile.am
+++ b/lang/Makefile.am
@@ -28,6 +28,7 @@ elisp_sources = \
elisp/example.el \
elisp/interface.scm \
elisp/transform.scm \
+ elisp/expand.scm \
elisp/variables.scm \
\
elisp/primitives/buffers.scm \
diff --git a/libguile/frames.c b/libguile/frames.c
index f53cade..c08fd31 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#if HAVE_CONFIG_H
# include <config.h>
@@ -45,6 +21,7 @@
#include <stdlib.h>
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"
diff --git a/libguile/frames.h b/libguile/frames.h
index 8367637..d74476a 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
+ * *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#ifndef _SCM_FRAMES_H_
#define _SCM_FRAMES_H_
@@ -97,7 +73,7 @@
* Heap frames
*/
-extern scm_t_bits scm_tc16_vm_frame;
+SCM_API scm_t_bits scm_tc16_vm_frame;
struct scm_vm_frame
{
@@ -118,24 +94,24 @@ struct scm_vm_frame
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
/* FIXME rename scm_byte_t */
-extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
+SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_byte_t *ip, scm_t_ptrdiff offset);
-extern SCM scm_vm_frame_p (SCM obj);
-extern SCM scm_vm_frame_program (SCM frame);
-extern SCM scm_vm_frame_arguments (SCM frame);
-extern SCM scm_vm_frame_source (SCM frame);
-extern SCM scm_vm_frame_local_ref (SCM frame, SCM index);
-extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
-extern SCM scm_vm_frame_return_address (SCM frame);
-extern SCM scm_vm_frame_mv_return_address (SCM frame);
-extern SCM scm_vm_frame_dynamic_link (SCM frame);
-extern SCM scm_vm_frame_external_link (SCM frame);
-extern SCM scm_vm_frame_stack (SCM frame);
-
-extern SCM scm_c_vm_frame_prev (SCM frame);
-
-extern void scm_bootstrap_frames (void);
-extern void scm_init_frames (void);
+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_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_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_external_link (SCM frame);
+SCM_API SCM scm_vm_frame_stack (SCM frame);
+
+SCM_API SCM scm_c_vm_frame_prev (SCM frame);
+
+SCM_INTERNAL void scm_bootstrap_frames (void);
+SCM_INTERNAL void scm_init_frames (void);
#endif /* _SCM_FRAMES_H_ */
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 4f504f0..f0f52e4 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -1,49 +1,27 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
+
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "instructions.h"
diff --git a/libguile/instructions.h b/libguile/instructions.h
index 4968671..f4f45b3 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#ifndef _SCM_INSTRUCTIONS_H_
#define _SCM_INSTRUCTIONS_H_
@@ -57,16 +33,16 @@ enum scm_opcode {
scm_op_last = SCM_VM_NUM_INSTRUCTIONS
};
-extern SCM scm_instruction_list (void);
-extern SCM scm_instruction_p (SCM obj);
-extern SCM scm_instruction_length (SCM inst);
-extern SCM scm_instruction_pops (SCM inst);
-extern SCM scm_instruction_pushes (SCM inst);
-extern SCM scm_instruction_to_opcode (SCM inst);
-extern SCM scm_opcode_to_instruction (SCM op);
+SCM_API SCM scm_instruction_list (void);
+SCM_API SCM scm_instruction_p (SCM obj);
+SCM_API SCM scm_instruction_length (SCM inst);
+SCM_API SCM scm_instruction_pops (SCM inst);
+SCM_API SCM scm_instruction_pushes (SCM inst);
+SCM_API SCM scm_instruction_to_opcode (SCM inst);
+SCM_API SCM scm_opcode_to_instruction (SCM op);
-extern void scm_bootstrap_instructions (void);
-extern void scm_init_instructions (void);
+SCM_INTERNAL void scm_bootstrap_instructions (void);
+SCM_INTERNAL void scm_init_instructions (void);
#endif /* _SCM_INSTRUCTIONS_H_ */
diff --git a/libguile/macros.c b/libguile/macros.c
index d132c01..ca3e83e 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -48,10 +48,13 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
|| scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
macro, port, pstate)))
{
+ scm_puts ("#<", port);
+
+ if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
+ scm_puts ("extended-", port);
+
if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code))
- scm_puts ("#<primitive-", port);
- else
- scm_puts ("#<", port);
+ scm_puts ("primitive-", port);
if (SCM_MACRO_TYPE (macro) == 0)
scm_puts ("syntax", port);
@@ -63,6 +66,8 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
scm_puts ("macro!", port);
if (SCM_MACRO_TYPE (macro) == 3)
scm_puts ("builtin-macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 4)
+ scm_puts ("syncase-macro", port);
scm_putc (' ', port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
@@ -77,6 +82,14 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
scm_iprin1 (src, port, pstate);
}
+ if (SCM_MACRO_IS_EXTENDED (macro))
+ {
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_2 (macro), port);
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_3 (macro), port);
+ }
+
scm_putc ('>', port);
}
@@ -84,6 +97,16 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
}
static SCM
+macro_mark (SCM macro)
+{
+ if (SCM_MACRO_IS_EXTENDED (macro))
+ { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro));
+ scm_gc_mark (SCM_SMOB_OBJECT_3 (macro));
+ }
+ return SCM_SMOB_OBJECT (macro);
+}
+
+static SCM
makmac (SCM code, scm_t_bits flags)
{
SCM z;
@@ -164,11 +187,45 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0,
#endif
+SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0,
+ (SCM type, SCM binding),
+ "Return a @dfn{macro} that requires expansion by syntax-case.\n"
+ "While users should not call this function, it is useful to know\n"
+ "that syntax-case macros are represented as Guile primitive
macros.")
+#define FUNC_NAME s_scm_make_syncase_macro
+{
+ SCM z;
+ SCM_VALIDATE_SYMBOL (1, type);
+
+ SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type),
+ SCM_UNPACK (binding));
+ SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED);
+ return z;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3,
0, 0,
+ (SCM m, SCM type, SCM binding),
+ "Extend a core macro @var{m} with a syntax-case binding.")
+#define FUNC_NAME s_scm_make_extended_syncase_macro
+{
+ SCM z;
+ SCM_VALIDATE_SMOB (1, m, macro);
+ SCM_VALIDATE_SYMBOL (2, type);
+
+ SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type),
+ SCM_UNPACK (binding));
+ SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED);
+ return z;
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0,
(SCM obj),
- "Return @code{#t} if @var{obj} is a regular macro, a memoizing
macro or a\n"
- "syntax transformer.")
+ "Return @code{#t} if @var{obj} is a regular macro, a memoizing
macro, a\n"
+ "syntax transformer, or a syntax-case macro.")
#define FUNC_NAME s_scm_macro_p
{
return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj));
@@ -182,14 +239,15 @@ SCM_SYMBOL (scm_sym_macro, "macro");
#endif
SCM_SYMBOL (scm_sym_mmacro, "macro!");
SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!");
+SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro");
SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
(SCM m),
- "Return one of the symbols @code{syntax}, @code{macro} or\n"
- "@code{macro!}, depending on whether @var{m} is a syntax\n"
- "transformer, a regular macro, or a memoizing macro,\n"
- "respectively. If @var{m} is not a macro, @code{#f} is\n"
- "returned.")
+ "Return one of the symbols @code{syntax}, @code{macro},\n"
+ "@code{macro!}, or @code{syntax-case}, depending on whether\n"
+ "@var{m} is a syntax transformer, a regular macro, a memoizing\n"
+ "macro, or a syntax-case macro, respectively. If @var{m} is\n"
+ "not a macro, @code{#f} is returned.")
#define FUNC_NAME s_scm_macro_type
{
if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m))
@@ -202,6 +260,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
#endif
case 2: return scm_sym_mmacro;
case 3: return scm_sym_bimacro;
+ case 4: return scm_sym_syncase_macro;
default: scm_wrong_type_arg (FUNC_NAME, 1, m);
}
}
@@ -214,7 +273,9 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
#define FUNC_NAME s_scm_macro_name
{
SCM_VALIDATE_SMOB (1, m, macro);
- return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m)));
+ if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m))))
+ return scm_procedure_name (SCM_SMOB_OBJECT (m));
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -236,6 +297,34 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1,
0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0,
+ (SCM m),
+ "Return the type of the macro @var{m}.")
+#define FUNC_NAME s_scm_syncase_macro_type
+{
+ SCM_VALIDATE_SMOB (1, m, macro);
+
+ if (SCM_MACRO_IS_EXTENDED (m))
+ return SCM_SMOB_OBJECT_2 (m);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0,
+ (SCM m),
+ "Return the binding of the macro @var{m}.")
+#define FUNC_NAME s_scm_syncase_macro_binding
+{
+ SCM_VALIDATE_SMOB (1, m, macro);
+
+ if (SCM_MACRO_IS_EXTENDED (m))
+ return SCM_SMOB_OBJECT_3 (m);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
SCM
scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
{
@@ -249,7 +338,7 @@ void
scm_init_macros ()
{
scm_tc16_macro = scm_make_smob_type ("macro", 0);
- scm_set_smob_mark (scm_tc16_macro, scm_markcdr);
+ scm_set_smob_mark (scm_tc16_macro, macro_mark);
scm_set_smob_print (scm_tc16_macro, macro_print);
#include "libguile/macros.x"
}
diff --git a/libguile/macros.h b/libguile/macros.h
index e1de77f..5e3d64a 100644
--- a/libguile/macros.h
+++ b/libguile/macros.h
@@ -29,9 +29,15 @@
#define SCM_ASSYNT(_cond, _msg, _subr) \
if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL);
+#define SCM_MACRO_TYPE_BITS (3)
+#define SCM_MACRO_TYPE_MASK ((1<<SCM_MACRO_TYPE_BITS)-1)
+#define SCM_F_MACRO_EXTENDED (1<<SCM_MACRO_TYPE_BITS)
+
#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
-#define SCM_MACRO_TYPE(m) SCM_SMOB_FLAGS (m)
+#define SCM_MACRO_TYPE(m) (SCM_SMOB_FLAGS (m) & SCM_MACRO_TYPE_MASK)
+#define SCM_MACRO_IS_EXTENDED(m) (SCM_SMOB_FLAGS (m) & SCM_F_MACRO_EXTENDED)
#define SCM_BUILTIN_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 3)
+#define SCM_SYNCASE_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 4)
#define SCM_MACRO_CODE(m) SCM_SMOB_OBJECT (m)
SCM_API scm_t_bits scm_tc16_macro;
@@ -39,10 +45,15 @@ SCM_API scm_t_bits scm_tc16_macro;
SCM_INTERNAL SCM scm_i_makbimacro (SCM code);
SCM_API SCM scm_makmmacro (SCM code);
SCM_API SCM scm_makacro (SCM code);
+SCM_API SCM scm_make_syncase_macro (SCM type, SCM binding);
+SCM_API SCM scm_make_extended_syncase_macro (SCM builtin, SCM type,
+ SCM binding);
SCM_API SCM scm_macro_p (SCM obj);
SCM_API SCM scm_macro_type (SCM m);
SCM_API SCM scm_macro_name (SCM m);
SCM_API SCM scm_macro_transformer (SCM m);
+SCM_API SCM scm_syncase_macro_type (SCM m);
+SCM_API SCM scm_syncase_macro_binding (SCM m);
SCM_API SCM scm_make_synt (const char *name,
SCM (*macroizer) (SCM),
SCM (*fcn) ());
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 8bc203d..6a0a11b 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#if HAVE_CONFIG_H
# include <config.h>
@@ -51,6 +27,7 @@
#include <sys/types.h>
#include <assert.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "programs.h"
#include "objcodes.h"
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 2226916..acd43a6 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
+ * *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#ifndef _SCM_OBJCODES_H_
#define _SCM_OBJCODES_H_
@@ -60,7 +36,7 @@ struct scm_objcode {
#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1)
#define SCM_F_OBJCODE_IS_SLICE (1<<2)
-extern scm_t_bits scm_tc16_objcode;
+SCM_API scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
@@ -80,15 +56,15 @@ extern scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr);
-extern SCM scm_load_objcode (SCM file);
-extern SCM scm_objcode_p (SCM obj);
-extern SCM scm_objcode_meta (SCM objcode);
-extern SCM scm_bytecode_to_objcode (SCM bytecode);
-extern SCM scm_objcode_to_bytecode (SCM objcode);
-extern SCM scm_write_objcode (SCM objcode, SCM port);
+SCM_API SCM scm_load_objcode (SCM file);
+SCM_API SCM scm_objcode_p (SCM obj);
+SCM_API SCM scm_objcode_meta (SCM objcode);
+SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
+SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
+SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
-extern void scm_bootstrap_objcodes (void);
-extern void scm_init_objcodes (void);
+SCM_INTERNAL void scm_bootstrap_objcodes (void);
+SCM_INTERNAL void scm_init_objcodes (void);
#endif /* _SCM_OBJCODES_H_ */
diff --git a/libguile/programs.c b/libguile/programs.c
index 8e89829..68e0b85 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -1,49 +1,26 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "instructions.h"
#include "modules.h"
diff --git a/libguile/programs.h b/libguile/programs.h
index 68a6936..ae819ef 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#ifndef _SCM_PROGRAMS_H_
#define _SCM_PROGRAMS_H_
@@ -51,7 +27,7 @@
typedef unsigned char scm_byte_t;
-extern scm_t_bits scm_tc16_program;
+SCM_API scm_t_bits scm_tc16_program;
#define SCM_F_PROGRAM_IS_BOOT (1<<0)
@@ -63,27 +39,27 @@ extern scm_t_bits scm_tc16_program;
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
-extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
+SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
-extern SCM scm_program_p (SCM obj);
-extern SCM scm_program_base (SCM program);
-extern SCM scm_program_arity (SCM program);
-extern SCM scm_program_meta (SCM program);
-extern SCM scm_program_bindings (SCM program);
-extern SCM scm_program_sources (SCM program);
-extern SCM scm_program_source (SCM program, SCM ip);
-extern SCM scm_program_properties (SCM program);
-extern SCM scm_program_name (SCM program);
-extern SCM scm_program_objects (SCM program);
-extern SCM scm_program_module (SCM program);
-extern SCM scm_program_external (SCM program);
-extern SCM scm_program_external_set_x (SCM program, SCM external);
-extern SCM scm_program_objcode (SCM program);
+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_properties (SCM program);
+SCM_API SCM scm_program_name (SCM program);
+SCM_API SCM scm_program_objects (SCM program);
+SCM_API SCM scm_program_module (SCM program);
+SCM_API SCM scm_program_external (SCM program);
+SCM_API SCM scm_program_external_set_x (SCM program, SCM external);
+SCM_API SCM scm_program_objcode (SCM program);
-extern SCM scm_c_program_source (SCM program, size_t ip);
+SCM_API SCM scm_c_program_source (SCM program, size_t ip);
-extern void scm_bootstrap_programs (void);
-extern void scm_init_programs (void);
+SCM_INTERNAL void scm_bootstrap_programs (void);
+SCM_INTERNAL void scm_init_programs (void);
#endif /* _SCM_PROGRAMS_H_ */
diff --git a/libguile/read.c b/libguile/read.c
index 47b8004..a4db2ab 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -182,6 +182,7 @@ static SCM *scm_read_hash_procedures;
/* Read an SCSH block comment. */
static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
+static SCM scm_read_commented_expression (int chr, SCM port);
/* Read from PORT until a delimiter (e.g., a whitespace) is read. Return
zero if the whole token fits in BUF, non-zero otherwise. */
@@ -257,6 +258,9 @@ flush_ws (SCM port, const char *eoferr)
case '!':
scm_read_scsh_block_comment (c, port);
break;
+ case ';':
+ scm_read_commented_expression (c, port);
+ break;
default:
scm_ungetc (c, port);
return '#';
@@ -691,6 +695,65 @@ scm_read_quote (int chr, SCM port)
return p;
}
+SCM_SYMBOL (sym_syntax, "syntax");
+SCM_SYMBOL (sym_quasisyntax, "quasisyntax");
+SCM_SYMBOL (sym_unsyntax, "unsyntax");
+SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing");
+
+static SCM
+scm_read_syntax (int chr, SCM port)
+{
+ SCM p;
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+
+ switch (chr)
+ {
+ case '`':
+ p = sym_quasisyntax;
+ break;
+
+ case '\'':
+ p = sym_syntax;
+ break;
+
+ case ',':
+ {
+ int c;
+
+ c = scm_getc (port);
+ if ('@' == c)
+ p = sym_unsyntax_splicing;
+ else
+ {
+ scm_ungetc (c, port);
+ p = sym_unsyntax;
+ }
+ break;
+ }
+
+ default:
+ fprintf (stderr, "%s: unhandled syntax character (%i)\n",
+ "scm_read_syntax", chr);
+ abort ();
+ }
+
+ p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
+ if (SCM_RECORD_POSITIONS_P)
+ scm_whash_insert (scm_source_whash, p,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
+
+
+ return p;
+}
+
static inline SCM
scm_read_semicolon_comment (int chr, SCM port)
{
@@ -854,6 +917,20 @@ scm_read_scsh_block_comment (int chr, SCM port)
}
static SCM
+scm_read_commented_expression (int chr, SCM port)
+{
+ int c;
+
+ c = flush_ws (port, (char *) NULL);
+ if (EOF == c)
+ scm_i_input_error ("read_commented_expression", port,
+ "no expression after #; comment", SCM_EOL);
+ scm_ungetc (c, port);
+ scm_read_expression (port);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
scm_read_extended_symbol (int chr, SCM port)
{
/* Guile's extended symbol read syntax looks like this:
@@ -1014,6 +1091,12 @@ scm_read_sharp (int chr, SCM port)
return (scm_read_extended_symbol (chr, port));
case '!':
return (scm_read_scsh_block_comment (chr, port));
+ case ';':
+ return (scm_read_commented_expression (chr, port));
+ case '`':
+ case '\'':
+ case ',':
+ return (scm_read_syntax (chr, port));
default:
result = scm_read_sharp_extension (chr, port);
if (scm_is_eq (result, SCM_UNSPECIFIED))
diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h
index beecf0f..587766a 100644
--- a/libguile/vm-bootstrap.h
+++ b/libguile/vm-bootstrap.h
@@ -1,48 +1,24 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#ifndef _SCM_VM_BOOTSTRAP_H_
#define _SCM_VM_BOOTSTRAP_H_
-extern void scm_bootstrap_vm (void);
+SCM_INTERNAL void scm_bootstrap_vm (void);
#endif /* _SCM_VM_BOOTSTRAP_H_ */
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 45251fd..f43f8c7 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
/* This file is included in vm.c multiple times */
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 6bb2354..8c919f6 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
/* This file is included in vm_engine.c */
@@ -147,8 +123,12 @@
#ifdef VM_ENABLE_PARANOID_ASSERTIONS
#define CHECK_IP() \
do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
+#define ASSERT_BOUND(x) \
+ do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \
+ } while (0)
#else
#define CHECK_IP()
+#define ASSERT_BOUND(x)
#endif
/* Get a local copy of the program's "object table" (i.e. the vector of
diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h
index 7ad2b9d..02dfbc4 100644
--- a/libguile/vm-expand.h
+++ b/libguile/vm-expand.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#ifndef VM_LABEL
#define VM_LABEL(tag) l_##tag
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 4af6026..38dea32 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
/* This file is included in vm_engine.c */
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 5468604..42f2b19 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -230,6 +230,7 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0,
1)
VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
{
PUSH (LOCAL_REF (FETCH ()));
+ ASSERT_BOUND (*sp);
NEXT;
}
@@ -244,6 +245,7 @@ VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1,
0, 1)
}
CHECK_EXTERNAL(e);
PUSH (SCM_CAR (e));
+ ASSERT_BOUND (*sp);
NEXT;
}
@@ -408,12 +410,6 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set",
1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1)
-{
- PUSH (external);
- NEXT;
-}
-
/*
* branch and jump
diff --git a/libguile/vm.c b/libguile/vm.c
index 38d085c..081a691 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#if HAVE_CONFIG_H
# include <config.h>
@@ -46,6 +22,7 @@
#include <stdlib.h>
#include <alloca.h>
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"
#include "instructions.h"
diff --git a/libguile/vm.h b/libguile/vm.h
index 5c38f9f..2f2b617 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
#ifndef _SCM_VM_H_
#define _SCM_VM_H_
@@ -78,37 +54,37 @@ struct scm_vm {
SCM trace_frame; /* a frame being traced */
};
-extern SCM scm_the_vm_fluid;
+SCM_API SCM scm_the_vm_fluid;
#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x)
#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm))
#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
-extern SCM scm_the_vm ();
-extern SCM scm_make_vm (void);
-extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
-extern SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
-extern SCM scm_vm_option_ref (SCM vm, SCM key);
-extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
-
-extern SCM scm_vm_version (void);
-extern SCM scm_the_vm (void);
-extern SCM scm_vm_p (SCM obj);
-extern SCM scm_vm_ip (SCM vm);
-extern SCM scm_vm_sp (SCM vm);
-extern SCM scm_vm_fp (SCM vm);
-extern SCM scm_vm_boot_hook (SCM vm);
-extern SCM scm_vm_halt_hook (SCM vm);
-extern SCM scm_vm_next_hook (SCM vm);
-extern SCM scm_vm_break_hook (SCM vm);
-extern SCM scm_vm_enter_hook (SCM vm);
-extern SCM scm_vm_apply_hook (SCM vm);
-extern SCM scm_vm_exit_hook (SCM vm);
-extern SCM scm_vm_return_hook (SCM vm);
-extern SCM scm_vm_option (SCM vm, SCM key);
-extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
-extern SCM scm_vm_stats (SCM vm);
-extern SCM scm_vm_trace_frame (SCM vm);
+SCM_API SCM scm_the_vm ();
+SCM_API SCM scm_make_vm (void);
+SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
+SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
+SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
+SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
+
+SCM_API SCM scm_vm_version (void);
+SCM_API SCM scm_the_vm (void);
+SCM_API SCM scm_vm_p (SCM obj);
+SCM_API SCM scm_vm_ip (SCM vm);
+SCM_API SCM scm_vm_sp (SCM vm);
+SCM_API SCM scm_vm_fp (SCM vm);
+SCM_API SCM scm_vm_boot_hook (SCM vm);
+SCM_API SCM scm_vm_halt_hook (SCM vm);
+SCM_API SCM scm_vm_next_hook (SCM vm);
+SCM_API SCM scm_vm_break_hook (SCM vm);
+SCM_API SCM scm_vm_enter_hook (SCM vm);
+SCM_API SCM scm_vm_apply_hook (SCM vm);
+SCM_API SCM scm_vm_exit_hook (SCM vm);
+SCM_API SCM scm_vm_return_hook (SCM vm);
+SCM_API SCM scm_vm_option (SCM vm, SCM key);
+SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
+SCM_API SCM scm_vm_stats (SCM vm);
+SCM_API SCM scm_vm_trace_frame (SCM vm);
struct scm_vm_cont {
scm_byte_t *ip;
@@ -119,16 +95,16 @@ struct scm_vm_cont {
scm_t_ptrdiff reloc;
};
-extern scm_t_bits scm_tc16_vm_cont;
+SCM_API scm_t_bits scm_tc16_vm_cont;
#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
-extern SCM scm_vm_capture_continuations (void);
-extern void scm_vm_reinstate_continuations (SCM conts);
+SCM_API SCM scm_vm_capture_continuations (void);
+SCM_API void scm_vm_reinstate_continuations (SCM conts);
-extern SCM scm_load_compiled_with_vm (SCM file);
+SCM_API SCM scm_load_compiled_with_vm (SCM file);
-extern void scm_init_vm (void);
+SCM_INTERNAL void scm_init_vm (void);
#endif /* _SCM_VM_H_ */
diff --git a/module/Makefile.am b/module/Makefile.am
index 9cda51a..35959e2 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -31,13 +31,15 @@ modpath =
# putting these core modules first.
SOURCES = \
- ice-9/psyntax-pp.scm \
+ ice-9/psyntax-pp.scm
\
system/base/pmatch.scm system/base/syntax.scm
\
system/base/compile.scm system/base/language.scm \
\
+ language/tree-il.scm \
language/ghil.scm language/glil.scm language/assembly.scm \
\
$(SCHEME_LANG_SOURCES) \
+ $(TREE_IL_LANG_SOURCES) \
$(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)
\
@@ -63,10 +65,19 @@ ice-9/psyntax-pp.scm: ice-9/psyntax.scm
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
SCHEME_LANG_SOURCES = \
- language/scheme/amatch.scm \
- language/scheme/compile-ghil.scm language/scheme/spec.scm \
+ language/scheme/compile-ghil.scm \
+ language/scheme/spec.scm \
+ language/scheme/compile-tree-il.scm \
+ language/scheme/decompile-tree-il.scm \
language/scheme/inline.scm
+TREE_IL_LANG_SOURCES = \
+ language/tree-il/primitives.scm \
+ language/tree-il/optimize.scm \
+ language/tree-il/analyze.scm \
+ language/tree-il/compile-glil.scm \
+ language/tree-il/spec.scm
+
GHIL_LANG_SOURCES = \
language/ghil/spec.scm language/ghil/compile-glil.scm
@@ -132,7 +143,6 @@ ICE_9_SOURCES = \
ice-9/debugger.scm \
ice-9/documentation.scm \
ice-9/emacs.scm \
- ice-9/expand-support.scm \
ice-9/expect.scm \
ice-9/format.scm \
ice-9/getopt-long.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 44f5f02..4406631 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -33,8 +33,6 @@
-(define (void) (if #f #f))
-
;; Before compiling, make sure any symbols are resolved in the (guile)
;; module, the primary location of those symbols, rather than in
;; (guile-user), the default module that we compile in.
@@ -95,6 +93,42 @@
(define (provided? feature)
(and (memq feature *features*) #t))
+
+
+;;; {and-map and or-map}
+;;;
+;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;;
+
+;; and-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or f returns #f.
+;; If returning early, return #f. Otherwise, return the last value returned
+;; by f. If f has never been called because l is empty, return #t.
+;;
+(define (and-map f lst)
+ (let loop ((result #t)
+ (l lst))
+ (and result
+ (or (and (null? l)
+ result)
+ (loop (f (car l)) (cdr l))))))
+
+;; or-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or while f returns #f.
+;; If returning early, return the return value of f.
+;;
+(define (or-map f lst)
+ (let loop ((result #f)
+ (l lst))
+ (or result
+ (and (not (null? l))
+ (loop (f (car l)) (cdr l))))))
+
+
+
;; let format alias simple-format until the more complete version is loaded
(define format simple-format)
@@ -134,101 +168,150 @@
-;; Before the module system boots, there are no module names. But
-;; psyntax does want a module-name definition, so give it one.
+;; Define a minimal stub of the module API for psyntax, before modules
+;; have booted.
(define (module-name x)
'(guile))
-(define (module-add! module sym var)
- (hashq-set! (%get-pre-modules-obarray) sym var))
-(define (make-module-ref mod var kind)
- (case kind
- ((public) (if mod `(@ ,mod ,var) var))
- ((private) (if (and mod (not (equal? mod (module-name (current-module)))))
- `(@@ ,mod ,var)
- var))
- ((bare) var)
- ((hygiene) (if (and mod
- (not (equal? mod (module-name (current-module))))
- (module-variable (resolve-module mod) var))
- `(@@ ,mod ,var)
- var))
- (else (error "foo" mod var kind))))
+(define (module-define! module sym val)
+ (let ((v (hashq-ref (%get-pre-modules-obarray) sym)))
+ (if v
+ (variable-set! v val)
+ (hashq-set! (%get-pre-modules-obarray) sym
+ (make-variable val)))))
+(define (module-ref module sym)
+ (let ((v (module-variable module sym)))
+ (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
(define (resolve-module . args)
#f)
-;;; Here we use "keyword" in the sense that R6RS uses it, as in "a
-;;; definition may be a keyword definition or a variable definition".
-;;; Keywords are syntactic bindings; variables are value bindings.
-(define (module-define-keyword! mod sym type val)
- (let ((v (or (module-local-variable mod sym)
- (let ((v (make-variable val)))
- (module-add! mod sym v)
- v))))
- (if (or (not (variable-bound? v))
- (not (macro? (variable-ref v))))
- (variable-set! v val))
- (set-object-property! v '*sc-expander* (cons type val))))
-
-(define (module-lookup-keyword mod sym)
- (let ((v (module-variable mod sym)))
- (and v (object-property v '*sc-expander*))))
-
-(define (module-undefine-keyword! mod sym)
- (let ((v (module-local-variable mod sym)))
- (if v
- (let ((p (assq '*sc-expander* (object-properties v))))
- ;; probably should unbind the variable too
- (set-object-properties! v (delq p (object-properties v)))))))
-
-(define sc-expand #f)
-(define sc-expand3 #f)
-(define install-global-transformer #f)
-(define $sc-dispatch #f)
-(define syntax-violation #f)
+;; Input hook to syncase -- so that we might be able to pass annotated
+;; expressions in. Currently disabled. Maybe we should just use
+;; source-properties directly.
(define (annotation? x) #f)
+;; API provided by psyntax
+(define syntax-violation #f)
(define datum->syntax #f)
(define syntax->datum #f)
-
(define identifier? #f)
(define generate-temporaries #f)
(define bound-identifier=? #f)
(define free-identifier=? #f)
+(define sc-expand #f)
+
+;; $sc-expand is an implementation detail of psyntax. It is used by
+;; expanded macros, to dispatch an input against a set of patterns.
+(define $sc-dispatch #f)
-(define andmap
- (lambda (f first . rest)
- (or (null? first)
- (if (null? rest)
- (let andmap ((first first))
- (let ((x (car first)) (first (cdr first)))
- (if (null? first)
- (f x)
- (and (f x) (andmap first)))))
- (let andmap ((first first) (rest rest))
- (let ((x (car first))
- (xr (map car rest))
- (first (cdr first))
- (rest (map cdr rest)))
- (if (null? first)
- (apply f (cons x xr))
- (and (apply f (cons x xr)) (andmap first rest)))))))))
-
-(define (syncase-error who format-string why what)
- (%start-stack 'syncase-stack
- (lambda ()
- (scm-error 'misc-error who "~A ~S" (list why what) '()))))
-
-;; Until the module system is booted, this will be the current expander.
+;; Load it up!
(primitive-load-path "ice-9/psyntax-pp")
+;; %pre-modules-transformer is the Scheme expander from now until the
+;; module system has booted up.
(define %pre-modules-transformer sc-expand)
+(define-syntax and
+ (syntax-rules ()
+ ((_) #t)
+ ((_ x) x)
+ ((_ x y ...) (if x (and y ...) #f))))
+
+(define-syntax or
+ (syntax-rules ()
+ ((_) #f)
+ ((_ x) x)
+ ((_ x y ...) (let ((t x)) (if t t (or y ...))))))
+
+;; The "maybe-more" bits are something of a hack, so that we can support
+;; SRFI-61. Rewrites into a standalone syntax-case macro would be
+;; appreciated.
+(define-syntax cond
+ (syntax-rules (=> else)
+ ((_ "maybe-more" test consequent)
+ (if test consequent))
+
+ ((_ "maybe-more" test consequent clause ...)
+ (if test consequent (cond clause ...)))
+
+ ((_ (else else1 else2 ...))
+ (begin else1 else2 ...))
+
+ ((_ (test => receiver) more-clause ...)
+ (let ((t test))
+ (cond "maybe-more" t (receiver t) more-clause ...)))
+
+ ((_ (generator guard => receiver) more-clause ...)
+ (call-with-values (lambda () generator)
+ (lambda t
+ (cond "maybe-more"
+ (apply guard t) (apply receiver t) more-clause ...))))
+
+ ((_ (test => receiver ...) more-clause ...)
+ (syntax-violation 'cond "wrong number of receiver expressions"
+ '(test => receiver ...)))
+ ((_ (generator guard => receiver ...) more-clause ...)
+ (syntax-violation 'cond "wrong number of receiver expressions"
+ '(generator guard => receiver ...)))
+
+ ((_ (test) more-clause ...)
+ (let ((t test))
+ (cond "maybe-more" t t more-clause ...)))
+
+ ((_ (test body1 body2 ...) more-clause ...)
+ (cond "maybe-more"
+ test (begin body1 body2 ...) more-clause ...))))
+
+(define-syntax case
+ (syntax-rules (else)
+ ((case (key ...)
+ clauses ...)
+ (let ((atom-key (key ...)))
+ (case atom-key clauses ...)))
+ ((case key
+ (else result1 result2 ...))
+ (begin result1 result2 ...))
+ ((case key
+ ((atoms ...) result1 result2 ...))
+ (if (memv key '(atoms ...))
+ (begin result1 result2 ...)))
+ ((case key
+ ((atoms ...) result1 result2 ...)
+ clause clauses ...)
+ (if (memv key '(atoms ...))
+ (begin result1 result2 ...)
+ (case key clause clauses ...)))))
+
+(define-syntax do
+ (syntax-rules ()
+ ((do ((var init step ...) ...)
+ (test expr ...)
+ command ...)
+ (letrec
+ ((loop
+ (lambda (var ...)
+ (if test
+ (begin
+ (if #f #f)
+ expr ...)
+ (begin
+ command
+ ...
+ (loop (do "step" var step ...)
+ ...))))))
+ (loop init ...)))
+ ((do "step" x)
+ x)
+ ((do "step" x y)
+ y)))
+
+(define-syntax delay
+ (syntax-rules ()
+ ((_ exp) (make-promise (lambda () exp)))))
+
;;; {Defmacros}
;;;
-;;; Depends on: features, eval-case
-;;;
(define-syntax define-macro
(lambda (x)
@@ -521,40 +604,6 @@
-;;; {and-map and or-map}
-;;;
-;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
-;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
-;;;
-
-;; and-map f l
-;;
-;; Apply f to successive elements of l until exhaustion or f returns #f.
-;; If returning early, return #f. Otherwise, return the last value returned
-;; by f. If f has never been called because l is empty, return #t.
-;;
-(define (and-map f lst)
- (let loop ((result #t)
- (l lst))
- (and result
- (or (and (null? l)
- result)
- (loop (f (car l)) (cdr l))))))
-
-;; or-map f l
-;;
-;; Apply f to successive elements of l until exhaustion or while f returns #f.
-;; If returning early, return the return value of f.
-;;
-(define (or-map f lst)
- (let loop ((result #f)
- (l lst))
- (or result
- (and (not (null? l))
- (loop (f (car l)) (cdr l))))))
-
-
-
(if (provided? 'posix)
(primitive-load-path "ice-9/posix"))
@@ -912,9 +961,6 @@
;;; Reader code for various "#c" forms.
;;;
-(read-hash-extend #\' (lambda (c port)
- (read port)))
-
(define read-eval? (make-fluid))
(fluid-set! read-eval? #f)
(read-hash-extend #\.
@@ -1197,11 +1243,8 @@
(define (%print-module mod port) ; unused args: depth length style table)
(display "#<" port)
(display (or (module-kind mod) "module") port)
- (let ((name (module-name mod)))
- (if name
- (begin
- (display " " port)
- (display name port))))
+ (display " " port)
+ (display (module-name mod) port)
(display " " port)
(display (number->string (object-address mod) 16) port)
(display ">" port))
@@ -1866,7 +1909,7 @@
val
(let ((m (make-module 31)))
(set-module-kind! m 'directory)
- (set-module-name! m (append (or (module-name module) '())
+ (set-module-name! m (append (module-name module)
(list (car name))))
(module-define! module (car name) m)
m)))
@@ -1920,17 +1963,26 @@
(define default-duplicate-binding-procedures #f)
(define %app (make-module 31))
+(set-module-name! %app '(%app))
(define app %app) ;; for backwards compatability
-(local-define '(%app modules) (make-module 31))
+(let ((m (make-module 31)))
+ (set-module-name! m '())
+ (local-define '(%app modules) m))
(local-define '(%app modules guile) the-root-module)
;; This boots the module system. All bindings needed by modules.c
;; must have been defined by now.
;;
(set-current-module the-root-module)
-;; definition deferred for syncase's benefit
-(define module-name (record-accessor module-type 'name))
+;; definition deferred for syncase's benefit.
+(define module-name
+ (let ((accessor (record-accessor module-type 'name)))
+ (lambda (mod)
+ (or (accessor mod)
+ (begin
+ (set-module-name! mod (list (gensym)))
+ (accessor mod))))))
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
@@ -2388,11 +2440,12 @@ module '(ice-9 q) '(make-q q-length))}."
(define (set-repl-prompt! v) (set! scm-repl-prompt v))
(define (default-pre-unwind-handler key . args)
- (save-stack pre-unwind-handler-dispatch)
+ (save-stack 1)
(apply throw key args))
-(define (pre-unwind-handler-dispatch key . args)
- (apply default-pre-unwind-handler key args))
+(begin-deprecated
+ (define (pre-unwind-handler-dispatch key . args)
+ (apply default-pre-unwind-handler key args)))
(define abort-hook (make-hook))
@@ -2469,15 +2522,7 @@ module '(ice-9 q) '(make-q q-length))}."
(else
(apply bad-throw key args)))))))
- ;; Note that having just `pre-unwind-handler-dispatch'
- ;; here is connected with the mechanism that
- ;; produces a nice backtrace upon error. If, for
- ;; example, this is replaced with (lambda args
- ;; (apply pre-unwind-handler-dispatch args)), the stack
- ;; cutting (in save-stack) goes wrong and ends up
- ;; saving no stack at all, so there is no
- ;; backtrace.
- pre-unwind-handler-dispatch)))
+ default-pre-unwind-handler)))
(if next (loop next) status)))
(set! set-batch-mode?! (lambda (arg)
@@ -2973,19 +3018,6 @@ module '(ice-9 q) '(make-q q-length))}."
-;;; {Compiler interface}
-;;;
-;;; The full compiler interface can be found in (system). Here we put a
-;;; few useful procedures into the global namespace.
-
-(module-autoload! the-scm-module
- '(system base compile)
- '(compile
- compile-time-environment))
-
-
-
-
;;; {Parameters}
;;;
@@ -3412,6 +3444,7 @@ module '(ice-9 q) '(make-q q-length))}."
;; (module-eval-closure (current-module))))
;; (deannotate/source-properties (sc-expand (annotate exp)))))
-(define-module (guile-user))
+(define-module (guile-user)
+ #:autoload (system base compile) (compile))
;;; boot-9.scm ends here
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 7091ef9..2b8eec0 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -1,3 +1,4 @@
+(use-modules (language tree-il))
(let ((source (list-ref (command-line) 1))
(target (list-ref (command-line) 2)))
(let ((in (open-input-file source))
@@ -11,7 +12,8 @@
(close-port out)
(close-port in))
(begin
- (write (sc-expand3 x 'c '(compile load eval))
+ (write (tree-il->scheme
+ (sc-expand x 'c '(compile load eval)))
out)
(newline out)
(loop (read in))))))
diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm
index 234cd06..92d31ca 100644
--- a/module/ice-9/documentation.scm
+++ b/module/ice-9/documentation.scm
@@ -198,6 +198,8 @@ OBJECT can be a procedure, macro or any object that has its
(object-property object 'documentation)
(and (program? object)
(program-documentation object))
+ (and (macro? object)
+ (object-documentation (macro-transformer object)))
(and (procedure? object)
(not (closure? object))
(procedure-name object)
diff --git a/module/ice-9/expand-support.scm b/module/ice-9/expand-support.scm
deleted file mode 100644
index 372d959..0000000
--- a/module/ice-9/expand-support.scm
+++ /dev/null
@@ -1,169 +0,0 @@
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-;;;;
-
-
-(define-module (ice-9 expand-support)
- :export (<annotation> annotation? annotate deannotate make-annotation
- annotation-expression annotation-source annotation-stripped
- set-annotation-stripped!
- deannotate/source-properties
-
- <module-ref> make-module-ref
- module-ref-symbol module-ref-modname module-ref-public?
-
- <lexical> make-lexical
- lexical-name lexical-gensym
-
- strip-expansion-structures))
-
-(define <annotation>
- (make-vtable "prprpw"
- (lambda (struct port)
- (display "#<annotated " port)
- (display (struct-ref struct 0) port)
- (display ">" port))))
-
-(define (annotation? x)
- (and (struct? x) (eq? (struct-vtable x) <annotation>)))
-
-(define (make-annotation e s . stripped?)
- (if (null? stripped?)
- (make-struct <annotation> 0 e s #f)
- (apply make-struct <annotation> 0 e s stripped?)))
-
-(define (annotation-expression a)
- (struct-ref a 0))
-(define (annotation-source a)
- (struct-ref a 1))
-(define (annotation-stripped a)
- (struct-ref a 2))
-(define (set-annotation-stripped! a stripped?)
- (struct-set! a 2 stripped?))
-
-(define (annotate e)
- (let ((p (if (pair? e) (source-properties e) #f))
- (out (cond ((and (list? e) (not (null? e)))
- (map annotate e))
- ((pair? e)
- (cons (annotate (car e)) (annotate (cdr e))))
- (else e))))
- (if (pair? p)
- (make-annotation out p #f)
- out)))
-
-(define (deannotate e)
- (cond ((list? e)
- (map deannotate e))
- ((pair? e)
- (cons (deannotate (car e)) (deannotate (cdr e))))
- ((annotation? e) (deannotate (annotation-expression e)))
- (else e)))
-
-(define (deannotate/source-properties e)
- (cond ((list? e)
- (map deannotate/source-properties e))
- ((pair? e)
- (cons (deannotate/source-properties (car e))
- (deannotate/source-properties (cdr e))))
- ((annotation? e)
- (let ((e (deannotate/source-properties (annotation-expression e)))
- (source (annotation-source e)))
- (if (pair? e)
- (set-source-properties! e source))
- e))
- (else e)))
-
-
-
-(define <module-ref>
- (make-vtable "prprpr"
- (lambda (struct port)
- (display "#<" port)
- (display (if (module-ref-public? struct) "@ " "@@ ") port)
- (display (module-ref-modname struct) port)
- (display " " port)
- (display (module-ref-symbol struct) port)
- (display ">" port))))
-
-(define (module-ref? x)
- (and (struct? x) (eq? (struct-vtable x) <module-ref>)))
-
-(define (make-module-ref modname symbol public?)
- (make-struct <module-ref> 0 modname symbol public?))
-
-(define (module-ref-modname a)
- (struct-ref a 0))
-(define (module-ref-symbol a)
- (struct-ref a 1))
-(define (module-ref-public? a)
- (struct-ref a 2))
-
-
-
-(define <lexical>
- (make-vtable "prpr"
- (lambda (struct port)
- (display "#<lexical " port)
- (display (lexical-name struct) port)
- (display "/" port)
- (display (lexical-gensym struct) port)
- (display ">" port))))
-
-(define (lexical? x)
- (and (struct? x) (eq? (struct-vtable x) <lexical>)))
-
-(define (make-lexical name gensym)
- (make-struct <lexical> 0 name gensym))
-
-(define (lexical-name a)
- (struct-ref a 0))
-(define (lexical-gensym a)
- (struct-ref a 1))
-
-
-
-(define (strip-expansion-structures e)
- (cond ((list? e)
- (map strip-expansion-structures e))
- ((pair? e)
- (cons (strip-expansion-structures (car e))
- (strip-expansion-structures (cdr e))))
- ((annotation? e)
- (let ((e (strip-expansion-structures (annotation-expression e)))
- (source (annotation-source e)))
- (if (pair? e)
- (set-source-properties! e source))
- e))
- ((module-ref? e)
- (cond
- ((or (not (module-ref-modname e))
- (eq? (module-ref-modname e)
- (module-name (current-module)))
- (and (not (module-ref-public? e))
- (not (module-variable
- (resolve-module (module-ref-modname e))
- (module-ref-symbol e)))))
- (module-ref-symbol e))
- (else
- `(,(if (module-ref-public? e) '@ '@@)
- ,(module-ref-modname e)
- ,(module-ref-symbol e)))))
- ((lexical? e)
- (lexical-gensym e))
- ((record? e)
- (error "unexpected record in expansion" e))
- (else e)))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 31066c3..f33f492 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1,13 +1,13 @@
(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
-(void)
-(letrec ((lambda-var-list1132 (lambda (vars1337) (let lvl1338 ((vars1339
vars1337) (ls1340 (quote ())) (w1341 (quote (())))) (cond ((pair? vars1339)
(lvl1338 (cdr vars1339) (cons (wrap1111 (car vars1339) w1341 #f) ls1340)
w1341)) ((id?1083 vars1339) (cons (wrap1111 vars1339 w1341 #f) ls1340)) ((null?
vars1339) ls1340) ((syntax-object?1067 vars1339) (lvl1338
(syntax-object-expression1068 vars1339) ls1340 (join-wraps1102 w1341
(syntax-object-wrap1069 vars1339)))) ((annotation? vars1339) (lvl1338
(annotation-expression vars1339) ls1340 w1341)) (else (cons vars1339
ls1340)))))) (gen-var1131 (lambda (id1342) (let ((id1343 (if
(syntax-object?1067 id1342) (syntax-object-expression1068 id1342) id1342))) (if
(annotation? id1343) (build-annotated1060 (annotation-source id1343) (gensym
(symbol->string (annotation-expression id1343)))) (build-annotated1060 #f
(gensym (symbol->string id1343))))))) (strip1130 (lambda (x1344 w1345) (if
(memq (quote top) (wrap-marks1086 w1345)) (if (or (annotation? x1344) (and
(pair? x1344) (annotation? (car x1344)))) (strip-annotation1129 x1344 #f)
x1344) (let f1346 ((x1347 x1344)) (cond ((syntax-object?1067 x1347) (strip1130
(syntax-object-expression1068 x1347) (syntax-object-wrap1069 x1347))) ((pair?
x1347) (let ((a1348 (f1346 (car x1347))) (d1349 (f1346 (cdr x1347)))) (if (and
(eq? a1348 (car x1347)) (eq? d1349 (cdr x1347))) x1347 (cons a1348 d1349))))
((vector? x1347) (let ((old1350 (vector->list x1347))) (let ((new1351 (map
f1346 old1350))) (if (andmap eq? old1350 new1351) x1347 (list->vector
new1351))))) (else x1347)))))) (strip-annotation1129 (lambda (x1352 parent1353)
(cond ((pair? x1352) (let ((new1354 (cons #f #f))) (begin (if parent1353
(set-annotation-stripped! parent1353 new1354)) (set-car! new1354
(strip-annotation1129 (car x1352) #f)) (set-cdr! new1354 (strip-annotation1129
(cdr x1352) #f)) new1354))) ((annotation? x1352) (or (annotation-stripped
x1352) (strip-annotation1129 (annotation-expression x1352) x1352))) ((vector?
x1352) (let ((new1355 (make-vector (vector-length x1352)))) (begin (if
parent1353 (set-annotation-stripped! parent1353 new1355)) (let loop1356 ((i1357
(- (vector-length x1352) 1))) (unless (fx<1053 i1357 0) (vector-set! new1355
i1357 (strip-annotation1129 (vector-ref x1352 i1357) #f)) (loop1356 (fx-1051
i1357 1)))) new1355))) (else x1352)))) (ellipsis?1128 (lambda (x1358) (and
(nonsymbol-id?1082 x1358) (free-id=?1106 x1358 (quote #(syntax-object ...
((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-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 build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook remove-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(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")) #(ribcage
(define-structure) ((top)) ("i"))) (hygiene guile))))))) (chi-void1127 (lambda
() (build-annotated1060 #f (list (build-annotated1060 #f (quote void))))))
(eval-local-transformer1126 (lambda (expanded1359 mod1360) (let ((p1361
(local-eval-hook1055 expanded1359 mod1360))) (if (procedure? p1361) p1361
(syntax-violation #f "nonprocedure transformer" p1361)))))
(chi-local-syntax1125 (lambda (rec?1362 e1363 r1364 w1365 s1366 mod1367 k1368)
((lambda (tmp1369) ((lambda (tmp1370) (if tmp1370 (apply (lambda (_1371 id1372
val1373 e11374 e21375) (let ((ids1376 id1372)) (if (not (valid-bound-ids?1108
ids1376)) (syntax-violation #f "duplicate bound keyword" e1363) (let
((labels1378 (gen-labels1089 ids1376))) (let ((new-w1379 (make-binding-wrap1100
ids1376 labels1378 w1365))) (k1368 (cons e11374 e21375) (extend-env1077
labels1378 (let ((w1381 (if rec?1362 new-w1379 w1365)) (trans-r1382
(macros-only-env1079 r1364))) (map (lambda (x1383) (cons (quote macro)
(eval-local-transformer1126 (chi1119 x1383 trans-r1382 w1381 mod1367)
mod1367))) val1373)) r1364) new-w1379 s1366 mod1367)))))) tmp1370) ((lambda
(_1385) (syntax-violation #f "bad local syntax definition" (source-wrap1112
e1363 w1365 s1366 mod1367))) tmp1369))) ($sc-dispatch tmp1369 (quote (any
#(each (any any)) any . each-any))))) e1363))) (chi-lambda-clause1124 (lambda
(e1386 docstring1387 c1388 r1389 w1390 mod1391 k1392) ((lambda (tmp1393)
((lambda (tmp1394) (if (if tmp1394 (apply (lambda (args1395 doc1396 e11397
e21398) (and (string? (syntax->datum doc1396)) (not docstring1387))) tmp1394)
#f) (apply (lambda (args1399 doc1400 e11401 e21402) (chi-lambda-clause1124
e1386 doc1400 (cons args1399 (cons e11401 e21402)) r1389 w1390 mod1391 k1392))
tmp1394) ((lambda (tmp1404) (if tmp1404 (apply (lambda (id1405 e11406 e21407)
(let ((ids1408 id1405)) (if (not (valid-bound-ids?1108 ids1408))
(syntax-violation (quote lambda) "invalid parameter list" e1386) (let
((labels1410 (gen-labels1089 ids1408)) (new-vars1411 (map gen-var1131
ids1408))) (k1392 new-vars1411 docstring1387 (chi-body1123 (cons e11406 e21407)
e1386 (extend-var-env1078 labels1410 new-vars1411 r1389) (make-binding-wrap1100
ids1408 labels1410 w1390) mod1391)))))) tmp1404) ((lambda (tmp1413) (if tmp1413
(apply (lambda (ids1414 e11415 e21416) (let ((old-ids1417 (lambda-var-list1132
ids1414))) (if (not (valid-bound-ids?1108 old-ids1417)) (syntax-violation
(quote lambda) "invalid parameter list" e1386) (let ((labels1418
(gen-labels1089 old-ids1417)) (new-vars1419 (map gen-var1131 old-ids1417)))
(k1392 (let f1420 ((ls11421 (cdr new-vars1419)) (ls21422 (car new-vars1419)))
(if (null? ls11421) ls21422 (f1420 (cdr ls11421) (cons (car ls11421)
ls21422)))) docstring1387 (chi-body1123 (cons e11415 e21416) e1386
(extend-var-env1078 labels1418 new-vars1419 r1389) (make-binding-wrap1100
old-ids1417 labels1418 w1390) mod1391)))))) tmp1413) ((lambda (_1424)
(syntax-violation (quote lambda) "bad lambda" e1386)) tmp1393))) ($sc-dispatch
tmp1393 (quote (any any . each-any)))))) ($sc-dispatch tmp1393 (quote (each-any
any . each-any)))))) ($sc-dispatch tmp1393 (quote (any any any . each-any)))))
c1388))) (chi-body1123 (lambda (body1425 outer-form1426 r1427 w1428 mod1429)
(let ((r1430 (cons (quote ("placeholder" placeholder)) r1427))) (let
((ribcage1431 (make-ribcage1090 (quote ()) (quote ()) (quote ())))) (let
((w1432 (make-wrap1085 (wrap-marks1086 w1428) (cons ribcage1431 (wrap-subst1087
w1428))))) (let parse1433 ((body1434 (map (lambda (x1440) (cons r1430 (wrap1111
x1440 w1432 mod1429))) body1425)) (ids1435 (quote ())) (labels1436 (quote ()))
(vars1437 (quote ())) (vals1438 (quote ())) (bindings1439 (quote ()))) (if
(null? body1434) (syntax-violation #f "no expressions in body" outer-form1426)
(let ((e1441 (cdar body1434)) (er1442 (caar body1434))) (call-with-values
(lambda () (syntax-type1117 e1441 er1442 (quote (())) #f ribcage1431 mod1429))
(lambda (type1443 value1444 e1445 w1446 s1447 mod1448) (let ((t1449 type1443))
(if (memv t1449 (quote (define-form))) (let ((id1450 (wrap1111 value1444 w1446
mod1448)) (label1451 (gen-label1088))) (let ((var1452 (gen-var1131 id1450)))
(begin (extend-ribcage!1099 ribcage1431 id1450 label1451) (parse1433 (cdr
body1434) (cons id1450 ids1435) (cons label1451 labels1436) (cons var1452
vars1437) (cons (cons er1442 (wrap1111 e1445 w1446 mod1448)) vals1438) (cons
(cons (quote lexical) var1452) bindings1439))))) (if (memv t1449 (quote
(define-syntax-form))) (let ((id1453 (wrap1111 value1444 w1446 mod1448))
(label1454 (gen-label1088))) (begin (extend-ribcage!1099 ribcage1431 id1453
label1454) (parse1433 (cdr body1434) (cons id1453 ids1435) (cons label1454
labels1436) vars1437 vals1438 (cons (cons (quote macro) (cons er1442 (wrap1111
e1445 w1446 mod1448))) bindings1439)))) (if (memv t1449 (quote (begin-form)))
((lambda (tmp1455) ((lambda (tmp1456) (if tmp1456 (apply (lambda (_1457 e11458)
(parse1433 (let f1459 ((forms1460 e11458)) (if (null? forms1460) (cdr body1434)
(cons (cons er1442 (wrap1111 (car forms1460) w1446 mod1448)) (f1459 (cdr
forms1460))))) ids1435 labels1436 vars1437 vals1438 bindings1439)) tmp1456)
(syntax-violation #f "source expression failed to match any pattern" tmp1455)))
($sc-dispatch tmp1455 (quote (any . each-any))))) e1445) (if (memv t1449 (quote
(local-syntax-form))) (chi-local-syntax1125 value1444 e1445 er1442 w1446 s1447
mod1448 (lambda (forms1462 er1463 w1464 s1465 mod1466) (parse1433 (let f1467
((forms1468 forms1462)) (if (null? forms1468) (cdr body1434) (cons (cons er1463
(wrap1111 (car forms1468) w1464 mod1466)) (f1467 (cdr forms1468))))) ids1435
labels1436 vars1437 vals1438 bindings1439))) (if (null? ids1435)
(build-sequence1062 #f (map (lambda (x1469) (chi1119 (cdr x1469) (car x1469)
(quote (())) mod1448)) (cons (cons er1442 (source-wrap1112 e1445 w1446 s1447
mod1448)) (cdr body1434)))) (begin (if (not (valid-bound-ids?1108 ids1435))
(syntax-violation #f "invalid or duplicate identifier in definition"
outer-form1426)) (let loop1470 ((bs1471 bindings1439) (er-cache1472 #f)
(r-cache1473 #f)) (if (not (null? bs1471)) (let ((b1474 (car bs1471))) (if (eq?
(car b1474) (quote macro)) (let ((er1475 (cadr b1474))) (let ((r-cache1476 (if
(eq? er1475 er-cache1472) r-cache1473 (macros-only-env1079 er1475)))) (begin
(set-cdr! b1474 (eval-local-transformer1126 (chi1119 (cddr b1474) r-cache1476
(quote (())) mod1448) mod1448)) (loop1470 (cdr bs1471) er1475 r-cache1476))))
(loop1470 (cdr bs1471) er-cache1472 r-cache1473))))) (set-cdr! r1430
(extend-env1077 labels1436 bindings1439 (cdr r1430))) (build-letrec1065 #f
vars1437 (map (lambda (x1477) (chi1119 (cdr x1477) (car x1477) (quote (()))
mod1448)) vals1438) (build-sequence1062 #f (map (lambda (x1478) (chi1119 (cdr
x1478) (car x1478) (quote (())) mod1448)) (cons (cons er1442 (source-wrap1112
e1445 w1446 s1447 mod1448)) (cdr body1434)))))))))))))))))))))) (chi-macro1122
(lambda (p1479 e1480 r1481 w1482 rib1483 mod1484) (letrec
((rebuild-macro-output1485 (lambda (x1486 m1487) (cond ((pair? x1486) (cons
(rebuild-macro-output1485 (car x1486) m1487) (rebuild-macro-output1485 (cdr
x1486) m1487))) ((syntax-object?1067 x1486) (let ((w1488
(syntax-object-wrap1069 x1486))) (let ((ms1489 (wrap-marks1086 w1488)) (s1490
(wrap-subst1087 w1488))) (if (and (pair? ms1489) (eq? (car ms1489) #f))
(make-syntax-object1066 (syntax-object-expression1068 x1486) (make-wrap1085
(cdr ms1489) (if rib1483 (cons rib1483 (cdr s1490)) (cdr s1490)))
(syntax-object-module1070 x1486)) (make-syntax-object1066
(syntax-object-expression1068 x1486) (make-wrap1085 (cons m1487 ms1489) (if
rib1483 (cons rib1483 (cons (quote shift) s1490)) (cons (quote shift) s1490)))
(let ((pmod1491 (procedure-module p1479))) (if pmod1491 (cons (quote hygiene)
(module-name pmod1491)) (quote (hygiene guile))))))))) ((vector? x1486) (let
((n1492 (vector-length x1486))) (let ((v1493 (make-vector n1492))) (let
doloop1494 ((i1495 0)) (if (fx=1052 i1495 n1492) v1493 (begin (vector-set!
v1493 i1495 (rebuild-macro-output1485 (vector-ref x1486 i1495) m1487))
(doloop1494 (fx+1050 i1495 1)))))))) ((symbol? x1486) (syntax-violation #f
"encountered raw symbol in macro output" (source-wrap1112 e1480 w1482 s
mod1484) x1486)) (else x1486))))) (rebuild-macro-output1485 (p1479 (wrap1111
e1480 (anti-mark1098 w1482) mod1484)) (string #\m))))) (chi-application1121
(lambda (x1496 e1497 r1498 w1499 s1500 mod1501) ((lambda (tmp1502) ((lambda
(tmp1503) (if tmp1503 (apply (lambda (e01504 e11505) (build-annotated1060 s1500
(cons x1496 (map (lambda (e1506) (chi1119 e1506 r1498 w1499 mod1501))
e11505)))) tmp1503) (syntax-violation #f "source expression failed to match any
pattern" tmp1502))) ($sc-dispatch tmp1502 (quote (any . each-any))))) e1497)))
(chi-expr1120 (lambda (type1508 value1509 e1510 r1511 w1512 s1513 mod1514) (let
((t1515 type1508)) (if (memv t1515 (quote (lexical))) (build-annotated1060
s1513 value1509) (if (memv t1515 (quote (core external-macro))) (value1509
e1510 r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (module-ref)))
(call-with-values (lambda () (value1509 e1510)) (lambda (id1516 mod1517)
(build-annotated1060 s1513 (if mod1517 (make-module-ref (cdr mod1517) id1516
(car mod1517)) (make-module-ref mod1517 id1516 (quote bare)))))) (if (memv
t1515 (quote (lexical-call))) (chi-application1121 (build-annotated1060
(source-annotation1074 (car e1510)) value1509) e1510 r1511 w1512 s1513 mod1514)
(if (memv t1515 (quote (global-call))) (chi-application1121
(build-annotated1060 (source-annotation1074 (car e1510)) (if (if
(syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510))
mod1514) (make-module-ref (cdr (if (syntax-object?1067 (car e1510))
(syntax-object-module1070 (car e1510)) mod1514)) value1509 (car (if
(syntax-object?1067 (car e1510)) (syntax-object-module1070 (car e1510))
mod1514))) (make-module-ref (if (syntax-object?1067 (car e1510))
(syntax-object-module1070 (car e1510)) mod1514) value1509 (quote bare)))) e1510
r1511 w1512 s1513 mod1514) (if (memv t1515 (quote (constant))) (build-data1061
s1513 (strip1130 (source-wrap1112 e1510 w1512 s1513 mod1514) (quote (())))) (if
(memv t1515 (quote (global))) (build-annotated1060 s1513 (if mod1514
(make-module-ref (cdr mod1514) value1509 (car mod1514)) (make-module-ref
mod1514 value1509 (quote bare)))) (if (memv t1515 (quote (call)))
(chi-application1121 (chi1119 (car e1510) r1511 w1512 mod1514) e1510 r1511
w1512 s1513 mod1514) (if (memv t1515 (quote (begin-form))) ((lambda (tmp1518)
((lambda (tmp1519) (if tmp1519 (apply (lambda (_1520 e11521 e21522)
(chi-sequence1113 (cons e11521 e21522) r1511 w1512 s1513 mod1514)) tmp1519)
(syntax-violation #f "source expression failed to match any pattern" tmp1518)))
($sc-dispatch tmp1518 (quote (any any . each-any))))) e1510) (if (memv t1515
(quote (local-syntax-form))) (chi-local-syntax1125 value1509 e1510 r1511 w1512
s1513 mod1514 chi-sequence1113) (if (memv t1515 (quote (eval-when-form)))
((lambda (tmp1524) ((lambda (tmp1525) (if tmp1525 (apply (lambda (_1526 x1527
e11528 e21529) (let ((when-list1530 (chi-when-list1116 e1510 x1527 w1512))) (if
(memq (quote eval) when-list1530) (chi-sequence1113 (cons e11528 e21529) r1511
w1512 s1513 mod1514) (chi-void1127)))) tmp1525) (syntax-violation #f "source
expression failed to match any pattern" tmp1524))) ($sc-dispatch tmp1524 (quote
(any each-any any . each-any))))) e1510) (if (memv t1515 (quote (define-form
define-syntax-form))) (syntax-violation #f "definition in expression context"
e1510 (wrap1111 value1509 w1512 mod1514)) (if (memv t1515 (quote (syntax)))
(syntax-violation #f "reference to pattern variable outside syntax form"
(source-wrap1112 e1510 w1512 s1513 mod1514)) (if (memv t1515 (quote
(displaced-lexical))) (syntax-violation #f (source-wrap1112 e1510 w1512 s1513
mod1514) "reference to identifier outside its scope") (syntax-violation #f
"unexpected syntax" (source-wrap1112 e1510 w1512 s1513
mod1514))))))))))))))))))) (chi1119 (lambda (e1533 r1534 w1535 mod1536)
(call-with-values (lambda () (syntax-type1117 e1533 r1534 w1535 #f #f mod1536))
(lambda (type1537 value1538 e1539 w1540 s1541 mod1542) (chi-expr1120 type1537
value1538 e1539 r1534 w1540 s1541 mod1542))))) (chi-top1118 (lambda (e1543
r1544 w1545 m1546 esew1547 mod1548) (call-with-values (lambda ()
(syntax-type1117 e1543 r1544 w1545 #f #f mod1548)) (lambda (type1556 value1557
e1558 w1559 s1560 mod1561) (let ((t1562 type1556)) (if (memv t1562 (quote
(begin-form))) ((lambda (tmp1563) ((lambda (tmp1564) (if tmp1564 (apply (lambda
(_1565) (chi-void1127)) tmp1564) ((lambda (tmp1566) (if tmp1566 (apply (lambda
(_1567 e11568 e21569) (chi-top-sequence1114 (cons e11568 e21569) r1544 w1559
s1560 m1546 esew1547 mod1561)) tmp1566) (syntax-violation #f "source expression
failed to match any pattern" tmp1563))) ($sc-dispatch tmp1563 (quote (any any .
each-any)))))) ($sc-dispatch tmp1563 (quote (any))))) e1558) (if (memv t1562
(quote (local-syntax-form))) (chi-local-syntax1125 value1557 e1558 r1544 w1559
s1560 mod1561 (lambda (body1571 r1572 w1573 s1574 mod1575)
(chi-top-sequence1114 body1571 r1572 w1573 s1574 m1546 esew1547 mod1575))) (if
(memv t1562 (quote (eval-when-form))) ((lambda (tmp1576) ((lambda (tmp1577) (if
tmp1577 (apply (lambda (_1578 x1579 e11580 e21581) (let ((when-list1582
(chi-when-list1116 e1558 x1579 w1559)) (body1583 (cons e11580 e21581))) (cond
((eq? m1546 (quote e)) (if (memq (quote eval) when-list1582)
(chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval))
mod1561) (chi-void1127))) ((memq (quote load) when-list1582) (if (or (memq
(quote compile) when-list1582) (and (eq? m1546 (quote c&e)) (memq (quote eval)
when-list1582))) (chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c&e)
(quote (compile load)) mod1561) (if (memq m1546 (quote (c c&e)))
(chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote c) (quote (load))
mod1561) (chi-void1127)))) ((or (memq (quote compile) when-list1582) (and (eq?
m1546 (quote c&e)) (memq (quote eval) when-list1582))) (top-level-eval-hook1054
(chi-top-sequence1114 body1583 r1544 w1559 s1560 (quote e) (quote (eval))
mod1561) mod1561) (chi-void1127)) (else (chi-void1127))))) tmp1577)
(syntax-violation #f "source expression failed to match any pattern" tmp1576)))
($sc-dispatch tmp1576 (quote (any each-any any . each-any))))) e1558) (if (memv
t1562 (quote (define-syntax-form))) (let ((n1586 (id-var-name1105 value1557
w1559)) (r1587 (macros-only-env1079 r1544))) (let ((t1588 m1546)) (if (memv
t1588 (quote (c))) (if (memq (quote compile) esew1547) (let ((e1589
(chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)))) (begin
(top-level-eval-hook1054 e1589 mod1561) (if (memq (quote load) esew1547) e1589
(chi-void1127)))) (if (memq (quote load) esew1547) (chi-install-global1115
n1586 (chi1119 e1558 r1587 w1559 mod1561)) (chi-void1127))) (if (memv t1588
(quote (c&e))) (let ((e1590 (chi-install-global1115 n1586 (chi1119 e1558 r1587
w1559 mod1561)))) (begin (top-level-eval-hook1054 e1590 mod1561) e1590)) (begin
(if (memq (quote eval) esew1547) (top-level-eval-hook1054
(chi-install-global1115 n1586 (chi1119 e1558 r1587 w1559 mod1561)) mod1561))
(chi-void1127)))))) (if (memv t1562 (quote (define-form))) (let ((n1591
(id-var-name1105 value1557 w1559))) (let ((type1592 (binding-type1075
(lookup1080 n1591 r1544 mod1561)))) (let ((t1593 type1592)) (if (memv t1593
(quote (global))) (let ((x1594 (build-annotated1060 s1560 (list (quote define)
n1591 (chi1119 e1558 r1544 w1559 mod1561))))) (begin (if (eq? m1546 (quote
c&e)) (top-level-eval-hook1054 x1594 mod1561)) x1594)) (if (memv t1593 (quote
(displaced-lexical))) (syntax-violation #f "identifier out of context" e1558
(wrap1111 value1557 w1559 mod1561)) (if (memv t1593 (quote (core macro
module-ref))) (begin (remove-global-definition-hook1058 n1591) (let ((x1595
(build-annotated1060 s1560 (list (quote define) n1591 (chi1119 e1558 r1544
w1559 mod1561))))) (begin (if (eq? m1546 (quote c&e)) (top-level-eval-hook1054
x1595 mod1561)) x1595))) (syntax-violation #f "cannot define keyword at top
level" e1558 (wrap1111 value1557 w1559 mod1561)))))))) (let ((x1596
(chi-expr1120 type1556 value1557 e1558 r1544 w1559 s1560 mod1561))) (begin (if
(eq? m1546 (quote c&e)) (top-level-eval-hook1054 x1596 mod1561))
x1596)))))))))))) (syntax-type1117 (lambda (e1597 r1598 w1599 s1600 rib1601
mod1602) (cond ((symbol? e1597) (let ((n1603 (id-var-name1105 e1597 w1599)))
(let ((b1604 (lookup1080 n1603 r1598 mod1602))) (let ((type1605
(binding-type1075 b1604))) (let ((t1606 type1605)) (if (memv t1606 (quote
(lexical))) (values type1605 (binding-value1076 b1604) e1597 w1599 s1600
mod1602) (if (memv t1606 (quote (global))) (values type1605 n1603 e1597 w1599
s1600 mod1602) (if (memv t1606 (quote (macro))) (syntax-type1117 (chi-macro1122
(binding-value1076 b1604) e1597 r1598 w1599 rib1601 mod1602) r1598 (quote (()))
s1600 rib1601 mod1602) (values type1605 (binding-value1076 b1604) e1597 w1599
s1600 mod1602))))))))) ((pair? e1597) (let ((first1607 (car e1597))) (if
(id?1083 first1607) (let ((n1608 (id-var-name1105 first1607 w1599))) (let
((b1609 (lookup1080 n1608 r1598 (or (and (syntax-object?1067 first1607)
(syntax-object-module1070 first1607)) mod1602)))) (let ((type1610
(binding-type1075 b1609))) (let ((t1611 type1610)) (if (memv t1611 (quote
(lexical))) (values (quote lexical-call) (binding-value1076 b1609) e1597 w1599
s1600 mod1602) (if (memv t1611 (quote (global))) (values (quote global-call)
n1608 e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (macro)))
(syntax-type1117 (chi-macro1122 (binding-value1076 b1609) e1597 r1598 w1599
rib1601 mod1602) r1598 (quote (())) s1600 rib1601 mod1602) (if (memv t1611
(quote (core external-macro module-ref))) (values type1610 (binding-value1076
b1609) e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (local-syntax)))
(values (quote local-syntax-form) (binding-value1076 b1609) e1597 w1599 s1600
mod1602) (if (memv t1611 (quote (begin))) (values (quote begin-form) #f e1597
w1599 s1600 mod1602) (if (memv t1611 (quote (eval-when))) (values (quote
eval-when-form) #f e1597 w1599 s1600 mod1602) (if (memv t1611 (quote (define)))
((lambda (tmp1612) ((lambda (tmp1613) (if (if tmp1613 (apply (lambda (_1614
name1615 val1616) (id?1083 name1615)) tmp1613) #f) (apply (lambda (_1617
name1618 val1619) (values (quote define-form) name1618 val1619 w1599 s1600
mod1602)) tmp1613) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (_1621
name1622 args1623 e11624 e21625) (and (id?1083 name1622) (valid-bound-ids?1108
(lambda-var-list1132 args1623)))) tmp1620) #f) (apply (lambda (_1626 name1627
args1628 e11629 e21630) (values (quote define-form) (wrap1111 name1627 w1599
mod1602) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1
e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () ()
()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i"
"i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation
ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause
chi-body chi-macro chi-application chi-expr chi chi-top syntax-type
chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-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 build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook remove-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(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")) #(ribcage
(define-structure) ((top)) ("i"))) (hygiene guile))) (wrap1111 (cons args1628
(cons e11629 e21630)) w1599 mod1602)) (quote (())) s1600 mod1602)) tmp1620)
((lambda (tmp1632) (if (if tmp1632 (apply (lambda (_1633 name1634) (id?1083
name1634)) tmp1632) #f) (apply (lambda (_1635 name1636) (values (quote
define-form) (wrap1111 name1636 w1599 mod1602) (quote (#(syntax-object void
((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i"
"i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation
ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause
chi-body chi-macro chi-application chi-expr chi chi-top syntax-type
chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-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 build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook remove-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(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")) #(ribcage
(define-structure) ((top)) ("i"))) (hygiene guile)))) (quote (())) s1600
mod1602)) tmp1632) (syntax-violation #f "source expression failed to match any
pattern" tmp1612))) ($sc-dispatch tmp1612 (quote (any any)))))) ($sc-dispatch
tmp1612 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp1612
(quote (any any any))))) e1597) (if (memv t1611 (quote (define-syntax)))
((lambda (tmp1637) ((lambda (tmp1638) (if (if tmp1638 (apply (lambda (_1639
name1640 val1641) (id?1083 name1640)) tmp1638) #f) (apply (lambda (_1642
name1643 val1644) (values (quote define-syntax-form) name1643 val1644 w1599
s1600 mod1602)) tmp1638) (syntax-violation #f "source expression failed to
match any pattern" tmp1637))) ($sc-dispatch tmp1637 (quote (any any any)))))
e1597) (values (quote call) #f e1597 w1599 s1600 mod1602)))))))))))))) (values
(quote call) #f e1597 w1599 s1600 mod1602)))) ((syntax-object?1067 e1597)
(syntax-type1117 (syntax-object-expression1068 e1597) r1598 (join-wraps1102
w1599 (syntax-object-wrap1069 e1597)) #f rib1601 (or (syntax-object-module1070
e1597) mod1602))) ((annotation? e1597) (syntax-type1117 (annotation-expression
e1597) r1598 w1599 (annotation-source e1597) rib1601 mod1602))
((self-evaluating? e1597) (values (quote constant) #f e1597 w1599 s1600
mod1602)) (else (values (quote other) #f e1597 w1599 s1600 mod1602)))))
(chi-when-list1116 (lambda (e1645 when-list1646 w1647) (let f1648
((when-list1649 when-list1646) (situations1650 (quote ()))) (if (null?
when-list1649) situations1650 (f1648 (cdr when-list1649) (cons (let ((x1651
(car when-list1649))) (cond ((free-id=?1106 x1651 (quote #(syntax-object
compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage ()
() ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis?
chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body
chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-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 build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook remove-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(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")) #(ribcage
(define-structure) ((top)) ("i"))) (hygiene guile)))) (quote compile))
((free-id=?1106 x1651 (quote #(syntax-object load ((top) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list
situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage
#(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-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 build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook remove-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(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")) #(ribcage
(define-structure) ((top)) ("i"))) (hygiene guile)))) (quote load))
((free-id=?1106 x1651 (quote #(syntax-object eval ((top) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list
situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage
#(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-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 build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook remove-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(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")) #(ribcage
(define-structure) ((top)) ("i"))) (hygiene guile)))) (quote eval)) (else
(syntax-violation (quote eval-when) "invalid situation" e1645 (wrap1111 x1651
w1647 #f))))) situations1650)))))) (chi-install-global1115 (lambda (name1652
e1653) (build-annotated1060 #f (list (build-annotated1060 #f (quote
install-global-transformer)) (build-data1061 #f name1652) e1653))))
(chi-top-sequence1114 (lambda (body1654 r1655 w1656 s1657 m1658 esew1659
mod1660) (build-sequence1062 s1657 (let dobody1661 ((body1662 body1654) (r1663
r1655) (w1664 w1656) (m1665 m1658) (esew1666 esew1659) (mod1667 mod1660)) (if
(null? body1662) (quote ()) (let ((first1668 (chi-top1118 (car body1662) r1663
w1664 m1665 esew1666 mod1667))) (cons first1668 (dobody1661 (cdr body1662)
r1663 w1664 m1665 esew1666 mod1667)))))))) (chi-sequence1113 (lambda (body1669
r1670 w1671 s1672 mod1673) (build-sequence1062 s1672 (let dobody1674 ((body1675
body1669) (r1676 r1670) (w1677 w1671) (mod1678 mod1673)) (if (null? body1675)
(quote ()) (let ((first1679 (chi1119 (car body1675) r1676 w1677 mod1678)))
(cons first1679 (dobody1674 (cdr body1675) r1676 w1677 mod1678))))))))
(source-wrap1112 (lambda (x1680 w1681 s1682 defmod1683) (wrap1111 (if s1682
(make-annotation x1680 s1682 #f) x1680) w1681 defmod1683))) (wrap1111 (lambda
(x1684 w1685 defmod1686) (cond ((and (null? (wrap-marks1086 w1685)) (null?
(wrap-subst1087 w1685))) x1684) ((syntax-object?1067 x1684)
(make-syntax-object1066 (syntax-object-expression1068 x1684) (join-wraps1102
w1685 (syntax-object-wrap1069 x1684)) (syntax-object-module1070 x1684)))
((null? x1684) x1684) (else (make-syntax-object1066 x1684 w1685 defmod1686)))))
(bound-id-member?1110 (lambda (x1687 list1688) (and (not (null? list1688)) (or
(bound-id=?1107 x1687 (car list1688)) (bound-id-member?1110 x1687 (cdr
list1688)))))) (distinct-bound-ids?1109 (lambda (ids1689) (let distinct?1690
((ids1691 ids1689)) (or (null? ids1691) (and (not (bound-id-member?1110 (car
ids1691) (cdr ids1691))) (distinct?1690 (cdr ids1691)))))))
(valid-bound-ids?1108 (lambda (ids1692) (and (let all-ids?1693 ((ids1694
ids1692)) (or (null? ids1694) (and (id?1083 (car ids1694)) (all-ids?1693 (cdr
ids1694))))) (distinct-bound-ids?1109 ids1692)))) (bound-id=?1107 (lambda
(i1695 j1696) (if (and (syntax-object?1067 i1695) (syntax-object?1067 j1696))
(and (eq? (let ((e1697 (syntax-object-expression1068 i1695))) (if (annotation?
e1697) (annotation-expression e1697) e1697)) (let ((e1698
(syntax-object-expression1068 j1696))) (if (annotation? e1698)
(annotation-expression e1698) e1698))) (same-marks?1104 (wrap-marks1086
(syntax-object-wrap1069 i1695)) (wrap-marks1086 (syntax-object-wrap1069
j1696)))) (eq? (let ((e1699 i1695)) (if (annotation? e1699)
(annotation-expression e1699) e1699)) (let ((e1700 j1696)) (if (annotation?
e1700) (annotation-expression e1700) e1700)))))) (free-id=?1106 (lambda (i1701
j1702) (and (eq? (let ((x1703 i1701)) (let ((e1704 (if (syntax-object?1067
x1703) (syntax-object-expression1068 x1703) x1703))) (if (annotation? e1704)
(annotation-expression e1704) e1704))) (let ((x1705 j1702)) (let ((e1706 (if
(syntax-object?1067 x1705) (syntax-object-expression1068 x1705) x1705))) (if
(annotation? e1706) (annotation-expression e1706) e1706)))) (eq?
(id-var-name1105 i1701 (quote (()))) (id-var-name1105 j1702 (quote (())))))))
(id-var-name1105 (lambda (id1707 w1708) (letrec ((search-vector-rib1711 (lambda
(sym1717 subst1718 marks1719 symnames1720 ribcage1721) (let ((n1722
(vector-length symnames1720))) (let f1723 ((i1724 0)) (cond ((fx=1052 i1724
n1722) (search1709 sym1717 (cdr subst1718) marks1719)) ((and (eq? (vector-ref
symnames1720 i1724) sym1717) (same-marks?1104 marks1719 (vector-ref
(ribcage-marks1093 ribcage1721) i1724))) (values (vector-ref
(ribcage-labels1094 ribcage1721) i1724) marks1719)) (else (f1723 (fx+1050 i1724
1)))))))) (search-list-rib1710 (lambda (sym1725 subst1726 marks1727
symnames1728 ribcage1729) (let f1730 ((symnames1731 symnames1728) (i1732 0))
(cond ((null? symnames1731) (search1709 sym1725 (cdr subst1726) marks1727))
((and (eq? (car symnames1731) sym1725) (same-marks?1104 marks1727 (list-ref
(ribcage-marks1093 ribcage1729) i1732))) (values (list-ref (ribcage-labels1094
ribcage1729) i1732) marks1727)) (else (f1730 (cdr symnames1731) (fx+1050 i1732
1))))))) (search1709 (lambda (sym1733 subst1734 marks1735) (if (null?
subst1734) (values #f marks1735) (let ((fst1736 (car subst1734))) (if (eq?
fst1736 (quote shift)) (search1709 sym1733 (cdr subst1734) (cdr marks1735))
(let ((symnames1737 (ribcage-symnames1092 fst1736))) (if (vector? symnames1737)
(search-vector-rib1711 sym1733 subst1734 marks1735 symnames1737 fst1736)
(search-list-rib1710 sym1733 subst1734 marks1735 symnames1737 fst1736)))))))))
(cond ((symbol? id1707) (or (call-with-values (lambda () (search1709 id1707
(wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda (x1739 . ignore1738)
x1739)) id1707)) ((syntax-object?1067 id1707) (let ((id1740 (let ((e1742
(syntax-object-expression1068 id1707))) (if (annotation? e1742)
(annotation-expression e1742) e1742))) (w11741 (syntax-object-wrap1069
id1707))) (let ((marks1743 (join-marks1103 (wrap-marks1086 w1708)
(wrap-marks1086 w11741)))) (call-with-values (lambda () (search1709 id1740
(wrap-subst1087 w1708) marks1743)) (lambda (new-id1744 marks1745) (or
new-id1744 (call-with-values (lambda () (search1709 id1740 (wrap-subst1087
w11741) marks1745)) (lambda (x1747 . ignore1746) x1747)) id1740))))))
((annotation? id1707) (let ((id1748 (let ((e1749 id1707)) (if (annotation?
e1749) (annotation-expression e1749) e1749)))) (or (call-with-values (lambda ()
(search1709 id1748 (wrap-subst1087 w1708) (wrap-marks1086 w1708))) (lambda
(x1751 . ignore1750) x1751)) id1748))) (else (error-hook1056 (quote
id-var-name) "invalid id" id1707)))))) (same-marks?1104 (lambda (x1752 y1753)
(or (eq? x1752 y1753) (and (not (null? x1752)) (not (null? y1753)) (eq? (car
x1752) (car y1753)) (same-marks?1104 (cdr x1752) (cdr y1753))))))
(join-marks1103 (lambda (m11754 m21755) (smart-append1101 m11754 m21755)))
(join-wraps1102 (lambda (w11756 w21757) (let ((m11758 (wrap-marks1086 w11756))
(s11759 (wrap-subst1087 w11756))) (if (null? m11758) (if (null? s11759) w21757
(make-wrap1085 (wrap-marks1086 w21757) (smart-append1101 s11759 (wrap-subst1087
w21757)))) (make-wrap1085 (smart-append1101 m11758 (wrap-marks1086 w21757))
(smart-append1101 s11759 (wrap-subst1087 w21757))))))) (smart-append1101
(lambda (m11760 m21761) (if (null? m21761) m11760 (append m11760 m21761))))
(make-binding-wrap1100 (lambda (ids1762 labels1763 w1764) (if (null? ids1762)
w1764 (make-wrap1085 (wrap-marks1086 w1764) (cons (let ((labelvec1765
(list->vector labels1763))) (let ((n1766 (vector-length labelvec1765))) (let
((symnamevec1767 (make-vector n1766)) (marksvec1768 (make-vector n1766)))
(begin (let f1769 ((ids1770 ids1762) (i1771 0)) (if (not (null? ids1770))
(call-with-values (lambda () (id-sym-name&marks1084 (car ids1770) w1764))
(lambda (symname1772 marks1773) (begin (vector-set! symnamevec1767 i1771
symname1772) (vector-set! marksvec1768 i1771 marks1773) (f1769 (cdr ids1770)
(fx+1050 i1771 1))))))) (make-ribcage1090 symnamevec1767 marksvec1768
labelvec1765))))) (wrap-subst1087 w1764)))))) (extend-ribcage!1099 (lambda
(ribcage1774 id1775 label1776) (begin (set-ribcage-symnames!1095 ribcage1774
(cons (let ((e1777 (syntax-object-expression1068 id1775))) (if (annotation?
e1777) (annotation-expression e1777) e1777)) (ribcage-symnames1092
ribcage1774))) (set-ribcage-marks!1096 ribcage1774 (cons (wrap-marks1086
(syntax-object-wrap1069 id1775)) (ribcage-marks1093 ribcage1774)))
(set-ribcage-labels!1097 ribcage1774 (cons label1776 (ribcage-labels1094
ribcage1774)))))) (anti-mark1098 (lambda (w1778) (make-wrap1085 (cons #f
(wrap-marks1086 w1778)) (cons (quote shift) (wrap-subst1087 w1778)))))
(set-ribcage-labels!1097 (lambda (x1779 update1780) (vector-set! x1779 3
update1780))) (set-ribcage-marks!1096 (lambda (x1781 update1782) (vector-set!
x1781 2 update1782))) (set-ribcage-symnames!1095 (lambda (x1783 update1784)
(vector-set! x1783 1 update1784))) (ribcage-labels1094 (lambda (x1785)
(vector-ref x1785 3))) (ribcage-marks1093 (lambda (x1786) (vector-ref x1786
2))) (ribcage-symnames1092 (lambda (x1787) (vector-ref x1787 1))) (ribcage?1091
(lambda (x1788) (and (vector? x1788) (= (vector-length x1788) 4) (eq?
(vector-ref x1788 0) (quote ribcage))))) (make-ribcage1090 (lambda
(symnames1789 marks1790 labels1791) (vector (quote ribcage) symnames1789
marks1790 labels1791))) (gen-labels1089 (lambda (ls1792) (if (null? ls1792)
(quote ()) (cons (gen-label1088) (gen-labels1089 (cdr ls1792))))))
(gen-label1088 (lambda () (string #\i))) (wrap-subst1087 cdr) (wrap-marks1086
car) (make-wrap1085 cons) (id-sym-name&marks1084 (lambda (x1793 w1794) (if
(syntax-object?1067 x1793) (values (let ((e1795 (syntax-object-expression1068
x1793))) (if (annotation? e1795) (annotation-expression e1795) e1795))
(join-marks1103 (wrap-marks1086 w1794) (wrap-marks1086 (syntax-object-wrap1069
x1793)))) (values (let ((e1796 x1793)) (if (annotation? e1796)
(annotation-expression e1796) e1796)) (wrap-marks1086 w1794))))) (id?1083
(lambda (x1797) (cond ((symbol? x1797) #t) ((syntax-object?1067 x1797) (symbol?
(let ((e1798 (syntax-object-expression1068 x1797))) (if (annotation? e1798)
(annotation-expression e1798) e1798)))) ((annotation? x1797) (symbol?
(annotation-expression x1797))) (else #f)))) (nonsymbol-id?1082 (lambda (x1799)
(and (syntax-object?1067 x1799) (symbol? (let ((e1800
(syntax-object-expression1068 x1799))) (if (annotation? e1800)
(annotation-expression e1800) e1800)))))) (global-extend1081 (lambda (type1801
sym1802 val1803) (put-global-definition-hook1057 sym1802 type1801 val1803)))
(lookup1080 (lambda (x1804 r1805 mod1806) (cond ((assq x1804 r1805) => cdr)
((symbol? x1804) (or (get-global-definition-hook1059 x1804 mod1806) (quote
(global)))) (else (quote (displaced-lexical)))))) (macros-only-env1079 (lambda
(r1807) (if (null? r1807) (quote ()) (let ((a1808 (car r1807))) (if (eq? (cadr
a1808) (quote macro)) (cons a1808 (macros-only-env1079 (cdr r1807)))
(macros-only-env1079 (cdr r1807))))))) (extend-var-env1078 (lambda (labels1809
vars1810 r1811) (if (null? labels1809) r1811 (extend-var-env1078 (cdr
labels1809) (cdr vars1810) (cons (cons (car labels1809) (cons (quote lexical)
(car vars1810))) r1811))))) (extend-env1077 (lambda (labels1812 bindings1813
r1814) (if (null? labels1812) r1814 (extend-env1077 (cdr labels1812) (cdr
bindings1813) (cons (cons (car labels1812) (car bindings1813)) r1814)))))
(binding-value1076 cdr) (binding-type1075 car) (source-annotation1074 (lambda
(x1815) (cond ((annotation? x1815) (annotation-source x1815))
((syntax-object?1067 x1815) (source-annotation1074
(syntax-object-expression1068 x1815))) (else #f))))
(set-syntax-object-module!1073 (lambda (x1816 update1817) (vector-set! x1816 3
update1817))) (set-syntax-object-wrap!1072 (lambda (x1818 update1819)
(vector-set! x1818 2 update1819))) (set-syntax-object-expression!1071 (lambda
(x1820 update1821) (vector-set! x1820 1 update1821))) (syntax-object-module1070
(lambda (x1822) (vector-ref x1822 3))) (syntax-object-wrap1069 (lambda (x1823)
(vector-ref x1823 2))) (syntax-object-expression1068 (lambda (x1824)
(vector-ref x1824 1))) (syntax-object?1067 (lambda (x1825) (and (vector? x1825)
(= (vector-length x1825) 4) (eq? (vector-ref x1825 0) (quote syntax-object)))))
(make-syntax-object1066 (lambda (expression1826 wrap1827 module1828) (vector
(quote syntax-object) expression1826 wrap1827 module1828))) (build-letrec1065
(lambda (src1829 vars1830 val-exps1831 body-exp1832) (if (null? vars1830)
(build-annotated1060 src1829 body-exp1832) (build-annotated1060 src1829 (list
(quote letrec) (map list vars1830 val-exps1831) body-exp1832)))))
(build-named-let1064 (lambda (src1833 vars1834 val-exps1835 body-exp1836) (if
(null? vars1834) (build-annotated1060 src1833 body-exp1836)
(build-annotated1060 src1833 (list (quote let) (car vars1834) (map list (cdr
vars1834) val-exps1835) body-exp1836))))) (build-let1063 (lambda (src1837
vars1838 val-exps1839 body-exp1840) (if (null? vars1838) (build-annotated1060
src1837 body-exp1840) (build-annotated1060 src1837 (list (quote let) (map list
vars1838 val-exps1839) body-exp1840))))) (build-sequence1062 (lambda (src1841
exps1842) (if (null? (cdr exps1842)) (build-annotated1060 src1841 (car
exps1842)) (build-annotated1060 src1841 (cons (quote begin) exps1842)))))
(build-data1061 (lambda (src1843 exp1844) (if (and (self-evaluating? exp1844)
(not (vector? exp1844))) (build-annotated1060 src1843 exp1844)
(build-annotated1060 src1843 (list (quote quote) exp1844)))))
(build-annotated1060 (lambda (src1845 exp1846) (if (and src1845 (not
(annotation? exp1846))) (make-annotation exp1846 src1845 #t) exp1846)))
(get-global-definition-hook1059 (lambda (symbol1847 module1848) (begin (if (and
(not module1848) (current-module)) (warn "module system is booted, we should
have a module" symbol1847)) (module-lookup-keyword (if module1848
(resolve-module (cdr module1848)) (current-module)) symbol1847))))
(remove-global-definition-hook1058 (lambda (symbol1849)
(module-undefine-keyword! (current-module) symbol1849)))
(put-global-definition-hook1057 (lambda (symbol1850 type1851 val1852)
(module-define-keyword! (current-module) symbol1850 type1851 val1852)))
(error-hook1056 (lambda (who1853 why1854 what1855) (error who1853 "~a ~s"
why1854 what1855))) (local-eval-hook1055 (lambda (x1856 mod1857)
(primitive-eval (list noexpand1049 x1856)))) (top-level-eval-hook1054 (lambda
(x1858 mod1859) (primitive-eval (list noexpand1049 x1858)))) (fx<1053 <)
(fx=1052 =) (fx-1051 -) (fx+1050 +) (noexpand1049 "noexpand")) (begin
(global-extend1081 (quote local-syntax) (quote letrec-syntax) #t)
(global-extend1081 (quote local-syntax) (quote let-syntax) #f)
(global-extend1081 (quote core) (quote fluid-let-syntax) (lambda (e1860 r1861
w1862 s1863 mod1864) ((lambda (tmp1865) ((lambda (tmp1866) (if (if tmp1866
(apply (lambda (_1867 var1868 val1869 e11870 e21871) (valid-bound-ids?1108
var1868)) tmp1866) #f) (apply (lambda (_1873 var1874 val1875 e11876 e21877)
(let ((names1878 (map (lambda (x1879) (id-var-name1105 x1879 w1862)) var1874)))
(begin (for-each (lambda (id1881 n1882) (let ((t1883 (binding-type1075
(lookup1080 n1882 r1861 mod1864)))) (if (memv t1883 (quote
(displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier
out of context" e1860 (source-wrap1112 id1881 w1862 s1863 mod1864))))) var1874
names1878) (chi-body1123 (cons e11876 e21877) (source-wrap1112 e1860 w1862
s1863 mod1864) (extend-env1077 names1878 (let ((trans-r1886
(macros-only-env1079 r1861))) (map (lambda (x1887) (cons (quote macro)
(eval-local-transformer1126 (chi1119 x1887 trans-r1886 w1862 mod1864)
mod1864))) val1875)) r1861) w1862 mod1864)))) tmp1866) ((lambda (_1889)
(syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap1112 e1860
w1862 s1863 mod1864))) tmp1865))) ($sc-dispatch tmp1865 (quote (any #(each (any
any)) any . each-any))))) e1860))) (global-extend1081 (quote core) (quote
quote) (lambda (e1890 r1891 w1892 s1893 mod1894) ((lambda (tmp1895) ((lambda
(tmp1896) (if tmp1896 (apply (lambda (_1897 e1898) (build-data1061 s1893
(strip1130 e1898 w1892))) tmp1896) ((lambda (_1899) (syntax-violation (quote
quote) "bad syntax" (source-wrap1112 e1890 w1892 s1893 mod1894))) tmp1895)))
($sc-dispatch tmp1895 (quote (any any))))) e1890))) (global-extend1081 (quote
core) (quote syntax) (letrec ((regen1907 (lambda (x1908) (let ((t1909 (car
x1908))) (if (memv t1909 (quote (ref))) (build-annotated1060 #f (cadr x1908))
(if (memv t1909 (quote (primitive))) (build-annotated1060 #f (cadr x1908)) (if
(memv t1909 (quote (quote))) (build-data1061 #f (cadr x1908)) (if (memv t1909
(quote (lambda))) (build-annotated1060 #f (list (quote lambda) (cadr x1908)
(regen1907 (caddr x1908)))) (if (memv t1909 (quote (map))) (let ((ls1910 (map
regen1907 (cdr x1908)))) (build-annotated1060 #f (cons (if (fx=1052 (length
ls1910) 2) (build-annotated1060 #f (quote map)) (build-annotated1060 #f (quote
map))) ls1910))) (build-annotated1060 #f (cons (build-annotated1060 #f (car
x1908)) (map regen1907 (cdr x1908)))))))))))) (gen-vector1906 (lambda (x1911)
(cond ((eq? (car x1911) (quote list)) (cons (quote vector) (cdr x1911))) ((eq?
(car x1911) (quote quote)) (list (quote quote) (list->vector (cadr x1911))))
(else (list (quote list->vector) x1911))))) (gen-append1905 (lambda (x1912
y1913) (if (equal? y1913 (quote (quote ()))) x1912 (list (quote append) x1912
y1913)))) (gen-cons1904 (lambda (x1914 y1915) (let ((t1916 (car y1915))) (if
(memv t1916 (quote (quote))) (if (eq? (car x1914) (quote quote)) (list (quote
quote) (cons (cadr x1914) (cadr y1915))) (if (eq? (cadr y1915) (quote ()))
(list (quote list) x1914) (list (quote cons) x1914 y1915))) (if (memv t1916
(quote (list))) (cons (quote list) (cons x1914 (cdr y1915))) (list (quote cons)
x1914 y1915)))))) (gen-map1903 (lambda (e1917 map-env1918) (let ((formals1919
(map cdr map-env1918)) (actuals1920 (map (lambda (x1921) (list (quote ref) (car
x1921))) map-env1918))) (cond ((eq? (car e1917) (quote ref)) (car actuals1920))
((andmap (lambda (x1922) (and (eq? (car x1922) (quote ref)) (memq (cadr x1922)
formals1919))) (cdr e1917)) (cons (quote map) (cons (list (quote primitive)
(car e1917)) (map (let ((r1923 (map cons formals1919 actuals1920))) (lambda
(x1924) (cdr (assq (cadr x1924) r1923)))) (cdr e1917))))) (else (cons (quote
map) (cons (list (quote lambda) formals1919 e1917) actuals1920)))))))
(gen-mappend1902 (lambda (e1925 map-env1926) (list (quote apply) (quote
(primitive append)) (gen-map1903 e1925 map-env1926)))) (gen-ref1901 (lambda
(src1927 var1928 level1929 maps1930) (if (fx=1052 level1929 0) (values var1928
maps1930) (if (null? maps1930) (syntax-violation (quote syntax) "missing
ellipsis" src1927) (call-with-values (lambda () (gen-ref1901 src1927 var1928
(fx-1051 level1929 1) (cdr maps1930))) (lambda (outer-var1931 outer-maps1932)
(let ((b1933 (assq outer-var1931 (car maps1930)))) (if b1933 (values (cdr
b1933) maps1930) (let ((inner-var1934 (gen-var1131 (quote tmp)))) (values
inner-var1934 (cons (cons (cons outer-var1931 inner-var1934) (car maps1930))
outer-maps1932))))))))))) (gen-syntax1900 (lambda (src1935 e1936 r1937 maps1938
ellipsis?1939 mod1940) (if (id?1083 e1936) (let ((label1941 (id-var-name1105
e1936 (quote (()))))) (let ((b1942 (lookup1080 label1941 r1937 mod1940))) (if
(eq? (binding-type1075 b1942) (quote syntax)) (call-with-values (lambda () (let
((var.lev1943 (binding-value1076 b1942))) (gen-ref1901 src1935 (car
var.lev1943) (cdr var.lev1943) maps1938))) (lambda (var1944 maps1945) (values
(list (quote ref) var1944) maps1945))) (if (ellipsis?1939 e1936)
(syntax-violation (quote syntax) "misplaced ellipsis" src1935) (values (list
(quote quote) e1936) maps1938))))) ((lambda (tmp1946) ((lambda (tmp1947) (if
(if tmp1947 (apply (lambda (dots1948 e1949) (ellipsis?1939 dots1948)) tmp1947)
#f) (apply (lambda (dots1950 e1951) (gen-syntax1900 src1935 e1951 r1937
maps1938 (lambda (x1952) #f) mod1940)) tmp1947) ((lambda (tmp1953) (if (if
tmp1953 (apply (lambda (x1954 dots1955 y1956) (ellipsis?1939 dots1955))
tmp1953) #f) (apply (lambda (x1957 dots1958 y1959) (let f1960 ((y1961 y1959)
(k1962 (lambda (maps1963) (call-with-values (lambda () (gen-syntax1900 src1935
x1957 r1937 (cons (quote ()) maps1963) ellipsis?1939 mod1940)) (lambda (x1964
maps1965) (if (null? (car maps1965)) (syntax-violation (quote syntax) "extra
ellipsis" src1935) (values (gen-map1903 x1964 (car maps1965)) (cdr
maps1965)))))))) ((lambda (tmp1966) ((lambda (tmp1967) (if (if tmp1967 (apply
(lambda (dots1968 y1969) (ellipsis?1939 dots1968)) tmp1967) #f) (apply (lambda
(dots1970 y1971) (f1960 y1971 (lambda (maps1972) (call-with-values (lambda ()
(k1962 (cons (quote ()) maps1972))) (lambda (x1973 maps1974) (if (null? (car
maps1974)) (syntax-violation (quote syntax) "extra ellipsis" src1935) (values
(gen-mappend1902 x1973 (car maps1974)) (cdr maps1974)))))))) tmp1967) ((lambda
(_1975) (call-with-values (lambda () (gen-syntax1900 src1935 y1961 r1937
maps1938 ellipsis?1939 mod1940)) (lambda (y1976 maps1977) (call-with-values
(lambda () (k1962 maps1977)) (lambda (x1978 maps1979) (values (gen-append1905
x1978 y1976) maps1979)))))) tmp1966))) ($sc-dispatch tmp1966 (quote (any .
any))))) y1961))) tmp1953) ((lambda (tmp1980) (if tmp1980 (apply (lambda (x1981
y1982) (call-with-values (lambda () (gen-syntax1900 src1935 x1981 r1937
maps1938 ellipsis?1939 mod1940)) (lambda (x1983 maps1984) (call-with-values
(lambda () (gen-syntax1900 src1935 y1982 r1937 maps1984 ellipsis?1939 mod1940))
(lambda (y1985 maps1986) (values (gen-cons1904 x1983 y1985) maps1986))))))
tmp1980) ((lambda (tmp1987) (if tmp1987 (apply (lambda (e11988 e21989)
(call-with-values (lambda () (gen-syntax1900 src1935 (cons e11988 e21989) r1937
maps1938 ellipsis?1939 mod1940)) (lambda (e1991 maps1992) (values
(gen-vector1906 e1991) maps1992)))) tmp1987) ((lambda (_1993) (values (list
(quote quote) e1936) maps1938)) tmp1946))) ($sc-dispatch tmp1946 (quote
#(vector (any . each-any))))))) ($sc-dispatch tmp1946 (quote (any . any))))))
($sc-dispatch tmp1946 (quote (any any . any)))))) ($sc-dispatch tmp1946 (quote
(any any))))) e1936))))) (lambda (e1994 r1995 w1996 s1997 mod1998) (let ((e1999
(source-wrap1112 e1994 w1996 s1997 mod1998))) ((lambda (tmp2000) ((lambda
(tmp2001) (if tmp2001 (apply (lambda (_2002 x2003) (call-with-values (lambda ()
(gen-syntax1900 e1999 x2003 r1995 (quote ()) ellipsis?1128 mod1998)) (lambda
(e2004 maps2005) (regen1907 e2004)))) tmp2001) ((lambda (_2006)
(syntax-violation (quote syntax) "bad `syntax' form" e1999)) tmp2000)))
($sc-dispatch tmp2000 (quote (any any))))) e1999))))) (global-extend1081 (quote
core) (quote lambda) (lambda (e2007 r2008 w2009 s2010 mod2011) ((lambda
(tmp2012) ((lambda (tmp2013) (if tmp2013 (apply (lambda (_2014 c2015)
(chi-lambda-clause1124 (source-wrap1112 e2007 w2009 s2010 mod2011) #f c2015
r2008 w2009 mod2011 (lambda (vars2016 docstring2017 body2018)
(build-annotated1060 s2010 (cons (quote lambda) (cons vars2016 (append (if
docstring2017 (list docstring2017) (quote ())) (list body2018)))))))) tmp2013)
(syntax-violation #f "source expression failed to match any pattern" tmp2012)))
($sc-dispatch tmp2012 (quote (any . any))))) e2007))) (global-extend1081 (quote
core) (quote let) (letrec ((chi-let2019 (lambda (e2020 r2021 w2022 s2023
mod2024 constructor2025 ids2026 vals2027 exps2028) (if (not
(valid-bound-ids?1108 ids2026)) (syntax-violation (quote let) "duplicate bound
variable" e2020) (let ((labels2029 (gen-labels1089 ids2026)) (new-vars2030 (map
gen-var1131 ids2026))) (let ((nw2031 (make-binding-wrap1100 ids2026 labels2029
w2022)) (nr2032 (extend-var-env1078 labels2029 new-vars2030 r2021)))
(constructor2025 s2023 new-vars2030 (map (lambda (x2033) (chi1119 x2033 r2021
w2022 mod2024)) vals2027) (chi-body1123 exps2028 (source-wrap1112 e2020 nw2031
s2023 mod2024) nr2032 nw2031 mod2024)))))))) (lambda (e2034 r2035 w2036 s2037
mod2038) ((lambda (tmp2039) ((lambda (tmp2040) (if tmp2040 (apply (lambda
(_2041 id2042 val2043 e12044 e22045) (chi-let2019 e2034 r2035 w2036 s2037
mod2038 build-let1063 id2042 val2043 (cons e12044 e22045))) tmp2040) ((lambda
(tmp2049) (if (if tmp2049 (apply (lambda (_2050 f2051 id2052 val2053 e12054
e22055) (id?1083 f2051)) tmp2049) #f) (apply (lambda (_2056 f2057 id2058
val2059 e12060 e22061) (chi-let2019 e2034 r2035 w2036 s2037 mod2038
build-named-let1064 (cons f2057 id2058) val2059 (cons e12060 e22061))) tmp2049)
((lambda (_2065) (syntax-violation (quote let) "bad let" (source-wrap1112 e2034
w2036 s2037 mod2038))) tmp2039))) ($sc-dispatch tmp2039 (quote (any any #(each
(any any)) any . each-any)))))) ($sc-dispatch tmp2039 (quote (any #(each (any
any)) any . each-any))))) e2034)))) (global-extend1081 (quote core) (quote
letrec) (lambda (e2066 r2067 w2068 s2069 mod2070) ((lambda (tmp2071) ((lambda
(tmp2072) (if tmp2072 (apply (lambda (_2073 id2074 val2075 e12076 e22077) (let
((ids2078 id2074)) (if (not (valid-bound-ids?1108 ids2078)) (syntax-violation
(quote letrec) "duplicate bound variable" e2066) (let ((labels2080
(gen-labels1089 ids2078)) (new-vars2081 (map gen-var1131 ids2078))) (let
((w2082 (make-binding-wrap1100 ids2078 labels2080 w2068)) (r2083
(extend-var-env1078 labels2080 new-vars2081 r2067))) (build-letrec1065 s2069
new-vars2081 (map (lambda (x2084) (chi1119 x2084 r2083 w2082 mod2070)) val2075)
(chi-body1123 (cons e12076 e22077) (source-wrap1112 e2066 w2082 s2069 mod2070)
r2083 w2082 mod2070))))))) tmp2072) ((lambda (_2087) (syntax-violation (quote
letrec) "bad letrec" (source-wrap1112 e2066 w2068 s2069 mod2070))) tmp2071)))
($sc-dispatch tmp2071 (quote (any #(each (any any)) any . each-any)))))
e2066))) (global-extend1081 (quote core) (quote set!) (lambda (e2088 r2089
w2090 s2091 mod2092) ((lambda (tmp2093) ((lambda (tmp2094) (if (if tmp2094
(apply (lambda (_2095 id2096 val2097) (id?1083 id2096)) tmp2094) #f) (apply
(lambda (_2098 id2099 val2100) (let ((val2101 (chi1119 val2100 r2089 w2090
mod2092)) (n2102 (id-var-name1105 id2099 w2090))) (let ((b2103 (lookup1080
n2102 r2089 mod2092))) (let ((t2104 (binding-type1075 b2103))) (if (memv t2104
(quote (lexical))) (build-annotated1060 s2091 (list (quote set!)
(binding-value1076 b2103) val2101)) (if (memv t2104 (quote (global)))
(build-annotated1060 s2091 (list (quote set!) (if mod2092 (make-module-ref (cdr
mod2092) n2102 (car mod2092)) (make-module-ref mod2092 n2102 (quote bare)))
val2101)) (if (memv t2104 (quote (displaced-lexical))) (syntax-violation (quote
set!) "identifier out of context" (wrap1111 id2099 w2090 mod2092))
(syntax-violation (quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091
mod2092))))))))) tmp2094) ((lambda (tmp2105) (if tmp2105 (apply (lambda (_2106
head2107 tail2108 val2109) (call-with-values (lambda () (syntax-type1117
head2107 r2089 (quote (())) #f #f mod2092)) (lambda (type2110 value2111 ee2112
ww2113 ss2114 modmod2115) (let ((t2116 type2110)) (if (memv t2116 (quote
(module-ref))) (let ((val2117 (chi1119 val2109 r2089 w2090 mod2092)))
(call-with-values (lambda () (value2111 (cons head2107 tail2108))) (lambda
(id2119 mod2120) (build-annotated1060 s2091 (list (quote set!) (if mod2120
(make-module-ref (cdr mod2120) id2119 (car mod2120)) (make-module-ref mod2120
id2119 (quote bare))) val2117))))) (build-annotated1060 s2091 (cons (chi1119
(list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t)
#(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type
value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip
strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source unannotate
set-syntax-object-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 build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook remove-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(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")) #(ribcage
(define-structure) ((top)) ("i"))) (hygiene guile))) head2107) r2089 w2090
mod2092) (map (lambda (e2121) (chi1119 e2121 r2089 w2090 mod2092)) (append
tail2108 (list val2109)))))))))) tmp2105) ((lambda (_2123) (syntax-violation
(quote set!) "bad set!" (source-wrap1112 e2088 w2090 s2091 mod2092)))
tmp2093))) ($sc-dispatch tmp2093 (quote (any (any . each-any) any))))))
($sc-dispatch tmp2093 (quote (any any any))))) e2088))) (global-extend1081
(quote module-ref) (quote @) (lambda (e2124) ((lambda (tmp2125) ((lambda
(tmp2126) (if (if tmp2126 (apply (lambda (_2127 mod2128 id2129) (and (andmap
id?1083 mod2128) (id?1083 id2129))) tmp2126) #f) (apply (lambda (_2131 mod2132
id2133) (values (syntax->datum id2133) (syntax->datum (cons (quote
#(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-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 build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook remove-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(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")) #(ribcage
(define-structure) ((top)) ("i"))) (hygiene guile))) mod2132)))) tmp2126)
(syntax-violation #f "source expression failed to match any pattern" tmp2125)))
($sc-dispatch tmp2125 (quote (any each-any any))))) e2124))) (global-extend1081
(quote module-ref) (quote @@) (lambda (e2135) ((lambda (tmp2136) ((lambda
(tmp2137) (if (if tmp2137 (apply (lambda (_2138 mod2139 id2140) (and (andmap
id?1083 mod2139) (id?1083 id2140))) tmp2137) #f) (apply (lambda (_2142 mod2143
id2144) (values (syntax->datum id2144) (syntax->datum (cons (quote
#(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-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 build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook remove-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(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")) #(ribcage
(define-structure) ((top)) ("i"))) (hygiene guile))) mod2143)))) tmp2137)
(syntax-violation #f "source expression failed to match any pattern" tmp2136)))
($sc-dispatch tmp2136 (quote (any each-any any))))) e2135))) (global-extend1081
(quote begin) (quote begin) (quote ())) (global-extend1081 (quote define)
(quote define) (quote ())) (global-extend1081 (quote define-syntax) (quote
define-syntax) (quote ())) (global-extend1081 (quote eval-when) (quote
eval-when) (quote ())) (global-extend1081 (quote core) (quote syntax-case)
(letrec ((gen-syntax-case2149 (lambda (x2150 keys2151 clauses2152 r2153
mod2154) (if (null? clauses2152) (build-annotated1060 #f (list
(build-annotated1060 #f (quote syntax-violation)) #f "source expression failed
to match any pattern" x2150)) ((lambda (tmp2155) ((lambda (tmp2156) (if tmp2156
(apply (lambda (pat2157 exp2158) (if (and (id?1083 pat2157) (andmap (lambda
(x2159) (not (free-id=?1106 pat2157 x2159))) (cons (quote #(syntax-object ...
((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call
convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-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 build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook remove-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(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")) #(ribcage
(define-structure) ((top)) ("i"))) (hygiene guile))) keys2151))) (let
((labels2160 (list (gen-label1088))) (var2161 (gen-var1131 pat2157)))
(build-annotated1060 #f (list (build-annotated1060 #f (list (quote lambda)
(list var2161) (chi1119 exp2158 (extend-env1077 labels2160 (list (cons (quote
syntax) (cons var2161 0))) r2153) (make-binding-wrap1100 (list pat2157)
labels2160 (quote (()))) mod2154))) x2150))) (gen-clause2148 x2150 keys2151
(cdr clauses2152) r2153 pat2157 #t exp2158 mod2154))) tmp2156) ((lambda
(tmp2162) (if tmp2162 (apply (lambda (pat2163 fender2164 exp2165)
(gen-clause2148 x2150 keys2151 (cdr clauses2152) r2153 pat2163 fender2164
exp2165 mod2154)) tmp2162) ((lambda (_2166) (syntax-violation (quote
syntax-case) "invalid clause" (car clauses2152))) tmp2155))) ($sc-dispatch
tmp2155 (quote (any any any)))))) ($sc-dispatch tmp2155 (quote (any any)))))
(car clauses2152))))) (gen-clause2148 (lambda (x2167 keys2168 clauses2169 r2170
pat2171 fender2172 exp2173 mod2174) (call-with-values (lambda ()
(convert-pattern2146 pat2171 keys2168)) (lambda (p2175 pvars2176) (cond ((not
(distinct-bound-ids?1109 (map car pvars2176))) (syntax-violation (quote
syntax-case) "duplicate pattern variable" pat2171)) ((not (andmap (lambda
(x2177) (not (ellipsis?1128 (car x2177)))) pvars2176)) (syntax-violation (quote
syntax-case) "misplaced ellipsis" pat2171)) (else (let ((y2178 (gen-var1131
(quote tmp)))) (build-annotated1060 #f (list (build-annotated1060 #f (list
(quote lambda) (list y2178) (let ((y2179 (build-annotated1060 #f y2178)))
(build-annotated1060 #f (list (quote if) ((lambda (tmp2180) ((lambda (tmp2181)
(if tmp2181 (apply (lambda () y2179) tmp2181) ((lambda (_2182)
(build-annotated1060 #f (list (quote if) y2179 (build-dispatch-call2147
pvars2176 fender2172 y2179 r2170 mod2174) (build-data1061 #f #f)))) tmp2180)))
($sc-dispatch tmp2180 (quote #(atom #t))))) fender2172)
(build-dispatch-call2147 pvars2176 exp2173 y2179 r2170 mod2174)
(gen-syntax-case2149 x2167 keys2168 clauses2169 r2170 mod2174)))))) (if (eq?
p2175 (quote any)) (build-annotated1060 #f (list (build-annotated1060 #f (quote
list)) x2167)) (build-annotated1060 #f (list (build-annotated1060 #f (quote
$sc-dispatch)) x2167 (build-data1061 #f p2175)))))))))))))
(build-dispatch-call2147 (lambda (pvars2183 exp2184 y2185 r2186 mod2187) (let
((ids2188 (map car pvars2183)) (levels2189 (map cdr pvars2183))) (let
((labels2190 (gen-labels1089 ids2188)) (new-vars2191 (map gen-var1131
ids2188))) (build-annotated1060 #f (list (build-annotated1060 #f (quote apply))
(build-annotated1060 #f (list (quote lambda) new-vars2191 (chi1119 exp2184
(extend-env1077 labels2190 (map (lambda (var2192 level2193) (cons (quote
syntax) (cons var2192 level2193))) new-vars2191 (map cdr pvars2183)) r2186)
(make-binding-wrap1100 ids2188 labels2190 (quote (()))) mod2187))) y2185))))))
(convert-pattern2146 (lambda (pattern2194 keys2195) (let cvt2196 ((p2197
pattern2194) (n2198 0) (ids2199 (quote ()))) (if (id?1083 p2197) (if
(bound-id-member?1110 p2197 keys2195) (values (vector (quote free-id) p2197)
ids2199) (values (quote any) (cons (cons p2197 n2198) ids2199))) ((lambda
(tmp2200) ((lambda (tmp2201) (if (if tmp2201 (apply (lambda (x2202 dots2203)
(ellipsis?1128 dots2203)) tmp2201) #f) (apply (lambda (x2204 dots2205)
(call-with-values (lambda () (cvt2196 x2204 (fx+1050 n2198 1) ids2199)) (lambda
(p2206 ids2207) (values (if (eq? p2206 (quote any)) (quote each-any) (vector
(quote each) p2206)) ids2207)))) tmp2201) ((lambda (tmp2208) (if tmp2208 (apply
(lambda (x2209 y2210) (call-with-values (lambda () (cvt2196 y2210 n2198
ids2199)) (lambda (y2211 ids2212) (call-with-values (lambda () (cvt2196 x2209
n2198 ids2212)) (lambda (x2213 ids2214) (values (cons x2213 y2211)
ids2214)))))) tmp2208) ((lambda (tmp2215) (if tmp2215 (apply (lambda () (values
(quote ()) ids2199)) tmp2215) ((lambda (tmp2216) (if tmp2216 (apply (lambda
(x2217) (call-with-values (lambda () (cvt2196 x2217 n2198 ids2199)) (lambda
(p2219 ids2220) (values (vector (quote vector) p2219) ids2220)))) tmp2216)
((lambda (x2221) (values (vector (quote atom) (strip1130 p2197 (quote (()))))
ids2199)) tmp2200))) ($sc-dispatch tmp2200 (quote #(vector each-any))))))
($sc-dispatch tmp2200 (quote ()))))) ($sc-dispatch tmp2200 (quote (any .
any)))))) ($sc-dispatch tmp2200 (quote (any any))))) p2197)))))) (lambda (e2222
r2223 w2224 s2225 mod2226) (let ((e2227 (source-wrap1112 e2222 w2224 s2225
mod2226))) ((lambda (tmp2228) ((lambda (tmp2229) (if tmp2229 (apply (lambda
(_2230 val2231 key2232 m2233) (if (andmap (lambda (x2234) (and (id?1083 x2234)
(not (ellipsis?1128 x2234)))) key2232) (let ((x2236 (gen-var1131 (quote tmp))))
(build-annotated1060 s2225 (list (build-annotated1060 #f (list (quote lambda)
(list x2236) (gen-syntax-case2149 (build-annotated1060 #f x2236) key2232 m2233
r2223 mod2226))) (chi1119 val2231 r2223 (quote (())) mod2226))))
(syntax-violation (quote syntax-case) "invalid literals list" e2227))) tmp2229)
(syntax-violation #f "source expression failed to match any pattern" tmp2228)))
($sc-dispatch tmp2228 (quote (any any each-any . each-any))))) e2227))))) (set!
sc-expand (let ((m2239 (quote e)) (esew2240 (quote (eval)))) (lambda (x2241)
(if (and (pair? x2241) (equal? (car x2241) noexpand1049)) (cadr x2241)
(chi-top1118 x2241 (quote ()) (quote ((top))) m2239 esew2240 (cons (quote
hygiene) (module-name (current-module)))))))) (set! sc-expand3 (let ((m2242
(quote e)) (esew2243 (quote (eval)))) (lambda (x2245 . rest2244) (if (and
(pair? x2245) (equal? (car x2245) noexpand1049)) (cadr x2245) (chi-top1118
x2245 (quote ()) (quote ((top))) (if (null? rest2244) m2242 (car rest2244)) (if
(or (null? rest2244) (null? (cdr rest2244))) esew2243 (cadr rest2244)) (cons
(quote hygiene) (module-name (current-module)))))))) (set! identifier? (lambda
(x2246) (nonsymbol-id?1082 x2246))) (set! datum->syntax (lambda (id2247
datum2248) (make-syntax-object1066 datum2248 (syntax-object-wrap1069 id2247)
#f))) (set! syntax->datum (lambda (x2249) (strip1130 x2249 (quote (())))))
(set! generate-temporaries (lambda (ls2250) (begin (let ((x2251 ls2250)) (if
(not (list? x2251)) (error-hook1056 (quote generate-temporaries) "invalid
argument" x2251))) (map (lambda (x2252) (wrap1111 (gensym) (quote ((top))) #f))
ls2250)))) (set! free-identifier=? (lambda (x2253 y2254) (begin (let ((x2255
x2253)) (if (not (nonsymbol-id?1082 x2255)) (error-hook1056 (quote
free-identifier=?) "invalid argument" x2255))) (let ((x2256 y2254)) (if (not
(nonsymbol-id?1082 x2256)) (error-hook1056 (quote free-identifier=?) "invalid
argument" x2256))) (free-id=?1106 x2253 y2254)))) (set! bound-identifier=?
(lambda (x2257 y2258) (begin (let ((x2259 x2257)) (if (not (nonsymbol-id?1082
x2259)) (error-hook1056 (quote bound-identifier=?) "invalid argument" x2259)))
(let ((x2260 y2258)) (if (not (nonsymbol-id?1082 x2260)) (error-hook1056 (quote
bound-identifier=?) "invalid argument" x2260))) (bound-id=?1107 x2257 y2258))))
(set! syntax-violation (lambda (who2264 message2263 form2262 . subform2261)
(begin (let ((x2265 who2264)) (if (not ((lambda (x2266) (or (not x2266)
(string? x2266) (symbol? x2266))) x2265)) (error-hook1056 (quote
syntax-violation) "invalid argument" x2265))) (let ((x2267 message2263)) (if
(not (string? x2267)) (error-hook1056 (quote syntax-violation) "invalid
argument" x2267))) (scm-error (quote syntax-error) (quote sc-expand)
(string-append (if who2264 "~a: " "") "~a " (if (null? subform2261) "in ~a" "in
subform `~s' of `~s'")) (let ((tail2268 (cons message2263 (map (lambda (x2269)
(strip1130 x2269 (quote (())))) (append subform2261 (list form2262)))))) (if
who2264 (cons who2264 tail2268) tail2268)) #f)))) (set!
install-global-transformer (lambda (sym2270 v2271) (begin (let ((x2272
sym2270)) (if (not (symbol? x2272)) (error-hook1056 (quote define-syntax)
"invalid argument" x2272))) (let ((x2273 v2271)) (if (not (procedure? x2273))
(error-hook1056 (quote define-syntax) "invalid argument" x2273)))
(global-extend1081 (quote macro) sym2270 v2271)))) (letrec ((match2278 (lambda
(e2279 p2280 w2281 r2282 mod2283) (cond ((not r2282) #f) ((eq? p2280 (quote
any)) (cons (wrap1111 e2279 w2281 mod2283) r2282)) ((syntax-object?1067 e2279)
(match*2277 (let ((e2284 (syntax-object-expression1068 e2279))) (if
(annotation? e2284) (annotation-expression e2284) e2284)) p2280 (join-wraps1102
w2281 (syntax-object-wrap1069 e2279)) r2282 (syntax-object-module1070 e2279)))
(else (match*2277 (let ((e2285 e2279)) (if (annotation? e2285)
(annotation-expression e2285) e2285)) p2280 w2281 r2282 mod2283)))))
(match*2277 (lambda (e2286 p2287 w2288 r2289 mod2290) (cond ((null? p2287) (and
(null? e2286) r2289)) ((pair? p2287) (and (pair? e2286) (match2278 (car e2286)
(car p2287) w2288 (match2278 (cdr e2286) (cdr p2287) w2288 r2289 mod2290)
mod2290))) ((eq? p2287 (quote each-any)) (let ((l2291 (match-each-any2275 e2286
w2288 mod2290))) (and l2291 (cons l2291 r2289)))) (else (let ((t2292
(vector-ref p2287 0))) (if (memv t2292 (quote (each))) (if (null? e2286)
(match-empty2276 (vector-ref p2287 1) r2289) (let ((l2293 (match-each2274 e2286
(vector-ref p2287 1) w2288 mod2290))) (and l2293 (let collect2294 ((l2295
l2293)) (if (null? (car l2295)) r2289 (cons (map car l2295) (collect2294 (map
cdr l2295)))))))) (if (memv t2292 (quote (free-id))) (and (id?1083 e2286)
(free-id=?1106 (wrap1111 e2286 w2288 mod2290) (vector-ref p2287 1)) r2289) (if
(memv t2292 (quote (atom))) (and (equal? (vector-ref p2287 1) (strip1130 e2286
w2288)) r2289) (if (memv t2292 (quote (vector))) (and (vector? e2286)
(match2278 (vector->list e2286) (vector-ref p2287 1) w2288 r2289
mod2290))))))))))) (match-empty2276 (lambda (p2296 r2297) (cond ((null? p2296)
r2297) ((eq? p2296 (quote any)) (cons (quote ()) r2297)) ((pair? p2296)
(match-empty2276 (car p2296) (match-empty2276 (cdr p2296) r2297))) ((eq? p2296
(quote each-any)) (cons (quote ()) r2297)) (else (let ((t2298 (vector-ref p2296
0))) (if (memv t2298 (quote (each))) (match-empty2276 (vector-ref p2296 1)
r2297) (if (memv t2298 (quote (free-id atom))) r2297 (if (memv t2298 (quote
(vector))) (match-empty2276 (vector-ref p2296 1) r2297)))))))))
(match-each-any2275 (lambda (e2299 w2300 mod2301) (cond ((annotation? e2299)
(match-each-any2275 (annotation-expression e2299) w2300 mod2301)) ((pair?
e2299) (let ((l2302 (match-each-any2275 (cdr e2299) w2300 mod2301))) (and l2302
(cons (wrap1111 (car e2299) w2300 mod2301) l2302)))) ((null? e2299) (quote ()))
((syntax-object?1067 e2299) (match-each-any2275 (syntax-object-expression1068
e2299) (join-wraps1102 w2300 (syntax-object-wrap1069 e2299)) mod2301)) (else
#f)))) (match-each2274 (lambda (e2303 p2304 w2305 mod2306) (cond ((annotation?
e2303) (match-each2274 (annotation-expression e2303) p2304 w2305 mod2306))
((pair? e2303) (let ((first2307 (match2278 (car e2303) p2304 w2305 (quote ())
mod2306))) (and first2307 (let ((rest2308 (match-each2274 (cdr e2303) p2304
w2305 mod2306))) (and rest2308 (cons first2307 rest2308)))))) ((null? e2303)
(quote ())) ((syntax-object?1067 e2303) (match-each2274
(syntax-object-expression1068 e2303) p2304 (join-wraps1102 w2305
(syntax-object-wrap1069 e2303)) (syntax-object-module1070 e2303))) (else
#f))))) (set! $sc-dispatch (lambda (e2309 p2310) (cond ((eq? p2310 (quote any))
(list e2309)) ((syntax-object?1067 e2309) (match*2277 (let ((e2311
(syntax-object-expression1068 e2309))) (if (annotation? e2311)
(annotation-expression e2311) e2311)) p2310 (syntax-object-wrap1069 e2309)
(quote ()) (syntax-object-module1070 e2309))) (else (match*2277 (let ((e2312
e2309)) (if (annotation? e2312) (annotation-expression e2312) e2312)) p2310
(quote (())) (quote ()) #f))))))))
-(install-global-transformer (quote with-syntax) (lambda (x2313) ((lambda
(tmp2314) ((lambda (tmp2315) (if tmp2315 (apply (lambda (_2316 e12317 e22318)
(cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (cons e12317 e22318))) tmp2315) ((lambda (tmp2320) (if
tmp2320 (apply (lambda (_2321 out2322 in2323 e12324 e22325) (list (quote
#(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) in2323 (quote ()) (list out2322 (cons
(quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) (cons e12324 e22325))))) tmp2320) ((lambda
(tmp2327) (if tmp2327 (apply (lambda (_2328 out2329 in2330 e12331 e22332) (list
(quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top)
(top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list
((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) in2330) (quote ()) (list out2329 (cons (quote #(syntax-object begin
((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) (cons e12331 e22332))))) tmp2327) (syntax-violation #f "source
expression failed to match any pattern" tmp2314))) ($sc-dispatch tmp2314 (quote
(any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any
((any any)) any . each-any)))))) ($sc-dispatch tmp2314 (quote (any () any .
each-any))))) x2313)))
-(install-global-transformer (quote syntax-rules) (lambda (x2336) ((lambda
(tmp2337) ((lambda (tmp2338) (if tmp2338 (apply (lambda (_2339 k2340
keyword2341 pattern2342 template2343) (list (quote #(syntax-object lambda
((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k
keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))
(cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern
template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage ()
() ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote
#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top)
(top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) (cons k2340 (map (lambda (tmp2346
tmp2345) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k
keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
tmp2345) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword
pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
tmp2346))) template2343 pattern2342)))))) tmp2338) (syntax-violation #f "source
expression failed to match any pattern" tmp2337))) ($sc-dispatch tmp2337 (quote
(any each-any . #(each ((any . any) any))))))) x2336)))
-(install-global-transformer (quote let*) (lambda (x2347) ((lambda (tmp2348)
((lambda (tmp2349) (if (if tmp2349 (apply (lambda (let*2350 x2351 v2352 e12353
e22354) (andmap identifier? x2351)) tmp2349) #f) (apply (lambda (let*2356 x2357
v2358 e12359 e22360) (let f2361 ((bindings2362 (map list x2357 v2358))) (if
(null? bindings2362) (cons (quote #(syntax-object let ((top) #(ribcage () ()
()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1
e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () ()
()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons
e12359 e22360))) ((lambda (tmp2366) ((lambda (tmp2367) (if tmp2367 (apply
(lambda (body2368 binding2369) (list (quote #(syntax-object let ((top)
#(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2)
#((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding2369)
body2368)) tmp2367) (syntax-violation #f "source expression failed to match any
pattern" tmp2366))) ($sc-dispatch tmp2366 (quote (any any))))) (list (f2361
(cdr bindings2362)) (car bindings2362)))))) tmp2349) (syntax-violation #f
"source expression failed to match any pattern" tmp2348))) ($sc-dispatch
tmp2348 (quote (any #(each (any any)) any . each-any))))) x2347)))
-(install-global-transformer (quote do) (lambda (orig-x2370) ((lambda (tmp2371)
((lambda (tmp2372) (if tmp2372 (apply (lambda (_2373 var2374 init2375 step2376
e02377 e12378 c2379) ((lambda (tmp2380) ((lambda (tmp2381) (if tmp2381 (apply
(lambda (step2382) ((lambda (tmp2383) ((lambda (tmp2384) (if tmp2384 (apply
(lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top))
#("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop
((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c)
#((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile)))
(map list var2374 init2375) (list (quote #(syntax-object if ((top) #(ribcage
#(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top)
(top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () ()
()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote
#(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var
init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i"
"i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(hygiene guile))) e02377) (cons (quote #(syntax-object begin ((top) #(ribcage
#(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top)
(top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () ()
()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c2379 (list
(cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i"))
#(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x)
#((top)) #("i"))) (hygiene guile))) step2382))))))) tmp2384) ((lambda (tmp2389)
(if tmp2389 (apply (lambda (e12390 e22391) (list (quote #(syntax-object let
((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top))
#("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop
((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top))
#("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var2374 init2375) (list
(quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i"))
#(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top)
(top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e02377 (cons
(quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i"
"i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c)
#((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile)))
(cons e12390 e22391)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1
e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_
var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(hygiene guile))) (append c2379 (list (cons (quote #(syntax-object doloop
((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top))
#("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(orig-x) #((top)) #("i"))) (hygiene guile))) step2382))))))) tmp2389)
(syntax-violation #f "source expression failed to match any pattern" tmp2383)))
($sc-dispatch tmp2383 (quote (any . each-any)))))) ($sc-dispatch tmp2383 (quote
())))) e12378)) tmp2381) (syntax-violation #f "source expression failed to
match any pattern" tmp2380))) ($sc-dispatch tmp2380 (quote each-any)))) (map
(lambda (v2398 s2399) ((lambda (tmp2400) ((lambda (tmp2401) (if tmp2401 (apply
(lambda () v2398) tmp2401) ((lambda (tmp2402) (if tmp2402 (apply (lambda
(e2403) e2403) tmp2402) ((lambda (_2404) (syntax-violation (quote do) "bad step
expression" orig-x2370 s2399)) tmp2400))) ($sc-dispatch tmp2400 (quote
(any)))))) ($sc-dispatch tmp2400 (quote ())))) s2399)) var2374 step2376)))
tmp2372) (syntax-violation #f "source expression failed to match any pattern"
tmp2371))) ($sc-dispatch tmp2371 (quote (any #(each (any any . any)) (any .
each-any) . each-any))))) orig-x2370)))
-(install-global-transformer (quote quasiquote) (letrec ((quasicons2407 (lambda
(x2411 y2412) ((lambda (tmp2413) ((lambda (tmp2414) (if tmp2414 (apply (lambda
(x2415 y2416) ((lambda (tmp2417) ((lambda (tmp2418) (if tmp2418 (apply (lambda
(dy2419) ((lambda (tmp2420) ((lambda (tmp2421) (if tmp2421 (apply (lambda
(dx2422) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top))
#("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top))
#("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top)
(top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx2422 dy2419)))
tmp2421) ((lambda (_2423) (if (null? dy2419) (list (quote #(syntax-object list
((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i"))
#(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () ()
()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) x2415) (list (quote #(syntax-object cons ((top) #(ribcage
#(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y)
#((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi)
#((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415
y2416))) tmp2420))) ($sc-dispatch tmp2420 (quote (#(free-id #(syntax-object
quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top)
(top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x2415))
tmp2418) ((lambda (tmp2424) (if tmp2424 (apply (lambda (stuff2425) (cons (quote
#(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x
y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage
#(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons
x2415 stuff2425))) tmp2424) ((lambda (else2426) (list (quote #(syntax-object
cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top)
(top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2415 y2416))
tmp2417))) ($sc-dispatch tmp2417 (quote (#(free-id #(syntax-object list ((top)
#(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () ()
()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) . any)))))) ($sc-dispatch tmp2417 (quote (#(free-id
#(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i"
"i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top)
(top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y2416)) tmp2414)
(syntax-violation #f "source expression failed to match any pattern" tmp2413)))
($sc-dispatch tmp2413 (quote (any any))))) (list x2411 y2412))))
(quasiappend2408 (lambda (x2427 y2428) ((lambda (tmp2429) ((lambda (tmp2430)
(if tmp2430 (apply (lambda (x2431 y2432) ((lambda (tmp2433) ((lambda (tmp2434)
(if tmp2434 (apply (lambda () x2431) tmp2434) ((lambda (_2435) (list (quote
#(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage
#(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x2431
y2432)) tmp2433))) ($sc-dispatch tmp2433 (quote (#(free-id #(syntax-object
quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage
#(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i"
"i" "i"))) (hygiene guile))) ()))))) y2432)) tmp2430) (syntax-violation #f
"source expression failed to match any pattern" tmp2429))) ($sc-dispatch
tmp2429 (quote (any any))))) (list x2427 y2428)))) (quasivector2409 (lambda
(x2436) ((lambda (tmp2437) ((lambda (x2438) ((lambda (tmp2439) ((lambda
(tmp2440) (if tmp2440 (apply (lambda (x2441) (list (quote #(syntax-object quote
((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i"))
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile))) (list->vector x2441))) tmp2440) ((lambda
(tmp2443) (if tmp2443 (apply (lambda (x2444) (cons (quote #(syntax-object
vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i"))
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile))) x2444)) tmp2443) ((lambda (_2446) (list
(quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i"))
#(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))
x2438)) tmp2439))) ($sc-dispatch tmp2439 (quote (#(free-id #(syntax-object list
((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) .
each-any)))))) ($sc-dispatch tmp2439 (quote (#(free-id #(syntax-object quote
((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))
each-any))))) x2438)) tmp2437)) x2436))) (quasi2410 (lambda (p2447 lev2448)
((lambda (tmp2449) ((lambda (tmp2450) (if tmp2450 (apply (lambda (p2451) (if (=
lev2448 0) p2451 (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage
#(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top))
#("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top)
(top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote
((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev)
#((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi)
#((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410
(list p2451) (- lev2448 1))))) tmp2450) ((lambda (tmp2452) (if tmp2452 (apply
(lambda (p2453 q2454) (if (= lev2448 0) (quasiappend2408 p2453 (quasi2410 q2454
lev2448)) (quasicons2407 (quasicons2407 (quote (#(syntax-object quote ((top)
#(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p
lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))
#(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410 (list p2453) (- lev2448 1)))
(quasi2410 q2454 lev2448)))) tmp2452) ((lambda (tmp2455) (if tmp2455 (apply
(lambda (p2456) (quasicons2407 (quote (#(syntax-object quote ((top) #(ribcage
#(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top))
#("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top)
(top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote
((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev)
#((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi)
#((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi2410
(list p2456) (+ lev2448 1)))) tmp2455) ((lambda (tmp2457) (if tmp2457 (apply
(lambda (p2458 q2459) (quasicons2407 (quasi2410 p2458 lev2448) (quasi2410 q2459
lev2448))) tmp2457) ((lambda (tmp2460) (if tmp2460 (apply (lambda (x2461)
(quasivector2409 (quasi2410 x2461 lev2448))) tmp2460) ((lambda (p2463) (list
(quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage
() () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) p2463)) tmp2449))) ($sc-dispatch tmp2449 (quote #(vector
each-any)))))) ($sc-dispatch tmp2449 (quote (any . any)))))) ($sc-dispatch
tmp2449 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ())
#(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend
quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene
guile))) any)))))) ($sc-dispatch tmp2449 (quote ((#(free-id #(syntax-object
unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top))
#("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top)
(top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any))))))
($sc-dispatch tmp2449 (quote (#(free-id #(syntax-object unquote ((top)
#(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage
#(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i"
"i" "i"))) (hygiene guile))) any))))) p2447)))) (lambda (x2464) ((lambda
(tmp2465) ((lambda (tmp2466) (if tmp2466 (apply (lambda (_2467 e2468)
(quasi2410 e2468 0)) tmp2466) (syntax-violation #f "source expression failed to
match any pattern" tmp2465))) ($sc-dispatch tmp2465 (quote (any any)))))
x2464))))
-(install-global-transformer (quote include) (lambda (x2469) (letrec
((read-file2470 (lambda (fn2471 k2472) (let ((p2473 (open-input-file fn2471)))
(let f2474 ((x2475 (read p2473))) (if (eof-object? x2475) (begin
(close-input-port p2473) (quote ())) (cons (datum->syntax k2472 x2475) (f2474
(read p2473))))))))) ((lambda (tmp2476) ((lambda (tmp2477) (if tmp2477 (apply
(lambda (k2478 filename2479) (let ((fn2480 (syntax->datum filename2479)))
((lambda (tmp2481) ((lambda (tmp2482) (if tmp2482 (apply (lambda (exp2483)
(cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i"))
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i"))
#(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file)
((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp2483))
tmp2482) (syntax-violation #f "source expression failed to match any pattern"
tmp2481))) ($sc-dispatch tmp2481 (quote each-any)))) (read-file2470 fn2480
k2478)))) tmp2477) (syntax-violation #f "source expression failed to match any
pattern" tmp2476))) ($sc-dispatch tmp2476 (quote (any any))))) x2469))))
-(install-global-transformer (quote unquote) (lambda (x2485) ((lambda (tmp2486)
((lambda (tmp2487) (if tmp2487 (apply (lambda (_2488 e2489) (error (quote
unquote) "expression ,~s not valid outside of quasiquote" (syntax->datum
e2489))) tmp2487) (syntax-violation #f "source expression failed to match any
pattern" tmp2486))) ($sc-dispatch tmp2486 (quote (any any))))) x2485)))
-(install-global-transformer (quote unquote-splicing) (lambda (x2490) ((lambda
(tmp2491) ((lambda (tmp2492) (if tmp2492 (apply (lambda (_2493 e2494) (error
(quote unquote-splicing) "expression ,@~s not valid outside of quasiquote"
(syntax->datum e2494))) tmp2492) (syntax-violation #f "source expression failed
to match any pattern" tmp2491))) ($sc-dispatch tmp2491 (quote (any any)))))
x2490)))
-(install-global-transformer (quote case) (lambda (x2495) ((lambda (tmp2496)
((lambda (tmp2497) (if tmp2497 (apply (lambda (_2498 e2499 m12500 m22501)
((lambda (tmp2502) ((lambda (body2503) (list (quote #(syntax-object let ((top)
#(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body)
#((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i"
"i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) e2499)) body2503)) tmp2502)) (let f2504 ((clause2505 m12500)
(clauses2506 m22501)) (if (null? clauses2506) ((lambda (tmp2508) ((lambda
(tmp2509) (if tmp2509 (apply (lambda (e12510 e22511) (cons (quote
#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons
e12510 e22511))) tmp2509) ((lambda (tmp2513) (if tmp2513 (apply (lambda (k2514
e12515 e22516) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause
clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top)
(top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top)
#(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ())
#(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
#(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t
((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage ()
() ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote
#(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) k2514)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause
clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top)
(top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) (cons e12515 e22516)))) tmp2513) ((lambda
(_2519) (syntax-violation (quote case) "bad clause" x2495 clause2505))
tmp2508))) ($sc-dispatch tmp2508 (quote (each-any any . each-any))))))
($sc-dispatch tmp2508 (quote (#(free-id #(syntax-object else ((top) #(ribcage
() () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any .
each-any))))) clause2505) ((lambda (tmp2520) ((lambda (rest2521) ((lambda
(tmp2522) ((lambda (tmp2523) (if tmp2523 (apply (lambda (k2524 e12525 e22526)
(list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
#(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object
memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
#(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top)
(top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote
#(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f
clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2)
#((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) k2524)) (cons (quote #(syntax-object
begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause
clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top)
(top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) (cons e12525 e22526)) rest2521)) tmp2523)
((lambda (_2529) (syntax-violation (quote case) "bad clause" x2495 clause2505))
tmp2522))) ($sc-dispatch tmp2522 (quote (each-any any . each-any)))))
clause2505)) tmp2520)) (f2504 (car clauses2506) (cdr clauses2506)))))))
tmp2497) (syntax-violation #f "source expression failed to match any pattern"
tmp2496))) ($sc-dispatch tmp2496 (quote (any any any . each-any))))) x2495)))
-(install-global-transformer (quote identifier-syntax) (lambda (x2530) ((lambda
(tmp2531) ((lambda (tmp2532) (if tmp2532 (apply (lambda (_2533 e2534) (list
(quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
(quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list
(quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
(quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote
()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list
(quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
e2534)) (list (cons _2533 (quote (#(syntax-object x ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (cons e2534 (quote (#(syntax-object x ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile)))))))))) tmp2532) (syntax-violation #f "source expression failed to
match any pattern" tmp2531))) ($sc-dispatch tmp2531 (quote (any any)))))
x2530)))
+(if #f #f)
+(letrec ((and-map*151 (lambda (f191 first190 . rest189) (let ((t192 (null?
first190))) (if t192 t192 (if (null? rest189) (letrec ((andmap193 (lambda
(first194) (let ((x195 (car first194)) (first196 (cdr first194))) (if (null?
first196) (f191 x195) (if (f191 x195) (andmap193 first196) #f)))))) (andmap193
first190)) (letrec ((andmap197 (lambda (first198 rest199) (let ((x200 (car
first198)) (xr201 (map car rest199)) (first202 (cdr first198)) (rest203 (map
cdr rest199))) (if (null? first202) (apply f191 (cons x200 xr201)) (if (apply
f191 (cons x200 xr201)) (andmap197 first202 rest203) #f)))))) (andmap197
first190 rest189)))))))) (letrec ((lambda-var-list296 (lambda (vars420) (letrec
((lvl421 (lambda (vars422 ls423 w424) (if (pair? vars422) (lvl421 (cdr vars422)
(cons (wrap276 (car vars422) w424 #f) ls423) w424) (if (id?248 vars422) (cons
(wrap276 vars422 w424 #f) ls423) (if (null? vars422) ls423 (if
(syntax-object?232 vars422) (lvl421 (syntax-object-expression233 vars422) ls423
(join-wraps267 w424 (syntax-object-wrap234 vars422))) (cons vars422
ls423)))))))) (lvl421 vars420 (quote ()) (quote (())))))) (gen-var295 (lambda
(id425) (let ((id426 (if (syntax-object?232 id425) (syntax-object-expression233
id425) id425))) (gensym (symbol->string id426))))) (strip294 (lambda (x427
w428) (if (memq (quote top) (wrap-marks251 w428)) x427 (letrec ((f429 (lambda
(x430) (if (syntax-object?232 x430) (strip294 (syntax-object-expression233
x430) (syntax-object-wrap234 x430)) (if (pair? x430) (let ((a431 (f429 (car
x430))) (d432 (f429 (cdr x430)))) (if (if (eq? a431 (car x430)) (eq? d432 (cdr
x430)) #f) x430 (cons a431 d432))) (if (vector? x430) (let ((old433
(vector->list x430))) (let ((new434 (map f429 old433))) (if (and-map*151 eq?
old433 new434) x430 (list->vector new434)))) x430)))))) (f429 x427)))))
(ellipsis?293 (lambda (x435) (if (nonsymbol-id?247 x435) (free-id=?271 x435
(quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip
ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause
chi-body chi-macro chi-application chi-expr chi chi-top syntax-type
chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source 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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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)))) #f))) (chi-void292 (lambda ()
(build-void214 #f))) (eval-local-transformer291 (lambda (expanded436 mod437)
(let ((p438 (local-eval-hook211 expanded436 mod437))) (if (procedure? p438)
p438 (syntax-violation #f "nonprocedure transformer" p438)))))
(chi-local-syntax290 (lambda (rec?439 e440 r441 w442 s443 mod444 k445) ((lambda
(tmp446) ((lambda (tmp447) (if tmp447 (apply (lambda (_448 id449 val450 e1451
e2452) (let ((ids453 id449)) (if (not (valid-bound-ids?273 ids453))
(syntax-violation #f "duplicate bound keyword" e440) (let ((labels455
(gen-labels254 ids453))) (let ((new-w456 (make-binding-wrap265 ids453 labels455
w442))) (k445 (cons e1451 e2452) (extend-env242 labels455 (let ((w458 (if
rec?439 new-w456 w442)) (trans-r459 (macros-only-env244 r441))) (map (lambda
(x460) (cons (quote macro) (eval-local-transformer291 (chi284 x460 trans-r459
w458 mod444) mod444))) val450)) r441) new-w456 s443 mod444)))))) tmp447)
((lambda (_462) (syntax-violation #f "bad local syntax definition"
(source-wrap277 e440 w442 s443 mod444))) tmp446))) ($sc-dispatch tmp446 (quote
(any #(each (any any)) any . each-any))))) e440))) (chi-lambda-clause289
(lambda (e463 docstring464 c465 r466 w467 mod468 k469) ((lambda (tmp470)
((lambda (tmp471) (if (if tmp471 (apply (lambda (args472 doc473 e1474 e2475)
(if (string? (syntax->datum doc473)) (not docstring464) #f)) tmp471) #f) (apply
(lambda (args476 doc477 e1478 e2479) (chi-lambda-clause289 e463 doc477 (cons
args476 (cons e1478 e2479)) r466 w467 mod468 k469)) tmp471) ((lambda (tmp481)
(if tmp481 (apply (lambda (id482 e1483 e2484) (let ((ids485 id482)) (if (not
(valid-bound-ids?273 ids485)) (syntax-violation (quote lambda) "invalid
parameter list" e463) (let ((labels487 (gen-labels254 ids485)) (new-vars488
(map gen-var295 ids485))) (k469 (map syntax->datum ids485) new-vars488 (if
docstring464 (syntax->datum docstring464) #f) (chi-body288 (cons e1483 e2484)
e463 (extend-var-env243 labels487 new-vars488 r466) (make-binding-wrap265
ids485 labels487 w467) mod468)))))) tmp481) ((lambda (tmp490) (if tmp490 (apply
(lambda (ids491 e1492 e2493) (let ((old-ids494 (lambda-var-list296 ids491)))
(if (not (valid-bound-ids?273 old-ids494)) (syntax-violation (quote lambda)
"invalid parameter list" e463) (let ((labels495 (gen-labels254 old-ids494))
(new-vars496 (map gen-var295 old-ids494))) (k469 (letrec ((f497 (lambda (ls1498
ls2499) (if (null? ls1498) (syntax->datum ls2499) (f497 (cdr ls1498) (cons
(syntax->datum (car ls1498)) ls2499)))))) (f497 (cdr old-ids494) (car
old-ids494))) (letrec ((f500 (lambda (ls1501 ls2502) (if (null? ls1501) ls2502
(f500 (cdr ls1501) (cons (car ls1501) ls2502)))))) (f500 (cdr new-vars496) (car
new-vars496))) (if docstring464 (syntax->datum docstring464) #f) (chi-body288
(cons e1492 e2493) e463 (extend-var-env243 labels495 new-vars496 r466)
(make-binding-wrap265 old-ids494 labels495 w467) mod468)))))) tmp490) ((lambda
(_504) (syntax-violation (quote lambda) "bad lambda" e463)) tmp470)))
($sc-dispatch tmp470 (quote (any any . each-any)))))) ($sc-dispatch tmp470
(quote (each-any any . each-any)))))) ($sc-dispatch tmp470 (quote (any any any
. each-any))))) c465))) (chi-body288 (lambda (body505 outer-form506 r507 w508
mod509) (let ((r510 (cons (quote ("placeholder" placeholder)) r507))) (let
((ribcage511 (make-ribcage255 (quote ()) (quote ()) (quote ())))) (let ((w512
(make-wrap250 (wrap-marks251 w508) (cons ribcage511 (wrap-subst252 w508)))))
(letrec ((parse513 (lambda (body514 ids515 labels516 var-ids517 vars518 vals519
bindings520) (if (null? body514) (syntax-violation #f "no expressions in body"
outer-form506) (let ((e522 (cdar body514)) (er523 (caar body514)))
(call-with-values (lambda () (syntax-type282 e522 er523 (quote (()))
(source-annotation239 er523) ribcage511 mod509)) (lambda (type524 value525 e526
w527 s528 mod529) (if (memv type524 (quote (define-form))) (let ((id530
(wrap276 value525 w527 mod529)) (label531 (gen-label253))) (let ((var532
(gen-var295 id530))) (begin (extend-ribcage!264 ribcage511 id530 label531)
(parse513 (cdr body514) (cons id530 ids515) (cons label531 labels516) (cons
id530 var-ids517) (cons var532 vars518) (cons (cons er523 (wrap276 e526 w527
mod529)) vals519) (cons (cons (quote lexical) var532) bindings520))))) (if
(memv type524 (quote (define-syntax-form))) (let ((id533 (wrap276 value525 w527
mod529)) (label534 (gen-label253))) (begin (extend-ribcage!264 ribcage511 id533
label534) (parse513 (cdr body514) (cons id533 ids515) (cons label534 labels516)
var-ids517 vars518 vals519 (cons (cons (quote macro) (cons er523 (wrap276 e526
w527 mod529))) bindings520)))) (if (memv type524 (quote (begin-form))) ((lambda
(tmp535) ((lambda (tmp536) (if tmp536 (apply (lambda (_537 e1538) (parse513
(letrec ((f539 (lambda (forms540) (if (null? forms540) (cdr body514) (cons
(cons er523 (wrap276 (car forms540) w527 mod529)) (f539 (cdr forms540)))))))
(f539 e1538)) ids515 labels516 var-ids517 vars518 vals519 bindings520)) tmp536)
(syntax-violation #f "source expression failed to match any pattern" tmp535)))
($sc-dispatch tmp535 (quote (any . each-any))))) e526) (if (memv type524 (quote
(local-syntax-form))) (chi-local-syntax290 value525 e526 er523 w527 s528 mod529
(lambda (forms542 er543 w544 s545 mod546) (parse513 (letrec ((f547 (lambda
(forms548) (if (null? forms548) (cdr body514) (cons (cons er543 (wrap276 (car
forms548) w544 mod546)) (f547 (cdr forms548))))))) (f547 forms542)) ids515
labels516 var-ids517 vars518 vals519 bindings520))) (if (null? ids515)
(build-sequence227 #f (map (lambda (x549) (chi284 (cdr x549) (car x549) (quote
(())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528 mod529)) (cdr
body514)))) (begin (if (not (valid-bound-ids?273 ids515)) (syntax-violation #f
"invalid or duplicate identifier in definition" outer-form506)) (letrec
((loop550 (lambda (bs551 er-cache552 r-cache553) (if (not (null? bs551)) (let
((b554 (car bs551))) (if (eq? (car b554) (quote macro)) (let ((er555 (cadr
b554))) (let ((r-cache556 (if (eq? er555 er-cache552) r-cache553
(macros-only-env244 er555)))) (begin (set-cdr! b554 (eval-local-transformer291
(chi284 (cddr b554) r-cache556 (quote (())) mod529) mod529)) (loop550 (cdr
bs551) er555 r-cache556)))) (loop550 (cdr bs551) er-cache552 r-cache553)))))))
(loop550 bindings520 #f #f)) (set-cdr! r510 (extend-env242 labels516
bindings520 (cdr r510))) (build-letrec230 #f (map syntax->datum var-ids517)
vars518 (map (lambda (x557) (chi284 (cdr x557) (car x557) (quote (())) mod529))
vals519) (build-sequence227 #f (map (lambda (x558) (chi284 (cdr x558) (car
x558) (quote (())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528
mod529)) (cdr body514)))))))))))))))))) (parse513 (map (lambda (x521) (cons
r510 (wrap276 x521 w512 mod509))) body505) (quote ()) (quote ()) (quote ())
(quote ()) (quote ()) (quote ())))))))) (chi-macro287 (lambda (p559 e560 r561
w562 rib563 mod564) (letrec ((rebuild-macro-output565 (lambda (x566 m567) (if
(pair? x566) (cons (rebuild-macro-output565 (car x566) m567)
(rebuild-macro-output565 (cdr x566) m567)) (if (syntax-object?232 x566) (let
((w568 (syntax-object-wrap234 x566))) (let ((ms569 (wrap-marks251 w568)) (s570
(wrap-subst252 w568))) (if (if (pair? ms569) (eq? (car ms569) #f) #f)
(make-syntax-object231 (syntax-object-expression233 x566) (make-wrap250 (cdr
ms569) (if rib563 (cons rib563 (cdr s570)) (cdr s570)))
(syntax-object-module235 x566)) (make-syntax-object231
(syntax-object-expression233 x566) (make-wrap250 (cons m567 ms569) (if rib563
(cons rib563 (cons (quote shift) s570)) (cons (quote shift) s570))) (let
((pmod571 (procedure-module p559))) (if pmod571 (cons (quote hygiene)
(module-name pmod571)) (quote (hygiene guile)))))))) (if (vector? x566) (let
((n572 (vector-length x566))) (let ((v573 (make-vector n572))) (letrec
((loop574 (lambda (i575) (if (fx=208 i575 n572) (begin (if #f #f) v573) (begin
(vector-set! v573 i575 (rebuild-macro-output565 (vector-ref x566 i575) m567))
(loop574 (fx+206 i575 1))))))) (loop574 0)))) (if (symbol? x566)
(syntax-violation #f "encountered raw symbol in macro output" (source-wrap277
e560 w562 s mod564) x566) x566))))))) (rebuild-macro-output565 (p559 (wrap276
e560 (anti-mark263 w562) mod564)) (string #\m))))) (chi-application286 (lambda
(x576 e577 r578 w579 s580 mod581) ((lambda (tmp582) ((lambda (tmp583) (if
tmp583 (apply (lambda (e0584 e1585) (build-application215 s580 x576 (map
(lambda (e586) (chi284 e586 r578 w579 mod581)) e1585))) tmp583)
(syntax-violation #f "source expression failed to match any pattern" tmp582)))
($sc-dispatch tmp582 (quote (any . each-any))))) e577))) (chi-expr285 (lambda
(type588 value589 e590 r591 w592 s593 mod594) (if (memv type588 (quote
(lexical))) (build-lexical-reference217 (quote value) s593 e590 value589) (if
(memv type588 (quote (core external-macro))) (value589 e590 r591 w592 s593
mod594) (if (memv type588 (quote (module-ref))) (call-with-values (lambda ()
(value589 e590)) (lambda (id595 mod596) (build-global-reference220 s593 id595
mod596))) (if (memv type588 (quote (lexical-call))) (chi-application286
(build-lexical-reference217 (quote fun) (source-annotation239 (car e590)) (car
e590) value589) e590 r591 w592 s593 mod594) (if (memv type588 (quote
(global-call))) (chi-application286 (build-global-reference220
(source-annotation239 (car e590)) value589 (if (syntax-object?232 (car e590))
(syntax-object-module235 (car e590)) mod594)) e590 r591 w592 s593 mod594) (if
(memv type588 (quote (constant))) (build-data226 s593 (strip294 (source-wrap277
e590 w592 s593 mod594) (quote (())))) (if (memv type588 (quote (global)))
(build-global-reference220 s593 value589 mod594) (if (memv type588 (quote
(call))) (chi-application286 (chi284 (car e590) r591 w592 mod594) e590 r591
w592 s593 mod594) (if (memv type588 (quote (begin-form))) ((lambda (tmp597)
((lambda (tmp598) (if tmp598 (apply (lambda (_599 e1600 e2601) (chi-sequence278
(cons e1600 e2601) r591 w592 s593 mod594)) tmp598) (syntax-violation #f "source
expression failed to match any pattern" tmp597))) ($sc-dispatch tmp597 (quote
(any any . each-any))))) e590) (if (memv type588 (quote (local-syntax-form)))
(chi-local-syntax290 value589 e590 r591 w592 s593 mod594 chi-sequence278) (if
(memv type588 (quote (eval-when-form))) ((lambda (tmp603) ((lambda (tmp604) (if
tmp604 (apply (lambda (_605 x606 e1607 e2608) (let ((when-list609
(chi-when-list281 e590 x606 w592))) (if (memq (quote eval) when-list609)
(chi-sequence278 (cons e1607 e2608) r591 w592 s593 mod594) (chi-void292))))
tmp604) (syntax-violation #f "source expression failed to match any pattern"
tmp603))) ($sc-dispatch tmp603 (quote (any each-any any . each-any))))) e590)
(if (memv type588 (quote (define-form define-syntax-form))) (syntax-violation
#f "definition in expression context" e590 (wrap276 value589 w592 mod594)) (if
(memv type588 (quote (syntax))) (syntax-violation #f "reference to pattern
variable outside syntax form" (source-wrap277 e590 w592 s593 mod594)) (if (memv
type588 (quote (displaced-lexical))) (syntax-violation #f "reference to
identifier outside its scope" (source-wrap277 e590 w592 s593 mod594))
(syntax-violation #f "unexpected syntax" (source-wrap277 e590 w592 s593
mod594)))))))))))))))))) (chi284 (lambda (e612 r613 w614 mod615)
(call-with-values (lambda () (syntax-type282 e612 r613 w614
(source-annotation239 e612) #f mod615)) (lambda (type616 value617 e618 w619
s620 mod621) (chi-expr285 type616 value617 e618 r613 w619 s620 mod621)))))
(chi-top283 (lambda (e622 r623 w624 m625 esew626 mod627) (call-with-values
(lambda () (syntax-type282 e622 r623 w624 (source-annotation239 e622) #f
mod627)) (lambda (type635 value636 e637 w638 s639 mod640) (if (memv type635
(quote (begin-form))) ((lambda (tmp641) ((lambda (tmp642) (if tmp642 (apply
(lambda (_643) (chi-void292)) tmp642) ((lambda (tmp644) (if tmp644 (apply
(lambda (_645 e1646 e2647) (chi-top-sequence279 (cons e1646 e2647) r623 w638
s639 m625 esew626 mod640)) tmp644) (syntax-violation #f "source expression
failed to match any pattern" tmp641))) ($sc-dispatch tmp641 (quote (any any .
each-any)))))) ($sc-dispatch tmp641 (quote (any))))) e637) (if (memv type635
(quote (local-syntax-form))) (chi-local-syntax290 value636 e637 r623 w638 s639
mod640 (lambda (body649 r650 w651 s652 mod653) (chi-top-sequence279 body649
r650 w651 s652 m625 esew626 mod653))) (if (memv type635 (quote
(eval-when-form))) ((lambda (tmp654) ((lambda (tmp655) (if tmp655 (apply
(lambda (_656 x657 e1658 e2659) (let ((when-list660 (chi-when-list281 e637 x657
w638)) (body661 (cons e1658 e2659))) (if (eq? m625 (quote e)) (if (memq (quote
eval) when-list660) (chi-top-sequence279 body661 r623 w638 s639 (quote e)
(quote (eval)) mod640) (chi-void292)) (if (memq (quote load) when-list660) (if
(let ((t664 (memq (quote compile) when-list660))) (if t664 t664 (if (eq? m625
(quote c&e)) (memq (quote eval) when-list660) #f))) (chi-top-sequence279
body661 r623 w638 s639 (quote c&e) (quote (compile load)) mod640) (if (memq
m625 (quote (c c&e))) (chi-top-sequence279 body661 r623 w638 s639 (quote c)
(quote (load)) mod640) (chi-void292))) (if (let ((t665 (memq (quote compile)
when-list660))) (if t665 t665 (if (eq? m625 (quote c&e)) (memq (quote eval)
when-list660) #f))) (begin (top-level-eval-hook210 (chi-top-sequence279 body661
r623 w638 s639 (quote e) (quote (eval)) mod640) mod640) (chi-void292))
(chi-void292)))))) tmp655) (syntax-violation #f "source expression failed to
match any pattern" tmp654))) ($sc-dispatch tmp654 (quote (any each-any any .
each-any))))) e637) (if (memv type635 (quote (define-syntax-form))) (let ((n666
(id-var-name270 value636 w638)) (r667 (macros-only-env244 r623))) (if (memv
m625 (quote (c))) (if (memq (quote compile) esew626) (let ((e668
(chi-install-global280 n666 (chi284 e637 r667 w638 mod640)))) (begin
(top-level-eval-hook210 e668 mod640) (if (memq (quote load) esew626) e668
(chi-void292)))) (if (memq (quote load) esew626) (chi-install-global280 n666
(chi284 e637 r667 w638 mod640)) (chi-void292))) (if (memv m625 (quote (c&e)))
(let ((e669 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640))))
(begin (top-level-eval-hook210 e669 mod640) e669)) (begin (if (memq (quote
eval) esew626) (top-level-eval-hook210 (chi-install-global280 n666 (chi284 e637
r667 w638 mod640)) mod640)) (chi-void292))))) (if (memv type635 (quote
(define-form))) (let ((n670 (id-var-name270 value636 w638))) (let ((type671
(binding-type240 (lookup245 n670 r623 mod640)))) (if (memv type671 (quote
(global core macro module-ref))) (let ((x672 (build-global-definition223 s639
n670 (chi284 e637 r623 w638 mod640)))) (begin (if (eq? m625 (quote c&e))
(top-level-eval-hook210 x672 mod640)) x672)) (if (memv type671 (quote
(displaced-lexical))) (syntax-violation #f "identifier out of context" e637
(wrap276 value636 w638 mod640)) (syntax-violation #f "cannot define keyword at
top level" e637 (wrap276 value636 w638 mod640)))))) (let ((x673 (chi-expr285
type635 value636 e637 r623 w638 s639 mod640))) (begin (if (eq? m625 (quote
c&e)) (top-level-eval-hook210 x673 mod640)) x673))))))))))) (syntax-type282
(lambda (e674 r675 w676 s677 rib678 mod679) (if (symbol? e674) (let ((n680
(id-var-name270 e674 w676))) (let ((b681 (lookup245 n680 r675 mod679))) (let
((type682 (binding-type240 b681))) (if (memv type682 (quote (lexical))) (values
type682 (binding-value241 b681) e674 w676 s677 mod679) (if (memv type682 (quote
(global))) (values type682 n680 e674 w676 s677 mod679) (if (memv type682 (quote
(macro))) (syntax-type282 (chi-macro287 (binding-value241 b681) e674 r675 w676
rib678 mod679) r675 (quote (())) s677 rib678 mod679) (values type682
(binding-value241 b681) e674 w676 s677 mod679))))))) (if (pair? e674) (let
((first683 (car e674))) (if (id?248 first683) (let ((n684 (id-var-name270
first683 w676))) (let ((b685 (lookup245 n684 r675 (let ((t686 (if
(syntax-object?232 first683) (syntax-object-module235 first683) #f))) (if t686
t686 mod679))))) (let ((type687 (binding-type240 b685))) (if (memv type687
(quote (lexical))) (values (quote lexical-call) (binding-value241 b685) e674
w676 s677 mod679) (if (memv type687 (quote (global))) (values (quote
global-call) n684 e674 w676 s677 mod679) (if (memv type687 (quote (macro)))
(syntax-type282 (chi-macro287 (binding-value241 b685) e674 r675 w676 rib678
mod679) r675 (quote (())) s677 rib678 mod679) (if (memv type687 (quote (core
external-macro module-ref))) (values type687 (binding-value241 b685) e674 w676
s677 mod679) (if (memv type687 (quote (local-syntax))) (values (quote
local-syntax-form) (binding-value241 b685) e674 w676 s677 mod679) (if (memv
type687 (quote (begin))) (values (quote begin-form) #f e674 w676 s677 mod679)
(if (memv type687 (quote (eval-when))) (values (quote eval-when-form) #f e674
w676 s677 mod679) (if (memv type687 (quote (define))) ((lambda (tmp688)
((lambda (tmp689) (if (if tmp689 (apply (lambda (_690 name691 val692) (id?248
name691)) tmp689) #f) (apply (lambda (_693 name694 val695) (values (quote
define-form) name694 val695 w676 s677 mod679)) tmp689) ((lambda (tmp696) (if
(if tmp696 (apply (lambda (_697 name698 args699 e1700 e2701) (if (id?248
name698) (valid-bound-ids?273 (lambda-var-list296 args699)) #f)) tmp696) #f)
(apply (lambda (_702 name703 args704 e1705 e2706) (values (quote define-form)
(wrap276 name703 w676 mod679) (cons (quote #(syntax-object lambda ((top)
#(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i"
"i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage
#(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i"))
#(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var
strip ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source 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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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))) (wrap276 (cons args704 (cons e1705
e2706)) w676 mod679)) (quote (())) s677 mod679)) tmp696) ((lambda (tmp708) (if
(if tmp708 (apply (lambda (_709 name710) (id?248 name710)) tmp708) #f) (apply
(lambda (_711 name712) (values (quote define-form) (wrap276 name712 w676
mod679) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var
strip ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source 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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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)) #(syntax-object #f ((top) #(ribcage
#(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod)
#((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer
chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr
chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence
chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids?
valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks
join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage
new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap
set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels
ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label
make-rename rename-marks rename-new rename-old subst-rename? wrap-subst
wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id?
global-extend lookup macros-only-env extend-var-env extend-env null-env
binding-value binding-type make-binding arg-check source-annotation no-source
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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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)) #(syntax-object #f ((top) #(ribcage
#(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod)
#((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer
chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr
chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence
chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids?
valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks
join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage
new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap
set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels
ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label
make-rename rename-marks rename-new rename-old subst-rename? wrap-subst
wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id?
global-extend lookup macros-only-env extend-var-env extend-env null-env
binding-value binding-type make-binding arg-check source-annotation no-source
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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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)))) (quote (())) s677 mod679)) tmp708)
(syntax-violation #f "source expression failed to match any pattern" tmp688)))
($sc-dispatch tmp688 (quote (any any)))))) ($sc-dispatch tmp688 (quote (any
(any . any) any . each-any)))))) ($sc-dispatch tmp688 (quote (any any any)))))
e674) (if (memv type687 (quote (define-syntax))) ((lambda (tmp713) ((lambda
(tmp714) (if (if tmp714 (apply (lambda (_715 name716 val717) (id?248 name716))
tmp714) #f) (apply (lambda (_718 name719 val720) (values (quote
define-syntax-form) name719 val720 w676 s677 mod679)) tmp714) (syntax-violation
#f "source expression failed to match any pattern" tmp713))) ($sc-dispatch
tmp713 (quote (any any any))))) e674) (values (quote call) #f e674 w676 s677
mod679))))))))))))) (values (quote call) #f e674 w676 s677 mod679))) (if
(syntax-object?232 e674) (syntax-type282 (syntax-object-expression233 e674)
r675 (join-wraps267 w676 (syntax-object-wrap234 e674)) s677 rib678 (let ((t721
(syntax-object-module235 e674))) (if t721 t721 mod679))) (if (self-evaluating?
e674) (values (quote constant) #f e674 w676 s677 mod679) (values (quote other)
#f e674 w676 s677 mod679))))))) (chi-when-list281 (lambda (e722 when-list723
w724) (letrec ((f725 (lambda (when-list726 situations727) (if (null?
when-list726) situations727 (f725 (cdr when-list726) (cons (let ((x728 (car
when-list726))) (if (free-id=?271 x728 (quote #(syntax-object compile ((top)
#(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e
when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list
gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source 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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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)))) (quote compile) (if (free-id=?271
x728 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source 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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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)))) (quote load) (if (free-id=?271
x728 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source 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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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)))) (quote eval) (syntax-violation
(quote eval-when) "invalid situation" e722 (wrap276 x728 w724 #f))))))
situations727)))))) (f725 when-list723 (quote ()))))) (chi-install-global280
(lambda (name729 e730) (build-global-definition223 #f name729 (if (let ((v731
(module-variable (current-module) name729))) (if v731 (if (variable-bound?
v731) (if (macro? (variable-ref v731)) (not (eq? (macro-type (variable-ref
v731)) (quote syncase-macro))) #f) #f) #f)) (build-application215 #f
(build-primref225 #f (quote make-extended-syncase-macro)) (list
(build-application215 #f (build-primref225 #f (quote module-ref)) (list
(build-application215 #f (build-primref225 #f (quote current-module)) (quote
())) (build-data226 #f name729))) (build-data226 #f (quote macro)) e730))
(build-application215 #f (build-primref225 #f (quote make-syncase-macro)) (list
(build-data226 #f (quote macro)) e730)))))) (chi-top-sequence279 (lambda
(body732 r733 w734 s735 m736 esew737 mod738) (build-sequence227 s735 (letrec
((dobody739 (lambda (body740 r741 w742 m743 esew744 mod745) (if (null? body740)
(quote ()) (let ((first746 (chi-top283 (car body740) r741 w742 m743 esew744
mod745))) (cons first746 (dobody739 (cdr body740) r741 w742 m743 esew744
mod745))))))) (dobody739 body732 r733 w734 m736 esew737 mod738)))))
(chi-sequence278 (lambda (body747 r748 w749 s750 mod751) (build-sequence227
s750 (letrec ((dobody752 (lambda (body753 r754 w755 mod756) (if (null? body753)
(quote ()) (let ((first757 (chi284 (car body753) r754 w755 mod756))) (cons
first757 (dobody752 (cdr body753) r754 w755 mod756))))))) (dobody752 body747
r748 w749 mod751))))) (source-wrap277 (lambda (x758 w759 s760 defmod761) (begin
(if (if s760 (pair? x758) #f) (set-source-properties! x758 s760)) (wrap276 x758
w759 defmod761)))) (wrap276 (lambda (x762 w763 defmod764) (if (if (null?
(wrap-marks251 w763)) (null? (wrap-subst252 w763)) #f) x762 (if
(syntax-object?232 x762) (make-syntax-object231 (syntax-object-expression233
x762) (join-wraps267 w763 (syntax-object-wrap234 x762))
(syntax-object-module235 x762)) (if (null? x762) x762 (make-syntax-object231
x762 w763 defmod764)))))) (bound-id-member?275 (lambda (x765 list766) (if (not
(null? list766)) (let ((t767 (bound-id=?272 x765 (car list766)))) (if t767 t767
(bound-id-member?275 x765 (cdr list766)))) #f))) (distinct-bound-ids?274
(lambda (ids768) (letrec ((distinct?769 (lambda (ids770) (let ((t771 (null?
ids770))) (if t771 t771 (if (not (bound-id-member?275 (car ids770) (cdr
ids770))) (distinct?769 (cdr ids770)) #f)))))) (distinct?769 ids768))))
(valid-bound-ids?273 (lambda (ids772) (if (letrec ((all-ids?773 (lambda
(ids774) (let ((t775 (null? ids774))) (if t775 t775 (if (id?248 (car ids774))
(all-ids?773 (cdr ids774)) #f)))))) (all-ids?773 ids772))
(distinct-bound-ids?274 ids772) #f))) (bound-id=?272 (lambda (i776 j777) (if
(if (syntax-object?232 i776) (syntax-object?232 j777) #f) (if (eq?
(syntax-object-expression233 i776) (syntax-object-expression233 j777))
(same-marks?269 (wrap-marks251 (syntax-object-wrap234 i776)) (wrap-marks251
(syntax-object-wrap234 j777))) #f) (eq? i776 j777)))) (free-id=?271 (lambda
(i778 j779) (if (eq? (let ((x780 i778)) (if (syntax-object?232 x780)
(syntax-object-expression233 x780) x780)) (let ((x781 j779)) (if
(syntax-object?232 x781) (syntax-object-expression233 x781) x781))) (eq?
(id-var-name270 i778 (quote (()))) (id-var-name270 j779 (quote (())))) #f)))
(id-var-name270 (lambda (id782 w783) (letrec ((search-vector-rib786 (lambda
(sym792 subst793 marks794 symnames795 ribcage796) (let ((n797 (vector-length
symnames795))) (letrec ((f798 (lambda (i799) (if (fx=208 i799 n797) (search784
sym792 (cdr subst793) marks794) (if (if (eq? (vector-ref symnames795 i799)
sym792) (same-marks?269 marks794 (vector-ref (ribcage-marks258 ribcage796)
i799)) #f) (values (vector-ref (ribcage-labels259 ribcage796) i799) marks794)
(f798 (fx+206 i799 1))))))) (f798 0))))) (search-list-rib785 (lambda (sym800
subst801 marks802 symnames803 ribcage804) (letrec ((f805 (lambda (symnames806
i807) (if (null? symnames806) (search784 sym800 (cdr subst801) marks802) (if
(if (eq? (car symnames806) sym800) (same-marks?269 marks802 (list-ref
(ribcage-marks258 ribcage804) i807)) #f) (values (list-ref (ribcage-labels259
ribcage804) i807) marks802) (f805 (cdr symnames806) (fx+206 i807 1))))))) (f805
symnames803 0)))) (search784 (lambda (sym808 subst809 marks810) (if (null?
subst809) (values #f marks810) (let ((fst811 (car subst809))) (if (eq? fst811
(quote shift)) (search784 sym808 (cdr subst809) (cdr marks810)) (let
((symnames812 (ribcage-symnames257 fst811))) (if (vector? symnames812)
(search-vector-rib786 sym808 subst809 marks810 symnames812 fst811)
(search-list-rib785 sym808 subst809 marks810 symnames812 fst811))))))))) (if
(symbol? id782) (let ((t813 (call-with-values (lambda () (search784 id782
(wrap-subst252 w783) (wrap-marks251 w783))) (lambda (x815 . ignore814) x815))))
(if t813 t813 id782)) (if (syntax-object?232 id782) (let ((id816
(syntax-object-expression233 id782)) (w1817 (syntax-object-wrap234 id782)))
(let ((marks818 (join-marks268 (wrap-marks251 w783) (wrap-marks251 w1817))))
(call-with-values (lambda () (search784 id816 (wrap-subst252 w783) marks818))
(lambda (new-id819 marks820) (let ((t821 new-id819)) (if t821 t821 (let ((t822
(call-with-values (lambda () (search784 id816 (wrap-subst252 w1817) marks820))
(lambda (x824 . ignore823) x824)))) (if t822 t822 id816))))))))
(syntax-violation (quote id-var-name) "invalid id" id782)))))) (same-marks?269
(lambda (x825 y826) (let ((t827 (eq? x825 y826))) (if t827 t827 (if (not (null?
x825)) (if (not (null? y826)) (if (eq? (car x825) (car y826)) (same-marks?269
(cdr x825) (cdr y826)) #f) #f) #f))))) (join-marks268 (lambda (m1828 m2829)
(smart-append266 m1828 m2829))) (join-wraps267 (lambda (w1830 w2831) (let
((m1832 (wrap-marks251 w1830)) (s1833 (wrap-subst252 w1830))) (if (null? m1832)
(if (null? s1833) w2831 (make-wrap250 (wrap-marks251 w2831) (smart-append266
s1833 (wrap-subst252 w2831)))) (make-wrap250 (smart-append266 m1832
(wrap-marks251 w2831)) (smart-append266 s1833 (wrap-subst252 w2831)))))))
(smart-append266 (lambda (m1834 m2835) (if (null? m2835) m1834 (append m1834
m2835)))) (make-binding-wrap265 (lambda (ids836 labels837 w838) (if (null?
ids836) w838 (make-wrap250 (wrap-marks251 w838) (cons (let ((labelvec839
(list->vector labels837))) (let ((n840 (vector-length labelvec839))) (let
((symnamevec841 (make-vector n840)) (marksvec842 (make-vector n840))) (begin
(letrec ((f843 (lambda (ids844 i845) (if (not (null? ids844)) (call-with-values
(lambda () (id-sym-name&marks249 (car ids844) w838)) (lambda (symname846
marks847) (begin (vector-set! symnamevec841 i845 symname846) (vector-set!
marksvec842 i845 marks847) (f843 (cdr ids844) (fx+206 i845 1))))))))) (f843
ids836 0)) (make-ribcage255 symnamevec841 marksvec842 labelvec839)))))
(wrap-subst252 w838)))))) (extend-ribcage!264 (lambda (ribcage848 id849
label850) (begin (set-ribcage-symnames!260 ribcage848 (cons
(syntax-object-expression233 id849) (ribcage-symnames257 ribcage848)))
(set-ribcage-marks!261 ribcage848 (cons (wrap-marks251 (syntax-object-wrap234
id849)) (ribcage-marks258 ribcage848))) (set-ribcage-labels!262 ribcage848
(cons label850 (ribcage-labels259 ribcage848)))))) (anti-mark263 (lambda (w851)
(make-wrap250 (cons #f (wrap-marks251 w851)) (cons (quote shift) (wrap-subst252
w851))))) (set-ribcage-labels!262 (lambda (x852 update853) (vector-set! x852 3
update853))) (set-ribcage-marks!261 (lambda (x854 update855) (vector-set! x854
2 update855))) (set-ribcage-symnames!260 (lambda (x856 update857) (vector-set!
x856 1 update857))) (ribcage-labels259 (lambda (x858) (vector-ref x858 3)))
(ribcage-marks258 (lambda (x859) (vector-ref x859 2))) (ribcage-symnames257
(lambda (x860) (vector-ref x860 1))) (ribcage?256 (lambda (x861) (if (vector?
x861) (if (= (vector-length x861) 4) (eq? (vector-ref x861 0) (quote ribcage))
#f) #f))) (make-ribcage255 (lambda (symnames862 marks863 labels864) (vector
(quote ribcage) symnames862 marks863 labels864))) (gen-labels254 (lambda
(ls865) (if (null? ls865) (quote ()) (cons (gen-label253) (gen-labels254 (cdr
ls865)))))) (gen-label253 (lambda () (string #\i))) (wrap-subst252 cdr)
(wrap-marks251 car) (make-wrap250 cons) (id-sym-name&marks249 (lambda (x866
w867) (if (syntax-object?232 x866) (values (syntax-object-expression233 x866)
(join-marks268 (wrap-marks251 w867) (wrap-marks251 (syntax-object-wrap234
x866)))) (values x866 (wrap-marks251 w867))))) (id?248 (lambda (x868) (if
(symbol? x868) #t (if (syntax-object?232 x868) (symbol?
(syntax-object-expression233 x868)) #f)))) (nonsymbol-id?247 (lambda (x869) (if
(syntax-object?232 x869) (symbol? (syntax-object-expression233 x869)) #f)))
(global-extend246 (lambda (type870 sym871 val872)
(put-global-definition-hook212 sym871 type870 val872))) (lookup245 (lambda
(x873 r874 mod875) (let ((t876 (assq x873 r874))) (if t876 (cdr t876) (if
(symbol? x873) (let ((t877 (get-global-definition-hook213 x873 mod875))) (if
t877 t877 (quote (global)))) (quote (displaced-lexical)))))))
(macros-only-env244 (lambda (r878) (if (null? r878) (quote ()) (let ((a879 (car
r878))) (if (eq? (cadr a879) (quote macro)) (cons a879 (macros-only-env244 (cdr
r878))) (macros-only-env244 (cdr r878))))))) (extend-var-env243 (lambda
(labels880 vars881 r882) (if (null? labels880) r882 (extend-var-env243 (cdr
labels880) (cdr vars881) (cons (cons (car labels880) (cons (quote lexical) (car
vars881))) r882))))) (extend-env242 (lambda (labels883 bindings884 r885) (if
(null? labels883) r885 (extend-env242 (cdr labels883) (cdr bindings884) (cons
(cons (car labels883) (car bindings884)) r885))))) (binding-value241 cdr)
(binding-type240 car) (source-annotation239 (lambda (x886) (if
(syntax-object?232 x886) (source-annotation239 (syntax-object-expression233
x886)) (if (pair? x886) (let ((props887 (source-properties x886))) (if (pair?
props887) props887 #f)) #f)))) (set-syntax-object-module!238 (lambda (x888
update889) (vector-set! x888 3 update889))) (set-syntax-object-wrap!237 (lambda
(x890 update891) (vector-set! x890 2 update891)))
(set-syntax-object-expression!236 (lambda (x892 update893) (vector-set! x892 1
update893))) (syntax-object-module235 (lambda (x894) (vector-ref x894 3)))
(syntax-object-wrap234 (lambda (x895) (vector-ref x895 2)))
(syntax-object-expression233 (lambda (x896) (vector-ref x896 1)))
(syntax-object?232 (lambda (x897) (if (vector? x897) (if (= (vector-length
x897) 4) (eq? (vector-ref x897 0) (quote syntax-object)) #f) #f)))
(make-syntax-object231 (lambda (expression898 wrap899 module900) (vector (quote
syntax-object) expression898 wrap899 module900))) (build-letrec230 (lambda
(src901 ids902 vars903 val-exps904 body-exp905) (if (null? vars903) body-exp905
(let ((atom-key906 (fluid-ref *mode*205))) (if (memv atom-key906 (quote (c)))
(begin (for-each maybe-name-value!222 ids902 val-exps904) ((@ (language
tree-il) make-letrec) src901 ids902 vars903 val-exps904 body-exp905)) (list
(quote letrec) (map list vars903 val-exps904) body-exp905))))))
(build-named-let229 (lambda (src907 ids908 vars909 val-exps910 body-exp911)
(let ((f912 (car vars909)) (f-name913 (car ids908)) (vars914 (cdr vars909))
(ids915 (cdr ids908))) (let ((atom-key916 (fluid-ref *mode*205))) (if (memv
atom-key916 (quote (c))) (let ((proc917 (build-lambda224 src907 ids915 vars914
#f body-exp911))) (begin (maybe-name-value!222 f-name913 proc917) (for-each
maybe-name-value!222 ids915 val-exps910) ((@ (language tree-il) make-letrec)
src907 (list f-name913) (list f912) (list proc917) (build-application215 src907
(build-lexical-reference217 (quote fun) src907 f-name913 f912) val-exps910))))
(list (quote let) f912 (map list vars914 val-exps910) body-exp911))))))
(build-let228 (lambda (src918 ids919 vars920 val-exps921 body-exp922) (if
(null? vars920) body-exp922 (let ((atom-key923 (fluid-ref *mode*205))) (if
(memv atom-key923 (quote (c))) (begin (for-each maybe-name-value!222 ids919
val-exps921) ((@ (language tree-il) make-let) src918 ids919 vars920 val-exps921
body-exp922)) (list (quote let) (map list vars920 val-exps921)
body-exp922)))))) (build-sequence227 (lambda (src924 exps925) (if (null? (cdr
exps925)) (car exps925) (let ((atom-key926 (fluid-ref *mode*205))) (if (memv
atom-key926 (quote (c))) ((@ (language tree-il) make-sequence) src924 exps925)
(cons (quote begin) exps925)))))) (build-data226 (lambda (src927 exp928) (let
((atom-key929 (fluid-ref *mode*205))) (if (memv atom-key929 (quote (c))) ((@
(language tree-il) make-const) src927 exp928) (if (if (self-evaluating? exp928)
(not (vector? exp928)) #f) exp928 (list (quote quote) exp928))))))
(build-primref225 (lambda (src930 name931) (if (equal? (module-name
(current-module)) (quote (guile))) (let ((atom-key932 (fluid-ref *mode*205)))
(if (memv atom-key932 (quote (c))) ((@ (language tree-il) make-toplevel-ref)
src930 name931) name931)) (let ((atom-key933 (fluid-ref *mode*205))) (if (memv
atom-key933 (quote (c))) ((@ (language tree-il) make-module-ref) src930 (quote
(guile)) name931 #f) (list (quote @@) (quote (guile)) name931))))))
(build-lambda224 (lambda (src934 ids935 vars936 docstring937 exp938) (let
((atom-key939 (fluid-ref *mode*205))) (if (memv atom-key939 (quote (c))) ((@
(language tree-il) make-lambda) src934 ids935 vars936 (if docstring937 (list
(cons (quote documentation) docstring937)) (quote ())) exp938) (cons (quote
lambda) (cons vars936 (append (if docstring937 (list docstring937) (quote ()))
(list exp938)))))))) (build-global-definition223 (lambda (source940 var941
exp942) (let ((atom-key943 (fluid-ref *mode*205))) (if (memv atom-key943 (quote
(c))) (begin (maybe-name-value!222 var941 exp942) ((@ (language tree-il)
make-toplevel-define) source940 var941 exp942)) (list (quote define) var941
exp942))))) (maybe-name-value!222 (lambda (name944 val945) (if ((@ (language
tree-il) lambda?) val945) (let ((meta946 ((@ (language tree-il) lambda-meta)
val945))) (if (not (assq (quote name) meta946)) ((setter (@ (language tree-il)
lambda-meta)) val945 (acons (quote name) name944 meta946)))))))
(build-global-assignment221 (lambda (source947 var948 exp949 mod950)
(analyze-variable219 mod950 var948 (lambda (mod951 var952 public?953) (let
((atom-key954 (fluid-ref *mode*205))) (if (memv atom-key954 (quote (c))) ((@
(language tree-il) make-module-set) source947 mod951 var952 public?953 exp949)
(list (quote set!) (list (if public?953 (quote @) (quote @@)) mod951 var952)
exp949)))) (lambda (var955) (let ((atom-key956 (fluid-ref *mode*205))) (if
(memv atom-key956 (quote (c))) ((@ (language tree-il) make-toplevel-set)
source947 var955 exp949) (list (quote set!) var955 exp949)))))))
(build-global-reference220 (lambda (source957 var958 mod959)
(analyze-variable219 mod959 var958 (lambda (mod960 var961 public?962) (let
((atom-key963 (fluid-ref *mode*205))) (if (memv atom-key963 (quote (c))) ((@
(language tree-il) make-module-ref) source957 mod960 var961 public?962) (list
(if public?962 (quote @) (quote @@)) mod960 var961)))) (lambda (var964) (let
((atom-key965 (fluid-ref *mode*205))) (if (memv atom-key965 (quote (c))) ((@
(language tree-il) make-toplevel-ref) source957 var964) var964))))))
(analyze-variable219 (lambda (mod966 var967 modref-cont968 bare-cont969) (if
(not mod966) (bare-cont969 var967) (let ((kind970 (car mod966)) (mod971 (cdr
mod966))) (if (memv kind970 (quote (public))) (modref-cont968 mod971 var967 #t)
(if (memv kind970 (quote (private))) (if (not (equal? mod971 (module-name
(current-module)))) (modref-cont968 mod971 var967 #f) (bare-cont969 var967))
(if (memv kind970 (quote (bare))) (bare-cont969 var967) (if (memv kind970
(quote (hygiene))) (if (if (not (equal? mod971 (module-name (current-module))))
(module-variable (resolve-module mod971) var967) #f) (modref-cont968 mod971
var967 #f) (bare-cont969 var967)) (syntax-violation #f "bad module kind" var967
mod971))))))))) (build-lexical-assignment218 (lambda (source972 name973 var974
exp975) (let ((atom-key976 (fluid-ref *mode*205))) (if (memv atom-key976 (quote
(c))) ((@ (language tree-il) make-lexical-set) source972 name973 var974 exp975)
(list (quote set!) var974 exp975))))) (build-lexical-reference217 (lambda
(type977 source978 name979 var980) (let ((atom-key981 (fluid-ref *mode*205)))
(if (memv atom-key981 (quote (c))) ((@ (language tree-il) make-lexical-ref)
source978 name979 var980) var980)))) (build-conditional216 (lambda (source982
test-exp983 then-exp984 else-exp985) (let ((atom-key986 (fluid-ref *mode*205)))
(if (memv atom-key986 (quote (c))) ((@ (language tree-il) make-conditional)
source982 test-exp983 then-exp984 else-exp985) (if (equal? else-exp985 (quote
(if #f #f))) (list (quote if) test-exp983 then-exp984) (list (quote if)
test-exp983 then-exp984 else-exp985)))))) (build-application215 (lambda
(source987 fun-exp988 arg-exps989) (let ((atom-key990 (fluid-ref *mode*205)))
(if (memv atom-key990 (quote (c))) ((@ (language tree-il) make-application)
source987 fun-exp988 arg-exps989) (cons fun-exp988 arg-exps989)))))
(build-void214 (lambda (source991) (let ((atom-key992 (fluid-ref *mode*205)))
(if (memv atom-key992 (quote (c))) ((@ (language tree-il) make-void) source991)
(quote (if #f #f)))))) (get-global-definition-hook213 (lambda (symbol993
module994) (begin (if (if (not module994) (current-module) #f) (warn "module
system is booted, we should have a module" symbol993)) (let ((v995
(module-variable (if module994 (resolve-module (cdr module994))
(current-module)) symbol993))) (if v995 (if (variable-bound? v995) (let
((val996 (variable-ref v995))) (if (macro? val996) (if (syncase-macro-type
val996) (cons (syncase-macro-type val996) (syncase-macro-binding val996)) #f)
#f)) #f) #f))))) (put-global-definition-hook212 (lambda (symbol997 type998
val999) (let ((existing1000 (let ((v1001 (module-variable (current-module)
symbol997))) (if v1001 (if (variable-bound? v1001) (let ((val1002 (variable-ref
v1001))) (if (macro? val1002) (if (not (syncase-macro-type val1002)) val1002
#f) #f)) #f) #f)))) (module-define! (current-module) symbol997 (if existing1000
(make-extended-syncase-macro existing1000 type998 val999) (make-syncase-macro
type998 val999)))))) (local-eval-hook211 (lambda (x1003 mod1004)
(primitive-eval (list noexpand204 (let ((atom-key1005 (fluid-ref *mode*205)))
(if (memv atom-key1005 (quote (c))) ((@ (language tree-il) tree-il->scheme)
x1003) x1003)))))) (top-level-eval-hook210 (lambda (x1006 mod1007)
(primitive-eval (list noexpand204 (let ((atom-key1008 (fluid-ref *mode*205)))
(if (memv atom-key1008 (quote (c))) ((@ (language tree-il) tree-il->scheme)
x1006) x1006)))))) (fx<209 <) (fx=208 =) (fx-207 -) (fx+206 +) (*mode*205
(make-fluid)) (noexpand204 "noexpand")) (begin (global-extend246 (quote
local-syntax) (quote letrec-syntax) #t) (global-extend246 (quote local-syntax)
(quote let-syntax) #f) (global-extend246 (quote core) (quote fluid-let-syntax)
(lambda (e1009 r1010 w1011 s1012 mod1013) ((lambda (tmp1014) ((lambda (tmp1015)
(if (if tmp1015 (apply (lambda (_1016 var1017 val1018 e11019 e21020)
(valid-bound-ids?273 var1017)) tmp1015) #f) (apply (lambda (_1022 var1023
val1024 e11025 e21026) (let ((names1027 (map (lambda (x1028) (id-var-name270
x1028 w1011)) var1023))) (begin (for-each (lambda (id1030 n1031) (let
((atom-key1032 (binding-type240 (lookup245 n1031 r1010 mod1013)))) (if (memv
atom-key1032 (quote (displaced-lexical))) (syntax-violation (quote
fluid-let-syntax) "identifier out of context" e1009 (source-wrap277 id1030
w1011 s1012 mod1013))))) var1023 names1027) (chi-body288 (cons e11025 e21026)
(source-wrap277 e1009 w1011 s1012 mod1013) (extend-env242 names1027 (let
((trans-r1035 (macros-only-env244 r1010))) (map (lambda (x1036) (cons (quote
macro) (eval-local-transformer291 (chi284 x1036 trans-r1035 w1011 mod1013)
mod1013))) val1024)) r1010) w1011 mod1013)))) tmp1015) ((lambda (_1038)
(syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap277 e1009
w1011 s1012 mod1013))) tmp1014))) ($sc-dispatch tmp1014 (quote (any #(each (any
any)) any . each-any))))) e1009))) (global-extend246 (quote core) (quote quote)
(lambda (e1039 r1040 w1041 s1042 mod1043) ((lambda (tmp1044) ((lambda (tmp1045)
(if tmp1045 (apply (lambda (_1046 e1047) (build-data226 s1042 (strip294 e1047
w1041))) tmp1045) ((lambda (_1048) (syntax-violation (quote quote) "bad syntax"
(source-wrap277 e1039 w1041 s1042 mod1043))) tmp1044))) ($sc-dispatch tmp1044
(quote (any any))))) e1039))) (global-extend246 (quote core) (quote syntax)
(letrec ((regen1056 (lambda (x1057) (let ((atom-key1058 (car x1057))) (if (memv
atom-key1058 (quote (ref))) (build-lexical-reference217 (quote value) #f (cadr
x1057) (cadr x1057)) (if (memv atom-key1058 (quote (primitive)))
(build-primref225 #f (cadr x1057)) (if (memv atom-key1058 (quote (quote)))
(build-data226 #f (cadr x1057)) (if (memv atom-key1058 (quote (lambda)))
(build-lambda224 #f (cadr x1057) (cadr x1057) #f (regen1056 (caddr x1057)))
(build-application215 #f (build-primref225 #f (car x1057)) (map regen1056 (cdr
x1057)))))))))) (gen-vector1055 (lambda (x1059) (if (eq? (car x1059) (quote
list)) (cons (quote vector) (cdr x1059)) (if (eq? (car x1059) (quote quote))
(list (quote quote) (list->vector (cadr x1059))) (list (quote list->vector)
x1059))))) (gen-append1054 (lambda (x1060 y1061) (if (equal? y1061 (quote
(quote ()))) x1060 (list (quote append) x1060 y1061)))) (gen-cons1053 (lambda
(x1062 y1063) (let ((atom-key1064 (car y1063))) (if (memv atom-key1064 (quote
(quote))) (if (eq? (car x1062) (quote quote)) (list (quote quote) (cons (cadr
x1062) (cadr y1063))) (if (eq? (cadr y1063) (quote ())) (list (quote list)
x1062) (list (quote cons) x1062 y1063))) (if (memv atom-key1064 (quote (list)))
(cons (quote list) (cons x1062 (cdr y1063))) (list (quote cons) x1062
y1063)))))) (gen-map1052 (lambda (e1065 map-env1066) (let ((formals1067 (map
cdr map-env1066)) (actuals1068 (map (lambda (x1069) (list (quote ref) (car
x1069))) map-env1066))) (if (eq? (car e1065) (quote ref)) (car actuals1068) (if
(and-map (lambda (x1070) (if (eq? (car x1070) (quote ref)) (memq (cadr x1070)
formals1067) #f)) (cdr e1065)) (cons (quote map) (cons (list (quote primitive)
(car e1065)) (map (let ((r1071 (map cons formals1067 actuals1068))) (lambda
(x1072) (cdr (assq (cadr x1072) r1071)))) (cdr e1065)))) (cons (quote map)
(cons (list (quote lambda) formals1067 e1065) actuals1068)))))))
(gen-mappend1051 (lambda (e1073 map-env1074) (list (quote apply) (quote
(primitive append)) (gen-map1052 e1073 map-env1074)))) (gen-ref1050 (lambda
(src1075 var1076 level1077 maps1078) (if (fx=208 level1077 0) (values var1076
maps1078) (if (null? maps1078) (syntax-violation (quote syntax) "missing
ellipsis" src1075) (call-with-values (lambda () (gen-ref1050 src1075 var1076
(fx-207 level1077 1) (cdr maps1078))) (lambda (outer-var1079 outer-maps1080)
(let ((b1081 (assq outer-var1079 (car maps1078)))) (if b1081 (values (cdr
b1081) maps1078) (let ((inner-var1082 (gen-var295 (quote tmp)))) (values
inner-var1082 (cons (cons (cons outer-var1079 inner-var1082) (car maps1078))
outer-maps1080))))))))))) (gen-syntax1049 (lambda (src1083 e1084 r1085 maps1086
ellipsis?1087 mod1088) (if (id?248 e1084) (let ((label1089 (id-var-name270
e1084 (quote (()))))) (let ((b1090 (lookup245 label1089 r1085 mod1088))) (if
(eq? (binding-type240 b1090) (quote syntax)) (call-with-values (lambda () (let
((var.lev1091 (binding-value241 b1090))) (gen-ref1050 src1083 (car var.lev1091)
(cdr var.lev1091) maps1086))) (lambda (var1092 maps1093) (values (list (quote
ref) var1092) maps1093))) (if (ellipsis?1087 e1084) (syntax-violation (quote
syntax) "misplaced ellipsis" src1083) (values (list (quote quote) e1084)
maps1086))))) ((lambda (tmp1094) ((lambda (tmp1095) (if (if tmp1095 (apply
(lambda (dots1096 e1097) (ellipsis?1087 dots1096)) tmp1095) #f) (apply (lambda
(dots1098 e1099) (gen-syntax1049 src1083 e1099 r1085 maps1086 (lambda (x1100)
#f) mod1088)) tmp1095) ((lambda (tmp1101) (if (if tmp1101 (apply (lambda (x1102
dots1103 y1104) (ellipsis?1087 dots1103)) tmp1101) #f) (apply (lambda (x1105
dots1106 y1107) (letrec ((f1108 (lambda (y1109 k1110) ((lambda (tmp1114)
((lambda (tmp1115) (if (if tmp1115 (apply (lambda (dots1116 y1117)
(ellipsis?1087 dots1116)) tmp1115) #f) (apply (lambda (dots1118 y1119) (f1108
y1119 (lambda (maps1120) (call-with-values (lambda () (k1110 (cons (quote ())
maps1120))) (lambda (x1121 maps1122) (if (null? (car maps1122))
(syntax-violation (quote syntax) "extra ellipsis" src1083) (values
(gen-mappend1051 x1121 (car maps1122)) (cdr maps1122)))))))) tmp1115) ((lambda
(_1123) (call-with-values (lambda () (gen-syntax1049 src1083 y1109 r1085
maps1086 ellipsis?1087 mod1088)) (lambda (y1124 maps1125) (call-with-values
(lambda () (k1110 maps1125)) (lambda (x1126 maps1127) (values (gen-append1054
x1126 y1124) maps1127)))))) tmp1114))) ($sc-dispatch tmp1114 (quote (any .
any))))) y1109)))) (f1108 y1107 (lambda (maps1111) (call-with-values (lambda ()
(gen-syntax1049 src1083 x1105 r1085 (cons (quote ()) maps1111) ellipsis?1087
mod1088)) (lambda (x1112 maps1113) (if (null? (car maps1113)) (syntax-violation
(quote syntax) "extra ellipsis" src1083) (values (gen-map1052 x1112 (car
maps1113)) (cdr maps1113))))))))) tmp1101) ((lambda (tmp1128) (if tmp1128
(apply (lambda (x1129 y1130) (call-with-values (lambda () (gen-syntax1049
src1083 x1129 r1085 maps1086 ellipsis?1087 mod1088)) (lambda (x1131 maps1132)
(call-with-values (lambda () (gen-syntax1049 src1083 y1130 r1085 maps1132
ellipsis?1087 mod1088)) (lambda (y1133 maps1134) (values (gen-cons1053 x1131
y1133) maps1134)))))) tmp1128) ((lambda (tmp1135) (if tmp1135 (apply (lambda
(e11136 e21137) (call-with-values (lambda () (gen-syntax1049 src1083 (cons
e11136 e21137) r1085 maps1086 ellipsis?1087 mod1088)) (lambda (e1139 maps1140)
(values (gen-vector1055 e1139) maps1140)))) tmp1135) ((lambda (_1141) (values
(list (quote quote) e1084) maps1086)) tmp1094))) ($sc-dispatch tmp1094 (quote
#(vector (any . each-any))))))) ($sc-dispatch tmp1094 (quote (any . any))))))
($sc-dispatch tmp1094 (quote (any any . any)))))) ($sc-dispatch tmp1094 (quote
(any any))))) e1084))))) (lambda (e1142 r1143 w1144 s1145 mod1146) (let ((e1147
(source-wrap277 e1142 w1144 s1145 mod1146))) ((lambda (tmp1148) ((lambda
(tmp1149) (if tmp1149 (apply (lambda (_1150 x1151) (call-with-values (lambda ()
(gen-syntax1049 e1147 x1151 r1143 (quote ()) ellipsis?293 mod1146)) (lambda
(e1152 maps1153) (regen1056 e1152)))) tmp1149) ((lambda (_1154)
(syntax-violation (quote syntax) "bad `syntax' form" e1147)) tmp1148)))
($sc-dispatch tmp1148 (quote (any any))))) e1147))))) (global-extend246 (quote
core) (quote lambda) (lambda (e1155 r1156 w1157 s1158 mod1159) ((lambda
(tmp1160) ((lambda (tmp1161) (if tmp1161 (apply (lambda (_1162 c1163)
(chi-lambda-clause289 (source-wrap277 e1155 w1157 s1158 mod1159) #f c1163 r1156
w1157 mod1159 (lambda (names1164 vars1165 docstring1166 body1167)
(build-lambda224 s1158 names1164 vars1165 docstring1166 body1167)))) tmp1161)
(syntax-violation #f "source expression failed to match any pattern" tmp1160)))
($sc-dispatch tmp1160 (quote (any . any))))) e1155))) (global-extend246 (quote
core) (quote let) (letrec ((chi-let1168 (lambda (e1169 r1170 w1171 s1172
mod1173 constructor1174 ids1175 vals1176 exps1177) (if (not
(valid-bound-ids?273 ids1175)) (syntax-violation (quote let) "duplicate bound
variable" e1169) (let ((labels1178 (gen-labels254 ids1175)) (new-vars1179 (map
gen-var295 ids1175))) (let ((nw1180 (make-binding-wrap265 ids1175 labels1178
w1171)) (nr1181 (extend-var-env243 labels1178 new-vars1179 r1170)))
(constructor1174 s1172 (map syntax->datum ids1175) new-vars1179 (map (lambda
(x1182) (chi284 x1182 r1170 w1171 mod1173)) vals1176) (chi-body288 exps1177
(source-wrap277 e1169 nw1180 s1172 mod1173) nr1181 nw1180 mod1173))))))))
(lambda (e1183 r1184 w1185 s1186 mod1187) ((lambda (tmp1188) ((lambda (tmp1189)
(if (if tmp1189 (apply (lambda (_1190 id1191 val1192 e11193 e21194) (and-map
id?248 id1191)) tmp1189) #f) (apply (lambda (_1196 id1197 val1198 e11199
e21200) (chi-let1168 e1183 r1184 w1185 s1186 mod1187 build-let228 id1197
val1198 (cons e11199 e21200))) tmp1189) ((lambda (tmp1204) (if (if tmp1204
(apply (lambda (_1205 f1206 id1207 val1208 e11209 e21210) (if (id?248 f1206)
(and-map id?248 id1207) #f)) tmp1204) #f) (apply (lambda (_1212 f1213 id1214
val1215 e11216 e21217) (chi-let1168 e1183 r1184 w1185 s1186 mod1187
build-named-let229 (cons f1213 id1214) val1215 (cons e11216 e21217))) tmp1204)
((lambda (_1221) (syntax-violation (quote let) "bad let" (source-wrap277 e1183
w1185 s1186 mod1187))) tmp1188))) ($sc-dispatch tmp1188 (quote (any any #(each
(any any)) any . each-any)))))) ($sc-dispatch tmp1188 (quote (any #(each (any
any)) any . each-any))))) e1183)))) (global-extend246 (quote core) (quote
letrec) (lambda (e1222 r1223 w1224 s1225 mod1226) ((lambda (tmp1227) ((lambda
(tmp1228) (if (if tmp1228 (apply (lambda (_1229 id1230 val1231 e11232 e21233)
(and-map id?248 id1230)) tmp1228) #f) (apply (lambda (_1235 id1236 val1237
e11238 e21239) (let ((ids1240 id1236)) (if (not (valid-bound-ids?273 ids1240))
(syntax-violation (quote letrec) "duplicate bound variable" e1222) (let
((labels1242 (gen-labels254 ids1240)) (new-vars1243 (map gen-var295 ids1240)))
(let ((w1244 (make-binding-wrap265 ids1240 labels1242 w1224)) (r1245
(extend-var-env243 labels1242 new-vars1243 r1223))) (build-letrec230 s1225 (map
syntax->datum ids1240) new-vars1243 (map (lambda (x1246) (chi284 x1246 r1245
w1244 mod1226)) val1237) (chi-body288 (cons e11238 e21239) (source-wrap277
e1222 w1244 s1225 mod1226) r1245 w1244 mod1226))))))) tmp1228) ((lambda (_1249)
(syntax-violation (quote letrec) "bad letrec" (source-wrap277 e1222 w1224 s1225
mod1226))) tmp1227))) ($sc-dispatch tmp1227 (quote (any #(each (any any)) any .
each-any))))) e1222))) (global-extend246 (quote core) (quote set!) (lambda
(e1250 r1251 w1252 s1253 mod1254) ((lambda (tmp1255) ((lambda (tmp1256) (if (if
tmp1256 (apply (lambda (_1257 id1258 val1259) (id?248 id1258)) tmp1256) #f)
(apply (lambda (_1260 id1261 val1262) (let ((val1263 (chi284 val1262 r1251
w1252 mod1254)) (n1264 (id-var-name270 id1261 w1252))) (let ((b1265 (lookup245
n1264 r1251 mod1254))) (let ((atom-key1266 (binding-type240 b1265))) (if (memv
atom-key1266 (quote (lexical))) (build-lexical-assignment218 s1253
(syntax->datum id1261) (binding-value241 b1265) val1263) (if (memv atom-key1266
(quote (global))) (build-global-assignment221 s1253 n1264 val1263 mod1254) (if
(memv atom-key1266 (quote (displaced-lexical))) (syntax-violation (quote set!)
"identifier out of context" (wrap276 id1261 w1252 mod1254)) (syntax-violation
(quote set!) "bad set!" (source-wrap277 e1250 w1252 s1253 mod1254)))))))))
tmp1256) ((lambda (tmp1267) (if tmp1267 (apply (lambda (_1268 head1269 tail1270
val1271) (call-with-values (lambda () (syntax-type282 head1269 r1251 (quote
(())) #f #f mod1254)) (lambda (type1272 value1273 ee1274 ww1275 ss1276
modmod1277) (if (memv type1272 (quote (module-ref))) (let ((val1278 (chi284
val1271 r1251 w1252 mod1254))) (call-with-values (lambda () (value1273 (cons
head1269 tail1270))) (lambda (id1280 mod1281) (build-global-assignment221 s1253
id1280 val1278 mod1281)))) (build-application215 s1253 (chi284 (list (quote
#(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage
#(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i"
"i" "i" "i")) #(ribcage () () ()) #(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-lambda-clause
chi-body chi-macro chi-application chi-expr chi chi-top syntax-type
chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source 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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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))) head1269) r1251 w1252 mod1254) (map
(lambda (e1282) (chi284 e1282 r1251 w1252 mod1254)) (append tail1270 (list
val1271)))))))) tmp1267) ((lambda (_1284) (syntax-violation (quote set!) "bad
set!" (source-wrap277 e1250 w1252 s1253 mod1254))) tmp1255))) ($sc-dispatch
tmp1255 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1255 (quote
(any any any))))) e1250))) (global-extend246 (quote module-ref) (quote @)
(lambda (e1285) ((lambda (tmp1286) ((lambda (tmp1287) (if (if tmp1287 (apply
(lambda (_1288 mod1289 id1290) (if (and-map id?248 mod1289) (id?248 id1290)
#f)) tmp1287) #f) (apply (lambda (_1292 mod1293 id1294) (values (syntax->datum
id1294) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_
mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e)
#((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source 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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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))) mod1293)))) tmp1287)
(syntax-violation #f "source expression failed to match any pattern" tmp1286)))
($sc-dispatch tmp1286 (quote (any each-any any))))) e1285))) (global-extend246
(quote module-ref) (quote @@) (lambda (e1296) ((lambda (tmp1297) ((lambda
(tmp1298) (if (if tmp1298 (apply (lambda (_1299 mod1300 id1301) (if (and-map
id?248 mod1300) (id?248 id1301) #f)) tmp1298) #f) (apply (lambda (_1303 mod1304
id1305) (values (syntax->datum id1305) (syntax->datum (cons (quote
#(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage
(lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer
chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr
chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence
chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids?
valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks
join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage
new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap
set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels
ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label
make-rename rename-marks rename-new rename-old subst-rename? wrap-subst
wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id?
global-extend lookup macros-only-env extend-var-env extend-env null-env
binding-value binding-type make-binding arg-check source-annotation no-source
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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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))) mod1304)))) tmp1298)
(syntax-violation #f "source expression failed to match any pattern" tmp1297)))
($sc-dispatch tmp1297 (quote (any each-any any))))) e1296))) (global-extend246
(quote core) (quote if) (lambda (e1307 r1308 w1309 s1310 mod1311) ((lambda
(tmp1312) ((lambda (tmp1313) (if tmp1313 (apply (lambda (_1314 test1315
then1316) (build-conditional216 s1310 (chi284 test1315 r1308 w1309 mod1311)
(chi284 then1316 r1308 w1309 mod1311) (build-void214 #f))) tmp1313) ((lambda
(tmp1317) (if tmp1317 (apply (lambda (_1318 test1319 then1320 else1321)
(build-conditional216 s1310 (chi284 test1319 r1308 w1309 mod1311) (chi284
then1320 r1308 w1309 mod1311) (chi284 else1321 r1308 w1309 mod1311))) tmp1317)
(syntax-violation #f "source expression failed to match any pattern" tmp1312)))
($sc-dispatch tmp1312 (quote (any any any any)))))) ($sc-dispatch tmp1312
(quote (any any any))))) e1307))) (global-extend246 (quote begin) (quote begin)
(quote ())) (global-extend246 (quote define) (quote define) (quote ()))
(global-extend246 (quote define-syntax) (quote define-syntax) (quote ()))
(global-extend246 (quote eval-when) (quote eval-when) (quote ()))
(global-extend246 (quote core) (quote syntax-case) (letrec
((gen-syntax-case1325 (lambda (x1326 keys1327 clauses1328 r1329 mod1330) (if
(null? clauses1328) (build-application215 #f (build-primref225 #f (quote
syntax-violation)) (list (build-data226 #f #f) (build-data226 #f "source
expression failed to match any pattern") x1326)) ((lambda (tmp1331) ((lambda
(tmp1332) (if tmp1332 (apply (lambda (pat1333 exp1334) (if (if (id?248 pat1333)
(and-map (lambda (x1335) (not (free-id=?271 pat1333 x1335))) (cons (quote
#(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause
build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source 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 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 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)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "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))) keys1327)) #f) (let ((labels1336
(list (gen-label253))) (var1337 (gen-var295 pat1333))) (build-application215 #f
(build-lambda224 #f (list (syntax->datum pat1333)) (list var1337) #f (chi284
exp1334 (extend-env242 labels1336 (list (cons (quote syntax) (cons var1337 0)))
r1329) (make-binding-wrap265 (list pat1333) labels1336 (quote (()))) mod1330))
(list x1326))) (gen-clause1324 x1326 keys1327 (cdr clauses1328) r1329 pat1333
#t exp1334 mod1330))) tmp1332) ((lambda (tmp1338) (if tmp1338 (apply (lambda
(pat1339 fender1340 exp1341) (gen-clause1324 x1326 keys1327 (cdr clauses1328)
r1329 pat1339 fender1340 exp1341 mod1330)) tmp1338) ((lambda (_1342)
(syntax-violation (quote syntax-case) "invalid clause" (car clauses1328)))
tmp1331))) ($sc-dispatch tmp1331 (quote (any any any)))))) ($sc-dispatch
tmp1331 (quote (any any))))) (car clauses1328))))) (gen-clause1324 (lambda
(x1343 keys1344 clauses1345 r1346 pat1347 fender1348 exp1349 mod1350)
(call-with-values (lambda () (convert-pattern1322 pat1347 keys1344)) (lambda
(p1351 pvars1352) (if (not (distinct-bound-ids?274 (map car pvars1352)))
(syntax-violation (quote syntax-case) "duplicate pattern variable" pat1347) (if
(not (and-map (lambda (x1353) (not (ellipsis?293 (car x1353)))) pvars1352))
(syntax-violation (quote syntax-case) "misplaced ellipsis" pat1347) (let
((y1354 (gen-var295 (quote tmp)))) (build-application215 #f (build-lambda224 #f
(list (quote tmp)) (list y1354) #f (let ((y1355 (build-lexical-reference217
(quote value) #f (quote tmp) y1354))) (build-conditional216 #f ((lambda
(tmp1356) ((lambda (tmp1357) (if tmp1357 (apply (lambda () y1355) tmp1357)
((lambda (_1358) (build-conditional216 #f y1355 (build-dispatch-call1323
pvars1352 fender1348 y1355 r1346 mod1350) (build-data226 #f #f))) tmp1356)))
($sc-dispatch tmp1356 (quote #(atom #t))))) fender1348)
(build-dispatch-call1323 pvars1352 exp1349 y1355 r1346 mod1350)
(gen-syntax-case1325 x1343 keys1344 clauses1345 r1346 mod1350)))) (list (if
(eq? p1351 (quote any)) (build-application215 #f (build-primref225 #f (quote
list)) (list x1343)) (build-application215 #f (build-primref225 #f (quote
$sc-dispatch)) (list x1343 (build-data226 #f p1351)))))))))))))
(build-dispatch-call1323 (lambda (pvars1359 exp1360 y1361 r1362 mod1363) (let
((ids1364 (map car pvars1359)) (levels1365 (map cdr pvars1359))) (let
((labels1366 (gen-labels254 ids1364)) (new-vars1367 (map gen-var295 ids1364)))
(build-application215 #f (build-primref225 #f (quote apply)) (list
(build-lambda224 #f (map syntax->datum ids1364) new-vars1367 #f (chi284 exp1360
(extend-env242 labels1366 (map (lambda (var1368 level1369) (cons (quote syntax)
(cons var1368 level1369))) new-vars1367 (map cdr pvars1359)) r1362)
(make-binding-wrap265 ids1364 labels1366 (quote (()))) mod1363)) y1361))))))
(convert-pattern1322 (lambda (pattern1370 keys1371) (letrec ((cvt1372 (lambda
(p1373 n1374 ids1375) (if (id?248 p1373) (if (bound-id-member?275 p1373
keys1371) (values (vector (quote free-id) p1373) ids1375) (values (quote any)
(cons (cons p1373 n1374) ids1375))) ((lambda (tmp1376) ((lambda (tmp1377) (if
(if tmp1377 (apply (lambda (x1378 dots1379) (ellipsis?293 dots1379)) tmp1377)
#f) (apply (lambda (x1380 dots1381) (call-with-values (lambda () (cvt1372 x1380
(fx+206 n1374 1) ids1375)) (lambda (p1382 ids1383) (values (if (eq? p1382
(quote any)) (quote each-any) (vector (quote each) p1382)) ids1383)))) tmp1377)
((lambda (tmp1384) (if tmp1384 (apply (lambda (x1385 y1386) (call-with-values
(lambda () (cvt1372 y1386 n1374 ids1375)) (lambda (y1387 ids1388)
(call-with-values (lambda () (cvt1372 x1385 n1374 ids1388)) (lambda (x1389
ids1390) (values (cons x1389 y1387) ids1390)))))) tmp1384) ((lambda (tmp1391)
(if tmp1391 (apply (lambda () (values (quote ()) ids1375)) tmp1391) ((lambda
(tmp1392) (if tmp1392 (apply (lambda (x1393) (call-with-values (lambda ()
(cvt1372 x1393 n1374 ids1375)) (lambda (p1395 ids1396) (values (vector (quote
vector) p1395) ids1396)))) tmp1392) ((lambda (x1397) (values (vector (quote
atom) (strip294 p1373 (quote (())))) ids1375)) tmp1376))) ($sc-dispatch tmp1376
(quote #(vector each-any)))))) ($sc-dispatch tmp1376 (quote ())))))
($sc-dispatch tmp1376 (quote (any . any)))))) ($sc-dispatch tmp1376 (quote (any
any))))) p1373))))) (cvt1372 pattern1370 0 (quote ())))))) (lambda (e1398 r1399
w1400 s1401 mod1402) (let ((e1403 (source-wrap277 e1398 w1400 s1401 mod1402)))
((lambda (tmp1404) ((lambda (tmp1405) (if tmp1405 (apply (lambda (_1406 val1407
key1408 m1409) (if (and-map (lambda (x1410) (if (id?248 x1410) (not
(ellipsis?293 x1410)) #f)) key1408) (let ((x1412 (gen-var295 (quote tmp))))
(build-application215 s1401 (build-lambda224 #f (list (quote tmp)) (list x1412)
#f (gen-syntax-case1325 (build-lexical-reference217 (quote value) #f (quote
tmp) x1412) key1408 m1409 r1399 mod1402)) (list (chi284 val1407 r1399 (quote
(())) mod1402)))) (syntax-violation (quote syntax-case) "invalid literals list"
e1403))) tmp1405) (syntax-violation #f "source expression failed to match any
pattern" tmp1404))) ($sc-dispatch tmp1404 (quote (any any each-any .
each-any))))) e1403))))) (set! sc-expand (lambda (x1416 . rest1415) (if (if
(pair? x1416) (equal? (car x1416) noexpand204) #f) (cadr x1416) (let ((m1417
(if (null? rest1415) (quote e) (car rest1415))) (esew1418 (if (let ((t1419
(null? rest1415))) (if t1419 t1419 (null? (cdr rest1415)))) (quote (eval))
(cadr rest1415)))) (with-fluid* *mode*205 m1417 (lambda () (chi-top283 x1416
(quote ()) (quote ((top))) m1417 esew1418 (cons (quote hygiene) (module-name
(current-module)))))))))) (set! identifier? (lambda (x1420) (nonsymbol-id?247
x1420))) (set! datum->syntax (lambda (id1421 datum1422) (make-syntax-object231
datum1422 (syntax-object-wrap234 id1421) #f))) (set! syntax->datum (lambda
(x1423) (strip294 x1423 (quote (()))))) (set! generate-temporaries (lambda
(ls1424) (begin (let ((x1425 ls1424)) (if (not (list? x1425)) (syntax-violation
(quote generate-temporaries) "invalid argument" x1425))) (map (lambda (x1426)
(wrap276 (gensym) (quote ((top))) #f)) ls1424)))) (set! free-identifier=?
(lambda (x1427 y1428) (begin (let ((x1429 x1427)) (if (not (nonsymbol-id?247
x1429)) (syntax-violation (quote free-identifier=?) "invalid argument" x1429)))
(let ((x1430 y1428)) (if (not (nonsymbol-id?247 x1430)) (syntax-violation
(quote free-identifier=?) "invalid argument" x1430))) (free-id=?271 x1427
y1428)))) (set! bound-identifier=? (lambda (x1431 y1432) (begin (let ((x1433
x1431)) (if (not (nonsymbol-id?247 x1433)) (syntax-violation (quote
bound-identifier=?) "invalid argument" x1433))) (let ((x1434 y1432)) (if (not
(nonsymbol-id?247 x1434)) (syntax-violation (quote bound-identifier=?) "invalid
argument" x1434))) (bound-id=?272 x1431 y1432)))) (set! syntax-violation
(lambda (who1438 message1437 form1436 . subform1435) (begin (let ((x1439
who1438)) (if (not ((lambda (x1440) (let ((t1441 (not x1440))) (if t1441 t1441
(let ((t1442 (string? x1440))) (if t1442 t1442 (symbol? x1440)))))) x1439))
(syntax-violation (quote syntax-violation) "invalid argument" x1439))) (let
((x1443 message1437)) (if (not (string? x1443)) (syntax-violation (quote
syntax-violation) "invalid argument" x1443))) (scm-error (quote syntax-error)
(quote sc-expand) (string-append (if who1438 "~a: " "") "~a " (if (null?
subform1435) "in ~a" "in subform `~s' of `~s'")) (let ((tail1444 (cons
message1437 (map (lambda (x1445) (strip294 x1445 (quote (())))) (append
subform1435 (list form1436)))))) (if who1438 (cons who1438 tail1444) tail1444))
#f)))) (letrec ((match1450 (lambda (e1451 p1452 w1453 r1454 mod1455) (if (not
r1454) #f (if (eq? p1452 (quote any)) (cons (wrap276 e1451 w1453 mod1455)
r1454) (if (syntax-object?232 e1451) (match*1449 (syntax-object-expression233
e1451) p1452 (join-wraps267 w1453 (syntax-object-wrap234 e1451)) r1454
(syntax-object-module235 e1451)) (match*1449 e1451 p1452 w1453 r1454
mod1455)))))) (match*1449 (lambda (e1456 p1457 w1458 r1459 mod1460) (if (null?
p1457) (if (null? e1456) r1459 #f) (if (pair? p1457) (if (pair? e1456)
(match1450 (car e1456) (car p1457) w1458 (match1450 (cdr e1456) (cdr p1457)
w1458 r1459 mod1460) mod1460) #f) (if (eq? p1457 (quote each-any)) (let ((l1461
(match-each-any1447 e1456 w1458 mod1460))) (if l1461 (cons l1461 r1459) #f))
(let ((atom-key1462 (vector-ref p1457 0))) (if (memv atom-key1462 (quote
(each))) (if (null? e1456) (match-empty1448 (vector-ref p1457 1) r1459) (let
((l1463 (match-each1446 e1456 (vector-ref p1457 1) w1458 mod1460))) (if l1463
(letrec ((collect1464 (lambda (l1465) (if (null? (car l1465)) r1459 (cons (map
car l1465) (collect1464 (map cdr l1465))))))) (collect1464 l1463)) #f))) (if
(memv atom-key1462 (quote (free-id))) (if (id?248 e1456) (if (free-id=?271
(wrap276 e1456 w1458 mod1460) (vector-ref p1457 1)) r1459 #f) #f) (if (memv
atom-key1462 (quote (atom))) (if (equal? (vector-ref p1457 1) (strip294 e1456
w1458)) r1459 #f) (if (memv atom-key1462 (quote (vector))) (if (vector? e1456)
(match1450 (vector->list e1456) (vector-ref p1457 1) w1458 r1459 mod1460)
#f))))))))))) (match-empty1448 (lambda (p1466 r1467) (if (null? p1466) r1467
(if (eq? p1466 (quote any)) (cons (quote ()) r1467) (if (pair? p1466)
(match-empty1448 (car p1466) (match-empty1448 (cdr p1466) r1467)) (if (eq?
p1466 (quote each-any)) (cons (quote ()) r1467) (let ((atom-key1468 (vector-ref
p1466 0))) (if (memv atom-key1468 (quote (each))) (match-empty1448 (vector-ref
p1466 1) r1467) (if (memv atom-key1468 (quote (free-id atom))) r1467 (if (memv
atom-key1468 (quote (vector))) (match-empty1448 (vector-ref p1466 1)
r1467))))))))))) (match-each-any1447 (lambda (e1469 w1470 mod1471) (if (pair?
e1469) (let ((l1472 (match-each-any1447 (cdr e1469) w1470 mod1471))) (if l1472
(cons (wrap276 (car e1469) w1470 mod1471) l1472) #f)) (if (null? e1469) (quote
()) (if (syntax-object?232 e1469) (match-each-any1447
(syntax-object-expression233 e1469) (join-wraps267 w1470 (syntax-object-wrap234
e1469)) mod1471) #f))))) (match-each1446 (lambda (e1473 p1474 w1475 mod1476)
(if (pair? e1473) (let ((first1477 (match1450 (car e1473) p1474 w1475 (quote
()) mod1476))) (if first1477 (let ((rest1478 (match-each1446 (cdr e1473) p1474
w1475 mod1476))) (if rest1478 (cons first1477 rest1478) #f)) #f)) (if (null?
e1473) (quote ()) (if (syntax-object?232 e1473) (match-each1446
(syntax-object-expression233 e1473) p1474 (join-wraps267 w1475
(syntax-object-wrap234 e1473)) (syntax-object-module235 e1473)) #f)))))) (set!
$sc-dispatch (lambda (e1479 p1480) (if (eq? p1480 (quote any)) (list e1479) (if
(syntax-object?232 e1479) (match*1449 (syntax-object-expression233 e1479) p1480
(syntax-object-wrap234 e1479) (quote ()) (syntax-object-module235 e1479))
(match*1449 e1479 p1480 (quote (())) (quote ()) #f)))))))))
+(define with-syntax (make-syncase-macro (quote macro) (lambda (x1481) ((lambda
(tmp1482) ((lambda (tmp1483) (if tmp1483 (apply (lambda (_1484 e11485 e21486)
(cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (cons e11485 e21486))) tmp1483) ((lambda (tmp1488) (if
tmp1488 (apply (lambda (_1489 out1490 in1491 e11492 e21493) (list (quote
#(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) in1491 (quote ()) (list out1490 (cons
(quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) (cons e11492 e21493))))) tmp1488) ((lambda
(tmp1495) (if tmp1495 (apply (lambda (_1496 out1497 in1498 e11499 e21500) (list
(quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top)
(top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list
((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) in1498) (quote ()) (list out1497 (cons (quote #(syntax-object begin
((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) (cons e11499 e21500))))) tmp1495) (syntax-violation #f "source
expression failed to match any pattern" tmp1482))) ($sc-dispatch tmp1482 (quote
(any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any
((any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any () any .
each-any))))) x1481))))
+(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1504)
((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (_1507 k1508
keyword1509 pattern1510 template1511) (list (quote #(syntax-object lambda
((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k
keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))
(cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern
template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage ()
() ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote
#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top)
(top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) (cons k1508 (map (lambda (tmp1514
tmp1513) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k
keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
tmp1513) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword
pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
tmp1514))) template1511 pattern1510)))))) tmp1506) (syntax-violation #f "source
expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote
(any each-any . #(each ((any . any) any))))))) x1504))))
+(define let* (make-extended-syncase-macro (module-ref (current-module) (quote
let*)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if
(if tmp1517 (apply (lambda (let*1518 x1519 v1520 e11521 e21522) (and-map
identifier? x1519)) tmp1517) #f) (apply (lambda (let*1524 x1525 v1526 e11527
e21528) (letrec ((f1529 (lambda (bindings1530) (if (null? bindings1530) (cons
(quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings)
#((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11527 e21528)))
((lambda (tmp1534) ((lambda (tmp1535) (if tmp1535 (apply (lambda (body1536
binding1537) (list (quote #(syntax-object let ((top) #(ribcage #(body binding)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top)
(top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top))
#("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (list binding1537) body1536)) tmp1535) (syntax-violation #f
"source expression failed to match any pattern" tmp1534))) ($sc-dispatch
tmp1534 (quote (any any))))) (list (f1529 (cdr bindings1530)) (car
bindings1530))))))) (f1529 (map list x1525 v1526)))) tmp1517) (syntax-violation
#f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch
tmp1516 (quote (any #(each (any any)) any . each-any))))) x1515))))
+(define do (make-extended-syncase-macro (module-ref (current-module) (quote
do)) (quote macro) (lambda (orig-x1538) ((lambda (tmp1539) ((lambda (tmp1540)
(if tmp1540 (apply (lambda (_1541 var1542 init1543 step1544 e01545 e11546
c1547) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda
(step1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda ()
(list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i"))
#(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x)
#((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top)
#(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top)
(top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list
var1542 init1543) (list (quote #(syntax-object if ((top) #(ribcage #(step)
#((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote
#(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var
init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i"
"i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(hygiene guile))) e01545) (cons (quote #(syntax-object begin ((top) #(ribcage
#(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top)
(top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () ()
()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1547 (list
(cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i"))
#(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x)
#((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1552) ((lambda (tmp1557)
(if tmp1557 (apply (lambda (e11558 e21559) (list (quote #(syntax-object let
((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top))
#("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop
((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top))
#("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1542 init1543) (list
(quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i"))
#(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top)
(top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01545 (cons
(quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i"
"i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c)
#((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile)))
(cons e11558 e21559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1
e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_
var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(hygiene guile))) (append c1547 (list (cons (quote #(syntax-object doloop
((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top))
#("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(orig-x) #((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1557)
(syntax-violation #f "source expression failed to match any pattern" tmp1551)))
($sc-dispatch tmp1551 (quote (any . each-any)))))) ($sc-dispatch tmp1551 (quote
())))) e11546)) tmp1549) (syntax-violation #f "source expression failed to
match any pattern" tmp1548))) ($sc-dispatch tmp1548 (quote each-any)))) (map
(lambda (v1566 s1567) ((lambda (tmp1568) ((lambda (tmp1569) (if tmp1569 (apply
(lambda () v1566) tmp1569) ((lambda (tmp1570) (if tmp1570 (apply (lambda
(e1571) e1571) tmp1570) ((lambda (_1572) (syntax-violation (quote do) "bad step
expression" orig-x1538 s1567)) tmp1568))) ($sc-dispatch tmp1568 (quote
(any)))))) ($sc-dispatch tmp1568 (quote ())))) s1567)) var1542 step1544)))
tmp1540) (syntax-violation #f "source expression failed to match any pattern"
tmp1539))) ($sc-dispatch tmp1539 (quote (any #(each (any any . any)) (any .
each-any) . each-any))))) orig-x1538))))
+(define quasiquote (make-extended-syncase-macro (module-ref (current-module)
(quote quasiquote)) (quote macro) (letrec ((quasicons1575 (lambda (x1579 y1580)
((lambda (tmp1581) ((lambda (tmp1582) (if tmp1582 (apply (lambda (x1583 y1584)
((lambda (tmp1585) ((lambda (tmp1586) (if tmp1586 (apply (lambda (dy1587)
((lambda (tmp1588) ((lambda (tmp1589) (if tmp1589 (apply (lambda (dx1590) (list
(quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage
#(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage ()
() ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile))) (cons dx1590 dy1587))) tmp1589) ((lambda
(_1591) (if (null? dy1587) (list (quote #(syntax-object list ((top) #(ribcage
#(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y)
#((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi)
#((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583) (list
(quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage
#(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage ()
() ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile))) x1583 y1584))) tmp1588))) ($sc-dispatch
tmp1588 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top))
#("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage
#(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i"
"i" "i"))) (hygiene guile))) any))))) x1583)) tmp1586) ((lambda (tmp1592) (if
tmp1592 (apply (lambda (stuff1593) (cons (quote #(syntax-object list ((top)
#(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i"
"i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top)
(top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1583 stuff1593))) tmp1592)
((lambda (else1594) (list (quote #(syntax-object cons ((top) #(ribcage #(else)
#((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage
#(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i"
"i" "i"))) (hygiene guile))) x1583 y1584)) tmp1585))) ($sc-dispatch tmp1585
(quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top)
(top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any))))))
($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object quote ((top) #(ribcage
#(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend
quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene
guile))) any))))) y1584)) tmp1582) (syntax-violation #f "source expression
failed to match any pattern" tmp1581))) ($sc-dispatch tmp1581 (quote (any
any))))) (list x1579 y1580)))) (quasiappend1576 (lambda (x1595 y1596) ((lambda
(tmp1597) ((lambda (tmp1598) (if tmp1598 (apply (lambda (x1599 y1600) ((lambda
(tmp1601) ((lambda (tmp1602) (if tmp1602 (apply (lambda () x1599) tmp1602)
((lambda (_1603) (list (quote #(syntax-object append ((top) #(ribcage #(_)
#((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage
#(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i"
"i" "i"))) (hygiene guile))) x1599 y1600)) tmp1601))) ($sc-dispatch tmp1601
(quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top)
(top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1600))
tmp1598) (syntax-violation #f "source expression failed to match any pattern"
tmp1597))) ($sc-dispatch tmp1597 (quote (any any))))) (list x1595 y1596))))
(quasivector1577 (lambda (x1604) ((lambda (tmp1605) ((lambda (x1606) ((lambda
(tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (x1609) (list (quote
#(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x)
#((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector
x1609))) tmp1608) ((lambda (tmp1611) (if tmp1611 (apply (lambda (x1612) (cons
(quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage
#(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1612)) tmp1611)
((lambda (_1614) (list (quote #(syntax-object list->vector ((top) #(ribcage
#(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) x1606)) tmp1607))) ($sc-dispatch tmp1607 (quote (#(free-id
#(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) . each-any)))))) ($sc-dispatch tmp1607 (quote (#(free-id
#(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) each-any))))) x1606)) tmp1605)) x1604))) (quasi1578 (lambda
(p1615 lev1616) ((lambda (tmp1617) ((lambda (tmp1618) (if tmp1618 (apply
(lambda (p1619) (if (= lev1616 0) p1619 (quasicons1575 (quote (#(syntax-object
quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p
lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))
#(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile)))) (quasi1578 (list p1619) (- lev1616 1))))) tmp1618) ((lambda
(tmp1620) (if (if tmp1620 (apply (lambda (args1621) (= lev1616 0)) tmp1620) #f)
(apply (lambda (args1622) (syntax-violation (quote unquote) "unquote takes
exactly one argument" p1615 (cons (quote #(syntax-object unquote ((top)
#(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev)
#((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi)
#((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1622)))
tmp1620) ((lambda (tmp1623) (if tmp1623 (apply (lambda (p1624 q1625) (if (=
lev1616 0) (quasiappend1576 p1624 (quasi1578 q1625 lev1616)) (quasicons1575
(quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i"
"i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top)
(top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing
((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend
quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene
guile)))) (quasi1578 (list p1624) (- lev1616 1))) (quasi1578 q1625 lev1616))))
tmp1623) ((lambda (tmp1626) (if (if tmp1626 (apply (lambda (args1627 q1628) (=
lev1616 0)) tmp1626) #f) (apply (lambda (args1629 q1630) (syntax-violation
(quote unquote-splicing) "unquote-splicing takes exactly one argument" p1615
(cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top)
(top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1629))) tmp1626)
((lambda (tmp1631) (if tmp1631 (apply (lambda (p1632) (quasicons1575 (quote
(#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1632) (+ lev1616
1)))) tmp1631) ((lambda (tmp1633) (if tmp1633 (apply (lambda (p1634 q1635)
(quasicons1575 (quasi1578 p1634 lev1616) (quasi1578 q1635 lev1616))) tmp1633)
((lambda (tmp1636) (if tmp1636 (apply (lambda (x1637) (quasivector1577
(quasi1578 x1637 lev1616))) tmp1636) ((lambda (p1639) (list (quote
#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) p1639)) tmp1617))) ($sc-dispatch tmp1617 (quote #(vector
each-any)))))) ($sc-dispatch tmp1617 (quote (any . any)))))) ($sc-dispatch
tmp1617 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ())
#(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend
quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene
guile))) any)))))) ($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object
unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top))
#("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top)
(top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any))))))
($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object unquote-splicing
((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1617
(quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage
#(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend
quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene
guile))) . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object
unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i"
"i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top)
(top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1615)))) (lambda
(x1640) ((lambda (tmp1641) ((lambda (tmp1642) (if tmp1642 (apply (lambda (_1643
e1644) (quasi1578 e1644 0)) tmp1642) (syntax-violation #f "source expression
failed to match any pattern" tmp1641))) ($sc-dispatch tmp1641 (quote (any
any))))) x1640)))))
+(define include (make-syncase-macro (quote macro) (lambda (x1645) (letrec
((read-file1646 (lambda (fn1647 k1648) (let ((p1649 (open-input-file fn1647)))
(letrec ((f1650 (lambda (x1651) (if (eof-object? x1651) (begin
(close-input-port p1649) (quote ())) (cons (datum->syntax k1648 x1651) (f1650
(read p1649))))))) (f1650 (read p1649))))))) ((lambda (tmp1652) ((lambda
(tmp1653) (if tmp1653 (apply (lambda (k1654 filename1655) (let ((fn1656
(syntax->datum filename1655))) ((lambda (tmp1657) ((lambda (tmp1658) (if
tmp1658 (apply (lambda (exp1659) (cons (quote #(syntax-object begin ((top)
#(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i"
"i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) exp1659)) tmp1658) (syntax-violation #f "source expression
failed to match any pattern" tmp1657))) ($sc-dispatch tmp1657 (quote
each-any)))) (read-file1646 fn1656 k1654)))) tmp1653) (syntax-violation #f
"source expression failed to match any pattern" tmp1652))) ($sc-dispatch
tmp1652 (quote (any any))))) x1645)))))
+(define unquote (make-syncase-macro (quote macro) (lambda (x1661) ((lambda
(tmp1662) ((lambda (tmp1663) (if tmp1663 (apply (lambda (_1664 e1665)
(syntax-violation (quote unquote) "expression not valid outside of quasiquote"
x1661)) tmp1663) (syntax-violation #f "source expression failed to match any
pattern" tmp1662))) ($sc-dispatch tmp1662 (quote (any any))))) x1661))))
+(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1666)
((lambda (tmp1667) ((lambda (tmp1668) (if tmp1668 (apply (lambda (_1669 e1670)
(syntax-violation (quote unquote-splicing) "expression not valid outside of
quasiquote" x1666)) tmp1668) (syntax-violation #f "source expression failed to
match any pattern" tmp1667))) ($sc-dispatch tmp1667 (quote (any any)))))
x1666))))
+(define case (make-extended-syncase-macro (module-ref (current-module) (quote
case)) (quote macro) (lambda (x1671) ((lambda (tmp1672) ((lambda (tmp1673) (if
tmp1673 (apply (lambda (_1674 e1675 m11676 m21677) ((lambda (tmp1678) ((lambda
(body1679) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top))
#("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list
(list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1675)) body1679))
tmp1678)) (letrec ((f1680 (lambda (clause1681 clauses1682) (if (null?
clauses1682) ((lambda (tmp1684) ((lambda (tmp1685) (if tmp1685 (apply (lambda
(e11686 e21687) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (cons e11686 e21687))) tmp1685) ((lambda (tmp1689) (if
tmp1689 (apply (lambda (k1690 e11691 e21692) (list (quote #(syntax-object if
((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage ()
() ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote
#(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top))
#("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
(quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top)
(top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) k1690)) (cons (quote #(syntax-object begin ((top) #(ribcage
#(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage
#(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2)
#((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) (cons e11691 e21692)))) tmp1689)
((lambda (_1695) (syntax-violation (quote case) "bad clause" x1671 clause1681))
tmp1684))) ($sc-dispatch tmp1684 (quote (each-any any . each-any))))))
($sc-dispatch tmp1684 (quote (#(free-id #(syntax-object else ((top) #(ribcage
() () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any .
each-any))))) clause1681) ((lambda (tmp1696) ((lambda (rest1697) ((lambda
(tmp1698) ((lambda (tmp1699) (if tmp1699 (apply (lambda (k1700 e11701 e21702)
(list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
#(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object
memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
#(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top)
(top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote
#(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f
clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2)
#((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) k1700)) (cons (quote #(syntax-object
begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause
clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top)
(top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) (cons e11701 e21702)) rest1697)) tmp1699)
((lambda (_1705) (syntax-violation (quote case) "bad clause" x1671 clause1681))
tmp1698))) ($sc-dispatch tmp1698 (quote (each-any any . each-any)))))
clause1681)) tmp1696)) (f1680 (car clauses1682) (cdr clauses1682))))))) (f1680
m11676 m21677)))) tmp1673) (syntax-violation #f "source expression failed to
match any pattern" tmp1672))) ($sc-dispatch tmp1672 (quote (any any any .
each-any))))) x1671))))
+(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1706)
((lambda (tmp1707) ((lambda (tmp1708) (if tmp1708 (apply (lambda (_1709 e1710)
(list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))
(list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
(quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list
(quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
e1710)) (list (cons _1709 (quote (#(syntax-object x ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (cons e1710 (quote (#(syntax-object x ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile)))))))))) tmp1708) (syntax-violation #f "source expression failed to
match any pattern" tmp1707))) ($sc-dispatch tmp1707 (quote (any any)))))
x1706))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 00ce0b9..c2668c0 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -22,6 +22,9 @@
;;; Extracted from Chez Scheme Version 5.9f
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
+;;; Modified by Andy Wingo <address@hidden> according to the Git
+;;; revision control logs corresponding to this file: 2009.
+
;;; Modified by Mikael Djurfeldt <address@hidden> according
;;; to the ChangeLog distributed in the same directory as this file:
;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
@@ -81,44 +84,12 @@
;;; Revision 3, for a complete description)
;;; (syntax-violation who message form [subform])
;;; used to report errors found during expansion
-;;; (install-global-transformer symbol value)
-;;; used by expanded code to install top-level syntactic abstractions
;;; ($sc-dispatch e p)
;;; used by expanded code to handle syntax-case matching
;;; The following nonstandard procedures must be provided by the
-;;; implementation for this code to run.
-;;;
-;;; (void)
-;;; returns the implementation's cannonical "unspecified value". This
-;;; usually works: (define void (lambda () (if #f #f))).
-;;;
-;;; (andmap proc list1 list2 ...)
-;;; returns true if proc returns true when applied to each element of list1
-;;; along with the corresponding elements of list2 ....
-;;; The following definition works but does no error checking:
-;;;
-;;; (define andmap
-;;; (lambda (f first . rest)
-;;; (or (null? first)
-;;; (if (null? rest)
-;;; (let andmap ((first first))
-;;; (let ((x (car first)) (first (cdr first)))
-;;; (if (null? first)
-;;; (f x)
-;;; (and (f x) (andmap first)))))
-;;; (let andmap ((first first) (rest rest))
-;;; (let ((x (car first))
-;;; (xr (map car rest))
-;;; (first (cdr first))
-;;; (rest (map cdr rest)))
-;;; (if (null? first)
-;;; (apply f (cons x xr))
-;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
-;;;
-;;; The following nonstandard procedures must also be provided by the
;;; implementation for this code to run using the standard portable
-;;; hooks and output constructors. They are not used by expanded code,
+;;; hooks and output constructors. They are not used by expanded code,
;;; and so need be present only at expansion time.
;;;
;;; (eval x)
@@ -134,21 +105,8 @@
;;; by eval, and eval accepts one argument, nothing special must be done
;;; to support the "noexpand" flag, since it is handled by sc-expand.
;;;
-;;; (error who format-string why what)
-;;; where who is either a symbol or #f, format-string is always "~a ~s",
-;;; why is always a string, and what may be any object. error should
-;;; signal an error with a message something like
-;;;
-;;; "error in <who>: <why> <what>"
-;;;
;;; (gensym)
;;; returns a unique symbol each time it's called
-;;;
-;;; (putprop symbol key value)
-;;; (getprop symbol key)
-;;; key is always the symbol *sc-expander*; value may be any object.
-;;; putprop should associate the given value with the given symbol in
-;;; some way that it can be retrieved later with getprop.
;;; When porting to a new Scheme implementation, you should define the
;;; procedures listed above, load the expanded version of psyntax.ss
@@ -233,19 +191,6 @@
;;; The implementation of generate-temporaries assumes that it is possible
;;; to generate globally unique symbols (gensyms).
-;;; The input to sc-expand may contain "annotations" describing, e.g., the
-;;; source file and character position from where each object was read if
-;;; it was read from a file. These annotations are handled properly by
-;;; sc-expand only if the annotation? hook (see hooks below) is implemented
-;;; properly and the operators make-annotation, annotation-expression,
-;;; annotation-source, annotation-stripped, and set-annotation-stripped!
-;;; are supplied. If annotations are supplied, the proper annotation
-;;; source is passed to the various output constructors, allowing
-;;; implementations to accurately correlate source and expanded code.
-;;; Contact one of the authors for details if you wish to make use of
-;;; this feature.
-
-
;;; Bootstrapping:
@@ -260,6 +205,25 @@
(set-current-module (resolve-module '(guile))))
(let ()
+;;; Private version of and-map that handles multiple lists.
+(define and-map*
+ (lambda (f first . rest)
+ (or (null? first)
+ (if (null? rest)
+ (let andmap ((first first))
+ (let ((x (car first)) (first (cdr first)))
+ (if (null? first)
+ (f x)
+ (and (f x) (andmap first)))))
+ (let andmap ((first first) (rest rest))
+ (let ((x (car first))
+ (xr (map car rest))
+ (first (cdr first))
+ (rest (map cdr rest)))
+ (if (null? first)
+ (apply f (cons x xr))
+ (and (apply f (cons x xr)) (andmap first rest)))))))))
+
(define-syntax define-structure
(lambda (x)
(define construct-name
@@ -275,7 +239,7 @@
args))))))
(syntax-case x ()
((_ (name id1 ...))
- (andmap identifier? (syntax (name id1 ...)))
+ (and-map identifier? (syntax (name id1 ...)))
(with-syntax
((constructor (construct-name (syntax name) "make-" (syntax name)))
(predicate (construct-name (syntax name) (syntax name) "?"))
@@ -313,6 +277,7 @@
(let ()
(define noexpand "noexpand")
+(define *mode* (make-fluid))
;;; hooks to nonportable run-time helpers
(begin
@@ -323,15 +288,19 @@
(define top-level-eval-hook
(lambda (x mod)
- (primitive-eval `(,noexpand ,x))))
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
(define local-eval-hook
(lambda (x mod)
- (primitive-eval `(,noexpand ,x))))
-
-(define error-hook
- (lambda (who why what)
- (error who "~a ~s" why what)))
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
(define-syntax gensym-hook
(syntax-rules ()
@@ -339,148 +308,235 @@
(define put-global-definition-hook
(lambda (symbol type val)
- (module-define-keyword! (current-module) symbol type val)))
-
-(define remove-global-definition-hook
- (lambda (symbol)
- (module-undefine-keyword! (current-module) symbol)))
+ (let ((existing (let ((v (module-variable (current-module) symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val)
+ (not (syncase-macro-type val))
+ val))))))
+ (module-define! (current-module)
+ symbol
+ (if existing
+ (make-extended-syncase-macro existing type val)
+ (make-syncase-macro type val))))))
(define get-global-definition-hook
(lambda (symbol module)
(if (and (not module) (current-module))
(warn "module system is booted, we should have a module" symbol))
- (module-lookup-keyword (if module (resolve-module (cdr module))
- (current-module))
- symbol)))
+ (let ((v (module-variable (if module
+ (resolve-module (cdr module))
+ (current-module))
+ symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val) (syncase-macro-type val)
+ (cons (syncase-macro-type val)
+ (syncase-macro-binding val))))))))
)
;;; output constructors
-(define (build-annotated src exp)
- (if (and src (not (annotation? exp)))
- (make-annotation exp src #t)
- exp))
-
-(define-syntax build-application
- (syntax-rules ()
- ((_ source fun-exp arg-exps)
- (build-annotated source `(,fun-exp . ,arg-exps)))))
-
-(define-syntax build-conditional
- (syntax-rules ()
- ((_ source test-exp then-exp else-exp)
- (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
-
-(define-syntax build-lexical-reference
- (syntax-rules ()
- ((_ type source var)
- (build-annotated source var))))
-
-(define-syntax build-lexical-assignment
- (syntax-rules ()
- ((_ source var exp)
- (build-annotated source `(set! ,var ,exp)))))
-
-(define-syntax build-global-reference
- (syntax-rules ()
- ((_ source var mod)
- (build-annotated
- source
- (if mod
- (make-module-ref (cdr mod) var (car mod))
- (make-module-ref mod var 'bare))))))
-
-(define-syntax build-global-assignment
- (syntax-rules ()
- ((_ source var exp mod)
- (build-annotated source
- `(set! ,(if mod
- (make-module-ref (cdr mod) var (car mod))
- (make-module-ref mod var 'bare))
- ,exp)))))
-
-(define-syntax build-global-definition
- (syntax-rules ()
- ((_ source var exp mod)
- (build-annotated source `(define ,var ,exp)))))
-
-(define-syntax build-lambda
- (syntax-rules ()
- ((_ src vars docstring exp)
- (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
- ,exp)))
- ((_ src vars exp)
- (build-annotated src `(lambda ,vars ,exp)))))
-
-;; FIXME: wingo: add modules here somehow?
-(define-syntax build-primref
- (syntax-rules ()
- ((_ src name) (build-annotated src name))
- ((_ src level name) (build-annotated src name))))
+(define build-void
+ (lambda (source)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-void) source))
+ (else '(if #f #f)))))
+
+(define build-application
+ (lambda (source fun-exp arg-exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
+ (else `(,fun-exp . ,arg-exps)))))
+
+(define build-conditional
+ (lambda (source test-exp then-exp else-exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-conditional)
+ source test-exp then-exp else-exp))
+ (else (if (equal? else-exp '(if #f #f))
+ `(if ,test-exp ,then-exp)
+ `(if ,test-exp ,then-exp ,else-exp))))))
+
+(define build-lexical-reference
+ (lambda (type source name var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-ref) source name var))
+ (else var))))
+
+(define build-lexical-assignment
+ (lambda (source name var exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
+ (else `(set! ,var ,exp)))))
+
+;; Before modules are booted, we can't expand into data structures from
+;; (language tree-il) -- we need to give the evaluator the
+;; s-expressions that it understands natively. Actually the real truth
+;; of the matter is that the evaluator doesn't understand tree-il
+;; structures at all. So until we fix the evaluator, if ever, the
+;; conflation that we should use tree-il iff we are compiling
+;; holds true.
+;;
+(define (analyze-variable mod var modref-cont bare-cont)
+ (if (not mod)
+ (bare-cont var)
+ (let ((kind (car mod))
+ (mod (cdr mod)))
+ (case kind
+ ((public) (modref-cont mod var #t))
+ ((private) (if (not (equal? mod (module-name (current-module))))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ ((bare) (bare-cont var))
+ ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
+ (module-variable (resolve-module mod) var))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ (else (syntax-violation #f "bad module kind" var mod))))))
+
+(define build-global-reference
+ (lambda (source var mod)
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) source mod var public?))
+ (else (list (if public? '@ '@@) mod var))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) source var))
+ (else var))))))
+
+(define build-global-assignment
+ (lambda (source var exp mod)
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-set) source mod var public?
exp))
+ (else `(set! ,(list (if public? '@ '@@) mod var) ,exp))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
+ (else `(set! ,var ,exp)))))))
+
+;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz)
+;; from working. Hack around it.
+(define (maybe-name-value! name val)
+ (cond
+ (((@ (language tree-il) lambda?) val)
+ (let ((meta ((@ (language tree-il) lambda-meta) val)))
+ (if (not (assq 'name meta))
+ ((setter (@ (language tree-il) lambda-meta))
+ val
+ (acons 'name name meta)))))))
+
+(define build-global-definition
+ (lambda (source var exp)
+ (case (fluid-ref *mode*)
+ ((c)
+ (maybe-name-value! var exp)
+ ((@ (language tree-il) make-toplevel-define) source var exp))
+ (else `(define ,var ,exp)))))
+
+(define build-lambda
+ (lambda (src ids vars docstring exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src ids vars
+ (if docstring `((documentation . ,docstring)) '())
+ exp))
+ (else `(lambda ,vars ,@(if docstring (list docstring) '())
+ ,exp)))))
+
+(define build-primref
+ (lambda (src name)
+ (if (equal? (module-name (current-module)) '(guile))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) src name))
+ (else name))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
+ (else `(@@ (guile) ,name))))))
(define (build-data src exp)
- (if (and (self-evaluating? exp)
- (not (vector? exp)))
- (build-annotated src exp)
- (build-annotated src (list 'quote exp))))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-const) src exp))
+ (else (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp)))))
(define build-sequence
(lambda (src exps)
(if (null? (cdr exps))
- (build-annotated src (car exps))
- (build-annotated src `(begin ,@exps)))))
+ (car exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-sequence) src exps))
+ (else `(begin ,@exps))))))
(define build-let
- (lambda (src vars val-exps body-exp)
+ (lambda (src ids vars val-exps body-exp)
(if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-let) src ids vars val-exps body-exp))
+ (else `(let ,(map list vars val-exps) ,body-exp))))))
(define build-named-let
- (lambda (src vars val-exps body-exp)
- (if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src
- `(let ,(car vars)
- ,(map list (cdr vars) val-exps) ,body-exp)))))
+ (lambda (src ids vars val-exps body-exp)
+ (let ((f (car vars))
+ (f-name (car ids))
+ (vars (cdr vars))
+ (ids (cdr ids)))
+ (case (fluid-ref *mode*)
+ ((c)
+ (let ((proc (build-lambda src ids vars #f body-exp)))
+ (maybe-name-value! f-name proc)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-letrec) src
+ (list f-name) (list f) (list proc)
+ (build-application src (build-lexical-reference 'fun src f-name f)
+ val-exps))))
+ (else `(let ,f ,(map list vars val-exps) ,body-exp))))))
(define build-letrec
- (lambda (src vars val-exps body-exp)
+ (lambda (src ids vars val-exps body-exp)
(if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src
- `(letrec ,(map list vars val-exps) ,body-exp)))))
-
-;; FIXME: wingo: use make-lexical
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
+ (else `(letrec ,(map list vars val-exps) ,body-exp))))))
+
+;; FIXME: wingo: use make-lexical ?
(define-syntax build-lexical-var
(syntax-rules ()
- ((_ src id) (build-annotated src (gensym (symbol->string id))))))
+ ((_ src id) (gensym (symbol->string id)))))
(define-structure (syntax-object expression wrap module))
-(define-syntax unannotate
- (syntax-rules ()
- ((_ x)
- (let ((e x))
- (if (annotation? e)
- (annotation-expression e)
- e)))))
-
(define-syntax no-source (identifier-syntax #f))
(define source-annotation
(lambda (x)
(cond
- ((annotation? x) (annotation-source x))
- ((syntax-object? x) (source-annotation (syntax-object-expression x)))
- (else no-source))))
+ ((syntax-object? x)
+ (source-annotation (syntax-object-expression x)))
+ ((pair? x) (let ((props (source-properties x)))
+ (if (pair? props)
+ props
+ #f)))
+ (else #f))))
(define-syntax arg-check
(syntax-rules ()
((_ pred? e who)
(let ((x e))
- (if (not (pred? x)) (error-hook who "invalid argument" x))))))
+ (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
;;; compile-time environments
@@ -601,29 +657,30 @@
(define nonsymbol-id?
(lambda (x)
(and (syntax-object? x)
- (symbol? (unannotate (syntax-object-expression x))))))
+ (symbol? (syntax-object-expression x)))))
(define id?
(lambda (x)
(cond
((symbol? x) #t)
- ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
- ((annotation? x) (symbol? (annotation-expression x)))
+ ((syntax-object? x) (symbol? (syntax-object-expression x)))
(else #f))))
(define-syntax id-sym-name
(syntax-rules ()
((_ e)
(let ((x e))
- (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
+ (if (syntax-object? x)
+ (syntax-object-expression x)
+ x)))))
(define id-sym-name&marks
(lambda (x w)
(if (syntax-object? x)
(values
- (unannotate (syntax-object-expression x))
- (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
- (values (unannotate x) (wrap-marks w)))))
+ (syntax-object-expression x)
+ (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
+ (values x (wrap-marks w)))))
;;; syntax object wraps
@@ -689,7 +746,7 @@
; must receive ids with complete wraps
(lambda (ribcage id label)
(set-ribcage-symnames! ribcage
- (cons (unannotate (syntax-object-expression id))
+ (cons (syntax-object-expression id)
(ribcage-symnames ribcage)))
(set-ribcage-marks! ribcage
(cons (wrap-marks (syntax-object-wrap id))
@@ -789,7 +846,7 @@
((symbol? id)
(or (first (search id (wrap-subst w) (wrap-marks w))) id))
((syntax-object? id)
- (let ((id (unannotate (syntax-object-expression id)))
+ (let ((id (syntax-object-expression id))
(w1 (syntax-object-wrap id)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
(call-with-values (lambda () (search id (wrap-subst w) marks))
@@ -797,10 +854,7 @@
(or new-id
(first (search id (wrap-subst w1) marks))
id))))))
- ((annotation? id)
- (let ((id (unannotate id)))
- (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
- (else (error-hook 'id-var-name "invalid id" id)))))
+ (else (syntax-violation 'id-var-name "invalid id" id)))))
;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
@@ -817,11 +871,11 @@
(define bound-id=?
(lambda (i j)
(if (and (syntax-object? i) (syntax-object? j))
- (and (eq? (unannotate (syntax-object-expression i))
- (unannotate (syntax-object-expression j)))
+ (and (eq? (syntax-object-expression i)
+ (syntax-object-expression j))
(same-marks? (wrap-marks (syntax-object-wrap i))
(wrap-marks (syntax-object-wrap j))))
- (eq? (unannotate i) (unannotate j)))))
+ (eq? i j))))
;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
@@ -871,7 +925,9 @@
(define source-wrap
(lambda (x w s defmod)
- (wrap (if s (make-annotation x s #f) x) w defmod)))
+ (if (and s (pair? x))
+ (set-source-properties! x s))
+ (wrap x w defmod)))
;;; expanding
@@ -893,12 +949,33 @@
(let ((first (chi-top (car body) r w m esew mod)))
(cons first (dobody (cdr body) r w m esew mod))))))))
-;; FIXME: module?
(define chi-install-global
(lambda (name e)
- (build-application no-source
- (build-primref no-source 'install-global-transformer)
- (list (build-data no-source name) e))))
+ (build-global-definition
+ no-source
+ name
+ ;; FIXME: seems nasty to call current-module here
+ (if (let ((v (module-variable (current-module) name)))
+ ;; FIXME use primitive-macro?
+ (and v (variable-bound? v) (macro? (variable-ref v))
+ (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
+ (build-application
+ no-source
+ (build-primref no-source 'make-extended-syncase-macro)
+ (list (build-application
+ no-source
+ (build-primref no-source 'module-ref)
+ (list (build-application
+ no-source
+ (build-primref no-source 'current-module)
+ '())
+ (build-data no-source name)))
+ (build-data no-source 'macro)
+ e))
+ (build-application
+ no-source
+ (build-primref no-source 'make-syncase-macro)
+ (list (build-data no-source 'macro) e))))))
(define chi-when-list
(lambda (e when-list w)
@@ -1006,7 +1083,7 @@
((_ name)
(id? (syntax name))
(values 'define-form (wrap (syntax name) w mod)
- (syntax (void))
+ (syntax (if #f #f))
empty-wrap s mod))))
((define-syntax)
(syntax-case e ()
@@ -1018,13 +1095,10 @@
(values 'call #f e w s mod))))
(values 'call #f e w s mod))))
((syntax-object? e)
- ;; s can't be valid source if we've unwrapped
(syntax-type (syntax-object-expression e)
r
(join-wraps w (syntax-object-wrap e))
- no-source rib (or (syntax-object-module e) mod)))
- ((annotation? e)
- (syntax-type (annotation-expression e) r w (annotation-source e) rib
mod))
+ s rib (or (syntax-object-module e) mod)))
((self-evaluating? e) (values 'constant #f e w s mod))
(else (values 'other #f e w s mod)))))
@@ -1037,7 +1111,7 @@
(if (eq? m 'c&e) (top-level-eval-hook x mod))
x))))
(call-with-values
- (lambda () (syntax-type e r w no-source #f mod))
+ (lambda () (syntax-type e r w (source-annotation e) #f mod))
(lambda (type value e w s mod)
(case type
((begin-form)
@@ -1098,18 +1172,13 @@
(let* ((n (id-var-name value w))
(type (binding-type (lookup n r mod))))
(case type
- ((global)
+ ((global core macro module-ref)
(eval-if-c&e m
- (build-global-definition s n (chi e r w mod) mod)
+ (build-global-definition s n (chi e r w mod))
mod))
((displaced-lexical)
(syntax-violation #f "identifier out of context"
e (wrap value w mod)))
- ((core macro module-ref)
- (remove-global-definition-hook n)
- (eval-if-c&e m
- (build-global-definition s n (chi e r w mod) mod)
- mod))
(else
(syntax-violation #f "cannot define keyword at top level"
e (wrap value w mod))))))
@@ -1118,7 +1187,7 @@
(define chi
(lambda (e r w mod)
(call-with-values
- (lambda () (syntax-type e r w no-source #f mod))
+ (lambda () (syntax-type e r w (source-annotation e) #f mod))
(lambda (type value e w s mod)
(chi-expr type value e r w s mod)))))
@@ -1126,7 +1195,7 @@
(lambda (type value e r w s mod)
(case type
((lexical)
- (build-lexical-reference 'value s value))
+ (build-lexical-reference 'value s e value))
((core external-macro)
;; apply transformer
(value e r w s mod))
@@ -1136,7 +1205,8 @@
(lambda (id mod) (build-global-reference s id mod))))
((lexical-call)
(chi-application
- (build-lexical-reference 'fun (source-annotation (car e)) value)
+ (build-lexical-reference 'fun (source-annotation (car e))
+ (car e) value)
e r w s mod))
((global-call)
(chi-application
@@ -1167,8 +1237,8 @@
(syntax-violation #f "reference to pattern variable outside syntax form"
(source-wrap e w s mod)))
((displaced-lexical)
- (syntax-violation #f (source-wrap e w s mod)
- "reference to identifier outside its scope"))
+ (syntax-violation #f "reference to identifier outside its scope"
+ (source-wrap e w s mod)))
(else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod))))))
@@ -1266,12 +1336,13 @@
(ribcage (make-empty-ribcage))
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
(let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
- (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
+ (ids '()) (labels '())
+ (var-ids '()) (vars '()) (vals '()) (bindings '()))
(if (null? body)
(syntax-violation #f "no expressions in body" outer-form)
(let ((e (cdar body)) (er (caar body)))
(call-with-values
- (lambda () (syntax-type e er empty-wrap no-source ribcage mod))
+ (lambda () (syntax-type e er empty-wrap (source-annotation er)
ribcage mod))
(lambda (type value e w s mod)
(case type
((define-form)
@@ -1280,6 +1351,7 @@
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
+ (cons id var-ids)
(cons var vars) (cons (cons er (wrap e w mod)) vals)
(cons (make-binding 'lexical var) bindings)))))
((define-syntax-form)
@@ -1287,7 +1359,7 @@
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
- vars vals
+ var-ids vars vals
(cons (make-binding 'macro (cons er (wrap e w mod)))
bindings))))
((begin-form)
@@ -1298,7 +1370,7 @@
(cdr body)
(cons (cons er (wrap (car forms) w mod))
(f (cdr forms)))))
- ids labels vars vals bindings))))
+ ids labels var-ids vars vals bindings))))
((local-syntax-form)
(chi-local-syntax value e er w s mod
(lambda (forms er w s mod)
@@ -1307,7 +1379,7 @@
(cdr body)
(cons (cons er (wrap (car forms) w mod))
(f (cdr forms)))))
- ids labels vars vals bindings))))
+ ids labels var-ids vars vals bindings))))
(else ; found a non-definition
(if (null? ids)
(build-sequence no-source
@@ -1337,6 +1409,7 @@
(loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r)))
(build-letrec no-source
+ (map syntax->datum var-ids)
vars
(map (lambda (x)
(chi (cdr x) (car x) empty-wrap mod))
@@ -1359,8 +1432,9 @@
(syntax-violation 'lambda "invalid parameter list" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
- (k new-vars
- docstring
+ (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)
@@ -1372,11 +1446,15 @@
(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 new-vars)) (ls2 (car new-vars)))
+ (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))))
- docstring
+ (and docstring (syntax->datum docstring))
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
@@ -1420,7 +1498,7 @@
(define chi-void
(lambda ()
- (build-application no-source (build-primref no-source 'void) '())))
+ (build-void no-source)))
(define ellipsis?
(lambda (x)
@@ -1429,32 +1507,8 @@
;;; data
-;;; strips all annotations from potentially circular reader output
-
-(define strip-annotation
- (lambda (x parent)
- (cond
- ((pair? x)
- (let ((new (cons #f #f)))
- (if parent (set-annotation-stripped! parent new))
- (set-car! new (strip-annotation (car x) #f))
- (set-cdr! new (strip-annotation (cdr x) #f))
- new))
- ((annotation? x)
- (or (annotation-stripped x)
- (strip-annotation (annotation-expression x) x)))
- ((vector? x)
- (let ((new (make-vector (vector-length x))))
- (if parent (set-annotation-stripped! parent new))
- (let loop ((i (- (vector-length x) 1)))
- (unless (fx< i 0)
- (vector-set! new i (strip-annotation (vector-ref x i) #f))
- (loop (fx- i 1))))
- new))
- (else x))))
-
-;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
-;;; on an annotation, strips the annotation as well.
+;;; strips syntax-objects down to top-wrap
+;;;
;;; since only the head of a list is annotated by the reader, not each pair
;;; in the spine, we also check for pairs whose cars are annotated in case
;;; we've been passed the cdr of an annotated list
@@ -1462,32 +1516,28 @@
(define strip
(lambda (x w)
(if (top-marked? w)
- (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
- (strip-annotation x #f)
- x)
+ x
(let f ((x x))
(cond
- ((syntax-object? x)
- (strip (syntax-object-expression x) (syntax-object-wrap x)))
- ((pair? x)
- (let ((a (f (car x))) (d (f (cdr x))))
- (if (and (eq? a (car x)) (eq? d (cdr x)))
- x
- (cons a d))))
- ((vector? x)
- (let ((old (vector->list x)))
- (let ((new (map f old)))
- (if (andmap eq? old new) x (list->vector new)))))
- (else x))))))
+ ((syntax-object? x)
+ (strip (syntax-object-expression x) (syntax-object-wrap x)))
+ ((pair? x)
+ (let ((a (f (car x))) (d (f (cdr x))))
+ (if (and (eq? a (car x)) (eq? d (cdr x)))
+ x
+ (cons a d))))
+ ((vector? x)
+ (let ((old (vector->list x)))
+ (let ((new (map f old)))
+ (if (and-map* eq? old new) x (list->vector new)))))
+ (else x))))))
;;; lexical variables
(define gen-var
(lambda (id)
(let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
- (if (annotation? id)
- (build-lexical-var (annotation-source id) (annotation-expression id))
- (build-lexical-var no-source id)))))
+ (build-lexical-var no-source id))))
(define lambda-var-list
(lambda (vars)
@@ -1500,8 +1550,6 @@
(lvl (syntax-object-expression vars)
ls
(join-wraps w (syntax-object-wrap vars))))
- ((annotation? vars)
- (lvl (annotation-expression vars) ls w))
; include anything else to be caught by subsequent error
; checking
(else (cons vars ls))))))
@@ -1651,7 +1699,7 @@
; identity map equivalence:
; (map (lambda (x) x) y) == y
(car actuals))
- ((andmap
+ ((and-map
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e))
; eta map equivalence:
@@ -1691,17 +1739,10 @@
(define regen
(lambda (x)
(case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x)))
+ ((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) (regen (caddr x))))
- ((map) (let ((ls (map regen (cdr x))))
- (build-application no-source
- (if (fx= (length ls) 2)
- (build-primref no-source 'map)
- ; really need to do our own checking here
- (build-primref no-source 2 'map)) ; require error
check
- ls)))
+ ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr
x))))
(else (build-application no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
@@ -1721,7 +1762,8 @@
(syntax-case e ()
((_ . c)
(chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
- (lambda (vars docstring body) (build-lambda s vars docstring
body)))))))
+ (lambda (names vars docstring body)
+ (build-lambda s names vars docstring body)))))))
(global-extend 'core 'let
@@ -1734,6 +1776,7 @@
(let ((nw (make-binding-wrap ids labels w))
(nr (extend-var-env labels new-vars r)))
(constructor s
+ (map syntax->datum ids)
new-vars
(map (lambda (x) (chi x r w mod)) vals)
(chi-body exps (source-wrap e nw s mod)
@@ -1741,13 +1784,14 @@
(lambda (e r w s mod)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
+ (and-map id? (syntax (id ...)))
(chi-let e r w s mod
build-let
(syntax (id ...))
(syntax (val ...))
(syntax (e1 e2 ...))))
((_ f ((id val) ...) e1 e2 ...)
- (id? (syntax f))
+ (and (id? (syntax f)) (and-map id? (syntax (id ...))))
(chi-let e r w s mod
build-named-let
(syntax (f id ...))
@@ -1760,6 +1804,7 @@
(lambda (e r w s mod)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
+ (and-map id? (syntax (id ...)))
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
(syntax-violation 'letrec "duplicate bound variable" e)
@@ -1768,6 +1813,7 @@
(let ((w (make-binding-wrap ids labels w))
(r (extend-var-env labels new-vars r)))
(build-letrec s
+ (map syntax->datum ids)
new-vars
(map (lambda (x) (chi x r w mod)) (syntax (val ...)))
(chi-body (syntax (e1 e2 ...))
@@ -1785,7 +1831,10 @@
(let ((b (lookup n r mod)))
(case (binding-type b)
((lexical)
- (build-lexical-assignment s (binding-value b) val))
+ (build-lexical-assignment s
+ (syntax->datum (syntax id))
+ (binding-value b)
+ val))
((global) (build-global-assignment s n val mod))
((displaced-lexical)
(syntax-violation 'set! "identifier out of context"
@@ -1813,7 +1862,7 @@
(lambda (e)
(syntax-case e ()
((_ (mod ...) id)
- (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
+ (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
(values (syntax->datum (syntax id))
(syntax->datum
(syntax (public mod ...))))))))
@@ -1822,11 +1871,27 @@
(lambda (e)
(syntax-case e ()
((_ (mod ...) id)
- (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
+ (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
(values (syntax->datum (syntax id))
(syntax->datum
(syntax (private mod ...))))))))
+(global-extend 'core 'if
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ test then)
+ (build-conditional
+ s
+ (chi (syntax test) r w mod)
+ (chi (syntax then) r w mod)
+ (build-void no-source)))
+ ((_ test then else)
+ (build-conditional
+ s
+ (chi (syntax test) r w mod)
+ (chi (syntax then) r w mod)
+ (chi (syntax else) r w mod))))))
+
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
@@ -1875,7 +1940,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 new-vars
+ (list (build-lambda no-source (map syntax->datum ids) new-vars #f
(chi exp
(extend-env
labels
@@ -1896,14 +1961,15 @@
(cond
((not (distinct-bound-ids? (map car pvars)))
(syntax-violation 'syntax-case "duplicate pattern variable"
pat))
- ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
+ ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
(syntax-violation 'syntax-case "misplaced ellipsis" pat))
(else
(let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y
(build-application no-source
- (build-lambda no-source (list y)
- (let ((y (build-lexical-reference 'value no-source y)))
+ (build-lambda no-source (list 'tmp) (list y) #f
+ (let ((y (build-lexical-reference 'value no-source
+ 'tmp y)))
(build-conditional no-source
(syntax-case fender ()
(#t y)
@@ -1926,16 +1992,21 @@
(if (null? clauses)
(build-application no-source
(build-primref no-source 'syntax-violation)
- (list #f "source expression failed to match any pattern" x))
+ (list (build-data no-source #f)
+ (build-data no-source
+ "source expression failed to match any
pattern")
+ x))
(syntax-case (car clauses) ()
((pat exp)
(if (and (id? (syntax pat))
- (andmap (lambda (x) (not (free-id=? (syntax pat) x)))
- (cons (syntax (... ...)) keys)))
+ (and-map (lambda (x) (not (free-id=? (syntax pat) x)))
+ (cons (syntax (... ...)) keys)))
(let ((labels (list (gen-label)))
(var (gen-var (syntax pat))))
(build-application no-source
- (build-lambda no-source (list var)
+ (build-lambda no-source
+ (list (syntax->datum (syntax pat))) (list
var)
+ #f
(chi (syntax exp)
(extend-env labels
(list (make-binding 'syntax `(,var . 0)))
@@ -1956,13 +2027,14 @@
(let ((e (source-wrap e w s mod)))
(syntax-case e ()
((_ val (key ...) m ...)
- (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
- (syntax (key ...)))
+ (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
+ (syntax (key ...)))
(let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x
(build-application s
- (build-lambda no-source (list x)
- (gen-syntax-case (build-lexical-reference 'value
no-source x)
+ (build-lambda no-source (list 'tmp) (list x) #f
+ (gen-syntax-case (build-lexical-reference 'value no-source
+ 'tmp x)
(syntax (key ...)) (syntax (m ...))
r
mod))
@@ -1979,26 +2051,17 @@
;;; expanded, and the expanded definitions are also residualized into
;;; the object file if we are compiling a file.
(set! sc-expand
- (let ((m 'e) (esew '(eval)))
- (lambda (x)
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (chi-top x null-env top-wrap m esew
- (cons 'hygiene (module-name (current-module))))))))
-
-(set! sc-expand3
- (let ((m 'e) (esew '(eval)))
- (lambda (x . rest)
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (chi-top x
- null-env
- top-wrap
- (if (null? rest) m (car rest))
- (if (or (null? rest) (null? (cdr rest)))
- esew
- (cadr rest))
- (cons 'hygiene (module-name (current-module))))))))
+ (lambda (x . rest)
+ (if (and (pair? x) (equal? (car x) noexpand))
+ (cadr x)
+ (let ((m (if (null? rest) 'e (car rest)))
+ (esew (if (or (null? rest) (null? (cdr rest)))
+ '(eval)
+ (cadr rest))))
+ (with-fluid* *mode* m
+ (lambda ()
+ (chi-top x null-env top-wrap m esew
+ (cons 'hygiene (module-name
(current-module))))))))))
(set! identifier?
(lambda (x)
@@ -2047,12 +2110,6 @@
(if who (cons who tail) tail))
#f)))
-(set! install-global-transformer
- (lambda (sym v)
- (arg-check symbol? sym 'define-syntax)
- (arg-check procedure? v 'define-syntax)
- (global-extend 'macro sym v)))
-
;;; $sc-dispatch expects an expression and a pattern. If the expression
;;; matches the pattern a list of the matching expressions for each
;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
@@ -2080,35 +2137,31 @@
(define match-each
(lambda (e p w mod)
(cond
- ((annotation? e)
- (match-each (annotation-expression e) p w mod))
- ((pair? e)
- (let ((first (match (car e) p w '() mod)))
- (and first
- (let ((rest (match-each (cdr e) p w mod)))
- (and rest (cons first rest))))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each (syntax-object-expression e)
- p
- (join-wraps w (syntax-object-wrap e))
- (syntax-object-module e)))
- (else #f))))
+ ((pair? e)
+ (let ((first (match (car e) p w '() mod)))
+ (and first
+ (let ((rest (match-each (cdr e) p w mod)))
+ (and rest (cons first rest))))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))
+ (syntax-object-module e)))
+ (else #f))))
(define match-each-any
(lambda (e w mod)
(cond
- ((annotation? e)
- (match-each-any (annotation-expression e) w mod))
- ((pair? e)
- (let ((l (match-each-any (cdr e) w mod)))
- (and l (cons (wrap (car e) w mod) l))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each-any (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))
- mod))
- (else #f))))
+ ((pair? e)
+ (let ((l (match-each-any (cdr e) w mod)))
+ (and l (cons (wrap (car e) w mod) l))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each-any (syntax-object-expression e)
+ (join-wraps w (syntax-object-wrap e))
+ mod))
+ (else #f))))
(define match-empty
(lambda (p r)
@@ -2157,21 +2210,21 @@
((eq? p 'any) (cons (wrap e w mod) r))
((syntax-object? e)
(match*
- (unannotate (syntax-object-expression e))
- p
- (join-wraps w (syntax-object-wrap e))
- r
- (syntax-object-module e)))
- (else (match* (unannotate e) p w r mod)))))
+ (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))
+ r
+ (syntax-object-module e)))
+ (else (match* e p w r mod)))))
(set! $sc-dispatch
(lambda (e p)
(cond
((eq? p 'any) (list e))
((syntax-object? e)
- (match* (unannotate (syntax-object-expression e))
- p (syntax-object-wrap e) '() (syntax-object-module e)))
- (else (match* (unannotate e) p empty-wrap '() #f)))))
+ (match* (syntax-object-expression e)
+ p (syntax-object-wrap e) '() (syntax-object-module e)))
+ (else (match* e p empty-wrap '() #f)))))
))
)
@@ -2200,7 +2253,7 @@
(lambda (x)
(syntax-case x ()
((let* ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (x ...)))
+ (and-map identifier? (syntax (x ...)))
(let f ((bindings (syntax ((x v) ...))))
(if (null? bindings)
(syntax (let () e1 e2 ...))
@@ -2267,12 +2320,22 @@
(syntax p)
(quasicons (syntax (quote unquote))
(quasi (syntax (p)) (- lev 1)))))
+ ((unquote . args)
+ (= lev 0)
+ (syntax-violation 'unquote
+ "unquote takes exactly one argument"
+ p (syntax (unquote . args))))
(((unquote-splicing p) . q)
(if (= lev 0)
(quasiappend (syntax p) (quasi (syntax q) lev))
(quasicons (quasicons (syntax (quote unquote-splicing))
(quasi (syntax (p)) (- lev 1)))
(quasi (syntax q) lev))))
+ (((unquote-splicing . args) . q)
+ (= lev 0)
+ (syntax-violation 'unquote-splicing
+ "unquote-splicing takes exactly one argument"
+ p (syntax (unquote-splicing . args))))
((quasiquote p)
(quasicons (syntax (quote quasiquote))
(quasi (syntax (p)) (+ lev 1))))
@@ -2301,20 +2364,20 @@
(syntax (begin exp ...))))))))
(define-syntax unquote
- (lambda (x)
- (syntax-case x ()
- ((_ e)
- (error 'unquote
- "expression ,~s not valid outside of quasiquote"
- (syntax->datum (syntax e)))))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (syntax-violation 'unquote
+ "expression not valid outside of quasiquote"
+ x)))))
(define-syntax unquote-splicing
- (lambda (x)
- (syntax-case x ()
- ((_ e)
- (error 'unquote-splicing
- "expression ,@~s not valid outside of quasiquote"
- (syntax->datum (syntax e)))))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (syntax-violation 'unquote-splicing
+ "expression not valid outside of quasiquote"
+ x)))))
(define-syntax case
(lambda (x)
diff --git a/module/ice-9/stack-catch.scm b/module/ice-9/stack-catch.scm
index 2f4b3d1..a542676 100644
--- a/module/ice-9/stack-catch.scm
+++ b/module/ice-9/stack-catch.scm
@@ -40,4 +40,4 @@ this call to @code{catch}."
(catch key
thunk
handler
- pre-unwind-handler-dispatch))
+ default-pre-unwind-handler))
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index bd0f7b7..e07d766 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -32,21 +32,71 @@
;;; Code:
(define-module (ice-9 threads)
- :export (par-map
+ :export (begin-thread
+ parallel
+ letpar
+ make-thread
+ with-mutex
+ monitor
+
+ par-map
par-for-each
n-par-map
n-par-for-each
n-for-each-par-map
- %thread-handler)
- :export-syntax (begin-thread
- parallel
- letpar
- make-thread
- with-mutex
- monitor))
+ %thread-handler))
+;;; Macros first, so that the procedures expand correctly.
+
+(define-syntax begin-thread
+ (syntax-rules ()
+ ((_ e0 e1 ...)
+ (call-with-new-thread
+ (lambda () e0 e1 ...)
+ %thread-handler))))
+
+(define-syntax parallel
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e0 ...)
+ (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
+ (syntax
+ (let ((tmp0 (begin-thread e0))
+ ...)
+ (values (join-thread tmp0) ...))))))))
+
+(define-syntax letpar
+ (syntax-rules ()
+ ((_ ((v e) ...) b0 b1 ...)
+ (call-with-values
+ (lambda () (parallel e ...))
+ (lambda (v ...)
+ b0 b1 ...)))))
+
+(define-syntax make-thread
+ (syntax-rules ()
+ ((_ proc arg ...)
+ (call-with-new-thread
+ (lambda () (proc arg ...))
+ %thread-handler))))
+
+(define-syntax with-mutex
+ (syntax-rules ()
+ ((_ m e0 e1 ...)
+ (let ((x m))
+ (dynamic-wind
+ (lambda () (lock-mutex x))
+ (lambda () (begin e0 e1 ...))
+ (lambda () (unlock-mutex x)))))))
+
+(define-syntax monitor
+ (syntax-rules ()
+ ((_ first rest ...)
+ (with-mutex (make-mutex)
+ first rest ...))))
+
(define (par-mapper mapper)
(lambda (proc . arglists)
(mapper join-thread
@@ -171,52 +221,4 @@ of applying P-PROC on ARGLISTS."
;;; Set system thread handler
(define %thread-handler thread-handler)
-; --- MACROS -------------------------------------------------------
-
-(define-macro (begin-thread . forms)
- (if (null? forms)
- '(begin)
- `(call-with-new-thread
- (lambda ()
- ,@forms)
- %thread-handler)))
-
-(define-macro (parallel . forms)
- (cond ((null? forms) '(values))
- ((null? (cdr forms)) (car forms))
- (else
- (let ((vars (map (lambda (f)
- (make-symbol "f"))
- forms)))
- `((lambda ,vars
- (values ,@(map (lambda (v) `(join-thread ,v)) vars)))
- ,@(map (lambda (form) `(begin-thread ,form)) forms))))))
-
-(define-macro (letpar bindings . body)
- (cond ((or (null? bindings) (null? (cdr bindings)))
- `(let ,bindings ,@body))
- (else
- (let ((vars (map car bindings)))
- `((lambda ,vars
- ((lambda ,vars ,@body)
- ,@(map (lambda (v) `(join-thread ,v)) vars)))
- ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings))))))
-
-(define-macro (make-thread proc . args)
- `(call-with-new-thread
- (lambda ()
- (,proc ,@args))
- %thread-handler))
-
-(define-macro (with-mutex m . body)
- `(dynamic-wind
- (lambda () (lock-mutex ,m))
- (lambda () (begin ,@body))
- (lambda () (unlock-mutex ,m))))
-
-(define-macro (monitor first . rest)
- `(with-mutex ,(make-mutex)
- (begin
- ,first ,@rest)))
-
;;; threads.scm ends here
diff --git a/module/ice-9/time.scm b/module/ice-9/time.scm
index a704596..86ebcbf 100644
--- a/module/ice-9/time.scm
+++ b/module/ice-9/time.scm
@@ -53,6 +53,6 @@
result))
(define-macro (time exp)
- `(,time-proc (lambda () ,exp)))
+ `((@@ (ice-9 time) time-proc) (lambda () ,exp)))
;;; time.scm ends here
diff --git a/module/language/assembly/disassemble.scm
b/module/language/assembly/disassemble.scm
index 2752934..df61999 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -82,7 +82,7 @@
(if (program? x)
(begin (display "----------------------------------------\n")
(disassemble x))))
- (cddr (vector->list objs))))))
+ (cdr (vector->list objs))))))
(else
(error "bad load-program form" asm))))
diff --git a/module/language/ecmascript/spec.scm
b/module/language/ecmascript/spec.scm
index 550a0b7..0112af5 100644
--- a/module/language/ecmascript/spec.scm
+++ b/module/language/ecmascript/spec.scm
@@ -33,7 +33,6 @@
#:title "Guile ECMAScript"
#:version "3.0"
#:reader (lambda () (read-ecmascript/1 (current-input-port)))
- #:read-file read-ecmascript
#:compilers `((ghil . ,compile-ghil))
;; a pretty-printer would be interesting.
#:printer write
diff --git a/module/language/ghil/compile-glil.scm
b/module/language/ghil/compile-glil.scm
index c813319..02187be 100644
--- a/module/language/ghil/compile-glil.scm
+++ b/module/language/ghil/compile-glil.scm
@@ -187,7 +187,7 @@
(define (make-glil-var op env var)
(case (ghil-var-kind var)
((argument)
- (make-glil-argument op (ghil-var-index var)))
+ (make-glil-local op (ghil-var-index var)))
((local)
(make-glil-local op (ghil-var-index var)))
((external)
@@ -217,7 +217,9 @@
(set! stack (cons code stack))
(if loc (set! stack (cons (make-glil-source loc) stack))))
(define (var->binding var)
- (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
+ (list (ghil-var-name var) (let ((kind (ghil-var-kind var)))
+ (case kind ((argument) 'local) (else kind)))
+ (ghil-var-index var)))
(define (push-bindings! loc vars)
(if (not (null? vars))
(push-code! loc (make-glil-bind (map var->binding vars)))))
@@ -496,7 +498,7 @@
(locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
(exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
(nargs (allocate-indices-linearly! vars))
- (nlocs (allocate-locals! locs body))
+ (nlocs (allocate-locals! locs body nargs))
(nexts (allocate-indices-linearly! exts)))
;; meta bindings
(push-bindings! #f vars)
@@ -509,7 +511,7 @@
(let ((v (car l)))
(case (ghil-var-kind v)
((external)
- (push-code! #f (make-glil-argument 'ref n))
+ (push-code! #f (make-glil-local 'ref n))
(push-code! #f (make-glil-external 'set 0 (ghil-var-index
v)))))))
;; compile body
(comp body #t #f)
@@ -523,8 +525,8 @@
((null? l) n)
(let ((v (car l))) (set! (ghil-var-index v) n))))
-(define (allocate-locals! vars body)
- (let ((free '()) (nlocs 0))
+(define (allocate-locals! vars body nargs)
+ (let ((free '()) (nlocs nargs))
(define (allocate! var)
(cond
((pair? free)
diff --git a/module/language/glil.scm b/module/language/glil.scm
index 51e7efa..625760e 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -44,9 +44,6 @@
<glil-const> make-glil-const glil-const?
glil-const-obj
- <glil-argument> make-glil-argument glil-argument?
- glil-argument-op glil-argument-index
-
<glil-local> make-glil-local glil-local?
glil-local-op glil-local-index
@@ -87,7 +84,6 @@
(<glil-void>)
(<glil-const> obj)
;; Variables
- (<glil-argument> op index)
(<glil-local> op index)
(<glil-external> op depth index)
(<glil-toplevel> op name)
@@ -125,7 +121,6 @@
((source ,props) (make-glil-source props))
((void) (make-glil-void))
((const ,obj) (make-glil-const obj))
- ((argument ,op ,index) (make-glil-argument op index))
((local ,op ,index) (make-glil-local op index))
((external ,op ,depth ,index) (make-glil-external op depth index))
((toplevel ,op ,name) (make-glil-toplevel op name))
@@ -150,8 +145,6 @@
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
;; variables
- ((<glil-argument> op index)
- `(argument ,op ,index))
((<glil-local> op index)
`(local ,op ,index))
((<glil-external> op depth index)
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index ffac9db..4c92e0f 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -83,16 +83,15 @@
(define (make-closed-binding open-binding start end)
(make-binding (car open-binding) (cadr open-binding)
(caddr open-binding) start end))
-(define (open-binding bindings vars nargs start)
+(define (open-binding bindings vars start)
(cons
(acons start
(map
(lambda (v)
(pmatch v
- ((,name argument ,i) (make-open-binding name #f i))
- ((,name local ,i) (make-open-binding name #f (+ nargs i)))
+ ((,name local ,i) (make-open-binding name #f i))
((,name external ,i) (make-open-binding name #t i))
- (else (error "unknown binding type" name type))))
+ (else (error "unknown binding type" v))))
vars)
(car bindings))
(cdr bindings)))
@@ -129,13 +128,13 @@
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil 0 '() '(()) '() '() #f -1)
+ (glil->assembly glil '() '(()) '() '() #f -1)
(car code)))
(define (make-object-table objects)
(and (not (null? objects))
(list->vector (cons #f objects))))
-(define (glil->assembly glil nargs nexts-stack bindings
+(define (glil->assembly glil nexts-stack bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
(values (map assembly-pack x) bindings source-alist label-alist
object-alist))
@@ -159,7 +158,7 @@
addr))
(else
(receive (subcode bindings source-alist label-alist
object-alist)
- (glil->assembly (car body) nargs nexts-stack bindings
+ (glil->assembly (car body) nexts-stack bindings
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
@@ -196,14 +195,14 @@
((<glil-bind> vars)
(values '()
- (open-binding bindings vars nargs addr)
+ (open-binding bindings vars addr)
source-alist
label-alist
object-alist))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
- (open-binding bindings vars nargs addr)
+ (open-binding bindings vars addr)
source-alist
label-alist
object-alist))
@@ -238,16 +237,11 @@
(emit-code/object `((object-ref ,i))
object-alist)))))
- ((<glil-argument> op index)
+ ((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,index))
`((local-set ,index)))))
- ((<glil-local> op index)
- (emit-code (if (eq? op 'ref)
- `((local-ref ,(+ nargs index)))
- `((local-set ,(+ nargs index))))))
-
((<glil-external> op depth index)
(emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
(if (> d 0)
@@ -318,7 +312,12 @@
(error "Unknown instruction:" inst))
(let ((pops (instruction-pops inst)))
(cond ((< pops 0)
- (emit-code `((,inst ,nargs))))
+ (case (instruction-length inst)
+ ((1) (emit-code `((,inst ,nargs))))
+ ((2) (emit-code `((,inst ,(quotient nargs 256)
+ ,(modulo nargs 256)))))
+ (else (error "Unknown length for variable-arg instruction:"
+ inst (instruction-length inst)))))
((= pops nargs)
(emit-code `((,inst))))
(else
diff --git a/module/language/glil/decompile-assembly.scm
b/module/language/glil/decompile-assembly.scm
index a98c399..a47bd80 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -175,15 +175,11 @@
(1+ pos)))
((local-ref ,n)
(lp (cdr in) (cons *placeholder* stack)
- (cons (if (< n nargs)
- (make-glil-argument 'ref n)
- (make-glil-local 'ref (- n nargs)))
+ (cons (make-glil-local 'ref n)
out) (+ pos 2)))
((local-set ,n)
(lp (cdr in) (cdr stack)
- (cons (if (< n nargs)
- (make-glil-argument 'set n)
- (make-glil-local 'set (- n nargs)))
+ (cons (make-glil-local 'set n)
(emit-constants (list-head stack 1) out))
(+ pos 2)))
((br-if-not ,l)
diff --git a/module/language/scheme/amatch.scm
b/module/language/scheme/amatch.scm
deleted file mode 100644
index 190b37f..0000000
--- a/module/language/scheme/amatch.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-(define-module (language scheme amatch)
- #:export (amatch))
-
-;; This is exactly the same as pmatch except that it unpacks annotations
-;; as needed.
-
-(define-syntax amatch
- (syntax-rules (else guard)
- ((_ (op arg ...) cs ...)
- (let ((v (op arg ...)))
- (amatch v cs ...)))
- ((_ v) (if #f #f))
- ((_ v (else e0 e ...)) (begin e0 e ...))
- ((_ v (pat (guard g ...) e0 e ...) cs ...)
- (let ((fk (lambda () (amatch v cs ...))))
- (apat v pat
- (if (and g ...) (begin e0 e ...) (fk))
- (fk))))
- ((_ v (pat e0 e ...) cs ...)
- (let ((fk (lambda () (amatch v cs ...))))
- (apat v pat (begin e0 e ...) (fk))))))
-
-(define-syntax apat
- (syntax-rules (_ quote unquote)
- ((_ v _ kt kf) kt)
- ((_ v () kt kf) (if (null? v) kt kf))
- ((_ v (quote lit) kt kf)
- (if (equal? v (quote lit)) kt kf))
- ((_ v (unquote var) kt kf) (let ((var v)) kt))
- ((_ v (x . y) kt kf)
- (if (apair? v)
- (let ((vx (acar v)) (vy (acdr v)))
- (apat vx x (apat vy y kt kf) kf))
- kf))
- ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))
diff --git a/module/language/scheme/compile-ghil.scm
b/module/language/scheme/compile-ghil.scm
index 689770e..8d8332c 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -27,12 +27,11 @@
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
+ #:use-module (language tree-il)
#:use-module ((system base compile) #:select (syntax-error))
#:export (compile-ghil translate-1
*translate-table* define-scheme-translator))
-(module-ref (current-module) 'receive)
-
;;; environment := #f
;;; | MODULE
;;; | COMPILE-ENV
@@ -69,7 +68,8 @@
(and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars)
- (let ((x (sc-expand3 x 'c '(compile load eval))))
+ (let ((x (tree-il->scheme
+ (sc-expand x 'c '(compile load eval)))))
(let ((x (make-ghil-lambda env #f vars #f '()
(translate-1 env #f x)))
(cenv (make-cenv (current-module)
@@ -414,16 +414,6 @@
(,args
(-> (values (map retrans args)))))
-(define-scheme-translator compile-time-environment
- ;; (compile-time-environment)
- ;; => (MODULE LEXICALS . EXTERNALS)
- (()
- (-> (inline 'cons
- (list (retrans '(current-module))
- (-> (inline 'cons
- (list (-> (reified-env))
- (-> (inline 'externals '()))))))))))
-
(define (lookup-apply-transformer proc)
(cond ((eq? proc values)
(lambda (e l args)
diff --git a/module/language/scheme/compile-tree-il.scm
b/module/language/scheme/compile-tree-il.scm
new file mode 100644
index 0000000..4635abc
--- /dev/null
+++ b/module/language/scheme/compile-tree-il.scm
@@ -0,0 +1,64 @@
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme compile-tree-il)
+ #:use-module (language tree-il)
+ #:export (compile-tree-il))
+
+;;; environment := #f
+;;; | MODULE
+;;; | COMPILE-ENV
+;;; compile-env := (MODULE LEXICALS . EXTERNALS)
+(define (cenv-module env)
+ (cond ((not env) #f)
+ ((module? env) env)
+ ((and (pair? env) (module? (car env))) (car env))
+ (else (error "bad environment" env))))
+
+(define (cenv-lexicals env)
+ (cond ((not env) '())
+ ((module? env) '())
+ ((pair? env) (cadr env))
+ (else (error "bad environment" env))))
+
+(define (cenv-externals env)
+ (cond ((not env) '())
+ ((module? env) '())
+ ((pair? env) (cddr env))
+ (else (error "bad environment" env))))
+
+(define (make-cenv module lexicals externals)
+ (cons module (cons lexicals externals)))
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ props))))
+
+(define (compile-tree-il x e opts)
+ (save-module-excursion
+ (lambda ()
+ (and=> (cenv-module e) set-current-module)
+ (let* ((x (sc-expand x 'c '(compile load eval)))
+ (cenv (make-cenv (current-module)
+ (cenv-lexicals e) (cenv-externals e))))
+ (values x cenv cenv)))))
diff --git a/module/language/r5rs/null.il
b/module/language/scheme/decompile-tree-il.scm
similarity index 72%
copy from module/language/r5rs/null.il
copy to module/language/scheme/decompile-tree-il.scm
index efdc5f3..c4903d8 100644
--- a/module/language/r5rs/null.il
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -1,6 +1,6 @@
-;;; R5RS null environment
+;;; Guile VM code converters
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001,2009 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -18,3 +18,10 @@
;; Boston, MA 02111-1307, USA.
;;; Code:
+
+(define-module (language scheme decompile-tree-il)
+ #:use-module (language tree-il)
+ #:export (decompile-tree-il))
+
+(define (decompile-tree-il x env opts)
+ (values (tree-il->scheme x) env))
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 8f958eb..cec2693 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -22,6 +22,8 @@
(define-module (language scheme spec)
#:use-module (system base language)
#:use-module (language scheme compile-ghil)
+ #:use-module (language scheme compile-tree-il)
+ #:use-module (language scheme decompile-tree-il)
#:export (scheme))
;;;
@@ -30,12 +32,6 @@
(read-enable 'positions)
-(define (read-file port)
- (do ((x (read port) (read port))
- (l '() (cons x l)))
- ((eof-object? x)
- (cons 'begin (reverse! l)))))
-
;;;
;;; Language definition
;;;
@@ -44,8 +40,9 @@
#:title "Guile Scheme"
#:version "0.5"
#:reader read
- #:read-file read-file
- #:compilers `((ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il)
+ (ghil . ,compile-ghil))
+ #:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
new file mode 100644
index 0000000..3350311
--- /dev/null
+++ b/module/language/tree-il.scm
@@ -0,0 +1,359 @@
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+
+(define-module (language tree-il)
+ #:use-module (system base pmatch)
+ #:use-module (system base syntax)
+ #:export (tree-il-src
+
+ <void> void? make-void void-src
+ <const> const? make-const const-src const-exp
+ <primitive-ref> primitive-ref? make-primitive-ref
primitive-ref-src primitive-ref-name
+ <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src
lexical-ref-name lexical-ref-gensym
+ <lexical-set> lexical-set? make-lexical-set lexical-set-src
lexical-set-name lexical-set-gensym lexical-set-exp
+ <module-ref> module-ref? make-module-ref module-ref-src
module-ref-mod module-ref-name module-ref-public?
+ <module-set> module-set? make-module-set module-set-src
module-set-mod module-set-name module-set-public? module-set-exp
+ <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src
toplevel-ref-name
+ <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src
toplevel-set-name toplevel-set-exp
+ <toplevel-define> toplevel-define? make-toplevel-define
toplevel-define-src toplevel-define-name toplevel-define-exp
+ <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
+ <let> let? make-let let-src let-names let-vars let-vals let-exp
+ <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars
letrec-vals letrec-exp
+
+ parse-tree-il
+ unparse-tree-il
+ tree-il->scheme
+
+ post-order!
+ pre-order!))
+
+(define-type (<tree-il> #:common-slots (src))
+ (<void>)
+ (<const> exp)
+ (<primitive-ref> name)
+ (<lexical-ref> name gensym)
+ (<lexical-set> name gensym exp)
+ (<module-ref> mod name public?)
+ (<module-set> mod name public? exp)
+ (<toplevel-ref> name)
+ (<toplevel-set> name exp)
+ (<toplevel-define> name exp)
+ (<conditional> test then else)
+ (<application> proc args)
+ (<sequence> exps)
+ (<lambda> names vars meta body)
+ (<let> names vars vals exp)
+ (<letrec> names vars vals exp))
+
+
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (pair? props) props))))
+
+(define (parse-tree-il exp)
+ (let ((loc (location exp))
+ (retrans (lambda (x) (parse-tree-il x))))
+ (pmatch exp
+ ((void)
+ (make-void loc))
+
+ ((apply ,proc . ,args)
+ (make-application loc (retrans proc) (map retrans args)))
+
+ ((if ,test ,then ,else)
+ (make-conditional loc (retrans test) (retrans then) (retrans else)))
+
+ ((primitive ,name) (guard (symbol? name))
+ (make-primitive-ref loc name))
+
+ ((lexical ,name) (guard (symbol? name))
+ (make-lexical-ref loc name name))
+
+ ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
+ (make-lexical-ref loc name sym))
+
+ ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
+ (make-lexical-set loc name sym (retrans exp)))
+
+ ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-ref loc mod name #t))
+
+ ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-set loc mod name #t (retrans exp)))
+
+ ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-ref loc mod name #f))
+
+ ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-set loc mod name #f (retrans exp)))
+
+ ((toplevel ,name) (guard (symbol? name))
+ (make-toplevel-ref loc name))
+
+ ((set! (toplevel ,name) ,exp) (guard (symbol? name))
+ (make-toplevel-set loc name (retrans exp)))
+
+ ((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 ,names ,vars ,meta ,exp)
+ (make-lambda loc names vars meta (retrans exp)))
+
+ ((const ,exp)
+ (make-const loc exp))
+
+ ((begin . ,exps)
+ (make-sequence loc (map retrans exps)))
+
+ ((let ,names ,vars ,vals ,exp)
+ (make-let loc names vars (map retrans vals) (retrans exp)))
+
+ ((letrec ,names ,vars ,vals ,exp)
+ (make-letrec loc names vars (map retrans vals) (retrans exp)))
+
+ (else
+ (error "unrecognized tree-il" exp)))))
+
+(define (unparse-tree-il tree-il)
+ (record-case tree-il
+ ((<void>)
+ '(void))
+
+ ((<application> proc args)
+ `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+
+ ((<conditional> test then else)
+ `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il
else)))
+
+ ((<primitive-ref> name)
+ `(primitive ,name))
+
+ ((<lexical-ref> name gensym)
+ `(lexical ,name ,gensym))
+
+ ((<lexical-set> name gensym exp)
+ `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
+
+ ((<toplevel-ref> name)
+ `(toplevel ,name))
+
+ ((<toplevel-set> name exp)
+ `(set! (toplevel ,name) ,(unparse-tree-il exp)))
+
+ ((<toplevel-define> name exp)
+ `(define ,name ,(unparse-tree-il exp)))
+
+ ((<lambda> names vars meta body)
+ `(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
+
+ ((<const> exp)
+ `(const ,exp))
+
+ ((<sequence> exps)
+ `(begin ,@(map unparse-tree-il exps)))
+
+ ((<let> names vars vals exp)
+ `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
+
+ ((<letrec> names vars vals exp)
+ `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il
exp)))))
+
+(define (tree-il->scheme e)
+ (cond ((list? e)
+ (map tree-il->scheme e))
+ ((pair? e)
+ (cons (tree-il->scheme (car e))
+ (tree-il->scheme (cdr e))))
+ ((record? e)
+ (record-case e
+ ((<void>)
+ '(if #f #f))
+
+ ((<application> proc args)
+ `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
+
+ ((<conditional> test then else)
+ (if (void? else)
+ `(if ,(tree-il->scheme test) ,(tree-il->scheme then))
+ `(if ,(tree-il->scheme test) ,(tree-il->scheme then)
,(tree-il->scheme else))))
+
+ ((<primitive-ref> name)
+ name)
+
+ ((<lexical-ref> name gensym)
+ gensym)
+
+ ((<lexical-set> name gensym exp)
+ `(set! ,gensym ,(tree-il->scheme exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
+
+ ((<toplevel-ref> name)
+ name)
+
+ ((<toplevel-set> name exp)
+ `(set! ,name ,(tree-il->scheme exp)))
+
+ ((<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)))
+
+ ((<const> exp)
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp)))
+
+ ((<sequence> exps)
+ `(begin ,@(map tree-il->scheme exps)))
+
+ ((<let> vars vals exp)
+ `(let ,(map list vars (map tree-il->scheme vals))
,(tree-il->scheme exp)))
+
+ ((<letrec> vars vals exp)
+ `(letrec ,(map list vars (map tree-il->scheme vals))
,(tree-il->scheme exp)))))
+ (else e)))
+
+(define (post-order! f x)
+ (let lp ((x x))
+ (record-case x
+ ((<void>)
+ (or (f x) x))
+
+ ((<application> proc args)
+ (set! (application-proc x) (lp proc))
+ (set! (application-args x) (map lp args))
+ (or (f x) x))
+
+ ((<conditional> test then else)
+ (set! (conditional-test x) (lp test))
+ (set! (conditional-then x) (lp then))
+ (set! (conditional-else x) (lp else))
+ (or (f x) x))
+
+ ((<primitive-ref> name)
+ (or (f x) x))
+
+ ((<lexical-ref> name gensym)
+ (or (f x) x))
+
+ ((<lexical-set> name gensym exp)
+ (set! (lexical-set-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<module-ref> mod name public?)
+ (or (f x) x))
+
+ ((<module-set> mod name public? exp)
+ (set! (module-set-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<toplevel-ref> name)
+ (or (f x) x))
+
+ ((<toplevel-set> name exp)
+ (set! (toplevel-set-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<toplevel-define> name exp)
+ (set! (toplevel-define-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<lambda> vars meta body)
+ (set! (lambda-body x) (lp body))
+ (or (f x) x))
+
+ ((<const> exp)
+ (or (f x) x))
+
+ ((<sequence> exps)
+ (set! (sequence-exps x) (map lp exps))
+ (or (f x) x))
+
+ ((<let> vars vals exp)
+ (set! (let-vals x) (map lp vals))
+ (set! (let-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<letrec> vars vals exp)
+ (set! (letrec-vals x) (map lp vals))
+ (set! (letrec-exp x) (lp exp))
+ (or (f x) x)))))
+
+(define (pre-order! f x)
+ (let lp ((x x))
+ (let ((x (or (f x) x)))
+ (record-case x
+ ((<application> proc args)
+ (set! (application-proc x) (lp proc))
+ (set! (application-args x) (map lp args)))
+
+ ((<conditional> test then else)
+ (set! (conditional-test x) (lp test))
+ (set! (conditional-then x) (lp then))
+ (set! (conditional-else x) (lp else)))
+
+ ((<lexical-set> name gensym exp)
+ (set! (lexical-set-exp x) (lp exp)))
+
+ ((<module-set> mod name public? exp)
+ (set! (module-set-exp x) (lp exp)))
+
+ ((<toplevel-set> name exp)
+ (set! (toplevel-set-exp x) (lp exp)))
+
+ ((<toplevel-define> name exp)
+ (set! (toplevel-define-exp x) (lp exp)))
+
+ ((<lambda> vars meta body)
+ (set! (lambda-body x) (lp body)))
+
+ ((<sequence> exps)
+ (set! (sequence-exps x) (map lp exps)))
+
+ ((<let> vars vals exp)
+ (set! (let-vals x) (map lp vals))
+ (set! (let-exp x) (lp exp)))
+
+ ((<letrec> vars vals exp)
+ (set! (letrec-vals x) (map lp vals))
+ (set! (letrec-exp x) (lp exp)))
+
+ (else #f))
+ x)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
new file mode 100644
index 0000000..477f1fc
--- /dev/null
+++ b/module/language/tree-il/analyze.scm
@@ -0,0 +1,235 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il analyze)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:export (analyze-lexicals))
+
+;; allocation: the process of assigning a type and index to each var
+;; a var is external if it is heaps; assigning index is easy
+;; args are assigned in order
+;; locals are indexed as their linear position in the binding path
+;; (let (0 1)
+;; (let (2 3) ...)
+;; (let (2) ...))
+;; (let (2 3 4) ...))
+;; etc.
+;;
+;; This algorithm has the problem that variables are only allocated
+;; indices at the end of the binding path. If variables bound early in
+;; the path are not used in later portions of the path, their indices
+;; will not be recycled. This problem is particularly egregious in the
+;; expansion of `or':
+;;
+;; (or x y z)
+;; -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
+;;
+;; As you can see, the `a' binding is only used in the ephemeral `then'
+;; clause of the first `if', but its index would be reserved for the
+;; whole of the `or' expansion. So we have a hack for this specific
+;; case. A proper solution would be some sort of liveness analysis, and
+;; not our linear allocation algorithm.
+;;
+;; allocation:
+;; sym -> (local . index) | (heap level . index)
+;; lambda -> (nlocs . nexts)
+
+(define (analyze-lexicals x)
+ ;; parents: lambda -> parent
+ ;; useful when we see a closed-over var, so we can calculate its
+ ;; coordinates (depth and index).
+ ;; bindings: lambda -> (sym ...)
+ ;; useful for two reasons: one, so we know how much space to allocate
+ ;; when we go into a lambda; and two, so that we know when to stop,
+ ;; when looking for closed-over vars.
+ ;; heaps: sym -> lambda
+ ;; allows us to heapify vars in an O(1) fashion
+ ;; refcounts: sym -> count
+ ;; allows us to detect the or-expansion an O(1) time
+
+ (define (find-heap sym parent)
+ ;; fixme: check displaced lexicals here?
+ (if (memq sym (hashq-ref bindings parent))
+ parent
+ (find-heap sym (hashq-ref parents parent))))
+
+ (define (analyze! x parent level)
+ (define (step y) (analyze! y parent level))
+ (define (recur x parent) (analyze! x parent (1+ level)))
+ (record-case x
+ ((<application> proc args)
+ (step proc) (for-each step args))
+
+ ((<conditional> test then else)
+ (step test) (step then) (step else))
+
+ ((<lexical-ref> name gensym)
+ (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+ (if (and (not (memq gensym (hashq-ref bindings parent)))
+ (not (hashq-ref heaps gensym)))
+ (hashq-set! heaps gensym (find-heap gensym parent))))
+
+ ((<lexical-set> name gensym exp)
+ (step exp)
+ (if (not (hashq-ref heaps gensym))
+ (hashq-set! heaps gensym (find-heap gensym parent))))
+
+ ((<module-set> mod name public? exp)
+ (step exp))
+
+ ((<toplevel-set> name exp)
+ (step exp))
+
+ ((<toplevel-define> name exp)
+ (step exp))
+
+ ((<sequence> exps)
+ (for-each step exps))
+
+ ((<lambda> vars meta body)
+ (hashq-set! parents x parent)
+ (hashq-set! bindings x
+ (let rev* ((vars vars) (out '()))
+ (cond ((null? vars) out)
+ ((pair? vars) (rev* (cdr vars)
+ (cons (car vars) out)))
+ (else (cons vars out)))))
+ (recur body x)
+ (hashq-set! bindings x (reverse! (hashq-ref bindings x))))
+
+ ((<let> vars vals exp)
+ (for-each step vals)
+ (hashq-set! bindings parent
+ (append (reverse vars) (hashq-ref bindings parent)))
+ (step exp))
+
+ ((<letrec> vars vals exp)
+ (hashq-set! bindings parent
+ (append (reverse vars) (hashq-ref bindings parent)))
+ (for-each step vals)
+ (step exp))
+
+ (else #f)))
+
+ (define (allocate-heap! binder)
+ (hashq-set! heap-indexes binder
+ (1+ (hashq-ref heap-indexes binder -1))))
+
+ (define (allocate! x level n)
+ (define (recur y) (allocate! y level n))
+ (record-case x
+ ((<application> proc args)
+ (apply max (recur proc) (map recur args)))
+
+ ((<conditional> test then else)
+ (max (recur test) (recur then) (recur else)))
+
+ ((<lexical-set> name gensym exp)
+ (recur exp))
+
+ ((<module-set> mod name public? exp)
+ (recur exp))
+
+ ((<toplevel-set> name exp)
+ (recur exp))
+
+ ((<toplevel-define> name exp)
+ (recur exp))
+
+ ((<sequence> exps)
+ (apply max (map recur exps)))
+
+ ((<lambda> vars meta body)
+ (let lp ((vars vars) (n 0))
+ (if (null? vars)
+ (hashq-set! allocation x
+ (let ((nlocs (- (allocate! body (1+ level) n) n)))
+ (cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
+ (let ((v (if (pair? vars) (car vars) vars)))
+ (let ((binder (hashq-ref heaps v)))
+ (hashq-set!
+ allocation v
+ (if binder
+ (cons* 'heap (1+ level) (allocate-heap! binder))
+ (cons 'stack n))))
+ (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
+ n)
+
+ ((<let> vars vals exp)
+ (let ((nmax (apply max (map recur vals))))
+ (cond
+ ;; the `or' hack
+ ((and (conditional? exp)
+ (= (length vars) 1)
+ (let ((v (car vars)))
+ (and (not (hashq-ref heaps v))
+ (= (hashq-ref refcounts v 0) 2)
+ (lexical-ref? (conditional-test exp))
+ (eq? (lexical-ref-gensym (conditional-test exp)) v)
+ (lexical-ref? (conditional-then exp))
+ (eq? (lexical-ref-gensym (conditional-then exp)) v))))
+ (hashq-set! allocation (car vars) (cons 'stack n))
+ ;; the 1+ for this var
+ (max nmax (1+ n) (allocate! (conditional-else exp) level n)))
+ (else
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (max nmax (allocate! exp level n))
+ (let ((v (car vars)))
+ (let ((binder (hashq-ref heaps v)))
+ (hashq-set!
+ allocation v
+ (if binder
+ (cons* 'heap level (allocate-heap! binder))
+ (cons 'stack n)))
+ (lp (cdr vars) (if binder n (1+ n)))))))))))
+
+ ((<letrec> vars vals exp)
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (let ((nmax (apply max
+ (map (lambda (x)
+ (allocate! x level n))
+ vals))))
+ (max nmax (allocate! exp level n)))
+ (let ((v (car vars)))
+ (let ((binder (hashq-ref heaps v)))
+ (hashq-set!
+ allocation v
+ (if binder
+ (cons* 'heap level (allocate-heap! binder))
+ (cons 'stack n)))
+ (lp (cdr vars) (if binder n (1+ n))))))))
+
+ (else n)))
+
+ (define parents (make-hash-table))
+ (define bindings (make-hash-table))
+ (define heaps (make-hash-table))
+ (define refcounts (make-hash-table))
+ (define allocation (make-hash-table))
+ (define heap-indexes (make-hash-table))
+
+ (analyze! x #f -1)
+ (allocate! x -1 0)
+
+ allocation)
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
new file mode 100644
index 0000000..94ace7e
--- /dev/null
+++ b/module/language/tree-il/compile-glil.scm
@@ -0,0 +1,448 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il compile-glil)
+ #:use-module (system base syntax)
+ #:use-module (ice-9 receive)
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il optimize)
+ #:use-module (language tree-il analyze)
+ #:export (compile-glil))
+
+;;; TODO:
+;;
+;; call-with-values -> mv-bind
+;; basic degenerate-case reduction
+
+;; allocation:
+;; sym -> (local . index) | (heap level . index)
+;; lambda -> (nlocs . nexts)
+
+(define *comp-module* (make-fluid))
+
+(define (compile-glil x e opts)
+ (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+ (x (optimize! x e opts))
+ (allocation (analyze-lexicals x)))
+ (with-fluid* *comp-module* (or (and e (car e)) (current-module))
+ (lambda ()
+ (values (flatten-lambda x -1 allocation)
+ (and e (cons (car e) (cddr e)))
+ e)))))
+
+
+
+(define *primcall-ops* (make-hash-table))
+(for-each
+ (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
+ '(((eq? . 2) . eq?)
+ ((eqv? . 2) . eqv?)
+ ((equal? . 2) . equal?)
+ ((= . 2) . ee?)
+ ((< . 2) . lt?)
+ ((> . 2) . gt?)
+ ((<= . 2) . le?)
+ ((>= . 2) . ge?)
+ ((+ . 2) . add)
+ ((- . 2) . sub)
+ ((* . 2) . mul)
+ ((/ . 2) . div)
+ ((quotient . 2) . quo)
+ ((remainder . 2) . rem)
+ ((modulo . 2) . mod)
+ ((not . 1) . not)
+ ((pair? . 1) . pair?)
+ ((cons . 2) . cons)
+ ((car . 1) . car)
+ ((cdr . 1) . cdr)
+ ((set-car! . 2) . set-car!)
+ ((set-cdr! . 2) . set-cdr!)
+ ((null? . 1) . null?)
+ ((list? . 1) . list?)
+ (list . list)
+ (vector . vector)
+ ((@slot-ref . 2) . slot-ref)
+ ((@slot-set! . 3) . slot-set)))
+
+(define (make-label) (gensym ":L"))
+
+(define (vars->bind-list ids vars allocation)
+ (map (lambda (id v)
+ (let ((loc (hashq-ref allocation v)))
+ (case (car loc)
+ ((stack) (list id 'local (cdr loc)))
+ ((heap) (list id 'external (cddr loc)))
+ (else (error "badness" id v loc)))))
+ ids
+ vars))
+
+(define (emit-bindings src ids vars allocation emit-code)
+ (if (pair? vars)
+ (emit-code src (make-glil-bind
+ (vars->bind-list ids vars allocation)))))
+
+(define (with-output-to-code proc)
+ (let ((out '()))
+ (define (emit-code src x)
+ (set! out (cons x out))
+ (if src
+ (set! out (cons (make-glil-source src) out))))
+ (proc emit-code)
+ (reverse out)))
+
+(define (flatten-lambda x level 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)))
+ (nexts (cdr (hashq-ref allocation x))))
+ (make-glil-program
+ nargs nrest nlocs nexts (lambda-meta x)
+ (with-output-to-code
+ (lambda (emit-code)
+ ;; write bindings and source debugging info
+ (emit-bindings #f ids vars allocation emit-code)
+ (if (lambda-src x)
+ (emit-code #f (make-glil-source (lambda-src x))))
+
+ ;; copy args to the heap if necessary
+ (let lp ((in vars) (n 0))
+ (if (not (null? in))
+ (let ((loc (hashq-ref allocation (car in))))
+ (case (car loc)
+ ((heap)
+ (emit-code #f (make-glil-local 'ref n))
+ (emit-code #f (make-glil-external 'set 0 (cddr loc)))))
+ (lp (cdr in) (1+ n)))))
+
+ ;; and here, here, dear reader: we compile.
+ (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
+
+(define (flatten x level allocation emit-code)
+ (define (emit-label label)
+ (emit-code #f (make-glil-label label)))
+ (define (emit-branch src inst label)
+ (emit-code src (make-glil-branch inst label)))
+
+ (let comp ((x x) (context 'tail))
+ (define (comp-tail tree) (comp tree context))
+ (define (comp-push tree) (comp tree 'push))
+ (define (comp-drop tree) (comp tree 'drop))
+
+ (record-case x
+ ((<void>)
+ (case context
+ ((push) (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<const> src exp)
+ (case context
+ ((push) (emit-code src (make-glil-const exp)))
+ ((tail)
+ (emit-code src (make-glil-const exp))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ;; FIXME: should represent sequence as exps tail
+ ((<sequence> src exps)
+ (let lp ((exps exps))
+ (if (null? (cdr exps))
+ (comp-tail (car exps))
+ (begin
+ (comp-drop (car exps))
+ (lp (cdr exps))))))
+
+ ((<application> src proc args)
+ ;; FIXME: need a better pattern-matcher here
+ (cond
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@apply)
+ (>= (length args) 1))
+ (let ((proc (car args))
+ (args (cdr args)))
+ (cond
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)))
+ ;; tail: (lambda () (apply values '(1 2)))
+ ;; drop: (lambda () (apply values '(1 2)) 3)
+ ;; push: (lambda () (list (apply values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values* (length
args))))))
+
+ (else
+ (case context
+ ((tail)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'goto/apply (1+ (length
args)))))
+ ((push)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'apply (1+ (length args)))))
+ ((drop)
+ ;; Well, shit. The proc might return any number of
+ ;; values (including 0), since it's in a drop context,
+ ;; yet apply does not create a MV continuation. So we
+ ;; mv-call out to our trampoline instead.
+ (comp-drop
+ (make-application src (make-primitive-ref #f 'apply)
+ (cons proc args)))))))))
+
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)))
+ ;; tail: (lambda () (values '(1 2)))
+ ;; drop: (lambda () (values '(1 2)) 3)
+ ;; push: (lambda () (list (values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values (length args))))))
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@call-with-values)
+ (= (length args) 2))
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (let ((MV (make-label)) (POST (make-label))
+ (producer (car args)) (consumer (cadr args)))
+ (comp-push consumer)
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/args 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))))))
+
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@call-with-current-continuation)
+ (= (length args) 1))
+ (case context
+ ((tail)
+ (comp-push (car args))
+ (emit-code src (make-glil-call 'goto/cc 1)))
+ ((push)
+ (comp-push (car args))
+ (emit-code src (make-glil-call 'call/cc 1)))
+ ((drop)
+ ;; Crap. Just like `apply' in drop context.
+ (comp-drop
+ (make-application
+ src (make-primitive-ref #f 'call-with-current-continuation)
+ args)))))
+
+ ((and (primitive-ref? proc)
+ (or (hash-ref *primcall-ops*
+ (cons (primitive-ref-name proc) (length args)))
+ (hash-ref *primcall-ops* (primitive-ref-name proc))))
+ => (lambda (op)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call op (length args)))
+ (case context
+ ((tail) (emit-code #f (make-glil-call 'return 1)))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))))
+ (else
+ (comp-push proc)
+ (for-each comp-push args)
+ (let ((len (length args)))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/args len)))
+ ((push) (emit-code src (make-glil-call 'call len)))
+ ((drop)
+ (let ((MV (make-label)) (POST (make-label)))
+ (emit-code src (make-glil-mv-call len MV))
+ (emit-code #f (make-glil-call 'drop 1))
+ (emit-branch #f 'br POST)
+ (emit-label MV)
+ (emit-code #f (make-glil-mv-bind '() #f))
+ (emit-code #f (make-glil-unbind))
+ (emit-label POST))))))))
+
+ ((<conditional> src test then else)
+ ;; TEST
+ ;; (br-if-not L1)
+ ;; THEN
+ ;; (br L2)
+ ;; L1: ELSE
+ ;; L2:
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (comp-push test)
+ (emit-branch src 'br-if-not L1)
+ (comp-tail then)
+ (if (not (eq? context 'tail))
+ (emit-branch #f 'br L2))
+ (emit-label L1)
+ (comp-tail else)
+ (if (not (eq? context 'tail))
+ (emit-label L2))))
+
+ ((<primitive-ref> src name)
+ (cond
+ ((eq? (module-variable (fluid-ref *comp-module*) name)
+ (module-variable the-root-module name))
+ (case context
+ ((push)
+ (emit-code src (make-glil-toplevel 'ref name)))
+ ((tail)
+ (emit-code src (make-glil-toplevel 'ref name))
+ (emit-code #f (make-glil-call 'return 1)))))
+ (else
+ (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
+ (case context
+ ((push)
+ (emit-code src (make-glil-module 'ref '(guile) name #f)))
+ ((tail)
+ (emit-code src (make-glil-module 'ref '(guile) name #f))
+ (emit-code #f (make-glil-call 'return 1)))))))
+
+ ((<lexical-ref> src name gensym)
+ (case context
+ ((push tail)
+ (let ((loc (hashq-ref allocation gensym)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'ref (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external
+ 'ref (- level (cadr loc)) (cddr loc))))
+ (else (error "badness" x loc)))
+ (if (eq? context 'tail)
+ (emit-code #f (make-glil-call 'return 1)))))))
+
+ ((<lexical-set> src name gensym exp)
+ (comp-push exp)
+ (let ((loc (hashq-ref allocation gensym)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'set (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external
+ 'set (- level (cadr loc)) (cddr loc))))
+ (else (error "badness" x loc))))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<module-ref> src mod name public?)
+ (emit-code src (make-glil-module 'ref mod name public?))
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1)))
+ ((tail) (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<module-set> src mod name public? exp)
+ (comp-push exp)
+ (emit-code src (make-glil-module 'set mod name public?))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<toplevel-ref> src name)
+ (emit-code src (make-glil-toplevel 'ref name))
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1)))
+ ((tail) (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<toplevel-set> src name exp)
+ (comp-push exp)
+ (emit-code src (make-glil-toplevel 'set name))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<toplevel-define> src name exp)
+ (comp-push exp)
+ (emit-code src (make-glil-toplevel 'define name))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<lambda>)
+ (case context
+ ((push)
+ (emit-code #f (flatten-lambda x level allocation)))
+ ((tail)
+ (emit-code #f (flatten-lambda x level allocation))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<let> src names vars vals exp)
+ (for-each comp-push vals)
+ (emit-bindings src names vars allocation emit-code)
+ (for-each (lambda (v)
+ (let ((loc (hashq-ref allocation v)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'set (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external 'set 0 (cddr loc))))
+ (else (error "badness" x loc)))))
+ (reverse vars))
+ (comp-tail exp)
+ (emit-code #f (make-glil-unbind)))
+
+ ((<letrec> src names vars vals exp)
+ (for-each comp-push vals)
+ (emit-bindings src names vars allocation emit-code)
+ (for-each (lambda (v)
+ (let ((loc (hashq-ref allocation v)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'set (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external 'set 0 (cddr loc))))
+ (else (error "badness" x loc)))))
+ (reverse vars))
+ (comp-tail exp)
+ (emit-code #f (make-glil-unbind))))))
diff --git a/module/language/ecmascript/spec.scm
b/module/language/tree-il/optimize.scm
similarity index 57%
copy from module/language/ecmascript/spec.scm
copy to module/language/tree-il/optimize.scm
index 550a0b7..3a02e02 100644
--- a/module/language/ecmascript/spec.scm
+++ b/module/language/tree-il/optimize.scm
@@ -1,4 +1,4 @@
-;;; ECMAScript specification for Guile
+;;; Tree-il optimizer
;; Copyright (C) 2009 Free Software Foundation, Inc.
@@ -19,22 +19,24 @@
;;; Code:
-(define-module (language ecmascript spec)
- #:use-module (system base language)
- #:use-module (language ecmascript parse)
- #:use-module (language ecmascript compile-ghil)
- #:export (ecmascript))
-
-;;;
-;;; Language definition
-;;;
-
-(define-language ecmascript
- #:title "Guile ECMAScript"
- #:version "3.0"
- #:reader (lambda () (read-ecmascript/1 (current-input-port)))
- #:read-file read-ecmascript
- #:compilers `((ghil . ,compile-ghil))
- ;; a pretty-printer would be interesting.
- #:printer write
- )
+(define-module (language tree-il optimize)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:export (optimize!))
+
+(define (env-module e)
+ (if e (car e) (current-module)))
+
+(define (optimize! x env opts)
+ (expand-primitives! (resolve-primitives! x (env-module env))))
+
+;; Possible optimizations:
+;; * constant folding, propagation
+;; * procedure inlining
+;; * always when single call site
+;; * always for "trivial" procs
+;; * otherwise who knows
+;; * dead code elimination
+;; * degenerate case optimizations
+;; * "fixing letrec"
+
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
new file mode 100644
index 0000000..51bbfea
--- /dev/null
+++ b/module/language/tree-il/primitives.scm
@@ -0,0 +1,206 @@
+;;; GHIL macros
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il primitives)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:use-module (srfi srfi-16)
+ #:export (resolve-primitives! add-interesting-primitive!
+ expand-primitives!))
+
+(define *interesting-primitive-names*
+ '(apply @apply
+ call-with-values @call-with-values
+ call-with-current-continuation @call-with-current-continuation
+ call/cc
+ values
+ eq? eqv? equal?
+ = < > <= >= zero?
+ + * - / 1- 1+ quotient remainder modulo
+ not
+ pair? null? list? acons cons cons*
+
+ list vector
+
+ car cdr
+ set-car! set-cdr!
+
+ caar cadr cdar cddr
+
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
+
+(define (add-interesting-primitive! name)
+ (hashq-set! *interesting-primitive-vars*
+ (module-variable (current-module) name) name))
+
+(define *interesting-primitive-vars* (make-hash-table))
+
+(for-each add-interesting-primitive! *interesting-primitive-names*)
+
+(define (resolve-primitives! x mod)
+ (post-order!
+ (lambda (x)
+ (record-case x
+ ((<toplevel-ref> src name)
+ (and (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name))
+ (make-primitive-ref src name)))
+ ((<module-ref> src mod name public?)
+ ;; for the moment, we're disabling primitive resolution for
+ ;; public refs because resolve-interface can raise errors.
+ (let ((m (and (not public?) (resolve-module mod))))
+ (and m (hashq-ref *interesting-primitive-vars*
+ (module-variable m name))
+ (make-primitive-ref src name))))
+ (else #f)))
+ x))
+
+
+
+(define *primitive-expand-table* (make-hash-table))
+
+(define (expand-primitives! x)
+ (pre-order!
+ (lambda (x)
+ (record-case x
+ ((<application> src proc args)
+ (and (primitive-ref? proc)
+ (let ((expand (hashq-ref *primitive-expand-table*
+ (primitive-ref-name proc))))
+ (and expand (apply expand src args)))))
+ (else #f)))
+ x))
+
+;;; I actually did spend about 10 minutes trying to redo this with
+;;; syntax-rules. Patches appreciated.
+;;;
+(define-macro (define-primitive-expander sym . clauses)
+ (define (inline-args args)
+ (let lp ((in args) (out '()))
+ (cond ((null? in) `(list ,@(reverse out)))
+ ((symbol? in) `(cons* ,@(reverse out) ,in))
+ ((pair? (car in))
+ (lp (cdr in)
+ (cons `(make-application src (make-primitive-ref src ',(caar
in))
+ ,(inline-args (cdar in)))
+ out)))
+ ((symbol? (car in))
+ ;; assume it's locally bound
+ (lp (cdr in) (cons (car in) out)))
+ ((number? (car in))
+ (lp (cdr in) (cons `(make-const src ,(car in)) out)))
+ (else
+ (error "what what" (car in))))))
+ (define (consequent exp)
+ (cond
+ ((pair? exp)
+ `(make-application src (make-primitive-ref src ',(car exp))
+ ,(inline-args (cdr exp))))
+ ((symbol? exp)
+ ;; assume locally bound
+ exp)
+ ((number? exp)
+ `(make-const src ,exp))
+ (else (error "bad consequent yall" exp))))
+ `(hashq-set! *primitive-expand-table*
+ ',sym
+ (case-lambda
+ ,@(let lp ((in clauses) (out '()))
+ (if (null? in)
+ (reverse (cons '(else #f) out))
+ (lp (cddr in)
+ (cons `((src . ,(car in))
+ ,(consequent (cadr in))) out)))))))
+
+(define-primitive-expander +
+ () 0
+ (x) x
+ (x y z . rest) (+ x (+ y z . rest)))
+
+(define-primitive-expander *
+ () 1
+ (x) x
+ (x y z . rest) (* x (* y z . rest)))
+
+(define-primitive-expander -
+ (x) (- 0 x)
+ (x y z . rest) (- x (+ y z . rest)))
+
+(define-primitive-expander 1-
+ (x) (- x 1))
+
+(define-primitive-expander /
+ (x) (/ 1 x)
+ (x y z . rest) (/ x (* y z . rest)))
+
+(define-primitive-expander caar (x) (car (car x)))
+(define-primitive-expander cadr (x) (car (cdr x)))
+(define-primitive-expander cdar (x) (cdr (car x)))
+(define-primitive-expander cddr (x) (cdr (cdr x)))
+(define-primitive-expander caaar (x) (car (car (car x))))
+(define-primitive-expander caadr (x) (car (car (cdr x))))
+(define-primitive-expander cadar (x) (car (cdr (car x))))
+(define-primitive-expander caddr (x) (car (cdr (cdr x))))
+(define-primitive-expander cdaar (x) (cdr (car (car x))))
+(define-primitive-expander cdadr (x) (cdr (car (cdr x))))
+(define-primitive-expander cddar (x) (cdr (cdr (car x))))
+(define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
+(define-primitive-expander caaaar (x) (car (car (car (car x)))))
+(define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
+(define-primitive-expander caadar (x) (car (car (cdr (car x)))))
+(define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
+(define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
+(define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
+(define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
+(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
+(define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
+(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
+(define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
+(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
+(define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
+(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
+(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
+(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
+
+(define-primitive-expander cons*
+ (x) x
+ (x y) (cons x y)
+ (x y . rest) (cons x (cons* y . rest)))
+
+(define-primitive-expander acons (x y z)
+ (cons (cons x y) z))
+
+(define-primitive-expander apply (f . args)
+ (@apply f . args))
+
+(define-primitive-expander call-with-values (producer consumer)
+ (@call-with-values producer consumer))
+
+(define-primitive-expander call-with-current-continuation (proc)
+ (@call-with-current-continuation proc))
+
+(define-primitive-expander call/cc (proc)
+ (@call-with-current-continuation proc))
+
+(define-primitive-expander values (x) x)
diff --git a/module/language/ecmascript/spec.scm
b/module/language/tree-il/spec.scm
similarity index 60%
copy from module/language/ecmascript/spec.scm
copy to module/language/tree-il/spec.scm
index 550a0b7..c1f0982 100644
--- a/module/language/ecmascript/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -1,4 +1,4 @@
-;;; ECMAScript specification for Guile
+;;; Tree Intermediate Language
;; Copyright (C) 2009 Free Software Foundation, Inc.
@@ -19,22 +19,25 @@
;;; Code:
-(define-module (language ecmascript spec)
+(define-module (language tree-il spec)
#:use-module (system base language)
- #:use-module (language ecmascript parse)
- #:use-module (language ecmascript compile-ghil)
- #:export (ecmascript))
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il compile-glil)
+ #:export (tree-il))
-;;;
-;;; Language definition
-;;;
+(define (write-tree-il exp . port)
+ (apply write (unparse-tree-il exp) port))
-(define-language ecmascript
- #:title "Guile ECMAScript"
- #:version "3.0"
- #:reader (lambda () (read-ecmascript/1 (current-input-port)))
- #:read-file read-ecmascript
- #:compilers `((ghil . ,compile-ghil))
- ;; a pretty-printer would be interesting.
- #:printer write
+(define (join exps env)
+ (make-sequence #f exps))
+
+(define-language tree-il
+ #:title "Tree Intermediate Language"
+ #:version "1.0"
+ #:reader read
+ #:printer write-tree-il
+ #:parser parse-tree-il
+ #:joiner join
+ #:compilers `((glil . ,compile-glil))
)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index f84af33..6e3b150 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -477,41 +477,107 @@
(toplevel-define! 'name (make <generic> #:name 'name)))
(add-method! name (method args body ...))))))
-(define-macro (method args . body)
- (letrec ((specializers
- (lambda (ls)
- (cond ((null? ls) (list (list 'quote '())))
- ((pair? ls) (cons (if (pair? (car ls))
- (cadar ls)
- '<top>)
- (specializers (cdr ls))))
- (else '(<top>)))))
- (formals
- (lambda (ls)
- (if (pair? ls)
- (cons (if (pair? (car ls)) (caar ls) (car ls))
- (formals (cdr ls)))
- ls))))
- (let ((make-proc (compile-make-procedure (formals args)
- (specializers args)
- body)))
- `(make <method>
- #:specializers (cons* ,@(specializers args))
- #:formals ',(formals args)
- #:body ',body
- #:make-procedure ,make-proc
- #:procedure ,(and (not make-proc)
- ;; that is to say: we set #:procedure if
- ;; `compile-make-procedure' returned `#f',
- ;; which is the case if `body' does not
- ;; contain a call to `next-method'
- `(lambda ,(formals args)
- ,@(if (null? body)
- ;; This used to be '((begin)), but
- ;; guile's memoizer doesn't like
- ;; (lambda args (begin)).
- '((if #f #f))
- body)))))))
+(define-syntax method
+ (lambda (x)
+ (define (parse-args args)
+ (let lp ((ls args) (formals '()) (specializers '()))
+ (syntax-case ls ()
+ (((f s) . rest)
+ (and (identifier? (syntax f)) (identifier? (syntax s)))
+ (lp (syntax rest)
+ (cons (syntax f) formals)
+ (cons (syntax s) specializers)))
+ ((f . rest)
+ (identifier? (syntax f))
+ (lp (syntax rest)
+ (cons (syntax f) formals)
+ (cons (syntax <top>) specializers)))
+ (()
+ (list (reverse formals)
+ (reverse (cons (syntax '()) specializers))))
+ (tail
+ (identifier? (syntax tail))
+ (list (append (reverse formals) (syntax tail))
+ (reverse (cons (syntax <top>) specializers)))))))
+
+ (define (find-free-id exp referent)
+ (syntax-case exp ()
+ ((x . y)
+ (or (find-free-id (syntax x) referent)
+ (find-free-id (syntax y) referent)))
+ (x
+ (identifier? (syntax x))
+ (let ((id (datum->syntax (syntax x) referent)))
+ (and (free-identifier=? (syntax x) id) id)))
+ (_ #f)))
+
+ (define (compute-procedure formals body)
+ (syntax-case body ()
+ ((body0 ...)
+ (with-syntax ((formals formals))
+ (syntax (lambda formals body0 ...))))))
+
+ (define (->proper args)
+ (let lp ((ls args) (out '()))
+ (syntax-case ls ()
+ ((x . xs) (lp (syntax xs) (cons (syntax x) out)))
+ (() (reverse out))
+ (tail (reverse (cons (syntax tail) out))))))
+
+ (define (compute-make-procedure formals body next-method)
+ (syntax-case body ()
+ ((body ...)
+ (with-syntax ((next-method next-method))
+ (syntax-case formals ()
+ ((formal ...)
+ (syntax
+ (lambda (real-next-method)
+ (lambda (formal ...)
+ (let ((next-method (lambda args
+ (if (null? args)
+ (real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...)))))
+ (formals
+ (with-syntax (((formal ...) (->proper (syntax formals))))
+ (syntax
+ (lambda (real-next-method)
+ (lambda formals
+ (let ((next-method (lambda args
+ (if (null? args)
+ (apply real-next-method formal
...)
+ (apply real-next-method args)))))
+ body ...)))))))))))
+
+ (define (compute-procedures formals body)
+ ;; So, our use of this is broken, because it operates on the
+ ;; pre-expansion source code. It's equivalent to just searching
+ ;; for referent in the datums. Ah well.
+ (let ((id (find-free-id body 'next-method)))
+ (if id
+ ;; return a make-procedure
+ (values (syntax #f)
+ (compute-make-procedure formals body id))
+ (values (compute-procedure formals body)
+ (syntax #f)))))
+
+ (syntax-case x ()
+ ((_ args) (syntax (method args (if #f #f))))
+ ((_ args body0 body1 ...)
+ (with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
+ (call-with-values
+ (lambda ()
+ (compute-procedures (syntax formals) (syntax (body0 body1
...))))
+ (lambda (procedure make-procedure)
+ (with-syntax ((procedure procedure)
+ (make-procedure make-procedure))
+ (syntax
+ (make <method>
+ #:specializers (cons* specializer ...)
+ #:formals 'formals
+ #:body '(body0 body1 ...)
+ #:make-procedure make-procedure
+ #:procedure procedure))))))))))
;;;
;;; {add-method!}
@@ -1061,31 +1127,10 @@
;; the idea is to compile the index into the procedure, for fastest
;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
-;; separate expression so that we affect the expansion of the subsequent
-;; expression
-(eval-when (compile)
- (use-modules ((language scheme compile-ghil) :select
(define-scheme-translator))
- ((language ghil) :select (make-ghil-inline make-ghil-call))
- (system base pmatch)))
-
(eval-when (compile)
- ;; unfortunately, can't use define-inline because these are primitive
- ;; syntaxen.
- (define-scheme-translator @slot-ref
- ((,obj ,index) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-ref
- (list (retrans obj) (retrans index))))
- (else
- (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))
-
- (define-scheme-translator @slot-set!
- ((,obj ,index ,val) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-set
- (list (retrans obj) (retrans index) (retrans val))))
- (else
- (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))))
+ (use-modules ((language tree-il primitives) :select
(add-interesting-primitive!)))
+ (add-interesting-primitive! '@slot-ref)
+ (add-interesting-primitive! '@slot-set!))
(eval-when (eval load compile)
(define num-standard-pre-cache 20))
diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm
index 3962be4..e6b13c4 100644
--- a/module/oop/goops/compile.scm
+++ b/module/oop/goops/compile.scm
@@ -24,7 +24,7 @@
(define-module (oop goops compile)
:use-module (oop goops)
:use-module (oop goops util)
- :export (compute-cmethod compile-make-procedure)
+ :export (compute-cmethod)
:no-backtrace
)
@@ -60,9 +60,7 @@
;;; So, for the reader: there basic idea is that, given that the
;;; semantics of `next-method' depend on the concrete types being
;;; dispatched, why not compile a specific procedure to handle each type
-;;; combination that we see at runtime. There are two compilation
-;;; strategies implemented: one for the memoizer, and one for the VM
-;;; compiler.
+;;; combination that we see at runtime.
;;;
;;; In theory we can do much better than a bytecode compilation, because
;;; we know the *exact* types of the arguments. It's ideal for native
@@ -71,32 +69,6 @@
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
-;;; Temporary solution---return #f if x doesn't refer to `next-method'.
-(define (next-method? x)
- (and (pair? x)
- (or (eq? (car x) 'next-method)
- (next-method? (car x))
- (next-method? (cdr x)))))
-
-;; Called by the `method' macro in goops.scm.
-(define (compile-make-procedure formals specializers body)
- (and (next-method? body)
- (let ((next-method-sym (gensym " next-method"))
- (args-sym (gensym)))
- `(lambda (,next-method-sym)
- (lambda ,formals
- (let ((next-method (lambda ,args-sym
- (if (null? ,args-sym)
- ,(if (list? formals)
- `(,next-method-sym ,@formals)
- `(apply
- ,next-method-sym
- ,@(improper->proper formals)))
- (apply ,next-method-sym ,args-sym)))))
- ,@(if (null? body)
- '((begin))
- body)))))))
-
(define (compile-method methods types)
(let ((make-procedure (slot-ref (car methods) 'make-procedure)))
(if make-procedure
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 925ecb3..dd92079 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -151,8 +151,10 @@
(hashq-set! thread-exception-handlers ct hl)
(handler obj))
(lambda ()
- (let ((r (thunk)))
- (hashq-set! thread-exception-handlers ct hl) r))))))
+ (call-with-values thunk
+ (lambda res
+ (hashq-set! thread-exception-handlers ct hl)
+ (apply values res))))))))
(define (current-exception-handler)
(car (current-handler-stack)))
@@ -249,8 +251,8 @@
(define (wrap thunk)
(lambda (continuation)
(with-exception-handler (lambda (obj)
- (apply (current-exception-handler) (list obj))
- (apply continuation (list)))
+ ((current-exception-handler) obj)
+ (continuation))
thunk)))
;; A pass-thru to cancel-thread that first installs a handler that throws
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 7d54947..f6522f7 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -29,7 +29,7 @@
#:export (syntax-error
*current-language*
compiled-file-name compile-file compile-and-load
- compile compile-time-environment
+ compile
decompile)
#:export-syntax (call-with-compile-error-catch))
@@ -107,9 +107,9 @@
port)))
comp))
-(define* (compile-and-load file #:key (to 'value) (opts '()))
- (read-and-compile (open-input-port file)
- #:from lang #:to to #:opts opts))
+(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
+ (read-and-compile (open-input-file file)
+ #:from from #:to to #:opts opts))
(define (compiled-file-name file)
(let ((base (basename file))
@@ -135,11 +135,6 @@
;;; Compiler interface
;;;
-(define (read-file-in file lang)
- (call-with-input-file file
- (or (language-read-file lang)
- (error "language has no #:read-file" lang))))
-
(define (compile-passes from to opts)
(map cdr
(or (lookup-compilation-order from to)
@@ -152,13 +147,6 @@
(receive (x e new-cenv) ((car passes) x e opts)
(lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
-(define (compile-time-environment)
- "A special function known to the compiler that, when compiled, will
-return a representation of the lexical environment in place at compile
-time. Useful for supporting some forms of dynamic compilation. Returns
-#f if called from the interpreter."
- #f)
-
(define (find-language-joint from to)
(let lp ((in (reverse (or (lookup-compilation-order from to)
(error "no way to compile" from "to" to))))
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 649137c..8ae4d96 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -23,7 +23,7 @@
#:use-module (system base syntax)
#:export (define-language language? lookup-language make-language
language-name language-title language-version language-reader
- language-printer language-parser language-read-file
+ language-printer language-parser
language-compilers language-decompilers language-evaluator
language-joiner
@@ -42,7 +42,6 @@
reader
printer
(parser #f)
- (read-file #f)
(compilers '())
(decompilers '())
(evaluator #f)
diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm
index 5dae355..4777431 100644
--- a/module/system/base/pmatch.scm
+++ b/module/system/base/pmatch.scm
@@ -16,15 +16,15 @@
(let ((v (op arg ...)))
(pmatch v cs ...)))
((_ v) (if #f #f))
- ((_ v (else e0 e ...)) (begin e0 e ...))
+ ((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat
- (if (and g ...) (begin e0 e ...) (fk))
+ (if (and g ...) (let () e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
- (ppat v pat (begin e0 e ...) (fk))))))
+ (ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat
(syntax-rules (_ quote unquote)
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index ebf2b93..0a06e3d 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -89,7 +89,7 @@
(catch #t
(lambda () (%start-stack #t thunk))
default-catch-handler
- pre-unwind-handler-dispatch))
+ default-pre-unwind-handler))
(define-macro (with-backtrace form)
`(call-with-backtrace (lambda () ,form)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 3854d4a..358421a 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -93,6 +93,7 @@ SCM_TESTS = tests/alist.test \
tests/syntax.test \
tests/threads.test \
tests/time.test \
+ tests/tree-il.test \
tests/unif.test \
tests/version.test \
tests/weaks.test
diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index c4ddf9e..3f09ce4 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -317,20 +317,24 @@
(set! run-test local-run-test))
;;; A short form for tests that are expected to pass, taken from Greg.
-(defmacro pass-if (name . rest)
- (if (and (null? rest) (pair? name))
- ;; presume this is a simple test, i.e. (pass-if (even? 2))
- ;; where the body should also be the name.
- `(run-test ',name #t (lambda () ,name))
- `(run-test ,name #t (lambda () ,@rest))))
+(define-syntax pass-if
+ (syntax-rules ()
+ ((_ name)
+ ;; presume this is a simple test, i.e. (pass-if (even? 2))
+ ;; where the body should also be the name.
+ (run-test 'name #t (lambda () name)))
+ ((_ name rest ...)
+ (run-test name #t (lambda () rest ...)))))
;;; A short form for tests that are expected to fail, taken from Greg.
-(defmacro expect-fail (name . rest)
- (if (and (null? rest) (pair? name))
- ;; presume this is a simple test, i.e. (expect-fail (even? 2))
- ;; where the body should also be the name.
- `(run-test ',name #f (lambda () ,name))
- `(run-test ,name #f (lambda () ,@rest))))
+(define-syntax expect-fail
+ (syntax-rules ()
+ ((_ name)
+ ;; presume this is a simple test, i.e. (expect-fail (even? 2))
+ ;; where the body should also be the name.
+ (run-test 'name #f (lambda () name)))
+ ((_ name rest ...)
+ (run-test name #f (lambda () rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
@@ -362,12 +366,16 @@
(apply throw key proc message rest))))))))
;;; A short form for tests that expect a certain exception to be thrown.
-(defmacro pass-if-exception (name exception body . rest)
- `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
+(define-syntax pass-if-exception
+ (syntax-rules ()
+ ((_ name exception body rest ...)
+ (run-test-exception name exception #t (lambda () body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
-(defmacro expect-fail-exception (name exception body . rest)
- `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
+(define-syntax expect-fail-exception
+ (syntax-rules ()
+ ((_ name exception body rest ...)
+ (run-test-exception name exception #f (lambda () body rest ...)))))
;;;; TEST NAMES
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index d83167f..7324d77 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -18,45 +18,10 @@
(define-module (test-suite tests compiler)
:use-module (test-suite lib)
:use-module (test-suite guile-test)
- :use-module (system vm program))
+ :use-module (system base compile))
-(with-test-prefix "environments"
+(with-test-prefix "basic"
- (pass-if "compile-time-environment in evaluator"
- (eq? (primitive-eval '(compile-time-environment)) #f))
-
- (pass-if "compile-time-environment in compiler"
- (equal? (compile '(compile-time-environment))
- (cons (current-module)
- (cons '() '()))))
-
- (let ((env (compile
- '(let ((x 0)) (set! x 1) (compile-time-environment)))))
- (pass-if "compile-time-environment in compiler, heap-allocated var"
- (equal? env
- (cons (current-module)
- (cons '((x . 0)) '(1)))))
-
- ;; fixme: compiling with #t or module
- (pass-if "recompiling with environment"
- (equal? ((compile '(lambda () x) #:env env))
- 1))
-
- (pass-if "recompiling with environment/2"
- (equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env))
- 2))
-
- (pass-if "recompiling with environment/3"
- (equal? ((compile '(lambda () x) #:env env))
- 2))
- )
-
- (pass-if "compile environment is #f"
- (equal? ((compile '(lambda () 10)))
- 10))
-
- (pass-if "compile environment is a module"
- (equal? ((compile '(lambda () 10) #:env (current-module)))
- 10))
- )
\ No newline at end of file
+ (pass-if "compile to value"
+ (equal? (compile 1) 1)))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 7a22f0d..e5ef34b 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -24,6 +24,9 @@
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
+(define exception:failed-match
+ (cons 'syntax-error "failed to match any pattern"))
+
;;;
;;; miscellaneous
@@ -85,17 +88,19 @@
;; Macros are accepted as function parameters.
;; Functions that 'apply' macros are rewritten!!!
- (expect-fail-exception "macro as argument"
- exception:wrong-type-arg
- (let ((f (lambda (p a b) (p a b))))
- (f and #t #t)))
-
- (expect-fail-exception "passing macro as parameter"
- exception:wrong-type-arg
- (let* ((f (lambda (p a b) (p a b)))
- (foo (procedure-source f)))
- (f and #t #t)
- (equal? (procedure-source f) foo)))
+ (pass-if-exception "macro as argument"
+ exception:failed-match
+ (primitive-eval
+ '(let ((f (lambda (p a b) (p a b))))
+ (f and #t #t))))
+
+ (pass-if-exception "passing macro as parameter"
+ exception:failed-match
+ (primitive-eval
+ '(let* ((f (lambda (p a b) (p a b)))
+ (foo (procedure-source f)))
+ (f and #t #t)
+ (equal? (procedure-source f) foo))))
))
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index b068c71..5e95a7a 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -35,6 +35,8 @@
(cons 'read-error "end of file in string constant$"))
(define exception:illegal-escape
(cons 'read-error "illegal character in escape sequence: .*$"))
+(define exception:missing-expression
+ (cons 'read-error "no expression after #;"))
(define (read-string s)
@@ -189,3 +191,36 @@
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 0)))))
+(with-test-prefix "#;"
+ (for-each
+ (lambda (pair)
+ (pass-if (car pair)
+ (equal? (with-input-from-string (car pair) read) (cdr pair))))
+
+ '(("#;foo 10". 10)
+ ("#;(10 20 30) foo" . foo)
+ ("#; (10 20 30) foo" . foo)
+ ("#;\n10\n20" . 20)))
+
+ (pass-if "#;foo"
+ (eof-object? (with-input-from-string "#;foo" read)))
+
+ (pass-if-exception "#;"
+ exception:missing-expression
+ (with-input-from-string "#;" read))
+ (pass-if-exception "#;("
+ exception:eof
+ (with-input-from-string "#;(" read)))
+
+(with-test-prefix "#'"
+ (for-each
+ (lambda (pair)
+ (pass-if (car pair)
+ (equal? (with-input-from-string (car pair) read) (cdr pair))))
+
+ '(("#'foo". (syntax foo))
+ ("#`foo" . (quasisyntax foo))
+ ("#,foo" . (unsyntax foo))
+ ("#,@foo" . (unsyntax-splicing foo)))))
+
+
diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test
index fbacb15..4841f2e 100644
--- a/test-suite/tests/srfi-17.test
+++ b/test-suite/tests/srfi-17.test
@@ -50,6 +50,9 @@
(define %some-variable #f)
+(define exception:bad-quote
+ '(syntax-error . "quote: bad syntax"))
+
(with-test-prefix "set!"
(with-test-prefix "target is not procedure with setter"
@@ -59,7 +62,7 @@
(set! (symbol->string 'x) 1))
(pass-if-exception "(set! '#f 1)"
- exception:bad-variable
+ exception:bad-quote
(eval '(set! '#f 1) (interaction-environment))))
(with-test-prefix "target uses macro"
@@ -72,7 +75,7 @@
;; The `(quote x)' below used to be memoized as an infinite list before
;; Guile 1.8.3.
(pass-if-exception "(set! 'x 1)"
- exception:bad-variable
+ exception:bad-quote
(eval '(set! 'x 1) (interaction-environment)))))
;;
diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
index fa309e6..3c70906 100644
--- a/test-suite/tests/srfi-18.test
+++ b/test-suite/tests/srfi-18.test
@@ -21,8 +21,13 @@
(define-module (test-suite test-srfi-18)
#:use-module (test-suite lib))
-(and (provided? 'threads)
- (use-modules (srfi srfi-18))
+;; two expressions so that the srfi-18 import is in effect for expansion
+;; of the rest
+(if (provided? 'threads)
+ (use-modules (srfi srfi-18)))
+
+(and
+ (provided? 'threads)
(with-test-prefix "current-thread"
diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test
index bd69773..b23d3e2 100644
--- a/test-suite/tests/srfi-31.test
+++ b/test-suite/tests/srfi-31.test
@@ -23,7 +23,7 @@
(with-test-prefix "rec special form"
(pass-if-exception "bogus variable" '(misc-error . ".*")
- (rec #:foo))
+ (sc-expand '(rec #:foo)))
(pass-if "rec expressions"
(let ((ones-list (rec ones (cons 1 (delay ones)))))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 1277e52..aa2e051 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -21,6 +21,11 @@
:use-module (test-suite lib))
+(define exception:generic-syncase-error
+ (cons 'syntax-error "source expression failed to match"))
+(define exception:unexpected-syntax
+ (cons 'syntax-error "unexpected syntax"))
+
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
@@ -29,22 +34,32 @@
(define exception:missing-expr
(cons 'syntax-error "Missing expression"))
(define exception:missing-body-expr
- (cons 'syntax-error "Missing body expression"))
+ (cons 'syntax-error "no expressions in body"))
(define exception:extra-expr
(cons 'syntax-error "Extra expression"))
(define exception:illegal-empty-combination
(cons 'syntax-error "Illegal empty combination"))
+(define exception:bad-lambda
+ '(syntax-error . "bad lambda"))
+(define exception:bad-let
+ '(syntax-error . "bad let "))
+(define exception:bad-letrec
+ '(syntax-error . "bad letrec "))
+(define exception:bad-set!
+ '(syntax-error . "bad set!"))
+(define exception:bad-quote
+ '(syntax-error . "quote: bad syntax"))
(define exception:bad-bindings
(cons 'syntax-error "Bad bindings"))
(define exception:bad-binding
(cons 'syntax-error "Bad binding"))
(define exception:duplicate-binding
- (cons 'syntax-error "Duplicate binding"))
+ (cons 'syntax-error "duplicate bound variable"))
(define exception:bad-body
(cons 'misc-error "^bad body"))
(define exception:bad-formals
- (cons 'syntax-error "Bad formals"))
+ '(syntax-error . "invalid parameter list"))
(define exception:bad-formal
(cons 'syntax-error "Bad formal"))
(define exception:duplicate-formal
@@ -67,13 +82,13 @@
(with-test-prefix "Bad argument list"
(pass-if-exception "improper argument list of length 1"
- exception:wrong-num-args
+ exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo . 1))
(interaction-environment)))
(pass-if-exception "improper argument list of length 2"
- exception:wrong-num-args
+ exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo 1 . 2))
(interaction-environment))))
@@ -88,7 +103,7 @@
;; Fixed on 2001-3-3
(pass-if-exception "empty parentheses \"()\""
- exception:illegal-empty-combination
+ exception:unexpected-syntax
(eval '()
(interaction-environment)))))
@@ -106,28 +121,32 @@
(with-test-prefix "unquote-splicing"
(pass-if-exception "extra arguments"
- exception:missing/extra-expr
- (quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))
+ '(syntax-error . "unquote-splicing takes exactly one argument")
+ (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
+ (interaction-environment)))))
(with-test-prefix "begin"
(pass-if "legal (begin)"
- (begin)
- #t)
+ (eval '(begin (begin) #t) (interaction-environment)))
(with-test-prefix "unmemoization"
+ ;; FIXME. I have no idea why, but the expander is filling in (if #f
+ ;; #f) as the second arm of the if, if the second arm is missing. I
+ ;; thought I made it not do that. But in the meantime, let's adapt,
+ ;; since that's not what we're testing.
+
(pass-if "normal begin"
- (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))
- (foo) ; make sure, memoization has been performed
+ (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))
(equal? (procedure-source foo)
- '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))))
+ '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))))
(pass-if "redundant nested begin"
- (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))
+ (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))
#f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
- '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))))
+ '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))
#f)))))
(pass-if "redundant begin at start of body"
(let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
@@ -135,10 +154,20 @@
(equal? (procedure-source foo)
'(lambda () (begin (+ 1) (+ 2)))))))
- (expect-fail-exception "illegal (begin)"
- exception:bad-body
- (if #t (begin))
- #t))
+ (pass-if-exception "illegal (begin)"
+ exception:generic-syncase-error
+ (eval '(begin (if #t (begin)) #t) (interaction-environment))))
+
+(define-syntax matches?
+ (syntax-rules (_)
+ ((_ (op arg ...) pat) (let ((x (op arg ...)))
+ (matches? x pat)))
+ ((_ x ()) (null? x))
+ ((_ x (a . b)) (and (pair? x)
+ (matches? (car x) a)
+ (matches? (cdr x) b)))
+ ((_ x _) #t)
+ ((_ x pat) (equal? x 'pat))))
(with-test-prefix "lambda"
@@ -146,30 +175,28 @@
(pass-if "normal lambda"
(let ((foo (lambda () (lambda (x y) (+ x y)))))
- ((foo) 1 2) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (lambda (x y) (+ x y))))))
+ (matches? (procedure-source foo)
+ (lambda () (lambda (_ _) (+ _ _))))))
(pass-if "lambda with documentation"
(let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
- ((foo) 1 2) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (lambda (x y) "docstring" (+ x y)))))))
+ (matches? (procedure-source foo)
+ (lambda () (lambda (_ _) "docstring" (+ _ _)))))))
(with-test-prefix "bad formals"
(pass-if-exception "(lambda)"
- exception:missing-expr
+ exception:bad-lambda
(eval '(lambda)
(interaction-environment)))
(pass-if-exception "(lambda . \"foo\")"
- exception:bad-expression
+ exception:bad-lambda
(eval '(lambda . "foo")
(interaction-environment)))
(pass-if-exception "(lambda \"foo\")"
- exception:missing-expr
+ exception:bad-lambda
(eval '(lambda "foo")
(interaction-environment)))
@@ -179,22 +206,22 @@
(interaction-environment)))
(pass-if-exception "(lambda (x 1) 2)"
- exception:bad-formal
+ exception:bad-formals
(eval '(lambda (x 1) 2)
(interaction-environment)))
(pass-if-exception "(lambda (1 x) 2)"
- exception:bad-formal
+ exception:bad-formals
(eval '(lambda (1 x) 2)
(interaction-environment)))
(pass-if-exception "(lambda (x \"a\") 2)"
- exception:bad-formal
+ exception:bad-formals
(eval '(lambda (x "a") 2)
(interaction-environment)))
(pass-if-exception "(lambda (\"a\" x) 2)"
- exception:bad-formal
+ exception:bad-formals
(eval '(lambda ("a" x) 2)
(interaction-environment))))
@@ -202,20 +229,20 @@
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x) 1)"
- exception:duplicate-formal
+ exception:bad-formals
(eval '(lambda (x x) 1)
(interaction-environment)))
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x x) 1)"
- exception:duplicate-formal
+ exception:bad-formals
(eval '(lambda (x x x) 1)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(lambda ())"
- exception:missing-expr
+ exception:bad-lambda
(eval '(lambda ())
(interaction-environment)))))
@@ -225,9 +252,8 @@
(pass-if "normal let"
(let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (let ((i 1) (j 2)) (+ i j)))))))
+ (matches? (procedure-source foo)
+ (lambda () (let ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
@@ -238,42 +264,42 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let)"
- exception:missing-expr
+ exception:bad-let
(eval '(let)
(interaction-environment)))
(pass-if-exception "(let 1)"
- exception:missing-expr
+ exception:bad-let
(eval '(let 1)
(interaction-environment)))
(pass-if-exception "(let (x))"
- exception:missing-expr
+ exception:bad-let
(eval '(let (x))
(interaction-environment)))
(pass-if-exception "(let ((x)))"
- exception:missing-expr
+ exception:bad-let
(eval '(let ((x)))
(interaction-environment)))
(pass-if-exception "(let (x) 1)"
- exception:bad-binding
+ exception:bad-let
(eval '(let (x) 1)
(interaction-environment)))
(pass-if-exception "(let ((x)) 3)"
- exception:bad-binding
+ exception:bad-let
(eval '(let ((x)) 3)
(interaction-environment)))
(pass-if-exception "(let ((x 1) y) x)"
- exception:bad-binding
+ exception:bad-let
(eval '(let ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(let ((1 2)) 3)"
- exception:bad-variable
+ exception:bad-let
(eval '(let ((1 2)) 3)
(interaction-environment))))
@@ -287,12 +313,12 @@
(with-test-prefix "bad body"
(pass-if-exception "(let ())"
- exception:missing-expr
+ exception:bad-let
(eval '(let ())
(interaction-environment)))
(pass-if-exception "(let ((x 1)))"
- exception:missing-expr
+ exception:bad-let
(eval '(let ((x 1)))
(interaction-environment)))))
@@ -307,19 +333,19 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let x (y))"
- exception:missing-expr
+ exception:bad-let
(eval '(let x (y))
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(let x ())"
- exception:missing-expr
+ exception:bad-let
(eval '(let x ())
(interaction-environment)))
(pass-if-exception "(let x ((y 1)))"
- exception:missing-expr
+ exception:bad-let
(eval '(let x ((y 1)))
(interaction-environment)))))
@@ -329,19 +355,16 @@
(pass-if "normal let*"
(let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (let* ((x 1) (y 2)) (+ x y))))))
+ (matches? (procedure-source foo)
+ (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _)))))))
(pass-if "let* without bindings"
(let ((foo (lambda () (let ((x 1) (y 2))
(let* ()
(and (= x 1) (= y 2)))))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (let ((x 1) (y 2))
- (let* ()
- (and (= x 1) (= y 2)))))))))
+ (matches? (procedure-source foo)
+ (lambda () (let ((_ 1) (_ 2))
+ (if (= _ 1) (= _ 2) #f)))))))
(with-test-prefix "bindings"
@@ -361,59 +384,59 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let*)"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(let*)
(interaction-environment)))
(pass-if-exception "(let* 1)"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(let* 1)
(interaction-environment)))
(pass-if-exception "(let* (x))"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(let* (x))
(interaction-environment)))
(pass-if-exception "(let* (x) 1)"
- exception:bad-binding
+ exception:generic-syncase-error
(eval '(let* (x) 1)
(interaction-environment)))
(pass-if-exception "(let* ((x)) 3)"
- exception:bad-binding
+ exception:generic-syncase-error
(eval '(let* ((x)) 3)
(interaction-environment)))
(pass-if-exception "(let* ((x 1) y) x)"
- exception:bad-binding
+ exception:generic-syncase-error
(eval '(let* ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(let* x ())"
- exception:bad-bindings
+ exception:generic-syncase-error
(eval '(let* x ())
(interaction-environment)))
(pass-if-exception "(let* x (y))"
- exception:bad-bindings
+ exception:generic-syncase-error
(eval '(let* x (y))
(interaction-environment)))
(pass-if-exception "(let* ((1 2)) 3)"
- exception:bad-variable
+ exception:generic-syncase-error
(eval '(let* ((1 2)) 3)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(let* ())"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(let* ())
(interaction-environment)))
(pass-if-exception "(let* ((x 1)))"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(let* ((x 1)))
(interaction-environment)))))
@@ -423,9 +446,8 @@
(pass-if "normal letrec"
(let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (letrec ((i 1) (j 2)) (+ i j)))))))
+ (matches? (procedure-source foo)
+ (lambda () (letrec ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
@@ -437,47 +459,47 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(letrec)"
- exception:missing-expr
+ exception:bad-letrec
(eval '(letrec)
(interaction-environment)))
(pass-if-exception "(letrec 1)"
- exception:missing-expr
+ exception:bad-letrec
(eval '(letrec 1)
(interaction-environment)))
(pass-if-exception "(letrec (x))"
- exception:missing-expr
+ exception:bad-letrec
(eval '(letrec (x))
(interaction-environment)))
(pass-if-exception "(letrec (x) 1)"
- exception:bad-binding
+ exception:bad-letrec
(eval '(letrec (x) 1)
(interaction-environment)))
(pass-if-exception "(letrec ((x)) 3)"
- exception:bad-binding
+ exception:bad-letrec
(eval '(letrec ((x)) 3)
(interaction-environment)))
(pass-if-exception "(letrec ((x 1) y) x)"
- exception:bad-binding
+ exception:bad-letrec
(eval '(letrec ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(letrec x ())"
- exception:bad-bindings
+ exception:bad-letrec
(eval '(letrec x ())
(interaction-environment)))
(pass-if-exception "(letrec x (y))"
- exception:bad-bindings
+ exception:bad-letrec
(eval '(letrec x (y))
(interaction-environment)))
(pass-if-exception "(letrec ((1 2)) 3)"
- exception:bad-variable
+ exception:bad-letrec
(eval '(letrec ((1 2)) 3)
(interaction-environment))))
@@ -491,12 +513,12 @@
(with-test-prefix "bad body"
(pass-if-exception "(letrec ())"
- exception:missing-expr
+ exception:bad-letrec
(eval '(letrec ())
(interaction-environment)))
(pass-if-exception "(letrec ((x 1)))"
- exception:missing-expr
+ exception:bad-letrec
(eval '(letrec ((x 1)))
(interaction-environment)))))
@@ -508,17 +530,17 @@
(let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (if x (+ 1) (+ 2))))))
+ (matches? (procedure-source foo)
+ (lambda (_) (if _ (+ 1) (+ 2))))))
- (pass-if "if without else"
+ (expect-fail "if without else"
(let ((foo (lambda (x) (if x (+ 1)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (if x (+ 1))))))
- (pass-if "if #f without else"
+ (expect-fail "if #f without else"
(let ((foo (lambda () (if #f #f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
@@ -527,12 +549,12 @@
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)"
- exception:missing/extra-expr
+ exception:generic-syncase-error
(eval '(if)
(interaction-environment)))
(pass-if-exception "(if 1 2 3 4)"
- exception:missing/extra-expr
+ exception:generic-syncase-error
(eval '(if 1 2 3 4)
(interaction-environment)))))
@@ -594,78 +616,77 @@
(eq? 'ok (cond (#t identity =>) (else #f)))))
(pass-if-exception "missing recipient"
- '(syntax-error . "Missing recipient")
+ '(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity =>)))
(pass-if-exception "extra recipient"
- '(syntax-error . "Extra expression")
+ '(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity => identity identity))))
(with-test-prefix "unmemoization"
+ ;; FIXME: the (if #f #f) is a hack!
(pass-if "normal clauses"
- (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
- (foo 1) ; make sure, memoization has been performed
- (foo 2) ; make sure, memoization has been performed
+ (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
(equal? (procedure-source foo)
- '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
+ '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f)))))))
(pass-if "else"
(let ((foo (lambda () (cond (else 'bar)))))
- (foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
- '(lambda () (cond (else 'bar))))))
+ '(lambda () 'bar))))
+ ;; FIXME: the (if #f #f) is a hack!
(pass-if "=>"
(let ((foo (lambda () (cond (#t => identity)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (cond (#t => identity)))))))
+ (matches? (procedure-source foo)
+ (lambda () (let ((_ #t))
+ (if _ (identity _) (if #f #f))))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(cond)"
- exception:missing-clauses
+ exception:generic-syncase-error
(eval '(cond)
(interaction-environment)))
(pass-if-exception "(cond #t)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond #t)
(interaction-environment)))
(pass-if-exception "(cond 1)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond 1)
(interaction-environment)))
(pass-if-exception "(cond 1 2)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond 1 2)
(interaction-environment)))
(pass-if-exception "(cond 1 2 3)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond 1 2 3)
(interaction-environment)))
(pass-if-exception "(cond 1 2 3 4)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond 1 2 3 4)
(interaction-environment)))
(pass-if-exception "(cond ())"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond ())
(interaction-environment)))
(pass-if-exception "(cond () 1)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond () 1)
(interaction-environment)))
(pass-if-exception "(cond (1) 1)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond (1) 1)
(interaction-environment))))
@@ -683,7 +704,7 @@
(with-test-prefix "case is hygienic"
(pass-if-exception "bound 'else is handled correctly"
- exception:bad-case-labels
+ exception:generic-syncase-error
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
@@ -691,79 +712,83 @@
(pass-if "normal clauses"
(let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
- (foo 1) ; make sure, memoization has been performed
- (foo 2) ; make sure, memoization has been performed
- (foo 3) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))
+ (matches? (procedure-source foo)
+ (lambda (_)
+ (if ((@@ (guile) memv) _ '(1))
+ 'bar
+ (if ((@@ (guile) memv) _ '(2))
+ 'baz
+ 'foobar))))))
(pass-if "empty labels"
(let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
- (foo 1) ; make sure, memoization has been performed
- (foo 2) ; make sure, memoization has been performed
- (foo 3) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))
+ (matches? (procedure-source foo)
+ (lambda (_)
+ (if ((@@ (guile) memv) _ '(1))
+ 'bar
+ (if ((@@ (guile) memv) _ '())
+ 'baz
+ 'foobar)))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(case)"
- exception:missing-clauses
+ exception:generic-syncase-error
(eval '(case)
(interaction-environment)))
(pass-if-exception "(case . \"foo\")"
- exception:bad-expression
+ exception:generic-syncase-error
(eval '(case . "foo")
(interaction-environment)))
(pass-if-exception "(case 1)"
- exception:missing-clauses
+ exception:generic-syncase-error
(eval '(case 1)
(interaction-environment)))
(pass-if-exception "(case 1 . \"foo\")"
- exception:bad-expression
+ exception:generic-syncase-error
(eval '(case 1 . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 \"foo\")"
- exception:bad-case-clause
+ exception:generic-syncase-error
(eval '(case 1 "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ())"
- exception:bad-case-clause
+ exception:generic-syncase-error
(eval '(case 1 ())
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\"))"
- exception:bad-case-clause
+ exception:generic-syncase-error
(eval '(case 1 ("foo"))
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\" \"bar\"))"
- exception:bad-case-labels
+ exception:generic-syncase-error
(eval '(case 1 ("foo" "bar"))
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
- exception:bad-expression
+ exception:generic-syncase-error
(eval '(case 1 ((2) "bar") . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") (else))"
- exception:bad-case-clause
+ exception:generic-syncase-error
(eval '(case 1 ((2) "bar") (else))
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) . \"foo\")"
- exception:bad-expression
+ exception:generic-syncase-error
(eval '(case 1 (else #f) . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) ((1) #t))"
- exception:misplaced-else-clause
+ exception:generic-syncase-error
(eval '(case 1 (else #f) ((1) #t))
(interaction-environment)))))
@@ -780,14 +805,6 @@
(eval '(define round round) m)
(eq? (module-ref m 'round) round)))
- (with-test-prefix "currying"
-
- (pass-if "(define ((foo)) #f)"
- (eval '(begin
- (define ((foo)) #t)
- ((foo)))
- (interaction-environment))))
-
(with-test-prefix "unmemoization"
(pass-if "definition unmemoized without prior execution"
@@ -809,7 +826,7 @@
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(define)"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(define)
(interaction-environment)))))
@@ -886,34 +903,10 @@
'ok)
(bar))
(foo)
- (equal?
+ (matches?
(procedure-source foo)
- '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
- (interaction-environment))))
-
-(with-test-prefix "do"
-
- (with-test-prefix "unmemoization"
-
- (pass-if "normal case"
- (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2))
- ((> i 9) (+ i j))
- (identity i)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (do ((i 1 (+ i 1)) (j 2))
- ((> i 9) (+ i j))
- (identity i))))))
-
- (pass-if "reduced case"
- (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j
- ((> i 9) (+ i j))
- (identity i)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here
- ((> i 9) (+ i j))
- (identity i))))))))
+ (lambda () (letrec ((_ (lambda () (quote ok)))) (_)))))
+ (current-module))))
(with-test-prefix "set!"
@@ -922,50 +915,50 @@
(pass-if "normal set!"
(let ((foo (lambda (x) (set! x (+ 1 x)))))
(foo 1) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (set! x (+ 1 x)))))))
+ (matches? (procedure-source foo)
+ (lambda (_) (set! _ (+ 1 _)))))))
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)"
- exception:missing/extra-expr
+ exception:bad-set!
(eval '(set!)
(interaction-environment)))
(pass-if-exception "(set! 1)"
- exception:missing/extra-expr
+ exception:bad-set!
(eval '(set! 1)
(interaction-environment)))
(pass-if-exception "(set! 1 2 3)"
- exception:missing/extra-expr
+ exception:bad-set!
(eval '(set! 1 2 3)
(interaction-environment))))
(with-test-prefix "bad variable"
(pass-if-exception "(set! \"\" #t)"
- exception:bad-variable
+ exception:bad-set!
(eval '(set! "" #t)
(interaction-environment)))
(pass-if-exception "(set! 1 #t)"
- exception:bad-variable
+ exception:bad-set!
(eval '(set! 1 #t)
(interaction-environment)))
(pass-if-exception "(set! #t #f)"
- exception:bad-variable
+ exception:bad-set!
(eval '(set! #t #f)
(interaction-environment)))
(pass-if-exception "(set! #f #t)"
- exception:bad-variable
+ exception:bad-set!
(eval '(set! #f #t)
(interaction-environment)))
(pass-if-exception "(set! #\\space #f)"
- exception:bad-variable
+ exception:bad-set!
(eval '(set! #\space #f)
(interaction-environment)))))
@@ -974,12 +967,12 @@
(with-test-prefix "missing or extra expression"
(pass-if-exception "(quote)"
- exception:missing/extra-expr
+ exception:bad-quote
(eval '(quote)
(interaction-environment)))
(pass-if-exception "(quote a b)"
- exception:missing/extra-expr
+ exception:bad-quote
(eval '(quote a b)
(interaction-environment)))))
@@ -1010,46 +1003,27 @@
(do ((n 0 (1+ n)))
((> n 5))
(pass-if n
- (let ((cond (make-iterations-cond n)))
- (while (cond)))
- #t)))
+ (eval `(letrec ((make-iterations-cond
+ (lambda (n)
+ (lambda ()
+ (cond ((not n)
+ (error "oops, condition re-tested after
giving false"))
+ ((= 0 n)
+ (set! n #f)
+ #f)
+ (else
+ (set! n (1- n))
+ #t))))))
+ (let ((cond (make-iterations-cond ,n)))
+ (while (cond))
+ #t))
+ (interaction-environment)))))
(pass-if "initially false"
(while #f
(unreachable))
#t)
- (with-test-prefix "in empty environment"
-
- ;; an environment with no bindings at all
- (define empty-environment
- (make-module 1))
-
- ;; these tests are 'unresolved because to work with ice-9 syncase it was
- ;; necessary to drop the unquote from `do' in the implementation, and
- ;; unfortunately that makes `while' depend on its evaluation environment
-
- (pass-if "empty body"
- (throw 'unresolved)
- (eval `(,while #f)
- empty-environment)
- #t)
-
- (pass-if "initially false"
- (throw 'unresolved)
- (eval `(,while #f
- #f)
- empty-environment)
- #t)
-
- (pass-if "iterating"
- (throw 'unresolved)
- (let ((cond (make-iterations-cond 3)))
- (eval `(,while (,cond)
- 123 456)
- empty-environment))
- #t))
-
(with-test-prefix "iterations"
(do ((n 0 (1+ n)))
((> n 5))
@@ -1063,8 +1037,9 @@
(with-test-prefix "break"
(pass-if-exception "too many args" exception:wrong-num-args
- (while #t
- (break 1)))
+ (eval '(while #t
+ (break 1))
+ (interaction-environment)))
(with-test-prefix "from cond"
(pass-if "first"
@@ -1135,8 +1110,9 @@
(with-test-prefix "continue"
(pass-if-exception "too many args" exception:wrong-num-args
- (while #t
- (continue 1)))
+ (eval '(while #t
+ (continue 1))
+ (interaction-environment)))
(with-test-prefix "from cond"
(do ((n 0 (1+ n)))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
new file mode 100644
index 0000000..18b67d6
--- /dev/null
+++ b/test-suite/tests/tree-il.test
@@ -0,0 +1,467 @@
+;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
+;;;; Andy Wingo <address@hidden> --- May 2009
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-suite tree-il)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system base pmatch)
+ #:use-module (language tree-il)
+ #:use-module (language glil))
+
+;; Of course, the GLIL that is emitted depends on the source info of the
+;; input. Here we're not concerned about that, so we strip source
+;; information from the incoming tree-il.
+
+(define (strip-source x)
+ (post-order! (lambda (x) (set! (tree-il-src x) #f))
+ x))
+
+(define-syntax assert-scheme->glil
+ (syntax-rules ()
+ ((_ in out)
+ (let ((tree-il (strip-source
+ (compile 'in #:from 'scheme #:to 'tree-il))))
+ (pass-if 'in
+ (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to
'glil))
+ 'out))))))
+
+(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
+ (let ((glil (unparse-glil
+ (compile (strip-source (parse-tree-il exp))
+ #:from 'tree-il #:to 'glil))))
+ (pmatch glil
+ (pat (guard test ...) #t)
+ (else #f))))))))
+
+(with-test-prefix "void"
+ (assert-tree-il->glil
+ (void)
+ (program 0 0 0 0 () (void) (call return 1)))
+ (assert-tree-il->glil
+ (begin (void) (const 1))
+ (program 0 0 0 0 () (const 1) (call return 1)))
+ (assert-tree-il->glil
+ (apply (primitive +) (void) (const 1))
+ (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
+
+(with-test-prefix "application"
+ (assert-tree-il->glil
+ (apply (toplevel foo) (const 1))
+ (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
+ (assert-tree-il->glil/pmatch
+ (begin (apply (toplevel foo) (const 1)) (void))
+ (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+ (call drop 1) (branch br ,l2)
+ (label ,l3) (mv-bind () #f) (unbind)
+ (label ,l4)
+ (void) (call return 1))
+ (and (eq? l1 l3) (eq? l2 l4)))
+ (assert-tree-il->glil
+ (apply (toplevel foo) (apply (toplevel bar)))
+ (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
+ (call goto/args 1))))
+
+(with-test-prefix "conditional"
+ (assert-tree-il->glil/pmatch
+ (if (const #t) (const 1) (const 2))
+ (program 0 0 0 0 () (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
+ (begin (if (const #t) (const 1) (const 2)) (const #f))
+ (program 0 0 0 0 () (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
+ (apply (primitive null?) (if (const #t) (const 1) (const 2)))
+ (program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (const 1) (branch br ,l2)
+ (label ,l3) (const 2) (label ,l4)
+ (call null? 1) (call return 1))
+ (eq? l1 l3) (eq? l2 l4)))
+
+(with-test-prefix "primitive-ref"
+ (assert-tree-il->glil
+ (primitive +)
+ (program 0 0 0 0 () (toplevel ref +) (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (primitive +) (const #f))
+ (program 0 0 0 0 () (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (primitive +))
+ (program 0 0 0 0 () (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 0 ()
+ (const 1) (bind (x local 0)) (local set 0)
+ (local 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 0 ()
+ (const 1) (bind (x local 0)) (local 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 0 ()
+ (const 1) (bind (x local 0)) (local set 0)
+ (local ref 0) (call null? 1) (call return 1)
+ (unbind))))
+
+(with-test-prefix "lexical sets"
+ (assert-tree-il->glil
+ (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
+ (program 0 0 0 1 ()
+ (const 1) (bind (x external 0)) (external set 0 0)
+ (const 2) (external set 0 0) (void) (call return 1)
+ (unbind)))
+
+ (assert-tree-il->glil
+ (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
+ (program 0 0 0 1 ()
+ (const 1) (bind (x external 0)) (external set 0 0)
+ (const 2) (external set 0 0) (const #f) (call return 1)
+ (unbind)))
+
+ (assert-tree-il->glil
+ (let (x) (y) ((const 1))
+ (apply (primitive null?) (set! (lexical x y) (const 2))))
+ (program 0 0 0 1 ()
+ (const 1) (bind (x external 0)) (external set 0 0)
+ (const 2) (external set 0 0) (void) (call null? 1) (call return 1)
+ (unbind))))
+
+(with-test-prefix "module refs"
+ (assert-tree-il->glil
+ (@ (foo) bar)
+ (program 0 0 0 0 ()
+ (module public ref (foo) bar)
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (@ (foo) bar) (const #f))
+ (program 0 0 0 0 ()
+ (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 0 ()
+ (module public ref (foo) bar)
+ (call null? 1) (call return 1)))
+
+ (assert-tree-il->glil
+ (@@ (foo) bar)
+ (program 0 0 0 0 ()
+ (module private ref (foo) bar)
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (@@ (foo) bar) (const #f))
+ (program 0 0 0 0 ()
+ (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 0 ()
+ (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 0 ()
+ (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 0 ()
+ (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 0 ()
+ (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 0 ()
+ (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 0 ()
+ (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 0 ()
+ (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 0 ()
+ (toplevel ref bar)
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (toplevel bar) (const #f))
+ (program 0 0 0 0 ()
+ (toplevel ref bar) (call drop 1)
+ (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (toplevel bar))
+ (program 0 0 0 0 ()
+ (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 0 ()
+ (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 0 ()
+ (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 0 ()
+ (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 0 ()
+ (const 2) (toplevel define bar)
+ (void) (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (define bar (const 2)) (const #f))
+ (program 0 0 0 0 ()
+ (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 0 ()
+ (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 0 ()
+ (const 2) (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (const 2) (const #f))
+ (program 0 0 0 0 ()
+ (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (const 2))
+ (program 0 0 0 0 ()
+ (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 0 ()
+ (program 1 0 0 0 ()
+ (bind (x local 0))
+ (const 2) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda (x x1) (y y1) () (const 2))
+ (program 0 0 0 0 ()
+ (program 2 0 0 0 ()
+ (bind (x local 0) (x1 local 1))
+ (const 2) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda x y () (const 2))
+ (program 0 0 0 0 ()
+ (program 1 1 0 0 ()
+ (bind (x local 0))
+ (const 2) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda (x . x1) (y . y1) () (const 2))
+ (program 0 0 0 0 ()
+ (program 2 1 0 0 ()
+ (bind (x local 0) (x1 local 1))
+ (const 2) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda (x . x1) (y . y1) () (lexical x y))
+ (program 0 0 0 0 ()
+ (program 2 1 0 0 ()
+ (bind (x local 0) (x1 local 1))
+ (local ref 0) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda (x . x1) (y . y1) () (lexical x1 y1))
+ (program 0 0 0 0 ()
+ (program 2 1 0 0 ()
+ (bind (x local 0) (x1 local 1))
+ (local ref 1) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
+ (program 0 0 0 0 ()
+ (program 1 0 0 1 ()
+ (bind (x external 0))
+ (local ref 0) (external set 0 0)
+ (program 1 0 0 0 ()
+ (bind (y local 0))
+ (external ref 1 0) (call return 1))
+ (call return 1))
+ (call return 1))))
+
+(with-test-prefix "sequence"
+ (assert-tree-il->glil
+ (begin (begin (const 2) (const #f)) (const #t))
+ (program 0 0 0 0 ()
+ (const #t) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (begin (const #f) (const 2)))
+ (program 0 0 0 0 ()
+ (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
+ (let (x) (y) ((const 1))
+ (if (lexical x y)
+ (lexical x y)
+ (let (a) (b) ((const 2))
+ (lexical a b))))
+ (program 0 0 1 0 ()
+ (const 1) (bind (x local 0)) (local set 0)
+ (local ref 0) (branch br-if-not ,l1)
+ (local ref 0) (call return 1)
+ (label ,l2)
+ (const 2) (bind (a local 0)) (local set 0)
+ (local ref 0) (call return 1)
+ (unbind)
+ (unbind))
+ (eq? l1 l2))
+
+ (assert-tree-il->glil/pmatch
+ (let (x) (y) ((const 1))
+ (if (lexical x y)
+ (lexical x y)
+ (let (a) (b) ((const 2))
+ (lexical x y))))
+ (program 0 0 2 0 ()
+ (const 1) (bind (x local 0)) (local set 0)
+ (local ref 0) (branch br-if-not ,l1)
+ (local ref 0) (call return 1)
+ (label ,l2)
+ (const 2) (bind (a local 1)) (local set 1)
+ (local ref 0) (call return 1)
+ (unbind)
+ (unbind))
+ (eq? l1 l2)))
+
+(with-test-prefix "apply"
+ (assert-tree-il->glil
+ (apply (primitive @apply) (toplevel foo) (toplevel bar))
+ (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply
2)))
+ (assert-tree-il->glil/pmatch
+ (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
+ (program 0 0 0 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)
+ (void) (call return 1))
+ (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 0 ()
+ (toplevel ref foo)
+ (toplevel ref bar) (toplevel ref baz) (call apply 2)
+ (call goto/args 1))))
+
+(with-test-prefix "call/cc"
+ (assert-tree-il->glil
+ (apply (primitive @call-with-current-continuation) (toplevel foo))
+ (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
+ (assert-tree-il->glil/pmatch
+ (begin (apply (primitive @call-with-current-continuation) (toplevel foo))
(void))
+ (program 0 0 0 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)
+ (void) (call return 1))
+ (and (eq? l1 l3) (eq? l2 l4)))
+ (assert-tree-il->glil
+ (apply (toplevel foo)
+ (apply (toplevel @call-with-current-continuation) (toplevel bar)))
+ (program 0 0 0 0 ()
+ (toplevel ref foo)
+ (toplevel ref bar) (call call/cc 1)
+ (call goto/args 1))))
+
diff --git a/testsuite/t-match.scm b/testsuite/t-match.scm
index 4b85f30..ed56ae7 100644
--- a/testsuite/t-match.scm
+++ b/testsuite/t-match.scm
@@ -12,7 +12,7 @@
(define (matches? obj)
; (format #t "matches? ~a~%" obj)
(match obj
- (($ stuff) => #t)
+ (($ stuff) #t)
; (blurps #t)
("hello" #t)
(else #f)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. e3c5df539640a36eb1493f581087d54a4714f337,
Andy Wingo <=