summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-08-17 23:39:56 +0200
committerLudovic Courtès <ludo@gnu.org>2009-08-18 00:06:45 +0200
commitfbb857a472eb4e69c1cba05e86646b7004f32df6 (patch)
treeff23e64de5a558b575ed812349d8af6e64d8ceb4 /module
parent49c9839eae84f7f3cd10db45f389fa1ea1050659 (diff)
parente33a910dd0f430f34c32fe6846899aee33fc2cf6 (diff)
downloadguile-fbb857a472eb4e69c1cba05e86646b7004f32df6.tar.gz
Merge branch 'master' into boehm-demers-weiser-gc
Conflicts: lib/Makefile.am libguile/Makefile.am libguile/frames.c libguile/gc-card.c libguile/gc-freelist.c libguile/gc-mark.c libguile/gc-segment.c libguile/gc_os_dep.c libguile/load.c libguile/macros.c libguile/objcodes.c libguile/programs.c libguile/strings.c libguile/vm.c m4/gnulib-cache.m4 m4/gnulib-comp.m4 m4/inline.m4
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am251
-rw-r--r--module/ice-9/Makefile.am70
-rw-r--r--module/ice-9/and-let-star.scm2
-rw-r--r--module/ice-9/annotate.scm80
-rw-r--r--module/ice-9/arrays.scm21
-rw-r--r--module/ice-9/boot-9.scm843
-rw-r--r--module/ice-9/buffered-input.scm2
-rw-r--r--module/ice-9/calling.scm2
-rw-r--r--module/ice-9/channel.scm26
-rw-r--r--module/ice-9/common-list.scm2
-rw-r--r--module/ice-9/compile-psyntax.scm43
-rw-r--r--module/ice-9/debug.scm2
-rw-r--r--module/ice-9/debugger.scm26
-rw-r--r--module/ice-9/debugger/Makefile.am31
-rw-r--r--module/ice-9/debugger/command-loop.scm26
-rw-r--r--module/ice-9/debugger/commands.scm26
-rw-r--r--module/ice-9/debugger/state.scm26
-rw-r--r--module/ice-9/debugger/trc.scm26
-rw-r--r--module/ice-9/debugging/Makefile.am33
-rw-r--r--module/ice-9/debugging/breakpoints.scm26
-rw-r--r--module/ice-9/debugging/steps.scm26
-rw-r--r--module/ice-9/debugging/trace.scm26
-rwxr-xr-xmodule/ice-9/debugging/traps.scm26
-rw-r--r--module/ice-9/debugging/trc.scm26
-rw-r--r--module/ice-9/deprecated.scm4
-rw-r--r--module/ice-9/documentation.scm10
-rw-r--r--module/ice-9/emacs.scm2
-rw-r--r--module/ice-9/expect.scm2
-rw-r--r--module/ice-9/ftw.scm2
-rw-r--r--module/ice-9/gap-buffer.scm26
-rw-r--r--module/ice-9/gds-server.scm26
-rw-r--r--module/ice-9/getopt-long.scm26
-rw-r--r--module/ice-9/hcons.scm2
-rw-r--r--module/ice-9/history.scm2
-rw-r--r--module/ice-9/i18n.scm6
-rw-r--r--module/ice-9/lineio.scm2
-rw-r--r--module/ice-9/list.scm26
-rw-r--r--module/ice-9/ls.scm2
-rw-r--r--module/ice-9/mapping.scm2
-rw-r--r--module/ice-9/match.scm6
-rw-r--r--module/ice-9/networking.scm5
-rw-r--r--module/ice-9/null.scm3
-rw-r--r--module/ice-9/occam-channel.scm27
-rw-r--r--module/ice-9/optargs.scm14
-rw-r--r--module/ice-9/poe.scm2
-rw-r--r--module/ice-9/popen.scm2
-rw-r--r--module/ice-9/posix.scm5
-rw-r--r--module/ice-9/pretty-print.scm2
-rw-r--r--module/ice-9/psyntax-pp.scm12161
-rw-r--r--module/ice-9/psyntax.scm1482
-rw-r--r--module/ice-9/q.scm2
-rw-r--r--module/ice-9/r4rs.scm30
-rw-r--r--module/ice-9/r5rs.scm2
-rw-r--r--module/ice-9/rdelim.scm2
-rw-r--r--module/ice-9/receive.scm26
-rw-r--r--module/ice-9/regex.scm2
-rw-r--r--module/ice-9/runq.scm2
-rw-r--r--module/ice-9/rw.scm2
-rw-r--r--module/ice-9/safe-r5rs.scm2
-rw-r--r--module/ice-9/safe.scm2
-rw-r--r--module/ice-9/serialize.scm2
-rw-r--r--module/ice-9/session.scm2
-rw-r--r--module/ice-9/slib.scm6
-rw-r--r--module/ice-9/stack-catch.scm4
-rw-r--r--module/ice-9/streams.scm2
-rw-r--r--module/ice-9/string-fun.scm2
-rw-r--r--module/ice-9/syncase.scm241
-rw-r--r--module/ice-9/test.scm26
-rw-r--r--module/ice-9/threads.scm116
-rw-r--r--module/ice-9/time.scm4
-rw-r--r--module/ice-9/weak-vector.scm2
-rw-r--r--module/language/assembly.scm105
-rw-r--r--module/language/assembly/compile-bytecode.scm80
-rw-r--r--module/language/assembly/decompile-bytecode.scm63
-rw-r--r--module/language/assembly/disassemble.scm73
-rw-r--r--module/language/assembly/spec.scm27
-rw-r--r--module/language/brainfuck/compile-scheme.scm126
-rw-r--r--module/language/brainfuck/compile-tree-il.scm181
-rw-r--r--module/language/brainfuck/parse.scm91
-rw-r--r--module/language/brainfuck/spec.scm44
-rw-r--r--module/language/bytecode/spec.scm29
-rw-r--r--module/language/ecmascript/array.scm27
-rw-r--r--module/language/ecmascript/base.scm27
-rw-r--r--module/language/ecmascript/compile-ghil.scm572
-rw-r--r--module/language/ecmascript/compile-tree-il.scm549
-rw-r--r--module/language/ecmascript/function.scm27
-rw-r--r--module/language/ecmascript/impl.scm27
-rw-r--r--module/language/ecmascript/parse-lalr.scm25
-rw-r--r--module/language/ecmascript/parse.scm27
-rw-r--r--module/language/ecmascript/spec.scm32
-rw-r--r--module/language/ecmascript/tokenize.scm29
-rw-r--r--module/language/elisp/spec.scm27
-rw-r--r--module/language/ghil.scm32
-rw-r--r--module/language/ghil/compile-glil.scm46
-rw-r--r--module/language/ghil/spec.scm46
-rw-r--r--module/language/glil.scm92
-rw-r--r--module/language/glil/compile-assembly.scm301
-rw-r--r--module/language/glil/decompile-assembly.scm55
-rw-r--r--module/language/glil/spec.scm29
-rw-r--r--module/language/objcode.scm27
-rw-r--r--module/language/objcode/spec.scm48
-rw-r--r--module/language/r5rs/core.il27
-rw-r--r--module/language/r5rs/expand.scm27
-rw-r--r--module/language/r5rs/null.il27
-rw-r--r--module/language/r5rs/spec.scm27
-rw-r--r--module/language/scheme/amatch.scm37
-rw-r--r--module/language/scheme/compile-ghil.scm102
-rw-r--r--module/language/scheme/compile-tree-il.scm63
-rw-r--r--module/language/scheme/decompile-tree-il.scm26
-rw-r--r--module/language/scheme/expand.scm307
-rw-r--r--module/language/scheme/inline.scm27
-rw-r--r--module/language/scheme/spec.scm44
-rw-r--r--module/language/tree-il.scm474
-rw-r--r--module/language/tree-il/analyze.scm617
-rw-r--r--module/language/tree-il/compile-glil.scm723
-rw-r--r--module/language/tree-il/fix-letrec.scm240
-rw-r--r--module/language/tree-il/inline.scm81
-rw-r--r--module/language/tree-il/optimize.scm35
-rw-r--r--module/language/tree-il/primitives.scm287
-rw-r--r--module/language/tree-il/spec.scm42
-rw-r--r--module/language/value/spec.scm27
-rw-r--r--module/oop/Makefile.am30
-rw-r--r--module/oop/goops.scm402
-rw-r--r--module/oop/goops/Makefile.am30
-rw-r--r--module/oop/goops/accessors.scm21
-rw-r--r--module/oop/goops/active-slot.scm2
-rw-r--r--module/oop/goops/compile.scm45
-rw-r--r--module/oop/goops/composite-slot.scm2
-rw-r--r--module/oop/goops/describe.scm2
-rw-r--r--module/oop/goops/dispatch.scm7
-rw-r--r--module/oop/goops/internal.scm2
-rw-r--r--module/oop/goops/save.scm6
-rw-r--r--module/oop/goops/simple.scm7
-rw-r--r--module/oop/goops/stklos.scm73
-rw-r--r--module/oop/goops/util.scm2
-rw-r--r--module/rnrs/bytevector.scm85
-rw-r--r--module/rnrs/io/ports.scm111
-rw-r--r--module/scripts/ChangeLog-2008319
-rw-r--r--module/scripts/PROGRAM.scm40
-rw-r--r--module/scripts/README76
-rw-r--r--module/scripts/api-diff.scm176
-rw-r--r--module/scripts/autofrisk.scm216
-rw-r--r--module/scripts/compile.scm183
-rw-r--r--module/scripts/disassemble.scm40
-rw-r--r--module/scripts/display-commentary.scm65
-rw-r--r--module/scripts/doc-snarf.scm437
-rw-r--r--module/scripts/frisk.scm287
-rw-r--r--module/scripts/generate-autoload.scm141
-rw-r--r--module/scripts/lint.scm315
-rw-r--r--module/scripts/punify.scm84
-rw-r--r--module/scripts/read-rfc822.scm128
-rw-r--r--module/scripts/read-scheme-source.scm279
-rw-r--r--module/scripts/read-text-outline.scm250
-rw-r--r--module/scripts/scan-api.scm220
-rw-r--r--module/scripts/snarf-check-and-output-texi.scm308
-rw-r--r--module/scripts/snarf-guile-m4-docs.scm83
-rw-r--r--module/scripts/summarize-guile-TODO.scm210
-rw-r--r--module/scripts/use2dot.scm108
-rw-r--r--module/srfi/Makefile.am20
-rw-r--r--module/srfi/srfi-1.scm2
-rw-r--r--module/srfi/srfi-10.scm2
-rw-r--r--module/srfi/srfi-11.scm218
-rw-r--r--module/srfi/srfi-13.scm2
-rw-r--r--module/srfi/srfi-14.scm2
-rw-r--r--module/srfi/srfi-16.scm2
-rw-r--r--module/srfi/srfi-17.scm2
-rw-r--r--module/srfi/srfi-18.scm12
-rw-r--r--module/srfi/srfi-19.scm2
-rw-r--r--module/srfi/srfi-2.scm2
-rw-r--r--module/srfi/srfi-26.scm2
-rw-r--r--module/srfi/srfi-31.scm2
-rw-r--r--module/srfi/srfi-34.scm2
-rw-r--r--module/srfi/srfi-35.scm69
-rw-r--r--module/srfi/srfi-37.scm2
-rw-r--r--module/srfi/srfi-39.scm3
-rw-r--r--module/srfi/srfi-4.scm2
-rw-r--r--module/srfi/srfi-6.scm2
-rw-r--r--module/srfi/srfi-60.scm2
-rw-r--r--module/srfi/srfi-69.scm2
-rw-r--r--module/srfi/srfi-8.scm2
-rw-r--r--module/srfi/srfi-88.scm2
-rw-r--r--module/srfi/srfi-9.scm2
-rw-r--r--module/srfi/srfi-98.scm44
-rw-r--r--module/system/base/compile.scm211
-rw-r--r--module/system/base/language.scm31
-rw-r--r--module/system/base/message.scm102
-rw-r--r--module/system/base/pmatch.scm9
-rw-r--r--module/system/base/syntax.scm116
-rw-r--r--module/system/repl/command.scm162
-rw-r--r--module/system/repl/common.scm29
-rw-r--r--module/system/repl/describe.scm27
-rw-r--r--module/system/repl/repl.scm45
-rw-r--r--module/system/vm/debug.scm2
-rw-r--r--module/system/vm/frame.scm52
-rw-r--r--module/system/vm/instruction.scm29
-rw-r--r--module/system/vm/objcode.scm29
-rw-r--r--module/system/vm/profile.scm27
-rw-r--r--module/system/vm/program.scm40
-rw-r--r--module/system/vm/trace.scm34
-rw-r--r--module/system/vm/vm.scm2
-rw-r--r--module/system/xref.scm119
201 files changed, 23778 insertions, 4584 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index 64a74482b..5ef00be37 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -4,55 +4,88 @@
##
## This file is part of GUILE.
##
-## GUILE is free software; you can redistribute it and/or modify
-## it under the terms of the GNU General Public License as
-## published by the Free Software Foundation; either version 2, or
+## GUILE is free software; you can redistribute it and/or modify it
+## under the terms of the GNU Lesser General Public License as
+## published by the Free Software Foundation; either version 3, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU General Public License for more details.
+## GNU Lesser General Public License for more details.
##
-## You should have received a copy of the GNU General Public
-## License along with GUILE; see the file COPYING. If not, write
-## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-## Floor, Boston, MA 02110-1301 USA
+## You should have received a copy of the GNU Lesser General Public
+## License along with GUILE; see the file COPYING.LESSER. If not,
+## write to the Free Software Foundation, Inc., 51 Franklin Street,
+## Fifth Floor, Boston, MA 02110-1301 USA
-# Build the compiler and VM support first to avoid stack overflows
-# when building the rest.
-SUBDIRS = . ice-9 srfi oop
+include $(top_srcdir)/am/guilec
# We're at the root of the module hierarchy.
modpath =
+# Compile psyntax and boot-9 first, so that we get the speed benefit in
+# the rest of the compilation. Also, if there is too much switching back
+# and forth between interpreted and compiled code, we end up using more
+# of the C stack than the interpreter would have; so avoid that by
+# putting these core modules first.
+
SOURCES = \
+ ice-9/psyntax-pp.scm \
system/base/pmatch.scm system/base/syntax.scm \
system/base/compile.scm system/base/language.scm \
+ system/base/message.scm \
\
- system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \
- system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \
- system/vm/trace.scm system/vm/vm.scm \
- \
- system/xref.scm \
- \
- system/repl/repl.scm system/repl/common.scm \
- system/repl/command.scm \
- \
- language/ghil.scm language/glil.scm language/assembly.scm \
+ language/tree-il.scm \
+ language/glil.scm language/assembly.scm \
\
- $(SCHEME_LANG_SOURCES) $(ECMASCRIPT_LANG_SOURCES) \
- $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
+ $(SCHEME_LANG_SOURCES) \
+ $(TREE_IL_LANG_SOURCES) \
+ $(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
- $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)
+ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \
+ \
+ $(ICE_9_SOURCES) \
+ $(SRFI_SOURCES) \
+ $(RNRS_SOURCES) \
+ $(OOP_SOURCES) \
+ $(SYSTEM_SOURCES) \
+ $(SCRIPTS_SOURCES) \
+ $(GHIL_LANG_SOURCES) \
+ $(ECMASCRIPT_LANG_SOURCES) \
+ $(BRAINFUCK_LANG_SOURCES)
+
+## test.scm is not currently installed.
+EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008
+
+# We expect this to never be invoked when there is not already
+# ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends
+# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax-pp.scm")'.
+# In other words, to bootstrap this file, you need to do something like:
+# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax-pp.scm
+include $(top_srcdir)/am/pre-inst-guile
+ice-9/psyntax-pp.scm: ice-9/psyntax.scm
+ $(preinstguile) --no-autocompile -s $(srcdir)/ice-9/compile-psyntax.scm \
+ $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
SCHEME_LANG_SOURCES = \
- language/scheme/amatch.scm language/scheme/expand.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
-GHIL_LANG_SOURCES = \
- language/ghil/spec.scm language/ghil/compile-glil.scm
+TREE_IL_LANG_SOURCES = \
+ language/tree-il/primitives.scm \
+ language/tree-il/optimize.scm \
+ language/tree-il/inline.scm \
+ language/tree-il/fix-letrec.scm \
+ language/tree-il/analyze.scm \
+ language/tree-il/compile-glil.scm \
+ language/tree-il/spec.scm
+
+GHIL_LANG_SOURCES = \
+ language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm \
@@ -77,14 +110,166 @@ ECMASCRIPT_LANG_SOURCES = \
language/ecmascript/parse-lalr.scm \
language/ecmascript/tokenize.scm \
language/ecmascript/parse.scm \
- language/ecmascript/spec.scm \
language/ecmascript/impl.scm \
language/ecmascript/base.scm \
language/ecmascript/function.scm \
language/ecmascript/array.scm \
- language/ecmascript/compile-ghil.scm
+ language/ecmascript/compile-tree-il.scm \
+ language/ecmascript/spec.scm
-NOCOMP_SOURCES = \
- system/repl/describe.scm
+BRAINFUCK_LANG_SOURCES = \
+ language/brainfuck/parse.scm \
+ language/brainfuck/compile-scheme.scm \
+ language/brainfuck/compile-tree-il.scm \
+ language/brainfuck/spec.scm
-include $(top_srcdir)/am/guilec
+SCRIPTS_SOURCES = \
+ scripts/PROGRAM.scm \
+ scripts/autofrisk.scm \
+ scripts/compile.scm \
+ scripts/disassemble.scm \
+ scripts/display-commentary.scm \
+ scripts/doc-snarf.scm \
+ scripts/frisk.scm \
+ scripts/generate-autoload.scm \
+ scripts/lint.scm \
+ scripts/punify.scm \
+ scripts/read-scheme-source.scm \
+ scripts/read-text-outline.scm \
+ scripts/use2dot.scm \
+ scripts/snarf-check-and-output-texi.scm \
+ scripts/summarize-guile-TODO.scm \
+ scripts/scan-api.scm \
+ scripts/api-diff.scm \
+ scripts/read-rfc822.scm \
+ scripts/snarf-guile-m4-docs.scm
+
+ICE_9_SOURCES = \
+ ice-9/boot-9.scm \
+ ice-9/r4rs.scm \
+ ice-9/r5rs.scm \
+ ice-9/and-let-star.scm \
+ ice-9/calling.scm \
+ ice-9/common-list.scm \
+ ice-9/debug.scm \
+ ice-9/debugger.scm \
+ ice-9/documentation.scm \
+ ice-9/emacs.scm \
+ ice-9/expect.scm \
+ ice-9/format.scm \
+ ice-9/getopt-long.scm \
+ ice-9/hcons.scm \
+ ice-9/i18n.scm \
+ ice-9/lineio.scm \
+ ice-9/ls.scm \
+ ice-9/mapping.scm \
+ ice-9/match.scm \
+ ice-9/networking.scm \
+ ice-9/null.scm \
+ ice-9/occam-channel.scm \
+ ice-9/optargs.scm \
+ ice-9/poe.scm \
+ ice-9/popen.scm \
+ ice-9/posix.scm \
+ ice-9/q.scm \
+ ice-9/rdelim.scm \
+ ice-9/receive.scm \
+ ice-9/regex.scm \
+ ice-9/runq.scm \
+ ice-9/rw.scm \
+ ice-9/safe-r5rs.scm \
+ ice-9/safe.scm \
+ ice-9/session.scm \
+ ice-9/slib.scm \
+ ice-9/stack-catch.scm \
+ ice-9/streams.scm \
+ ice-9/string-fun.scm \
+ ice-9/syncase.scm \
+ ice-9/threads.scm \
+ ice-9/buffered-input.scm \
+ ice-9/time.scm \
+ ice-9/history.scm \
+ ice-9/channel.scm \
+ ice-9/pretty-print.scm \
+ ice-9/ftw.scm \
+ ice-9/gap-buffer.scm \
+ ice-9/weak-vector.scm \
+ ice-9/deprecated.scm \
+ ice-9/list.scm \
+ ice-9/serialize.scm \
+ ice-9/gds-server.scm
+
+SRFI_SOURCES = \
+ srfi/srfi-1.scm \
+ srfi/srfi-2.scm \
+ srfi/srfi-4.scm \
+ srfi/srfi-6.scm \
+ srfi/srfi-8.scm \
+ srfi/srfi-9.scm \
+ srfi/srfi-10.scm \
+ srfi/srfi-11.scm \
+ srfi/srfi-13.scm \
+ srfi/srfi-14.scm \
+ srfi/srfi-16.scm \
+ srfi/srfi-17.scm \
+ srfi/srfi-18.scm \
+ srfi/srfi-19.scm \
+ srfi/srfi-26.scm \
+ srfi/srfi-31.scm \
+ srfi/srfi-34.scm \
+ srfi/srfi-35.scm \
+ srfi/srfi-37.scm \
+ srfi/srfi-39.scm \
+ srfi/srfi-60.scm \
+ srfi/srfi-69.scm \
+ srfi/srfi-88.scm \
+ srfi/srfi-98.scm
+
+RNRS_SOURCES = \
+ rnrs/bytevector.scm \
+ rnrs/io/ports.scm
+
+EXTRA_DIST += scripts/ChangeLog-2008
+EXTRA_DIST += scripts/README
+
+OOP_SOURCES = \
+ oop/goops.scm \
+ oop/goops/active-slot.scm \
+ oop/goops/compile.scm \
+ oop/goops/composite-slot.scm \
+ oop/goops/describe.scm \
+ oop/goops/dispatch.scm \
+ oop/goops/internal.scm \
+ oop/goops/save.scm \
+ oop/goops/stklos.scm \
+ oop/goops/util.scm \
+ oop/goops/accessors.scm \
+ oop/goops/simple.scm
+
+SYSTEM_SOURCES = \
+ system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \
+ system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \
+ system/vm/trace.scm system/vm/vm.scm \
+ \
+ system/xref.scm \
+ \
+ system/repl/repl.scm system/repl/common.scm \
+ system/repl/command.scm
+
+EXTRA_DIST += oop/ChangeLog-2008
+
+NOCOMP_SOURCES = \
+ ice-9/gds-client.scm \
+ ice-9/psyntax.scm \
+ system/repl/describe.scm \
+ ice-9/debugger/command-loop.scm \
+ ice-9/debugger/commands.scm \
+ ice-9/debugger/state.scm \
+ ice-9/debugger/trc.scm \
+ ice-9/debugger/utils.scm \
+ ice-9/debugging/example-fns.scm \
+ ice-9/debugging/ice-9-debugger-extensions.scm \
+ ice-9/debugging/steps.scm \
+ ice-9/debugging/trace.scm \
+ ice-9/debugging/traps.scm \
+ ice-9/debugging/trc.scm
diff --git a/module/ice-9/Makefile.am b/module/ice-9/Makefile.am
deleted file mode 100644
index 8c94d8320..000000000
--- a/module/ice-9/Makefile.am
+++ /dev/null
@@ -1,70 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-##
-## Copyright (C) 1998,1999,2000,2001,2003, 2004, 2006, 2008 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE is free software; you can redistribute it and/or modify
-## it under the terms of the GNU General Public License as
-## published by the Free Software Foundation; either version 2, or
-## (at your option) any later version.
-##
-## GUILE is distributed in the hope that it will be useful, but
-## WITHOUT ANY WARRANTY; without even the implied warranty of
-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU General Public License for more details.
-##
-## You should have received a copy of the GNU General Public
-## License along with GUILE; see the file COPYING. If not, write
-## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-## Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-SUBDIRS = debugger debugging
-
-# These should be installed and distributed.
-modpath = ice-9
-# Compile psyntax and boot-9 first, so that we get the speed benefit in
-# the rest of the compilation. Also, if there is too much switching back
-# and forth between interpreted and compiled code, we end up using more
-# of the C stack than the interpreter would have; so avoid that by
-# putting these core modules first.
-SOURCES = psyntax-pp.scm annotate.scm boot-9.scm \
- and-let-star.scm calling.scm common-list.scm \
- debug.scm debugger.scm documentation.scm emacs.scm expect.scm \
- format.scm getopt-long.scm hcons.scm i18n.scm \
- lineio.scm ls.scm mapping.scm match.scm \
- networking.scm null.scm occam-channel.scm optargs.scm poe.scm \
- popen.scm posix.scm q.scm r4rs.scm r5rs.scm \
- rdelim.scm receive.scm regex.scm runq.scm rw.scm \
- safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \
- streams.scm string-fun.scm syncase.scm threads.scm \
- buffered-input.scm time.scm history.scm channel.scm \
- pretty-print.scm ftw.scm gap-buffer.scm \
- weak-vector.scm deprecated.scm list.scm serialize.scm \
- gds-server.scm
-
-# gds-client is tight with the memoizer, so punt on it until it can be
-# made portable.
-#
-# psyntax.scm needs help. fortunately it's only needed when recompiling
-# psyntax-pp.scm.
-NOCOMP_SOURCES = gds-client.scm psyntax.scm
-
-include $(top_srcdir)/am/guilec
-
-## test.scm is not currently installed.
-EXTRA_DIST += test.scm compile-psyntax.scm ChangeLog-2008
-
-TAGS_FILES = $(SOURCES)
-
-# We expect this to never be invoked when there is not already
-# ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends
-# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax-pp.scm")'.
-# In other words, to bootstrap this file, you need to do something like:
-# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax-pp.scm
-include $(top_srcdir)/am/pre-inst-guile
-psyntax-pp.scm: psyntax.scm
- $(preinstguile) -s $(srcdir)/compile-psyntax.scm \
- $(srcdir)/psyntax.scm $(srcdir)/psyntax-pp.scm
diff --git a/module/ice-9/and-let-star.scm b/module/ice-9/and-let-star.scm
index b8cb2a679..bfd597b1e 100644
--- a/module/ice-9/and-let-star.scm
+++ b/module/ice-9/and-let-star.scm
@@ -6,7 +6,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/annotate.scm b/module/ice-9/annotate.scm
deleted file mode 100644
index 30f49d710..000000000
--- a/module/ice-9/annotate.scm
+++ /dev/null
@@ -1,80 +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 annotate)
- :export (<annotation> annotation? annotate deannotate make-annotation
- annotation-expression annotation-source annotation-stripped
- set-annotation-stripped!
- deannotate/source-properties))
-
-(define <annotation>
- (make-vtable "prprpw"
- (lambda (struct port)
- (display "#<annotated " port)
- (display (struct-ref struct 0) port)
- (display ">" port))))
-
-(define (annotation? x)
- (and (struct? x) (eq? (struct-vtable x) <annotation>)))
-
-(define (make-annotation e s . stripped?)
- (if (null? stripped?)
- (make-struct <annotation> 0 e s #f)
- (apply make-struct <annotation> 0 e s stripped?)))
-
-(define (annotation-expression a)
- (struct-ref a 0))
-(define (annotation-source a)
- (struct-ref a 1))
-(define (annotation-stripped a)
- (struct-ref a 2))
-(define (set-annotation-stripped! a stripped?)
- (struct-set! a 2 stripped?))
-
-(define (annotate e)
- (let ((p (if (pair? e) (source-properties e) #f))
- (out (cond ((and (list? e) (not (null? e)))
- (map annotate e))
- ((pair? e)
- (cons (annotate (car e)) (annotate (cdr e))))
- (else e))))
- (if (pair? p)
- (make-annotation out p #f)
- out)))
-
-(define (deannotate e)
- (cond ((list? e)
- (map deannotate e))
- ((pair? e)
- (cons (deannotate (car e)) (deannotate (cdr e))))
- ((annotation? e) (deannotate (annotation-expression e)))
- (else e)))
-
-(define (deannotate/source-properties e)
- (cond ((list? e)
- (map deannotate/source-properties e))
- ((pair? e)
- (cons (deannotate/source-properties (car e))
- (deannotate/source-properties (cdr e))))
- ((annotation? e)
- (let ((e (deannotate/source-properties (annotation-expression e)))
- (source (annotation-source e)))
- (if (pair? e)
- (set-source-properties! e source))
- e))
- (else e)))
diff --git a/module/ice-9/arrays.scm b/module/ice-9/arrays.scm
index 7ddcc8ab8..f7f9e5eed 100644
--- a/module/ice-9/arrays.scm
+++ b/module/ice-9/arrays.scm
@@ -2,20 +2,19 @@
;;;; Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc.
;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
-;;;; This 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.
+;;;; 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 General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;;;; Boston, MA 02110-1301 USA
+;;;; 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 (array-shape a)
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index bb284cfbf..1f74d10ea 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -6,7 +6,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -33,6 +33,52 @@
+;; Before compiling, make sure any symbols are resolved in the (guile)
+;; module, the primary location of those symbols, rather than in
+;; (guile-user), the default module that we compile in.
+
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
+;;; {R4RS compliance}
+;;;
+
+(primitive-load-path "ice-9/r4rs")
+
+
+
+;;; {Simple Debugging Tools}
+;;;
+
+;; peek takes any number of arguments, writes them to the
+;; current ouput port, and returns the last argument.
+;; It is handy to wrap around an expression to look at
+;; a value each time is evaluated, e.g.:
+;;
+;; (+ 10 (troublesome-fn))
+;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
+;;
+
+(define (peek . stuff)
+ (newline)
+ (display ";;; ")
+ (write stuff)
+ (newline)
+ (car (last-pair stuff)))
+
+(define pk peek)
+
+(define (warn . stuff)
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (newline)
+ (display ";;; WARNING ")
+ (display stuff)
+ (newline)
+ (car (last-pair stuff)))))
+
+
+
;;; {Features}
;;;
@@ -47,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)
@@ -86,92 +168,181 @@
-;; (eval-when (situation...) form...)
-;;
-;; Evaluate certain code based on the situation that eval-when is used
-;; in. There are three situations defined.
-;;
-;; `load' triggers when a file is loaded via `load', or when a compiled
-;; file is loaded.
-;;
-;; `compile' triggers when an expression is compiled.
-;;
-;; `eval' triggers when code is evaluated interactively, as at the REPL
-;; or via the `compile' or `eval' procedures.
-
-;; NB: this macro is only ever expanded by the interpreter. The compiler
-;; notices it and interprets the situations differently.
-(define eval-when
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((situations (cadr exp))
- (body (cddr exp)))
- (if (or (memq 'load situations)
- (memq 'eval situations))
- `(begin . ,body))))))
+;; Define a minimal stub of the module API for psyntax, before modules
+;; have booted.
+(define (module-name x)
+ '(guile))
+(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)
+
+;; 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)
+
+;; 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)))))
-;; Before compiling, make sure any symbols are resolved in the (guile)
-;; module, the primary location of those symbols, rather than in
-;; (guile-user), the default module that we compile in.
-
-(eval-when (compile)
- (set-current-module (resolve-module '(guile))))
-
;;; {Defmacros}
;;;
-;;; Depends on: features, eval-case
-;;;
-
-(define macro-table (make-weak-key-hash-table 61))
-(define xformer-table (make-weak-key-hash-table 61))
-
-(define (defmacro? m) (hashq-ref macro-table m))
-(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
-(define (defmacro-transformer m) (hashq-ref xformer-table m))
-(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
-
-(define defmacro:transformer
- (lambda (f)
- (let* ((xform (lambda (exp env)
- (copy-tree (apply f (cdr exp)))))
- (a (procedure->memoizing-macro xform)))
- (assert-defmacro?! a)
- (set-defmacro-transformer! a f)
- a)))
-
-(define defmacro
- (let ((defmacro-transformer
- (lambda (name parms . body)
- (let ((transformer `(lambda ,parms ,@body)))
- `(eval-when
- (eval load compile)
- (define ,name (defmacro:transformer ,transformer)))))))
- (defmacro:transformer defmacro-transformer)))
-
-
-;; XXX - should the definition of the car really be looked up in the
-;; current module?
-
-(define (macroexpand-1 e)
- (cond
- ((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (local-ref (list a)))))
- (if (defmacro? val)
- (apply (defmacro-transformer val) (cdr e))
- e)))
- (#t e)))
-
-(define (macroexpand e)
- (cond
- ((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (local-ref (list a)))))
- (if (defmacro? val)
- (macroexpand (apply (defmacro-transformer val) (cdr e)))
- e)))
- (#t e)))
+(define-syntax define-macro
+ (lambda (x)
+ "Define a defmacro."
+ (syntax-case x ()
+ ((_ (macro . args) doc body1 body ...)
+ (string? (syntax->datum (syntax doc)))
+ (syntax (define-macro macro doc (lambda args body1 body ...))))
+ ((_ (macro . args) body ...)
+ (syntax (define-macro macro #f (lambda args body ...))))
+ ((_ macro doc transformer)
+ (or (string? (syntax->datum (syntax doc)))
+ (not (syntax->datum (syntax doc))))
+ (syntax
+ (define-syntax macro
+ (lambda (y)
+ doc
+ (syntax-case y ()
+ ((_ . args)
+ (let ((v (syntax->datum (syntax args))))
+ (datum->syntax y (apply transformer v))))))))))))
+
+(define-syntax defmacro
+ (lambda (x)
+ "Define a defmacro, with the old lispy defun syntax."
+ (syntax-case x ()
+ ((_ macro args doc body1 body ...)
+ (string? (syntax->datum (syntax doc)))
+ (syntax (define-macro macro doc (lambda args body1 body ...))))
+ ((_ macro args body ...)
+ (syntax (define-macro macro #f (lambda args body ...)))))))
(provide 'defmacro)
@@ -185,46 +356,7 @@
(defmacro begin-deprecated forms
(if (include-deprecated-features)
`(begin ,@forms)
- (begin)))
-
-
-
-;;; {R4RS compliance}
-;;;
-
-(primitive-load-path "ice-9/r4rs")
-
-
-
-;;; {Simple Debugging Tools}
-;;;
-
-;; peek takes any number of arguments, writes them to the
-;; current ouput port, and returns the last argument.
-;; It is handy to wrap around an expression to look at
-;; a value each time is evaluated, e.g.:
-;;
-;; (+ 10 (troublesome-fn))
-;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
-;;
-
-(define (peek . stuff)
- (newline)
- (display ";;; ")
- (write stuff)
- (newline)
- (car (last-pair stuff)))
-
-(define pk peek)
-
-(define (warn . stuff)
- (with-output-to-port (current-error-port)
- (lambda ()
- (newline)
- (display ";;; WARNING ")
- (display stuff)
- (newline)
- (car (last-pair stuff)))))
+ `(begin)))
@@ -250,8 +382,12 @@
(define (apply-to-args args fn) (apply fn args))
(defmacro false-if-exception (expr)
- `(catch #t (lambda () ,expr)
- (lambda args #f)))
+ `(catch #t
+ (lambda ()
+ ;; avoid saving backtraces inside false-if-exception
+ (with-fluid* the-last-stack (fluid-ref the-last-stack)
+ (lambda () ,expr)))
+ (lambda args #f)))
@@ -472,40 +608,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"))
@@ -513,12 +615,10 @@
(primitive-load-path "ice-9/networking"))
;; For reference, Emacs file-exists-p uses stat in this same way.
-;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in
-;; C where all that's needed is to inspect the return from stat().
(define file-exists?
(if (provided? 'posix)
(lambda (str)
- (->bool (false-if-exception (stat str))))
+ (->bool (stat str #f)))
(lambda (str)
(let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
(lambda args #f))))
@@ -752,6 +852,26 @@
(start-stack 'load-stack
(primitive-load-path name)))
+(define %load-verbosely #f)
+(define (assert-load-verbosity v) (set! %load-verbosely v))
+
+(define (%load-announce file)
+ (if %load-verbosely
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (display ";;; ")
+ (display "loading ")
+ (display file)
+ (newline)
+ (force-output)))))
+
+(set! %load-hook %load-announce)
+
+(define (load name . reader)
+ (with-fluid* current-reader (and (pair? reader) (car reader))
+ (lambda ()
+ (start-stack 'load-stack
+ (primitive-load name)))))
@@ -843,9 +963,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 #\.
@@ -1128,11 +1245,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))
@@ -1189,7 +1303,8 @@
"Lazy-binder expected to be a procedure or #f." binder))
(let ((module (module-constructor (make-hash-table size)
- uses binder #f #f #f #f #f
+ uses binder #f %pre-modules-transformer
+ #f #f #f
(make-hash-table %default-import-size)
'()
(make-weak-key-hash-table 31))))
@@ -1214,7 +1329,7 @@
(define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
-(define module-name (record-accessor module-type 'name))
+;; (define module-name (record-accessor module-type 'name)) wait until mods are booted
(define set-module-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
(define set-module-kind! (record-modifier module-type 'kind))
@@ -1368,7 +1483,9 @@
;; or its uses?
;;
(define (module-bound? m v)
- (module-search module-locally-bound? m v))
+ (let ((var (module-variable m v)))
+ (and var
+ (variable-bound? var))))
;;; {Is a symbol interned in a module?}
;;;
@@ -1804,7 +1921,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)))
@@ -1858,22 +1975,36 @@
(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
+ (let ((accessor (record-accessor module-type 'name)))
+ (lambda (mod)
+ (or (accessor mod)
+ (let ((name (list (gensym))))
+ ;; Name MOD and bind it in THE-ROOT-MODULE so that it's visible
+ ;; to `resolve-module'. This is important as `psyntax' stores
+ ;; module names and relies on being able to `resolve-module'
+ ;; them.
+ (set-module-name! mod name)
+ (nested-define! the-root-module `(%app modules ,@name) mod)
+ (accessor mod))))))
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
(define (try-load-module name)
- (or (begin-deprecated (try-module-linked name))
- (try-module-autoload name)
- (begin-deprecated (try-module-dynamic-link name))))
+ (try-module-autoload name))
(define (purify-module! module)
"Removes bindings in MODULE which are inherited from the (guile) module."
@@ -2007,23 +2138,34 @@
((#:use-module #:use-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
- (let* ((interface-args (cadr kws))
- (interface (apply resolve-interface interface-args)))
- (and (eq? (car kws) #:use-syntax)
- (or (symbol? (caar interface-args))
- (error "invalid module name for use-syntax"
- (car interface-args)))
- (set-module-transformer!
- module
- (module-ref interface
- (car (last-pair (car interface-args)))
- #f)))
+ (cond
+ ((equal? (caadr kws) '(ice-9 syncase))
+ (issue-deprecation-warning
+ "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
(loop (cddr kws)
- (cons interface reversed-interfaces)
+ reversed-interfaces
exports
re-exports
replacements
- autoloads)))
+ autoloads))
+ (else
+ (let* ((interface-args (cadr kws))
+ (interface (apply resolve-interface interface-args)))
+ (and (eq? (car kws) #:use-syntax)
+ (or (symbol? (caar interface-args))
+ (error "invalid module name for use-syntax"
+ (car interface-args)))
+ (set-module-transformer!
+ module
+ (module-ref interface
+ (car (last-pair (car interface-args)))
+ #f)))
+ (loop (cddr kws)
+ (cons interface reversed-interfaces)
+ exports
+ re-exports
+ replacements
+ autoloads)))))
((#:autoload)
(or (and (pair? (cdr kws)) (pair? (cddr kws)))
(unrecognized kws))
@@ -2126,11 +2268,6 @@ module '(ice-9 q) '(make-q q-length))}."
(loop (cddr args)))))))
-;;; {Compiled module}
-
-(if (not (defined? 'load-compiled))
- (define load-compiled #f))
-
;;; {Autoloading modules}
@@ -2152,27 +2289,15 @@ module '(ice-9 q) '(make-q q-length))}."
(resolve-module dir-hint-module-name #f)
(and (not (autoload-done-or-in-progress? dir-hint name))
(let ((didit #f))
- (define (load-file proc file)
- (save-module-excursion (lambda () (proc file)))
- (set! didit #t))
(dynamic-wind
(lambda () (autoload-in-progress! dir-hint name))
(lambda ()
- (let ((file (in-vicinity dir-hint name)))
- (let ((compiled (and load-compiled
- (%search-load-path
- (string-append file ".go"))))
- (source (%search-load-path file)))
- (cond ((and source
- (or (not compiled)
- (< (stat:mtime (stat compiled))
- (stat:mtime (stat source)))))
- (if compiled
- (warn "source file" source "newer than" compiled))
- (with-fluids ((current-reader #f))
- (load-file primitive-load source)))
- (compiled
- (load-file load-compiled compiled))))))
+ (with-fluid* current-reader #f
+ (lambda ()
+ (save-module-excursion
+ (lambda ()
+ (primitive-load-path (in-vicinity dir-hint name) #f)
+ (set! didit #t))))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
@@ -2214,9 +2339,9 @@ module '(ice-9 q) '(make-q q-length))}."
;;;
(defmacro define-option-interface (option-group)
- (let* ((option-name car)
- (option-value cadr)
- (option-documentation caddr)
+ (let* ((option-name 'car)
+ (option-value 'cadr)
+ (option-documentation 'caddr)
;; Below follow the macros defining the run-time option interfaces.
@@ -2227,15 +2352,15 @@ module '(ice-9 q) '(make-q q-length))}."
(,interface (car args)) (,interface))
(else (for-each
(lambda (option)
- (display (option-name option))
+ (display (,option-name option))
(if (< (string-length
- (symbol->string (option-name option)))
+ (symbol->string (,option-name option)))
8)
(display #\tab))
(display #\tab)
- (display (option-value option))
+ (display (,option-value option))
(display #\tab)
- (display (option-documentation option))
+ (display (,option-documentation option))
(newline))
(,interface #t)))))))
@@ -2320,11 +2445,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))
@@ -2401,15 +2527,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)
@@ -2684,32 +2802,6 @@ module '(ice-9 q) '(make-q q-length))}."
`(with-fluids* (list ,@fluids) (list ,@values)
(lambda () ,@body)))))
-
-
-;;; {Macros}
-;;;
-
-;; actually....hobbit might be able to hack these with a little
-;; coaxing
-;;
-
-(define (primitive-macro? m)
- (and (macro? m)
- (not (macro-transformer m))))
-
-(defmacro define-macro (first . rest)
- (let ((name (if (symbol? first) first (car first)))
- (transformer
- (if (symbol? first)
- (car rest)
- `(lambda ,(cdr first) ,@rest))))
- `(eval-when
- (eval load compile)
- (define ,name (defmacro:transformer ,transformer)))))
-
-
-
-
;;; {While}
;;;
;;; with `continue' and `break'.
@@ -2849,50 +2941,31 @@ module '(ice-9 q) '(make-q q-length))}."
(defmacro use-syntax (spec)
`(eval-when
(eval load compile)
- ,@(if (pair? spec)
- `((process-use-modules (list
- (list ,@(compile-interface-spec spec))))
- (set-module-transformer! (current-module)
- ,(car (last-pair spec))))
- `((set-module-transformer! (current-module) ,spec)))
- *unspecified*))
-
-;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
-;; as soon as guile supports hygienic macros.
-(define define-private define)
-
-(defmacro define-public args
- (define (syntax)
- (error "bad syntax" (list 'define-public args)))
- (define (defined-name n)
- (cond
- ((symbol? n) n)
- ((pair? n) (defined-name (car n)))
- (else (syntax))))
- (cond
- ((null? args)
- (syntax))
- (#t
- (let ((name (defined-name (car args))))
- `(begin
- (define-private ,@args)
- (export ,name))))))
+ (issue-deprecation-warning
+ "`use-syntax' is deprecated. Please contact guile-devel for more info.")
+ (process-use-modules (list (list ,@(compile-interface-spec spec))))
+ *unspecified*))
-(defmacro defmacro-public args
- (define (syntax)
- (error "bad syntax" (list 'defmacro-public args)))
- (define (defined-name n)
- (cond
- ((symbol? n) n)
- (else (syntax))))
- (cond
- ((null? args)
- (syntax))
- (#t
- (let ((name (defined-name (car args))))
- `(begin
- (export-syntax ,name)
- (defmacro ,@args))))))
+(define-syntax define-private
+ (syntax-rules ()
+ ((_ foo bar)
+ (define foo bar))))
+
+(define-syntax define-public
+ (syntax-rules ()
+ ((_ (name . args) . body)
+ (define-public name (lambda args . body)))
+ ((_ name val)
+ (begin
+ (define name val)
+ (export name)))))
+
+(define-syntax defmacro-public
+ (syntax-rules ()
+ ((_ name args . body)
+ (begin
+ (defmacro name args . body)
+ (export-syntax name)))))
;; Export a local variable
@@ -2946,44 +3019,6 @@ module '(ice-9 q) '(make-q q-length))}."
(define load load-module)
-;; The following macro allows one to write, for example,
-;;
-;; (@ (ice-9 pretty-print) pretty-print)
-;;
-;; to refer directly to the pretty-print variable in module (ice-9
-;; pretty-print). It works by looking up the variable and inserting
-;; it directly into the code. This is understood by the evaluator.
-;; Indeed, all references to global variables are memoized into such
-;; variable objects.
-
-(define-macro (@ mod-name var-name)
- (let ((var (module-variable (resolve-interface mod-name) var-name)))
- (if (not var)
- (error "no such public variable" (list '@ mod-name var-name)))
- var))
-
-;; The '@@' macro is like '@' but it can also access bindings that
-;; have not been explicitely exported.
-
-(define-macro (@@ mod-name var-name)
- (let ((var (module-variable (resolve-module mod-name) var-name)))
- (if (not var)
- (error "no such variable" (list '@@ mod-name var-name)))
- var))
-
-
-
-;;; {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}
@@ -3172,69 +3207,66 @@ module '(ice-9 q) '(make-q q-length))}."
(append (hashq-ref %cond-expand-table mod '())
features)))))
-(define cond-expand
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((clauses (cdr exp))
- (syntax-error (lambda (cl)
- (error "invalid clause in `cond-expand'" cl))))
- (letrec
- ((test-clause
- (lambda (clause)
- (cond
- ((symbol? clause)
- (or (memq clause %cond-expand-features)
- (let lp ((uses (module-uses (env-module env))))
- (if (pair? uses)
- (or (memq clause
- (hashq-ref %cond-expand-table
- (car uses) '()))
- (lp (cdr uses)))
- #f))))
- ((pair? clause)
- (cond
- ((eq? 'and (car clause))
- (let lp ((l (cdr clause)))
- (cond ((null? l)
- #t)
- ((pair? l)
- (and (test-clause (car l)) (lp (cdr l))))
- (else
- (syntax-error clause)))))
- ((eq? 'or (car clause))
- (let lp ((l (cdr clause)))
- (cond ((null? l)
- #f)
- ((pair? l)
- (or (test-clause (car l)) (lp (cdr l))))
- (else
- (syntax-error clause)))))
- ((eq? 'not (car clause))
- (cond ((not (pair? (cdr clause)))
- (syntax-error clause))
- ((pair? (cddr clause))
- ((syntax-error clause))))
- (not (test-clause (cadr clause))))
- (else
- (syntax-error clause))))
- (else
- (syntax-error clause))))))
- (let lp ((c clauses))
- (cond
- ((null? c)
- (error "Unfulfilled `cond-expand'"))
- ((not (pair? c))
- (syntax-error c))
- ((not (pair? (car c)))
- (syntax-error (car c)))
- ((test-clause (caar c))
- `(begin ,@(cdar c)))
- ((eq? (caar c) 'else)
- (if (pair? (cdr c))
- (syntax-error c))
- `(begin ,@(cdar c)))
- (else
- (lp (cdr c))))))))))
+(define-macro (cond-expand . clauses)
+ (let ((syntax-error (lambda (cl)
+ (error "invalid clause in `cond-expand'" cl))))
+ (letrec
+ ((test-clause
+ (lambda (clause)
+ (cond
+ ((symbol? clause)
+ (or (memq clause %cond-expand-features)
+ (let lp ((uses (module-uses (current-module))))
+ (if (pair? uses)
+ (or (memq clause
+ (hashq-ref %cond-expand-table
+ (car uses) '()))
+ (lp (cdr uses)))
+ #f))))
+ ((pair? clause)
+ (cond
+ ((eq? 'and (car clause))
+ (let lp ((l (cdr clause)))
+ (cond ((null? l)
+ #t)
+ ((pair? l)
+ (and (test-clause (car l)) (lp (cdr l))))
+ (else
+ (syntax-error clause)))))
+ ((eq? 'or (car clause))
+ (let lp ((l (cdr clause)))
+ (cond ((null? l)
+ #f)
+ ((pair? l)
+ (or (test-clause (car l)) (lp (cdr l))))
+ (else
+ (syntax-error clause)))))
+ ((eq? 'not (car clause))
+ (cond ((not (pair? (cdr clause)))
+ (syntax-error clause))
+ ((pair? (cddr clause))
+ ((syntax-error clause))))
+ (not (test-clause (cadr clause))))
+ (else
+ (syntax-error clause))))
+ (else
+ (syntax-error clause))))))
+ (let lp ((c clauses))
+ (cond
+ ((null? c)
+ (error "Unfulfilled `cond-expand'"))
+ ((not (pair? c))
+ (syntax-error c))
+ ((not (pair? (car c)))
+ (syntax-error (car c)))
+ ((test-clause (caar c))
+ `(begin ,@(cdar c)))
+ ((eq? (caar c) 'else)
+ (if (pair? (cdr c))
+ (syntax-error c))
+ `(begin ,@(cdar c)))
+ (else
+ (lp (cdr c))))))))
;; This procedure gets called from the startup code with a list of
;; numbers, which are the numbers of the SRFIs to be loaded on startup.
@@ -3406,6 +3438,13 @@ module '(ice-9 q) '(make-q q-length))}."
;;; Place the user in the guile-user module.
;;;
-(define-module (guile-user))
+;;; FIXME: annotate ?
+;; (define (syncase exp)
+;; (with-fluids ((expansion-eval-closure
+;; (module-eval-closure (current-module))))
+;; (deannotate/source-properties (sc-expand (annotate exp)))))
+
+(define-module (guile-user)
+ #:autoload (system base compile) (compile))
;;; boot-9.scm ends here
diff --git a/module/ice-9/buffered-input.scm b/module/ice-9/buffered-input.scm
index 11530e897..05e9255c0 100644
--- a/module/ice-9/buffered-input.scm
+++ b/module/ice-9/buffered-input.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/calling.scm b/module/ice-9/calling.scm
index 07f7a7805..f66bba27e 100644
--- a/module/ice-9/calling.scm
+++ b/module/ice-9/calling.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/channel.scm b/module/ice-9/channel.scm
index 8cbb00190..b9d470044 100644
--- a/module/ice-9/channel.scm
+++ b/module/ice-9/channel.scm
@@ -2,19 +2,19 @@
;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
diff --git a/module/ice-9/common-list.scm b/module/ice-9/common-list.scm
index 7d62bc319..ea1b0f3de 100644
--- a/module/ice-9/common-list.scm
+++ b/module/ice-9/common-list.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index a2fe77546..8b53267fe 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -1,27 +1,20 @@
-(use-modules (ice-9 syncase))
-
-;; XXX - We need to be inside (ice-9 syncase) since psyntax.ss calls
-;; `eval' int he `interaction-environment' aka the current module and
-;; it expects to have `andmap' there. The reason for this escapes me
-;; at the moment.
-;;
-(define-module (ice-9 syncase))
-
-(define source (list-ref (command-line) 1))
-(define target (list-ref (command-line) 2))
-
-(let ((in (open-input-file source))
- (out (open-output-file (string-append target ".tmp"))))
- (with-fluids ((expansion-eval-closure
- (module-eval-closure (current-module))))
+(use-modules (language tree-il) (ice-9 pretty-print))
+(let ((source (list-ref (command-line) 1))
+ (target (list-ref (command-line) 2)))
+ (let ((in (open-input-file source))
+ (out (open-output-file (string-append target ".tmp"))))
+ (write '(eval-when (compile) (set-current-module (resolve-module '(guile))))
+ out)
+ (newline out)
(let loop ((x (read in)))
(if (eof-object? x)
- (begin
- (close-port out)
- (close-port in))
- (begin
- (write (sc-expand3 x 'c '(compile load eval)) out)
- (newline out)
- (loop (read in)))))))
-
-(system (format #f "mv -f ~s.tmp ~s" target target))
+ (begin
+ (close-port out)
+ (close-port in))
+ (begin
+ (pretty-print (tree-il->scheme
+ (sc-expand x 'c '(compile load eval)))
+ out)
+ (newline out)
+ (loop (read in))))))
+ (system (format #f "mv -f ~s.tmp ~s" target target)))
diff --git a/module/ice-9/debug.scm b/module/ice-9/debug.scm
index 0e751590d..1fd5b66da 100644
--- a/module/ice-9/debug.scm
+++ b/module/ice-9/debug.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/debugger.scm b/module/ice-9/debugger.scm
index 3dddd9030..06f7ed230 100644
--- a/module/ice-9/debugger.scm
+++ b/module/ice-9/debugger.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 1999, 2001, 2002, 2006 Free Software Foundation, Inc.
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugger)
#:use-module (ice-9 debugger command-loop)
diff --git a/module/ice-9/debugger/Makefile.am b/module/ice-9/debugger/Makefile.am
deleted file mode 100644
index 7ef09a025..000000000
--- a/module/ice-9/debugger/Makefile.am
+++ /dev/null
@@ -1,31 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-##
-## Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE is free software; you can redistribute it and/or modify
-## it under the terms of the GNU General Public License as
-## published by the Free Software Foundation; either version 2, or
-## (at your option) any later version.
-##
-## GUILE is distributed in the hope that it will be useful, but
-## WITHOUT ANY WARRANTY; without even the implied warranty of
-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU General Public License for more details.
-##
-## You should have received a copy of the GNU General Public
-## License along with GUILE; see the file COPYING. If not, write
-## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-## Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-# These should be installed and distributed.
-ice9_debugger_sources = command-loop.scm commands.scm state.scm trc.scm utils.scm
-
-subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/ice-9/debugger
-subpkgdata_DATA = $(ice9_debugger_sources)
-TAGS_FILES = $(subpkgdata_DATA)
-
-EXTRA_DIST = $(ice9_debugger_sources)
diff --git a/module/ice-9/debugger/command-loop.scm b/module/ice-9/debugger/command-loop.scm
index 62a08ea65..c6628271c 100644
--- a/module/ice-9/debugger/command-loop.scm
+++ b/module/ice-9/debugger/command-loop.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 1999, 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugger command-loop)
#:use-module ((ice-9 debugger commands) :prefix debugger:)
diff --git a/module/ice-9/debugger/commands.scm b/module/ice-9/debugger/commands.scm
index ef6f79026..c254ce9e2 100644
--- a/module/ice-9/debugger/commands.scm
+++ b/module/ice-9/debugger/commands.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugger commands)
#:use-module (ice-9 debug)
diff --git a/module/ice-9/debugger/state.scm b/module/ice-9/debugger/state.scm
index 11b8ebbf0..0bda0fad5 100644
--- a/module/ice-9/debugger/state.scm
+++ b/module/ice-9/debugger/state.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugger state)
#:export (make-state
diff --git a/module/ice-9/debugger/trc.scm b/module/ice-9/debugger/trc.scm
index 49af2747d..3e7e2f359 100644
--- a/module/ice-9/debugger/trc.scm
+++ b/module/ice-9/debugger/trc.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugger trc)
#:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))
diff --git a/module/ice-9/debugging/Makefile.am b/module/ice-9/debugging/Makefile.am
deleted file mode 100644
index 44d86d3cf..000000000
--- a/module/ice-9/debugging/Makefile.am
+++ /dev/null
@@ -1,33 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-##
-## Copyright (C) 2006 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE is free software; you can redistribute it and/or modify
-## it under the terms of the GNU General Public License as
-## published by the Free Software Foundation; either version 2, or
-## (at your option) any later version.
-##
-## GUILE is distributed in the hope that it will be useful, but
-## WITHOUT ANY WARRANTY; without even the implied warranty of
-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU General Public License for more details.
-##
-## You should have received a copy of the GNU General Public
-## License along with GUILE; see the file COPYING. If not, write
-## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-## Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-# These should be installed and distributed.
-ice9_debugging_sources = example-fns.scm \
- ice-9-debugger-extensions.scm \
- steps.scm trace.scm traps.scm trc.scm
-
-subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging
-subpkgdata_DATA = $(ice9_debugging_sources)
-TAGS_FILES = $(subpkgdata_DATA)
-
-EXTRA_DIST = $(ice9_debugging_sources)
diff --git a/module/ice-9/debugging/breakpoints.scm b/module/ice-9/debugging/breakpoints.scm
index 132746f17..c839409ef 100644
--- a/module/ice-9/debugging/breakpoints.scm
+++ b/module/ice-9/debugging/breakpoints.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2005 Neil Jerram
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; This module provides a practical interface for setting and
;;; manipulating breakpoints.
diff --git a/module/ice-9/debugging/steps.scm b/module/ice-9/debugging/steps.scm
index fedbc6a32..cd328bd7d 100644
--- a/module/ice-9/debugging/steps.scm
+++ b/module/ice-9/debugging/steps.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugging steps)
#:use-module (ice-9 debugging traps)
diff --git a/module/ice-9/debugging/trace.scm b/module/ice-9/debugging/trace.scm
index ad3015ddf..55b1f3965 100644
--- a/module/ice-9/debugging/trace.scm
+++ b/module/ice-9/debugging/trace.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2002 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugging trace)
#:use-module (ice-9 debug)
diff --git a/module/ice-9/debugging/traps.scm b/module/ice-9/debugging/traps.scm
index ae1673688..e13011e99 100755
--- a/module/ice-9/debugging/traps.scm
+++ b/module/ice-9/debugging/traps.scm
@@ -3,19 +3,19 @@
;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
;;; Copyright (C) 2005 Neil Jerram
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; This module provides an abstraction around Guile's low level trap
;;; handler interface; its aim is to make the low level trap mechanism
diff --git a/module/ice-9/debugging/trc.scm b/module/ice-9/debugging/trc.scm
index 9e95d7e5c..face227d6 100644
--- a/module/ice-9/debugging/trc.scm
+++ b/module/ice-9/debugging/trc.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 debugging trc)
#:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index f3b7cafe4..53fc741c8 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -21,7 +21,7 @@
(define substring-move-right! substring-move!)
;; This method of dynamically linking Guile Extensions is deprecated.
-;; Use `load-extension' explicitely from Scheme code instead.
+;; Use `load-extension' explicitly from Scheme code instead.
(define (split-c-module-name str)
(let loop ((rev '())
diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm
index c5f447e78..bbd6713f6 100644
--- a/module/ice-9/documentation.scm
+++ b/module/ice-9/documentation.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -195,15 +195,11 @@ OBJECT can be a procedure, macro or any object that has its
`documentation' property set."
(or (and (procedure? object)
(proc-doc object))
- (and (defmacro? object)
- (proc-doc (defmacro-transformer object)))
- (and (macro? object)
- (let ((transformer (macro-transformer object)))
- (and transformer
- (proc-doc transformer))))
(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/emacs.scm b/module/ice-9/emacs.scm
index 12d8228ee..88035862f 100644
--- a/module/ice-9/emacs.scm
+++ b/module/ice-9/emacs.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/expect.scm b/module/ice-9/expect.scm
index a024e91e8..ffc2e1742 100644
--- a/module/ice-9/expect.scm
+++ b/module/ice-9/expect.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm
index 23f341521..ce2fb165e 100644
--- a/module/ice-9/ftw.scm
+++ b/module/ice-9/ftw.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/gap-buffer.scm b/module/ice-9/gap-buffer.scm
index b6162e802..4533bb539 100644
--- a/module/ice-9/gap-buffer.scm
+++ b/module/ice-9/gap-buffer.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2003, 2006 Free Software Foundation, Inc.
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
diff --git a/module/ice-9/gds-server.scm b/module/ice-9/gds-server.scm
index f59758729..b64e41161 100644
--- a/module/ice-9/gds-server.scm
+++ b/module/ice-9/gds-server.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2003 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 gds-server)
#:export (run-server))
diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm
index b16328ba8..891a2e3b3 100644
--- a/module/ice-9/getopt-long.scm
+++ b/module/ice-9/getopt-long.scm
@@ -1,18 +1,18 @@
;;; Copyright (C) 1998, 2001, 2006, 2009 Free Software Foundation, Inc.
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
diff --git a/module/ice-9/hcons.scm b/module/ice-9/hcons.scm
index 6323506d2..7275cf476 100644
--- a/module/ice-9/hcons.scm
+++ b/module/ice-9/hcons.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/history.scm b/module/ice-9/history.scm
index 921a25741..e9097c2cc 100644
--- a/module/ice-9/history.scm
+++ b/module/ice-9/history.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm
index f33a9f258..dd14e6754 100644
--- a/module/ice-9/i18n.scm
+++ b/module/ice-9/i18n.scm
@@ -5,13 +5,13 @@
;;;; 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.
-;;;;
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
diff --git a/module/ice-9/lineio.scm b/module/ice-9/lineio.scm
index f122268df..055eb6eb4 100644
--- a/module/ice-9/lineio.scm
+++ b/module/ice-9/lineio.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/list.scm b/module/ice-9/list.scm
index af83d1742..1b898a368 100644
--- a/module/ice-9/list.scm
+++ b/module/ice-9/list.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 list)
:export (rassoc rassv rassq))
diff --git a/module/ice-9/ls.scm b/module/ice-9/ls.scm
index e848be32a..f729d58ce 100644
--- a/module/ice-9/ls.scm
+++ b/module/ice-9/ls.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/mapping.scm b/module/ice-9/mapping.scm
index c4ef4fe99..2907a8d89 100644
--- a/module/ice-9/mapping.scm
+++ b/module/ice-9/mapping.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index e6fe56063..d7589239e 100644
--- a/module/ice-9/match.scm
+++ b/module/ice-9/match.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -194,6 +194,6 @@
(define match:runtime-structures #f)
(define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v)))
(define match:primitive-vector? vector?)
-(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct) (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
+(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
(defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311))))
-(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin ((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335)))))
+(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335)))))
diff --git a/module/ice-9/networking.scm b/module/ice-9/networking.scm
index c0218821f..7e84f0969 100644
--- a/module/ice-9/networking.scm
+++ b/module/ice-9/networking.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -17,6 +17,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
(define (gethostbyaddr addr) (gethost addr))
(define (gethostbyname name) (gethost name))
diff --git a/module/ice-9/null.scm b/module/ice-9/null.scm
index b9212e605..58b271e31 100644
--- a/module/ice-9/null.scm
+++ b/module/ice-9/null.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -18,7 +18,6 @@
;;;; The null environment - only syntactic bindings
(define-module (ice-9 null)
- :use-module (ice-9 syncase)
:re-export-syntax (define quote lambda if set!
cond case and or
diff --git a/module/ice-9/occam-channel.scm b/module/ice-9/occam-channel.scm
index e28f73d3b..ea1154b52 100644
--- a/module/ice-9/occam-channel.scm
+++ b/module/ice-9/occam-channel.scm
@@ -2,22 +2,21 @@
;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 occam-channel)
- #:use-syntax (ice-9 syncase)
#:use-module (oop goops)
#:use-module (ice-9 threads)
#:export-syntax (alt
diff --git a/module/ice-9/optargs.scm b/module/ice-9/optargs.scm
index 4dea92fd7..3093e15a4 100644
--- a/module/ice-9/optargs.scm
+++ b/module/ice-9/optargs.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -410,15 +410,11 @@
;; (defmacro* transmorgify (a #:optional b)
(defmacro defmacro* (NAME ARGLIST . BODY)
- (defmacro*-guts 'define NAME ARGLIST BODY))
+ `(define-macro ,NAME #f (lambda* ,ARGLIST ,@BODY)))
(defmacro defmacro*-public (NAME ARGLIST . BODY)
- (defmacro*-guts 'define-public NAME ARGLIST BODY))
-
-;; The guts of defmacro* and defmacro*-public
-(define (defmacro*-guts DT NAME ARGLIST BODY)
- `(,DT ,NAME
- (,(lambda (transformer) (defmacro:transformer transformer))
- (lambda* ,ARGLIST ,@BODY))))
+ `(begin
+ (defmacro* ,NAME ,ARGLIST ,@BODY)
+ (export-syntax ,NAME)))
;;; optargs.scm ends here
diff --git a/module/ice-9/poe.scm b/module/ice-9/poe.scm
index fe963db08..e7b6e3a75 100644
--- a/module/ice-9/poe.scm
+++ b/module/ice-9/poe.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 275faaa0c..1a1892851 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/posix.scm b/module/ice-9/posix.scm
index 53d01a026..a1be33c19 100644
--- a/module/ice-9/posix.scm
+++ b/module/ice-9/posix.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -17,6 +17,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
(define (stat:dev f) (vector-ref f 0))
(define (stat:ino f) (vector-ref f 1))
(define (stat:mode f) (vector-ref f 2))
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index bef76ddcb..0ce6a8003 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 1fde489a8..fecd2b25d 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1,11 +1,12150 @@
-(letrec ((syntmp-lambda-var-list-151 (lambda (syntmp-vars-536) (let syntmp-lvl-537 ((syntmp-vars-538 syntmp-vars-536) (syntmp-ls-539 (quote ())) (syntmp-w-540 (quote (())))) (cond ((pair? syntmp-vars-538) (syntmp-lvl-537 (cdr syntmp-vars-538) (cons (syntmp-wrap-130 (car syntmp-vars-538) syntmp-w-540) syntmp-ls-539) syntmp-w-540)) ((syntmp-id?-102 syntmp-vars-538) (cons (syntmp-wrap-130 syntmp-vars-538 syntmp-w-540) syntmp-ls-539)) ((null? syntmp-vars-538) syntmp-ls-539) ((syntmp-syntax-object?-88 syntmp-vars-538) (syntmp-lvl-537 (syntmp-syntax-object-expression-89 syntmp-vars-538) syntmp-ls-539 (syntmp-join-wraps-121 syntmp-w-540 (syntmp-syntax-object-wrap-90 syntmp-vars-538)))) ((annotation? syntmp-vars-538) (syntmp-lvl-537 (annotation-expression syntmp-vars-538) syntmp-ls-539 syntmp-w-540)) (else (cons syntmp-vars-538 syntmp-ls-539)))))) (syntmp-gen-var-150 (lambda (syntmp-id-541) (let ((syntmp-id-542 (if (syntmp-syntax-object?-88 syntmp-id-541) (syntmp-syntax-object-expression-89 syntmp-id-541) syntmp-id-541))) (if (annotation? syntmp-id-542) (syntmp-build-annotated-81 (annotation-source syntmp-id-542) (gensym (symbol->string (annotation-expression syntmp-id-542)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-542))))))) (syntmp-strip-149 (lambda (syntmp-x-543 syntmp-w-544) (if (memq (quote top) (syntmp-wrap-marks-105 syntmp-w-544)) (if (or (annotation? syntmp-x-543) (and (pair? syntmp-x-543) (annotation? (car syntmp-x-543)))) (syntmp-strip-annotation-148 syntmp-x-543 #f) syntmp-x-543) (let syntmp-f-545 ((syntmp-x-546 syntmp-x-543)) (cond ((syntmp-syntax-object?-88 syntmp-x-546) (syntmp-strip-149 (syntmp-syntax-object-expression-89 syntmp-x-546) (syntmp-syntax-object-wrap-90 syntmp-x-546))) ((pair? syntmp-x-546) (let ((syntmp-a-547 (syntmp-f-545 (car syntmp-x-546))) (syntmp-d-548 (syntmp-f-545 (cdr syntmp-x-546)))) (if (and (eq? syntmp-a-547 (car syntmp-x-546)) (eq? syntmp-d-548 (cdr syntmp-x-546))) syntmp-x-546 (cons syntmp-a-547 syntmp-d-548)))) ((vector? syntmp-x-546) (let ((syntmp-old-549 (vector->list syntmp-x-546))) (let ((syntmp-new-550 (map syntmp-f-545 syntmp-old-549))) (if (andmap eq? syntmp-old-549 syntmp-new-550) syntmp-x-546 (list->vector syntmp-new-550))))) (else syntmp-x-546)))))) (syntmp-strip-annotation-148 (lambda (syntmp-x-551 syntmp-parent-552) (cond ((pair? syntmp-x-551) (let ((syntmp-new-553 (cons #f #f))) (begin (if syntmp-parent-552 (set-annotation-stripped! syntmp-parent-552 syntmp-new-553)) (set-car! syntmp-new-553 (syntmp-strip-annotation-148 (car syntmp-x-551) #f)) (set-cdr! syntmp-new-553 (syntmp-strip-annotation-148 (cdr syntmp-x-551) #f)) syntmp-new-553))) ((annotation? syntmp-x-551) (or (annotation-stripped syntmp-x-551) (syntmp-strip-annotation-148 (annotation-expression syntmp-x-551) syntmp-x-551))) ((vector? syntmp-x-551) (let ((syntmp-new-554 (make-vector (vector-length syntmp-x-551)))) (begin (if syntmp-parent-552 (set-annotation-stripped! syntmp-parent-552 syntmp-new-554)) (let syntmp-loop-555 ((syntmp-i-556 (- (vector-length syntmp-x-551) 1))) (unless (syntmp-fx<-75 syntmp-i-556 0) (vector-set! syntmp-new-554 syntmp-i-556 (syntmp-strip-annotation-148 (vector-ref syntmp-x-551 syntmp-i-556) #f)) (syntmp-loop-555 (syntmp-fx--73 syntmp-i-556 1)))) syntmp-new-554))) (else syntmp-x-551)))) (syntmp-ellipsis?-147 (lambda (syntmp-x-557) (and (syntmp-nonsymbol-id?-101 syntmp-x-557) (syntmp-free-id=?-125 syntmp-x-557 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (syntmp-chi-void-146 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-145 (lambda (syntmp-expanded-558) (let ((syntmp-p-559 (syntmp-local-eval-hook-77 syntmp-expanded-558))) (if (procedure? syntmp-p-559) syntmp-p-559 (syntax-error syntmp-p-559 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-144 (lambda (syntmp-rec?-560 syntmp-e-561 syntmp-r-562 syntmp-w-563 syntmp-s-564 syntmp-k-565) ((lambda (syntmp-tmp-566) ((lambda (syntmp-tmp-567) (if syntmp-tmp-567 (apply (lambda (syntmp-_-568 syntmp-id-569 syntmp-val-570 syntmp-e1-571 syntmp-e2-572) (let ((syntmp-ids-573 syntmp-id-569)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-573)) (syntax-error syntmp-e-561 "duplicate bound keyword in") (let ((syntmp-labels-575 (syntmp-gen-labels-108 syntmp-ids-573))) (let ((syntmp-new-w-576 (syntmp-make-binding-wrap-119 syntmp-ids-573 syntmp-labels-575 syntmp-w-563))) (syntmp-k-565 (cons syntmp-e1-571 syntmp-e2-572) (syntmp-extend-env-96 syntmp-labels-575 (let ((syntmp-w-578 (if syntmp-rec?-560 syntmp-new-w-576 syntmp-w-563)) (syntmp-trans-r-579 (syntmp-macros-only-env-98 syntmp-r-562))) (map (lambda (syntmp-x-580) (cons (quote macro) (syntmp-eval-local-transformer-145 (syntmp-chi-138 syntmp-x-580 syntmp-trans-r-579 syntmp-w-578)))) syntmp-val-570)) syntmp-r-562) syntmp-new-w-576 syntmp-s-564)))))) syntmp-tmp-567) ((lambda (syntmp-_-582) (syntax-error (syntmp-source-wrap-131 syntmp-e-561 syntmp-w-563 syntmp-s-564))) syntmp-tmp-566))) (syntax-dispatch syntmp-tmp-566 (quote (any #(each (any any)) any . each-any))))) syntmp-e-561))) (syntmp-chi-lambda-clause-143 (lambda (syntmp-e-583 syntmp-c-584 syntmp-r-585 syntmp-w-586 syntmp-k-587) ((lambda (syntmp-tmp-588) ((lambda (syntmp-tmp-589) (if syntmp-tmp-589 (apply (lambda (syntmp-id-590 syntmp-e1-591 syntmp-e2-592) (let ((syntmp-ids-593 syntmp-id-590)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-593)) (syntax-error syntmp-e-583 "invalid parameter list in") (let ((syntmp-labels-595 (syntmp-gen-labels-108 syntmp-ids-593)) (syntmp-new-vars-596 (map syntmp-gen-var-150 syntmp-ids-593))) (syntmp-k-587 syntmp-new-vars-596 (syntmp-chi-body-142 (cons syntmp-e1-591 syntmp-e2-592) syntmp-e-583 (syntmp-extend-var-env-97 syntmp-labels-595 syntmp-new-vars-596 syntmp-r-585) (syntmp-make-binding-wrap-119 syntmp-ids-593 syntmp-labels-595 syntmp-w-586))))))) syntmp-tmp-589) ((lambda (syntmp-tmp-598) (if syntmp-tmp-598 (apply (lambda (syntmp-ids-599 syntmp-e1-600 syntmp-e2-601) (let ((syntmp-old-ids-602 (syntmp-lambda-var-list-151 syntmp-ids-599))) (if (not (syntmp-valid-bound-ids?-127 syntmp-old-ids-602)) (syntax-error syntmp-e-583 "invalid parameter list in") (let ((syntmp-labels-603 (syntmp-gen-labels-108 syntmp-old-ids-602)) (syntmp-new-vars-604 (map syntmp-gen-var-150 syntmp-old-ids-602))) (syntmp-k-587 (let syntmp-f-605 ((syntmp-ls1-606 (cdr syntmp-new-vars-604)) (syntmp-ls2-607 (car syntmp-new-vars-604))) (if (null? syntmp-ls1-606) syntmp-ls2-607 (syntmp-f-605 (cdr syntmp-ls1-606) (cons (car syntmp-ls1-606) syntmp-ls2-607)))) (syntmp-chi-body-142 (cons syntmp-e1-600 syntmp-e2-601) syntmp-e-583 (syntmp-extend-var-env-97 syntmp-labels-603 syntmp-new-vars-604 syntmp-r-585) (syntmp-make-binding-wrap-119 syntmp-old-ids-602 syntmp-labels-603 syntmp-w-586))))))) syntmp-tmp-598) ((lambda (syntmp-_-609) (syntax-error syntmp-e-583)) syntmp-tmp-588))) (syntax-dispatch syntmp-tmp-588 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-588 (quote (each-any any . each-any))))) syntmp-c-584))) (syntmp-chi-body-142 (lambda (syntmp-body-610 syntmp-outer-form-611 syntmp-r-612 syntmp-w-613) (let ((syntmp-r-614 (cons (quote ("placeholder" placeholder)) syntmp-r-612))) (let ((syntmp-ribcage-615 (syntmp-make-ribcage-109 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-616 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w-613) (cons syntmp-ribcage-615 (syntmp-wrap-subst-106 syntmp-w-613))))) (let syntmp-parse-617 ((syntmp-body-618 (map (lambda (syntmp-x-624) (cons syntmp-r-614 (syntmp-wrap-130 syntmp-x-624 syntmp-w-616))) syntmp-body-610)) (syntmp-ids-619 (quote ())) (syntmp-labels-620 (quote ())) (syntmp-vars-621 (quote ())) (syntmp-vals-622 (quote ())) (syntmp-bindings-623 (quote ()))) (if (null? syntmp-body-618) (syntax-error syntmp-outer-form-611 "no expressions in body") (let ((syntmp-e-625 (cdar syntmp-body-618)) (syntmp-er-626 (caar syntmp-body-618))) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-625 syntmp-er-626 (quote (())) #f syntmp-ribcage-615)) (lambda (syntmp-type-627 syntmp-value-628 syntmp-e-629 syntmp-w-630 syntmp-s-631) (let ((syntmp-t-632 syntmp-type-627)) (if (memv syntmp-t-632 (quote (define-form))) (let ((syntmp-id-633 (syntmp-wrap-130 syntmp-value-628 syntmp-w-630)) (syntmp-label-634 (syntmp-gen-label-107))) (let ((syntmp-var-635 (syntmp-gen-var-150 syntmp-id-633))) (begin (syntmp-extend-ribcage!-118 syntmp-ribcage-615 syntmp-id-633 syntmp-label-634) (syntmp-parse-617 (cdr syntmp-body-618) (cons syntmp-id-633 syntmp-ids-619) (cons syntmp-label-634 syntmp-labels-620) (cons syntmp-var-635 syntmp-vars-621) (cons (cons syntmp-er-626 (syntmp-wrap-130 syntmp-e-629 syntmp-w-630)) syntmp-vals-622) (cons (cons (quote lexical) syntmp-var-635) syntmp-bindings-623))))) (if (memv syntmp-t-632 (quote (define-syntax-form))) (let ((syntmp-id-636 (syntmp-wrap-130 syntmp-value-628 syntmp-w-630)) (syntmp-label-637 (syntmp-gen-label-107))) (begin (syntmp-extend-ribcage!-118 syntmp-ribcage-615 syntmp-id-636 syntmp-label-637) (syntmp-parse-617 (cdr syntmp-body-618) (cons syntmp-id-636 syntmp-ids-619) (cons syntmp-label-637 syntmp-labels-620) syntmp-vars-621 syntmp-vals-622 (cons (cons (quote macro) (cons syntmp-er-626 (syntmp-wrap-130 syntmp-e-629 syntmp-w-630))) syntmp-bindings-623)))) (if (memv syntmp-t-632 (quote (begin-form))) ((lambda (syntmp-tmp-638) ((lambda (syntmp-tmp-639) (if syntmp-tmp-639 (apply (lambda (syntmp-_-640 syntmp-e1-641) (syntmp-parse-617 (let syntmp-f-642 ((syntmp-forms-643 syntmp-e1-641)) (if (null? syntmp-forms-643) (cdr syntmp-body-618) (cons (cons syntmp-er-626 (syntmp-wrap-130 (car syntmp-forms-643) syntmp-w-630)) (syntmp-f-642 (cdr syntmp-forms-643))))) syntmp-ids-619 syntmp-labels-620 syntmp-vars-621 syntmp-vals-622 syntmp-bindings-623)) syntmp-tmp-639) (syntax-error syntmp-tmp-638))) (syntax-dispatch syntmp-tmp-638 (quote (any . each-any))))) syntmp-e-629) (if (memv syntmp-t-632 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-628 syntmp-e-629 syntmp-er-626 syntmp-w-630 syntmp-s-631 (lambda (syntmp-forms-645 syntmp-er-646 syntmp-w-647 syntmp-s-648) (syntmp-parse-617 (let syntmp-f-649 ((syntmp-forms-650 syntmp-forms-645)) (if (null? syntmp-forms-650) (cdr syntmp-body-618) (cons (cons syntmp-er-646 (syntmp-wrap-130 (car syntmp-forms-650) syntmp-w-647)) (syntmp-f-649 (cdr syntmp-forms-650))))) syntmp-ids-619 syntmp-labels-620 syntmp-vars-621 syntmp-vals-622 syntmp-bindings-623))) (if (null? syntmp-ids-619) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-651) (syntmp-chi-138 (cdr syntmp-x-651) (car syntmp-x-651) (quote (())))) (cons (cons syntmp-er-626 (syntmp-source-wrap-131 syntmp-e-629 syntmp-w-630 syntmp-s-631)) (cdr syntmp-body-618)))) (begin (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-619)) (syntax-error syntmp-outer-form-611 "invalid or duplicate identifier in definition")) (let syntmp-loop-652 ((syntmp-bs-653 syntmp-bindings-623) (syntmp-er-cache-654 #f) (syntmp-r-cache-655 #f)) (if (not (null? syntmp-bs-653)) (let ((syntmp-b-656 (car syntmp-bs-653))) (if (eq? (car syntmp-b-656) (quote macro)) (let ((syntmp-er-657 (cadr syntmp-b-656))) (let ((syntmp-r-cache-658 (if (eq? syntmp-er-657 syntmp-er-cache-654) syntmp-r-cache-655 (syntmp-macros-only-env-98 syntmp-er-657)))) (begin (set-cdr! syntmp-b-656 (syntmp-eval-local-transformer-145 (syntmp-chi-138 (cddr syntmp-b-656) syntmp-r-cache-658 (quote (()))))) (syntmp-loop-652 (cdr syntmp-bs-653) syntmp-er-657 syntmp-r-cache-658)))) (syntmp-loop-652 (cdr syntmp-bs-653) syntmp-er-cache-654 syntmp-r-cache-655))))) (set-cdr! syntmp-r-614 (syntmp-extend-env-96 syntmp-labels-620 syntmp-bindings-623 (cdr syntmp-r-614))) (syntmp-build-letrec-86 #f syntmp-vars-621 (map (lambda (syntmp-x-659) (syntmp-chi-138 (cdr syntmp-x-659) (car syntmp-x-659) (quote (())))) syntmp-vals-622) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-660) (syntmp-chi-138 (cdr syntmp-x-660) (car syntmp-x-660) (quote (())))) (cons (cons syntmp-er-626 (syntmp-source-wrap-131 syntmp-e-629 syntmp-w-630 syntmp-s-631)) (cdr syntmp-body-618)))))))))))))))))))))) (syntmp-chi-macro-141 (lambda (syntmp-p-661 syntmp-e-662 syntmp-r-663 syntmp-w-664 syntmp-rib-665) (letrec ((syntmp-rebuild-macro-output-666 (lambda (syntmp-x-667 syntmp-m-668) (cond ((pair? syntmp-x-667) (cons (syntmp-rebuild-macro-output-666 (car syntmp-x-667) syntmp-m-668) (syntmp-rebuild-macro-output-666 (cdr syntmp-x-667) syntmp-m-668))) ((syntmp-syntax-object?-88 syntmp-x-667) (let ((syntmp-w-669 (syntmp-syntax-object-wrap-90 syntmp-x-667))) (let ((syntmp-ms-670 (syntmp-wrap-marks-105 syntmp-w-669)) (syntmp-s-671 (syntmp-wrap-subst-106 syntmp-w-669))) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-667) (if (and (pair? syntmp-ms-670) (eq? (car syntmp-ms-670) #f)) (syntmp-make-wrap-104 (cdr syntmp-ms-670) (if syntmp-rib-665 (cons syntmp-rib-665 (cdr syntmp-s-671)) (cdr syntmp-s-671))) (syntmp-make-wrap-104 (cons syntmp-m-668 syntmp-ms-670) (if syntmp-rib-665 (cons syntmp-rib-665 (cons (quote shift) syntmp-s-671)) (cons (quote shift) syntmp-s-671)))))))) ((vector? syntmp-x-667) (let ((syntmp-n-672 (vector-length syntmp-x-667))) (let ((syntmp-v-673 (make-vector syntmp-n-672))) (let syntmp-doloop-674 ((syntmp-i-675 0)) (if (syntmp-fx=-74 syntmp-i-675 syntmp-n-672) syntmp-v-673 (begin (vector-set! syntmp-v-673 syntmp-i-675 (syntmp-rebuild-macro-output-666 (vector-ref syntmp-x-667 syntmp-i-675) syntmp-m-668)) (syntmp-doloop-674 (syntmp-fx+-72 syntmp-i-675 1)))))))) ((symbol? syntmp-x-667) (syntax-error syntmp-x-667 "encountered raw symbol in macro output")) (else syntmp-x-667))))) (syntmp-rebuild-macro-output-666 (syntmp-p-661 (syntmp-wrap-130 syntmp-e-662 (syntmp-anti-mark-117 syntmp-w-664))) (string #\m))))) (syntmp-chi-application-140 (lambda (syntmp-x-676 syntmp-e-677 syntmp-r-678 syntmp-w-679 syntmp-s-680) ((lambda (syntmp-tmp-681) ((lambda (syntmp-tmp-682) (if syntmp-tmp-682 (apply (lambda (syntmp-e0-683 syntmp-e1-684) (syntmp-build-annotated-81 syntmp-s-680 (cons syntmp-x-676 (map (lambda (syntmp-e-685) (syntmp-chi-138 syntmp-e-685 syntmp-r-678 syntmp-w-679)) syntmp-e1-684)))) syntmp-tmp-682) (syntax-error syntmp-tmp-681))) (syntax-dispatch syntmp-tmp-681 (quote (any . each-any))))) syntmp-e-677))) (syntmp-chi-expr-139 (lambda (syntmp-type-687 syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (let ((syntmp-t-693 syntmp-type-687)) (if (memv syntmp-t-693 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-692 syntmp-value-688) (if (memv syntmp-t-693 (quote (core external-macro))) (syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (lexical-call))) (syntmp-chi-application-140 (syntmp-build-annotated-81 (syntmp-source-annotation-93 (car syntmp-e-689)) syntmp-value-688) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (global-call))) (syntmp-chi-application-140 (syntmp-build-annotated-81 (syntmp-source-annotation-93 (car syntmp-e-689)) syntmp-value-688) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (constant))) (syntmp-build-data-82 syntmp-s-692 (syntmp-strip-149 (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) (quote (())))) (if (memv syntmp-t-693 (quote (global))) (syntmp-build-annotated-81 syntmp-s-692 syntmp-value-688) (if (memv syntmp-t-693 (quote (call))) (syntmp-chi-application-140 (syntmp-chi-138 (car syntmp-e-689) syntmp-r-690 syntmp-w-691) syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692) (if (memv syntmp-t-693 (quote (begin-form))) ((lambda (syntmp-tmp-694) ((lambda (syntmp-tmp-695) (if syntmp-tmp-695 (apply (lambda (syntmp-_-696 syntmp-e1-697 syntmp-e2-698) (syntmp-chi-sequence-132 (cons syntmp-e1-697 syntmp-e2-698) syntmp-r-690 syntmp-w-691 syntmp-s-692)) syntmp-tmp-695) (syntax-error syntmp-tmp-694))) (syntax-dispatch syntmp-tmp-694 (quote (any any . each-any))))) syntmp-e-689) (if (memv syntmp-t-693 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-688 syntmp-e-689 syntmp-r-690 syntmp-w-691 syntmp-s-692 syntmp-chi-sequence-132) (if (memv syntmp-t-693 (quote (eval-when-form))) ((lambda (syntmp-tmp-700) ((lambda (syntmp-tmp-701) (if syntmp-tmp-701 (apply (lambda (syntmp-_-702 syntmp-x-703 syntmp-e1-704 syntmp-e2-705) (let ((syntmp-when-list-706 (syntmp-chi-when-list-135 syntmp-e-689 syntmp-x-703 syntmp-w-691))) (if (memq (quote eval) syntmp-when-list-706) (syntmp-chi-sequence-132 (cons syntmp-e1-704 syntmp-e2-705) syntmp-r-690 syntmp-w-691 syntmp-s-692) (syntmp-chi-void-146)))) syntmp-tmp-701) (syntax-error syntmp-tmp-700))) (syntax-dispatch syntmp-tmp-700 (quote (any each-any any . each-any))))) syntmp-e-689) (if (memv syntmp-t-693 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-130 syntmp-value-688 syntmp-w-691) "invalid context for definition of") (if (memv syntmp-t-693 (quote (syntax))) (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) "reference to pattern variable outside syntax form") (if (memv syntmp-t-693 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-131 syntmp-e-689 syntmp-w-691 syntmp-s-692)))))))))))))))))) (syntmp-chi-138 (lambda (syntmp-e-709 syntmp-r-710 syntmp-w-711) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-709 syntmp-r-710 syntmp-w-711 #f #f)) (lambda (syntmp-type-712 syntmp-value-713 syntmp-e-714 syntmp-w-715 syntmp-s-716) (syntmp-chi-expr-139 syntmp-type-712 syntmp-value-713 syntmp-e-714 syntmp-r-710 syntmp-w-715 syntmp-s-716))))) (syntmp-chi-top-137 (lambda (syntmp-e-717 syntmp-r-718 syntmp-w-719 syntmp-m-720 syntmp-esew-721) (call-with-values (lambda () (syntmp-syntax-type-136 syntmp-e-717 syntmp-r-718 syntmp-w-719 #f #f)) (lambda (syntmp-type-734 syntmp-value-735 syntmp-e-736 syntmp-w-737 syntmp-s-738) (let ((syntmp-t-739 syntmp-type-734)) (if (memv syntmp-t-739 (quote (begin-form))) ((lambda (syntmp-tmp-740) ((lambda (syntmp-tmp-741) (if syntmp-tmp-741 (apply (lambda (syntmp-_-742) (syntmp-chi-void-146)) syntmp-tmp-741) ((lambda (syntmp-tmp-743) (if syntmp-tmp-743 (apply (lambda (syntmp-_-744 syntmp-e1-745 syntmp-e2-746) (syntmp-chi-top-sequence-133 (cons syntmp-e1-745 syntmp-e2-746) syntmp-r-718 syntmp-w-737 syntmp-s-738 syntmp-m-720 syntmp-esew-721)) syntmp-tmp-743) (syntax-error syntmp-tmp-740))) (syntax-dispatch syntmp-tmp-740 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-740 (quote (any))))) syntmp-e-736) (if (memv syntmp-t-739 (quote (local-syntax-form))) (syntmp-chi-local-syntax-144 syntmp-value-735 syntmp-e-736 syntmp-r-718 syntmp-w-737 syntmp-s-738 (lambda (syntmp-body-748 syntmp-r-749 syntmp-w-750 syntmp-s-751) (syntmp-chi-top-sequence-133 syntmp-body-748 syntmp-r-749 syntmp-w-750 syntmp-s-751 syntmp-m-720 syntmp-esew-721))) (if (memv syntmp-t-739 (quote (eval-when-form))) ((lambda (syntmp-tmp-752) ((lambda (syntmp-tmp-753) (if syntmp-tmp-753 (apply (lambda (syntmp-_-754 syntmp-x-755 syntmp-e1-756 syntmp-e2-757) (let ((syntmp-when-list-758 (syntmp-chi-when-list-135 syntmp-e-736 syntmp-x-755 syntmp-w-737)) (syntmp-body-759 (cons syntmp-e1-756 syntmp-e2-757))) (cond ((eq? syntmp-m-720 (quote e)) (if (memq (quote eval) syntmp-when-list-758) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote e) (quote (eval))) (syntmp-chi-void-146))) ((memq (quote load) syntmp-when-list-758) (if (or (memq (quote compile) syntmp-when-list-758) (and (eq? syntmp-m-720 (quote c&e)) (memq (quote eval) syntmp-when-list-758))) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote c&e) (quote (compile load))) (if (memq syntmp-m-720 (quote (c c&e))) (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote c) (quote (load))) (syntmp-chi-void-146)))) ((or (memq (quote compile) syntmp-when-list-758) (and (eq? syntmp-m-720 (quote c&e)) (memq (quote eval) syntmp-when-list-758))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-133 syntmp-body-759 syntmp-r-718 syntmp-w-737 syntmp-s-738 (quote e) (quote (eval)))) (syntmp-chi-void-146)) (else (syntmp-chi-void-146))))) syntmp-tmp-753) (syntax-error syntmp-tmp-752))) (syntax-dispatch syntmp-tmp-752 (quote (any each-any any . each-any))))) syntmp-e-736) (if (memv syntmp-t-739 (quote (define-syntax-form))) (let ((syntmp-n-762 (syntmp-id-var-name-124 syntmp-value-735 syntmp-w-737)) (syntmp-r-763 (syntmp-macros-only-env-98 syntmp-r-718))) (let ((syntmp-t-764 syntmp-m-720)) (if (memv syntmp-t-764 (quote (c))) (if (memq (quote compile) syntmp-esew-721) (let ((syntmp-e-765 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-765) (if (memq (quote load) syntmp-esew-721) syntmp-e-765 (syntmp-chi-void-146)))) (if (memq (quote load) syntmp-esew-721) (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)) (syntmp-chi-void-146))) (if (memv syntmp-t-764 (quote (c&e))) (let ((syntmp-e-766 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-766) syntmp-e-766)) (begin (if (memq (quote eval) syntmp-esew-721) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-134 syntmp-n-762 (syntmp-chi-138 syntmp-e-736 syntmp-r-763 syntmp-w-737)))) (syntmp-chi-void-146)))))) (if (memv syntmp-t-739 (quote (define-form))) (let ((syntmp-n-767 (syntmp-id-var-name-124 syntmp-value-735 syntmp-w-737))) (let ((syntmp-type-768 (syntmp-binding-type-94 (syntmp-lookup-99 syntmp-n-767 syntmp-r-718)))) (let ((syntmp-t-769 syntmp-type-768)) (if (memv syntmp-t-769 (quote (global))) (let ((syntmp-x-770 (syntmp-build-annotated-81 syntmp-s-738 (list (quote define) syntmp-n-767 (syntmp-chi-138 syntmp-e-736 syntmp-r-718 syntmp-w-737))))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-770)) syntmp-x-770)) (if (memv syntmp-t-769 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-130 syntmp-value-735 syntmp-w-737) "identifier out of context") (if (eq? syntmp-type-768 (quote external-macro)) (let ((syntmp-x-771 (syntmp-build-annotated-81 syntmp-s-738 (list (quote define) syntmp-n-767 (syntmp-chi-138 syntmp-e-736 syntmp-r-718 syntmp-w-737))))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-771)) syntmp-x-771)) (syntax-error (syntmp-wrap-130 syntmp-value-735 syntmp-w-737) "cannot define keyword at top level"))))))) (let ((syntmp-x-772 (syntmp-chi-expr-139 syntmp-type-734 syntmp-value-735 syntmp-e-736 syntmp-r-718 syntmp-w-737 syntmp-s-738))) (begin (if (eq? syntmp-m-720 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-772)) syntmp-x-772)))))))))))) (syntmp-syntax-type-136 (lambda (syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-rib-777) (cond ((symbol? syntmp-e-773) (let ((syntmp-n-778 (syntmp-id-var-name-124 syntmp-e-773 syntmp-w-775))) (let ((syntmp-b-779 (syntmp-lookup-99 syntmp-n-778 syntmp-r-774))) (let ((syntmp-type-780 (syntmp-binding-type-94 syntmp-b-779))) (let ((syntmp-t-781 syntmp-type-780)) (if (memv syntmp-t-781 (quote (lexical))) (values syntmp-type-780 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-781 (quote (global))) (values syntmp-type-780 syntmp-n-778 syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-781 (quote (macro))) (syntmp-syntax-type-136 (syntmp-chi-macro-141 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-rib-777) syntmp-r-774 (quote (())) syntmp-s-776 syntmp-rib-777) (values syntmp-type-780 (syntmp-binding-value-95 syntmp-b-779) syntmp-e-773 syntmp-w-775 syntmp-s-776))))))))) ((pair? syntmp-e-773) (let ((syntmp-first-782 (car syntmp-e-773))) (if (syntmp-id?-102 syntmp-first-782) (let ((syntmp-n-783 (syntmp-id-var-name-124 syntmp-first-782 syntmp-w-775))) (let ((syntmp-b-784 (syntmp-lookup-99 syntmp-n-783 syntmp-r-774))) (let ((syntmp-type-785 (syntmp-binding-type-94 syntmp-b-784))) (let ((syntmp-t-786 syntmp-type-785)) (if (memv syntmp-t-786 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (global))) (values (quote global-call) syntmp-n-783 syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (macro))) (syntmp-syntax-type-136 (syntmp-chi-macro-141 (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-r-774 syntmp-w-775 syntmp-rib-777) syntmp-r-774 (quote (())) syntmp-s-776 syntmp-rib-777) (if (memv syntmp-t-786 (quote (core external-macro))) (values syntmp-type-785 (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-95 syntmp-b-784) syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (begin))) (values (quote begin-form) #f syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-773 syntmp-w-775 syntmp-s-776) (if (memv syntmp-t-786 (quote (define))) ((lambda (syntmp-tmp-787) ((lambda (syntmp-tmp-788) (if (if syntmp-tmp-788 (apply (lambda (syntmp-_-789 syntmp-name-790 syntmp-val-791) (syntmp-id?-102 syntmp-name-790)) syntmp-tmp-788) #f) (apply (lambda (syntmp-_-792 syntmp-name-793 syntmp-val-794) (values (quote define-form) syntmp-name-793 syntmp-val-794 syntmp-w-775 syntmp-s-776)) syntmp-tmp-788) ((lambda (syntmp-tmp-795) (if (if syntmp-tmp-795 (apply (lambda (syntmp-_-796 syntmp-name-797 syntmp-args-798 syntmp-e1-799 syntmp-e2-800) (and (syntmp-id?-102 syntmp-name-797) (syntmp-valid-bound-ids?-127 (syntmp-lambda-var-list-151 syntmp-args-798)))) syntmp-tmp-795) #f) (apply (lambda (syntmp-_-801 syntmp-name-802 syntmp-args-803 syntmp-e1-804 syntmp-e2-805) (values (quote define-form) (syntmp-wrap-130 syntmp-name-802 syntmp-w-775) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (syntmp-wrap-130 (cons syntmp-args-803 (cons syntmp-e1-804 syntmp-e2-805)) syntmp-w-775)) (quote (())) syntmp-s-776)) syntmp-tmp-795) ((lambda (syntmp-tmp-807) (if (if syntmp-tmp-807 (apply (lambda (syntmp-_-808 syntmp-name-809) (syntmp-id?-102 syntmp-name-809)) syntmp-tmp-807) #f) (apply (lambda (syntmp-_-810 syntmp-name-811) (values (quote define-form) (syntmp-wrap-130 syntmp-name-811 syntmp-w-775) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) syntmp-s-776)) syntmp-tmp-807) (syntax-error syntmp-tmp-787))) (syntax-dispatch syntmp-tmp-787 (quote (any any)))))) (syntax-dispatch syntmp-tmp-787 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-787 (quote (any any any))))) syntmp-e-773) (if (memv syntmp-t-786 (quote (define-syntax))) ((lambda (syntmp-tmp-812) ((lambda (syntmp-tmp-813) (if (if syntmp-tmp-813 (apply (lambda (syntmp-_-814 syntmp-name-815 syntmp-val-816) (syntmp-id?-102 syntmp-name-815)) syntmp-tmp-813) #f) (apply (lambda (syntmp-_-817 syntmp-name-818 syntmp-val-819) (values (quote define-syntax-form) syntmp-name-818 syntmp-val-819 syntmp-w-775 syntmp-s-776)) syntmp-tmp-813) (syntax-error syntmp-tmp-812))) (syntax-dispatch syntmp-tmp-812 (quote (any any any))))) syntmp-e-773) (values (quote call) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)))))))))))))) (values (quote call) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)))) ((syntmp-syntax-object?-88 syntmp-e-773) (syntmp-syntax-type-136 (syntmp-syntax-object-expression-89 syntmp-e-773) syntmp-r-774 (syntmp-join-wraps-121 syntmp-w-775 (syntmp-syntax-object-wrap-90 syntmp-e-773)) #f syntmp-rib-777)) ((annotation? syntmp-e-773) (syntmp-syntax-type-136 (annotation-expression syntmp-e-773) syntmp-r-774 syntmp-w-775 (annotation-source syntmp-e-773) syntmp-rib-777)) ((self-evaluating? syntmp-e-773) (values (quote constant) #f syntmp-e-773 syntmp-w-775 syntmp-s-776)) (else (values (quote other) #f syntmp-e-773 syntmp-w-775 syntmp-s-776))))) (syntmp-chi-when-list-135 (lambda (syntmp-e-820 syntmp-when-list-821 syntmp-w-822) (let syntmp-f-823 ((syntmp-when-list-824 syntmp-when-list-821) (syntmp-situations-825 (quote ()))) (if (null? syntmp-when-list-824) syntmp-situations-825 (syntmp-f-823 (cdr syntmp-when-list-824) (cons (let ((syntmp-x-826 (car syntmp-when-list-824))) (cond ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((syntmp-free-id=?-125 syntmp-x-826 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (syntmp-wrap-130 syntmp-x-826 syntmp-w-822) "invalid eval-when situation")))) syntmp-situations-825)))))) (syntmp-chi-install-global-134 (lambda (syntmp-name-827 syntmp-e-828) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-827) syntmp-e-828)))) (syntmp-chi-top-sequence-133 (lambda (syntmp-body-829 syntmp-r-830 syntmp-w-831 syntmp-s-832 syntmp-m-833 syntmp-esew-834) (syntmp-build-sequence-83 syntmp-s-832 (let syntmp-dobody-835 ((syntmp-body-836 syntmp-body-829) (syntmp-r-837 syntmp-r-830) (syntmp-w-838 syntmp-w-831) (syntmp-m-839 syntmp-m-833) (syntmp-esew-840 syntmp-esew-834)) (if (null? syntmp-body-836) (quote ()) (let ((syntmp-first-841 (syntmp-chi-top-137 (car syntmp-body-836) syntmp-r-837 syntmp-w-838 syntmp-m-839 syntmp-esew-840))) (cons syntmp-first-841 (syntmp-dobody-835 (cdr syntmp-body-836) syntmp-r-837 syntmp-w-838 syntmp-m-839 syntmp-esew-840)))))))) (syntmp-chi-sequence-132 (lambda (syntmp-body-842 syntmp-r-843 syntmp-w-844 syntmp-s-845) (syntmp-build-sequence-83 syntmp-s-845 (let syntmp-dobody-846 ((syntmp-body-847 syntmp-body-842) (syntmp-r-848 syntmp-r-843) (syntmp-w-849 syntmp-w-844)) (if (null? syntmp-body-847) (quote ()) (let ((syntmp-first-850 (syntmp-chi-138 (car syntmp-body-847) syntmp-r-848 syntmp-w-849))) (cons syntmp-first-850 (syntmp-dobody-846 (cdr syntmp-body-847) syntmp-r-848 syntmp-w-849)))))))) (syntmp-source-wrap-131 (lambda (syntmp-x-851 syntmp-w-852 syntmp-s-853) (syntmp-wrap-130 (if syntmp-s-853 (make-annotation syntmp-x-851 syntmp-s-853 #f) syntmp-x-851) syntmp-w-852))) (syntmp-wrap-130 (lambda (syntmp-x-854 syntmp-w-855) (cond ((and (null? (syntmp-wrap-marks-105 syntmp-w-855)) (null? (syntmp-wrap-subst-106 syntmp-w-855))) syntmp-x-854) ((syntmp-syntax-object?-88 syntmp-x-854) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-854) (syntmp-join-wraps-121 syntmp-w-855 (syntmp-syntax-object-wrap-90 syntmp-x-854)))) ((null? syntmp-x-854) syntmp-x-854) (else (syntmp-make-syntax-object-87 syntmp-x-854 syntmp-w-855))))) (syntmp-bound-id-member?-129 (lambda (syntmp-x-856 syntmp-list-857) (and (not (null? syntmp-list-857)) (or (syntmp-bound-id=?-126 syntmp-x-856 (car syntmp-list-857)) (syntmp-bound-id-member?-129 syntmp-x-856 (cdr syntmp-list-857)))))) (syntmp-distinct-bound-ids?-128 (lambda (syntmp-ids-858) (let syntmp-distinct?-859 ((syntmp-ids-860 syntmp-ids-858)) (or (null? syntmp-ids-860) (and (not (syntmp-bound-id-member?-129 (car syntmp-ids-860) (cdr syntmp-ids-860))) (syntmp-distinct?-859 (cdr syntmp-ids-860))))))) (syntmp-valid-bound-ids?-127 (lambda (syntmp-ids-861) (and (let syntmp-all-ids?-862 ((syntmp-ids-863 syntmp-ids-861)) (or (null? syntmp-ids-863) (and (syntmp-id?-102 (car syntmp-ids-863)) (syntmp-all-ids?-862 (cdr syntmp-ids-863))))) (syntmp-distinct-bound-ids?-128 syntmp-ids-861)))) (syntmp-bound-id=?-126 (lambda (syntmp-i-864 syntmp-j-865) (if (and (syntmp-syntax-object?-88 syntmp-i-864) (syntmp-syntax-object?-88 syntmp-j-865)) (and (eq? (let ((syntmp-e-866 (syntmp-syntax-object-expression-89 syntmp-i-864))) (if (annotation? syntmp-e-866) (annotation-expression syntmp-e-866) syntmp-e-866)) (let ((syntmp-e-867 (syntmp-syntax-object-expression-89 syntmp-j-865))) (if (annotation? syntmp-e-867) (annotation-expression syntmp-e-867) syntmp-e-867))) (syntmp-same-marks?-123 (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-i-864)) (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-j-865)))) (eq? (let ((syntmp-e-868 syntmp-i-864)) (if (annotation? syntmp-e-868) (annotation-expression syntmp-e-868) syntmp-e-868)) (let ((syntmp-e-869 syntmp-j-865)) (if (annotation? syntmp-e-869) (annotation-expression syntmp-e-869) syntmp-e-869)))))) (syntmp-free-id=?-125 (lambda (syntmp-i-870 syntmp-j-871) (and (eq? (let ((syntmp-x-872 syntmp-i-870)) (let ((syntmp-e-873 (if (syntmp-syntax-object?-88 syntmp-x-872) (syntmp-syntax-object-expression-89 syntmp-x-872) syntmp-x-872))) (if (annotation? syntmp-e-873) (annotation-expression syntmp-e-873) syntmp-e-873))) (let ((syntmp-x-874 syntmp-j-871)) (let ((syntmp-e-875 (if (syntmp-syntax-object?-88 syntmp-x-874) (syntmp-syntax-object-expression-89 syntmp-x-874) syntmp-x-874))) (if (annotation? syntmp-e-875) (annotation-expression syntmp-e-875) syntmp-e-875)))) (eq? (syntmp-id-var-name-124 syntmp-i-870 (quote (()))) (syntmp-id-var-name-124 syntmp-j-871 (quote (()))))))) (syntmp-id-var-name-124 (lambda (syntmp-id-876 syntmp-w-877) (letrec ((syntmp-search-vector-rib-880 (lambda (syntmp-sym-891 syntmp-subst-892 syntmp-marks-893 syntmp-symnames-894 syntmp-ribcage-895) (let ((syntmp-n-896 (vector-length syntmp-symnames-894))) (let syntmp-f-897 ((syntmp-i-898 0)) (cond ((syntmp-fx=-74 syntmp-i-898 syntmp-n-896) (syntmp-search-878 syntmp-sym-891 (cdr syntmp-subst-892) syntmp-marks-893)) ((and (eq? (vector-ref syntmp-symnames-894 syntmp-i-898) syntmp-sym-891) (syntmp-same-marks?-123 syntmp-marks-893 (vector-ref (syntmp-ribcage-marks-112 syntmp-ribcage-895) syntmp-i-898))) (values (vector-ref (syntmp-ribcage-labels-113 syntmp-ribcage-895) syntmp-i-898) syntmp-marks-893)) (else (syntmp-f-897 (syntmp-fx+-72 syntmp-i-898 1)))))))) (syntmp-search-list-rib-879 (lambda (syntmp-sym-899 syntmp-subst-900 syntmp-marks-901 syntmp-symnames-902 syntmp-ribcage-903) (let syntmp-f-904 ((syntmp-symnames-905 syntmp-symnames-902) (syntmp-i-906 0)) (cond ((null? syntmp-symnames-905) (syntmp-search-878 syntmp-sym-899 (cdr syntmp-subst-900) syntmp-marks-901)) ((and (eq? (car syntmp-symnames-905) syntmp-sym-899) (syntmp-same-marks?-123 syntmp-marks-901 (list-ref (syntmp-ribcage-marks-112 syntmp-ribcage-903) syntmp-i-906))) (values (list-ref (syntmp-ribcage-labels-113 syntmp-ribcage-903) syntmp-i-906) syntmp-marks-901)) (else (syntmp-f-904 (cdr syntmp-symnames-905) (syntmp-fx+-72 syntmp-i-906 1))))))) (syntmp-search-878 (lambda (syntmp-sym-907 syntmp-subst-908 syntmp-marks-909) (if (null? syntmp-subst-908) (values #f syntmp-marks-909) (let ((syntmp-fst-910 (car syntmp-subst-908))) (if (eq? syntmp-fst-910 (quote shift)) (syntmp-search-878 syntmp-sym-907 (cdr syntmp-subst-908) (cdr syntmp-marks-909)) (let ((syntmp-symnames-911 (syntmp-ribcage-symnames-111 syntmp-fst-910))) (if (vector? syntmp-symnames-911) (syntmp-search-vector-rib-880 syntmp-sym-907 syntmp-subst-908 syntmp-marks-909 syntmp-symnames-911 syntmp-fst-910) (syntmp-search-list-rib-879 syntmp-sym-907 syntmp-subst-908 syntmp-marks-909 syntmp-symnames-911 syntmp-fst-910))))))))) (cond ((symbol? syntmp-id-876) (or (call-with-values (lambda () (syntmp-search-878 syntmp-id-876 (syntmp-wrap-subst-106 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w-877))) (lambda (syntmp-x-913 . syntmp-ignore-912) syntmp-x-913)) syntmp-id-876)) ((syntmp-syntax-object?-88 syntmp-id-876) (let ((syntmp-id-914 (let ((syntmp-e-916 (syntmp-syntax-object-expression-89 syntmp-id-876))) (if (annotation? syntmp-e-916) (annotation-expression syntmp-e-916) syntmp-e-916))) (syntmp-w1-915 (syntmp-syntax-object-wrap-90 syntmp-id-876))) (let ((syntmp-marks-917 (syntmp-join-marks-122 (syntmp-wrap-marks-105 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w1-915)))) (call-with-values (lambda () (syntmp-search-878 syntmp-id-914 (syntmp-wrap-subst-106 syntmp-w-877) syntmp-marks-917)) (lambda (syntmp-new-id-918 syntmp-marks-919) (or syntmp-new-id-918 (call-with-values (lambda () (syntmp-search-878 syntmp-id-914 (syntmp-wrap-subst-106 syntmp-w1-915) syntmp-marks-919)) (lambda (syntmp-x-921 . syntmp-ignore-920) syntmp-x-921)) syntmp-id-914)))))) ((annotation? syntmp-id-876) (let ((syntmp-id-922 (let ((syntmp-e-923 syntmp-id-876)) (if (annotation? syntmp-e-923) (annotation-expression syntmp-e-923) syntmp-e-923)))) (or (call-with-values (lambda () (syntmp-search-878 syntmp-id-922 (syntmp-wrap-subst-106 syntmp-w-877) (syntmp-wrap-marks-105 syntmp-w-877))) (lambda (syntmp-x-925 . syntmp-ignore-924) syntmp-x-925)) syntmp-id-922))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-876)))))) (syntmp-same-marks?-123 (lambda (syntmp-x-926 syntmp-y-927) (or (eq? syntmp-x-926 syntmp-y-927) (and (not (null? syntmp-x-926)) (not (null? syntmp-y-927)) (eq? (car syntmp-x-926) (car syntmp-y-927)) (syntmp-same-marks?-123 (cdr syntmp-x-926) (cdr syntmp-y-927)))))) (syntmp-join-marks-122 (lambda (syntmp-m1-928 syntmp-m2-929) (syntmp-smart-append-120 syntmp-m1-928 syntmp-m2-929))) (syntmp-join-wraps-121 (lambda (syntmp-w1-930 syntmp-w2-931) (let ((syntmp-m1-932 (syntmp-wrap-marks-105 syntmp-w1-930)) (syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w1-930))) (if (null? syntmp-m1-932) (if (null? syntmp-s1-933) syntmp-w2-931 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w2-931) (syntmp-smart-append-120 syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w2-931)))) (syntmp-make-wrap-104 (syntmp-smart-append-120 syntmp-m1-932 (syntmp-wrap-marks-105 syntmp-w2-931)) (syntmp-smart-append-120 syntmp-s1-933 (syntmp-wrap-subst-106 syntmp-w2-931))))))) (syntmp-smart-append-120 (lambda (syntmp-m1-934 syntmp-m2-935) (if (null? syntmp-m2-935) syntmp-m1-934 (append syntmp-m1-934 syntmp-m2-935)))) (syntmp-make-binding-wrap-119 (lambda (syntmp-ids-936 syntmp-labels-937 syntmp-w-938) (if (null? syntmp-ids-936) syntmp-w-938 (syntmp-make-wrap-104 (syntmp-wrap-marks-105 syntmp-w-938) (cons (let ((syntmp-labelvec-939 (list->vector syntmp-labels-937))) (let ((syntmp-n-940 (vector-length syntmp-labelvec-939))) (let ((syntmp-symnamevec-941 (make-vector syntmp-n-940)) (syntmp-marksvec-942 (make-vector syntmp-n-940))) (begin (let syntmp-f-943 ((syntmp-ids-944 syntmp-ids-936) (syntmp-i-945 0)) (if (not (null? syntmp-ids-944)) (call-with-values (lambda () (syntmp-id-sym-name&marks-103 (car syntmp-ids-944) syntmp-w-938)) (lambda (syntmp-symname-946 syntmp-marks-947) (begin (vector-set! syntmp-symnamevec-941 syntmp-i-945 syntmp-symname-946) (vector-set! syntmp-marksvec-942 syntmp-i-945 syntmp-marks-947) (syntmp-f-943 (cdr syntmp-ids-944) (syntmp-fx+-72 syntmp-i-945 1))))))) (syntmp-make-ribcage-109 syntmp-symnamevec-941 syntmp-marksvec-942 syntmp-labelvec-939))))) (syntmp-wrap-subst-106 syntmp-w-938)))))) (syntmp-extend-ribcage!-118 (lambda (syntmp-ribcage-948 syntmp-id-949 syntmp-label-950) (begin (syntmp-set-ribcage-symnames!-114 syntmp-ribcage-948 (cons (let ((syntmp-e-951 (syntmp-syntax-object-expression-89 syntmp-id-949))) (if (annotation? syntmp-e-951) (annotation-expression syntmp-e-951) syntmp-e-951)) (syntmp-ribcage-symnames-111 syntmp-ribcage-948))) (syntmp-set-ribcage-marks!-115 syntmp-ribcage-948 (cons (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-id-949)) (syntmp-ribcage-marks-112 syntmp-ribcage-948))) (syntmp-set-ribcage-labels!-116 syntmp-ribcage-948 (cons syntmp-label-950 (syntmp-ribcage-labels-113 syntmp-ribcage-948)))))) (syntmp-anti-mark-117 (lambda (syntmp-w-952) (syntmp-make-wrap-104 (cons #f (syntmp-wrap-marks-105 syntmp-w-952)) (cons (quote shift) (syntmp-wrap-subst-106 syntmp-w-952))))) (syntmp-set-ribcage-labels!-116 (lambda (syntmp-x-953 syntmp-update-954) (vector-set! syntmp-x-953 3 syntmp-update-954))) (syntmp-set-ribcage-marks!-115 (lambda (syntmp-x-955 syntmp-update-956) (vector-set! syntmp-x-955 2 syntmp-update-956))) (syntmp-set-ribcage-symnames!-114 (lambda (syntmp-x-957 syntmp-update-958) (vector-set! syntmp-x-957 1 syntmp-update-958))) (syntmp-ribcage-labels-113 (lambda (syntmp-x-959) (vector-ref syntmp-x-959 3))) (syntmp-ribcage-marks-112 (lambda (syntmp-x-960) (vector-ref syntmp-x-960 2))) (syntmp-ribcage-symnames-111 (lambda (syntmp-x-961) (vector-ref syntmp-x-961 1))) (syntmp-ribcage?-110 (lambda (syntmp-x-962) (and (vector? syntmp-x-962) (= (vector-length syntmp-x-962) 4) (eq? (vector-ref syntmp-x-962 0) (quote ribcage))))) (syntmp-make-ribcage-109 (lambda (syntmp-symnames-963 syntmp-marks-964 syntmp-labels-965) (vector (quote ribcage) syntmp-symnames-963 syntmp-marks-964 syntmp-labels-965))) (syntmp-gen-labels-108 (lambda (syntmp-ls-966) (if (null? syntmp-ls-966) (quote ()) (cons (syntmp-gen-label-107) (syntmp-gen-labels-108 (cdr syntmp-ls-966)))))) (syntmp-gen-label-107 (lambda () (string #\i))) (syntmp-wrap-subst-106 cdr) (syntmp-wrap-marks-105 car) (syntmp-make-wrap-104 cons) (syntmp-id-sym-name&marks-103 (lambda (syntmp-x-967 syntmp-w-968) (if (syntmp-syntax-object?-88 syntmp-x-967) (values (let ((syntmp-e-969 (syntmp-syntax-object-expression-89 syntmp-x-967))) (if (annotation? syntmp-e-969) (annotation-expression syntmp-e-969) syntmp-e-969)) (syntmp-join-marks-122 (syntmp-wrap-marks-105 syntmp-w-968) (syntmp-wrap-marks-105 (syntmp-syntax-object-wrap-90 syntmp-x-967)))) (values (let ((syntmp-e-970 syntmp-x-967)) (if (annotation? syntmp-e-970) (annotation-expression syntmp-e-970) syntmp-e-970)) (syntmp-wrap-marks-105 syntmp-w-968))))) (syntmp-id?-102 (lambda (syntmp-x-971) (cond ((symbol? syntmp-x-971) #t) ((syntmp-syntax-object?-88 syntmp-x-971) (symbol? (let ((syntmp-e-972 (syntmp-syntax-object-expression-89 syntmp-x-971))) (if (annotation? syntmp-e-972) (annotation-expression syntmp-e-972) syntmp-e-972)))) ((annotation? syntmp-x-971) (symbol? (annotation-expression syntmp-x-971))) (else #f)))) (syntmp-nonsymbol-id?-101 (lambda (syntmp-x-973) (and (syntmp-syntax-object?-88 syntmp-x-973) (symbol? (let ((syntmp-e-974 (syntmp-syntax-object-expression-89 syntmp-x-973))) (if (annotation? syntmp-e-974) (annotation-expression syntmp-e-974) syntmp-e-974)))))) (syntmp-global-extend-100 (lambda (syntmp-type-975 syntmp-sym-976 syntmp-val-977) (syntmp-put-global-definition-hook-79 syntmp-sym-976 (cons syntmp-type-975 syntmp-val-977)))) (syntmp-lookup-99 (lambda (syntmp-x-978 syntmp-r-979) (cond ((assq syntmp-x-978 syntmp-r-979) => cdr) ((symbol? syntmp-x-978) (or (syntmp-get-global-definition-hook-80 syntmp-x-978) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-98 (lambda (syntmp-r-980) (if (null? syntmp-r-980) (quote ()) (let ((syntmp-a-981 (car syntmp-r-980))) (if (eq? (cadr syntmp-a-981) (quote macro)) (cons syntmp-a-981 (syntmp-macros-only-env-98 (cdr syntmp-r-980))) (syntmp-macros-only-env-98 (cdr syntmp-r-980))))))) (syntmp-extend-var-env-97 (lambda (syntmp-labels-982 syntmp-vars-983 syntmp-r-984) (if (null? syntmp-labels-982) syntmp-r-984 (syntmp-extend-var-env-97 (cdr syntmp-labels-982) (cdr syntmp-vars-983) (cons (cons (car syntmp-labels-982) (cons (quote lexical) (car syntmp-vars-983))) syntmp-r-984))))) (syntmp-extend-env-96 (lambda (syntmp-labels-985 syntmp-bindings-986 syntmp-r-987) (if (null? syntmp-labels-985) syntmp-r-987 (syntmp-extend-env-96 (cdr syntmp-labels-985) (cdr syntmp-bindings-986) (cons (cons (car syntmp-labels-985) (car syntmp-bindings-986)) syntmp-r-987))))) (syntmp-binding-value-95 cdr) (syntmp-binding-type-94 car) (syntmp-source-annotation-93 (lambda (syntmp-x-988) (cond ((annotation? syntmp-x-988) (annotation-source syntmp-x-988)) ((syntmp-syntax-object?-88 syntmp-x-988) (syntmp-source-annotation-93 (syntmp-syntax-object-expression-89 syntmp-x-988))) (else #f)))) (syntmp-set-syntax-object-wrap!-92 (lambda (syntmp-x-989 syntmp-update-990) (vector-set! syntmp-x-989 2 syntmp-update-990))) (syntmp-set-syntax-object-expression!-91 (lambda (syntmp-x-991 syntmp-update-992) (vector-set! syntmp-x-991 1 syntmp-update-992))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-993) (vector-ref syntmp-x-993 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-994) (vector-ref syntmp-x-994 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-995) (and (vector? syntmp-x-995) (= (vector-length syntmp-x-995) 3) (eq? (vector-ref syntmp-x-995 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-expression-996 syntmp-wrap-997) (vector (quote syntax-object) syntmp-expression-996 syntmp-wrap-997))) (syntmp-build-letrec-86 (lambda (syntmp-src-998 syntmp-vars-999 syntmp-val-exps-1000 syntmp-body-exp-1001) (if (null? syntmp-vars-999) (syntmp-build-annotated-81 syntmp-src-998 syntmp-body-exp-1001) (syntmp-build-annotated-81 syntmp-src-998 (list (quote letrec) (map list syntmp-vars-999 syntmp-val-exps-1000) syntmp-body-exp-1001))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1002 syntmp-vars-1003 syntmp-val-exps-1004 syntmp-body-exp-1005) (if (null? syntmp-vars-1003) (syntmp-build-annotated-81 syntmp-src-1002 syntmp-body-exp-1005) (syntmp-build-annotated-81 syntmp-src-1002 (list (quote let) (car syntmp-vars-1003) (map list (cdr syntmp-vars-1003) syntmp-val-exps-1004) syntmp-body-exp-1005))))) (syntmp-build-let-84 (lambda (syntmp-src-1006 syntmp-vars-1007 syntmp-val-exps-1008 syntmp-body-exp-1009) (if (null? syntmp-vars-1007) (syntmp-build-annotated-81 syntmp-src-1006 syntmp-body-exp-1009) (syntmp-build-annotated-81 syntmp-src-1006 (list (quote let) (map list syntmp-vars-1007 syntmp-val-exps-1008) syntmp-body-exp-1009))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1010 syntmp-exps-1011) (if (null? (cdr syntmp-exps-1011)) (syntmp-build-annotated-81 syntmp-src-1010 (car syntmp-exps-1011)) (syntmp-build-annotated-81 syntmp-src-1010 (cons (quote begin) syntmp-exps-1011))))) (syntmp-build-data-82 (lambda (syntmp-src-1012 syntmp-exp-1013) (if (and (self-evaluating? syntmp-exp-1013) (not (vector? syntmp-exp-1013))) (syntmp-build-annotated-81 syntmp-src-1012 syntmp-exp-1013) (syntmp-build-annotated-81 syntmp-src-1012 (list (quote quote) syntmp-exp-1013))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1014 syntmp-exp-1015) (if (and syntmp-src-1014 (not (annotation? syntmp-exp-1015))) (make-annotation syntmp-exp-1015 syntmp-src-1014 #t) syntmp-exp-1015))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1016) (getprop syntmp-symbol-1016 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1017 syntmp-binding-1018) (putprop syntmp-symbol-1017 (quote *sc-expander*) syntmp-binding-1018))) (syntmp-error-hook-78 (lambda (syntmp-who-1019 syntmp-why-1020 syntmp-what-1021) (error syntmp-who-1019 "~a ~s" syntmp-why-1020 syntmp-what-1021))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1022) (eval (list syntmp-noexpand-71 syntmp-x-1022) (interaction-environment)))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1023) (eval (list syntmp-noexpand-71 syntmp-x-1023) (interaction-environment)))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-100 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-100 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-100 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1024 syntmp-r-1025 syntmp-w-1026 syntmp-s-1027) ((lambda (syntmp-tmp-1028) ((lambda (syntmp-tmp-1029) (if (if syntmp-tmp-1029 (apply (lambda (syntmp-_-1030 syntmp-var-1031 syntmp-val-1032 syntmp-e1-1033 syntmp-e2-1034) (syntmp-valid-bound-ids?-127 syntmp-var-1031)) syntmp-tmp-1029) #f) (apply (lambda (syntmp-_-1036 syntmp-var-1037 syntmp-val-1038 syntmp-e1-1039 syntmp-e2-1040) (let ((syntmp-names-1041 (map (lambda (syntmp-x-1042) (syntmp-id-var-name-124 syntmp-x-1042 syntmp-w-1026)) syntmp-var-1037))) (begin (for-each (lambda (syntmp-id-1044 syntmp-n-1045) (let ((syntmp-t-1046 (syntmp-binding-type-94 (syntmp-lookup-99 syntmp-n-1045 syntmp-r-1025)))) (if (memv syntmp-t-1046 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-131 syntmp-id-1044 syntmp-w-1026 syntmp-s-1027) "identifier out of context")))) syntmp-var-1037 syntmp-names-1041) (syntmp-chi-body-142 (cons syntmp-e1-1039 syntmp-e2-1040) (syntmp-source-wrap-131 syntmp-e-1024 syntmp-w-1026 syntmp-s-1027) (syntmp-extend-env-96 syntmp-names-1041 (let ((syntmp-trans-r-1049 (syntmp-macros-only-env-98 syntmp-r-1025))) (map (lambda (syntmp-x-1050) (cons (quote macro) (syntmp-eval-local-transformer-145 (syntmp-chi-138 syntmp-x-1050 syntmp-trans-r-1049 syntmp-w-1026)))) syntmp-val-1038)) syntmp-r-1025) syntmp-w-1026)))) syntmp-tmp-1029) ((lambda (syntmp-_-1052) (syntax-error (syntmp-source-wrap-131 syntmp-e-1024 syntmp-w-1026 syntmp-s-1027))) syntmp-tmp-1028))) (syntax-dispatch syntmp-tmp-1028 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1024))) (syntmp-global-extend-100 (quote core) (quote quote) (lambda (syntmp-e-1053 syntmp-r-1054 syntmp-w-1055 syntmp-s-1056) ((lambda (syntmp-tmp-1057) ((lambda (syntmp-tmp-1058) (if syntmp-tmp-1058 (apply (lambda (syntmp-_-1059 syntmp-e-1060) (syntmp-build-data-82 syntmp-s-1056 (syntmp-strip-149 syntmp-e-1060 syntmp-w-1055))) syntmp-tmp-1058) ((lambda (syntmp-_-1061) (syntax-error (syntmp-source-wrap-131 syntmp-e-1053 syntmp-w-1055 syntmp-s-1056))) syntmp-tmp-1057))) (syntax-dispatch syntmp-tmp-1057 (quote (any any))))) syntmp-e-1053))) (syntmp-global-extend-100 (quote core) (quote syntax) (letrec ((syntmp-regen-1069 (lambda (syntmp-x-1070) (let ((syntmp-t-1071 (car syntmp-x-1070))) (if (memv syntmp-t-1071 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1070)) (if (memv syntmp-t-1071 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1070) (syntmp-regen-1069 (caddr syntmp-x-1070)))) (if (memv syntmp-t-1071 (quote (map))) (let ((syntmp-ls-1072 (map syntmp-regen-1069 (cdr syntmp-x-1070)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1072) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1072))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1070)) (map syntmp-regen-1069 (cdr syntmp-x-1070)))))))))))) (syntmp-gen-vector-1068 (lambda (syntmp-x-1073) (cond ((eq? (car syntmp-x-1073) (quote list)) (cons (quote vector) (cdr syntmp-x-1073))) ((eq? (car syntmp-x-1073) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1073)))) (else (list (quote list->vector) syntmp-x-1073))))) (syntmp-gen-append-1067 (lambda (syntmp-x-1074 syntmp-y-1075) (if (equal? syntmp-y-1075 (quote (quote ()))) syntmp-x-1074 (list (quote append) syntmp-x-1074 syntmp-y-1075)))) (syntmp-gen-cons-1066 (lambda (syntmp-x-1076 syntmp-y-1077) (let ((syntmp-t-1078 (car syntmp-y-1077))) (if (memv syntmp-t-1078 (quote (quote))) (if (eq? (car syntmp-x-1076) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1076) (cadr syntmp-y-1077))) (if (eq? (cadr syntmp-y-1077) (quote ())) (list (quote list) syntmp-x-1076) (list (quote cons) syntmp-x-1076 syntmp-y-1077))) (if (memv syntmp-t-1078 (quote (list))) (cons (quote list) (cons syntmp-x-1076 (cdr syntmp-y-1077))) (list (quote cons) syntmp-x-1076 syntmp-y-1077)))))) (syntmp-gen-map-1065 (lambda (syntmp-e-1079 syntmp-map-env-1080) (let ((syntmp-formals-1081 (map cdr syntmp-map-env-1080)) (syntmp-actuals-1082 (map (lambda (syntmp-x-1083) (list (quote ref) (car syntmp-x-1083))) syntmp-map-env-1080))) (cond ((eq? (car syntmp-e-1079) (quote ref)) (car syntmp-actuals-1082)) ((andmap (lambda (syntmp-x-1084) (and (eq? (car syntmp-x-1084) (quote ref)) (memq (cadr syntmp-x-1084) syntmp-formals-1081))) (cdr syntmp-e-1079)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1079)) (map (let ((syntmp-r-1085 (map cons syntmp-formals-1081 syntmp-actuals-1082))) (lambda (syntmp-x-1086) (cdr (assq (cadr syntmp-x-1086) syntmp-r-1085)))) (cdr syntmp-e-1079))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1081 syntmp-e-1079) syntmp-actuals-1082))))))) (syntmp-gen-mappend-1064 (lambda (syntmp-e-1087 syntmp-map-env-1088) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1065 syntmp-e-1087 syntmp-map-env-1088)))) (syntmp-gen-ref-1063 (lambda (syntmp-src-1089 syntmp-var-1090 syntmp-level-1091 syntmp-maps-1092) (if (syntmp-fx=-74 syntmp-level-1091 0) (values syntmp-var-1090 syntmp-maps-1092) (if (null? syntmp-maps-1092) (syntax-error syntmp-src-1089 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1063 syntmp-src-1089 syntmp-var-1090 (syntmp-fx--73 syntmp-level-1091 1) (cdr syntmp-maps-1092))) (lambda (syntmp-outer-var-1093 syntmp-outer-maps-1094) (let ((syntmp-b-1095 (assq syntmp-outer-var-1093 (car syntmp-maps-1092)))) (if syntmp-b-1095 (values (cdr syntmp-b-1095) syntmp-maps-1092) (let ((syntmp-inner-var-1096 (syntmp-gen-var-150 (quote tmp)))) (values syntmp-inner-var-1096 (cons (cons (cons syntmp-outer-var-1093 syntmp-inner-var-1096) (car syntmp-maps-1092)) syntmp-outer-maps-1094))))))))))) (syntmp-gen-syntax-1062 (lambda (syntmp-src-1097 syntmp-e-1098 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101) (if (syntmp-id?-102 syntmp-e-1098) (let ((syntmp-label-1102 (syntmp-id-var-name-124 syntmp-e-1098 (quote (()))))) (let ((syntmp-b-1103 (syntmp-lookup-99 syntmp-label-1102 syntmp-r-1099))) (if (eq? (syntmp-binding-type-94 syntmp-b-1103) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1104 (syntmp-binding-value-95 syntmp-b-1103))) (syntmp-gen-ref-1063 syntmp-src-1097 (car syntmp-var.lev-1104) (cdr syntmp-var.lev-1104) syntmp-maps-1100))) (lambda (syntmp-var-1105 syntmp-maps-1106) (values (list (quote ref) syntmp-var-1105) syntmp-maps-1106))) (if (syntmp-ellipsis?-1101 syntmp-e-1098) (syntax-error syntmp-src-1097 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1098) syntmp-maps-1100))))) ((lambda (syntmp-tmp-1107) ((lambda (syntmp-tmp-1108) (if (if syntmp-tmp-1108 (apply (lambda (syntmp-dots-1109 syntmp-e-1110) (syntmp-ellipsis?-1101 syntmp-dots-1109)) syntmp-tmp-1108) #f) (apply (lambda (syntmp-dots-1111 syntmp-e-1112) (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-e-1112 syntmp-r-1099 syntmp-maps-1100 (lambda (syntmp-x-1113) #f))) syntmp-tmp-1108) ((lambda (syntmp-tmp-1114) (if (if syntmp-tmp-1114 (apply (lambda (syntmp-x-1115 syntmp-dots-1116 syntmp-y-1117) (syntmp-ellipsis?-1101 syntmp-dots-1116)) syntmp-tmp-1114) #f) (apply (lambda (syntmp-x-1118 syntmp-dots-1119 syntmp-y-1120) (let syntmp-f-1121 ((syntmp-y-1122 syntmp-y-1120) (syntmp-k-1123 (lambda (syntmp-maps-1124) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-x-1118 syntmp-r-1099 (cons (quote ()) syntmp-maps-1124) syntmp-ellipsis?-1101)) (lambda (syntmp-x-1125 syntmp-maps-1126) (if (null? (car syntmp-maps-1126)) (syntax-error syntmp-src-1097 "extra ellipsis in syntax form") (values (syntmp-gen-map-1065 syntmp-x-1125 (car syntmp-maps-1126)) (cdr syntmp-maps-1126)))))))) ((lambda (syntmp-tmp-1127) ((lambda (syntmp-tmp-1128) (if (if syntmp-tmp-1128 (apply (lambda (syntmp-dots-1129 syntmp-y-1130) (syntmp-ellipsis?-1101 syntmp-dots-1129)) syntmp-tmp-1128) #f) (apply (lambda (syntmp-dots-1131 syntmp-y-1132) (syntmp-f-1121 syntmp-y-1132 (lambda (syntmp-maps-1133) (call-with-values (lambda () (syntmp-k-1123 (cons (quote ()) syntmp-maps-1133))) (lambda (syntmp-x-1134 syntmp-maps-1135) (if (null? (car syntmp-maps-1135)) (syntax-error syntmp-src-1097 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1064 syntmp-x-1134 (car syntmp-maps-1135)) (cdr syntmp-maps-1135)))))))) syntmp-tmp-1128) ((lambda (syntmp-_-1136) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-y-1122 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-y-1137 syntmp-maps-1138) (call-with-values (lambda () (syntmp-k-1123 syntmp-maps-1138)) (lambda (syntmp-x-1139 syntmp-maps-1140) (values (syntmp-gen-append-1067 syntmp-x-1139 syntmp-y-1137) syntmp-maps-1140)))))) syntmp-tmp-1127))) (syntax-dispatch syntmp-tmp-1127 (quote (any . any))))) syntmp-y-1122))) syntmp-tmp-1114) ((lambda (syntmp-tmp-1141) (if syntmp-tmp-1141 (apply (lambda (syntmp-x-1142 syntmp-y-1143) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-x-1142 syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-x-1144 syntmp-maps-1145) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 syntmp-y-1143 syntmp-r-1099 syntmp-maps-1145 syntmp-ellipsis?-1101)) (lambda (syntmp-y-1146 syntmp-maps-1147) (values (syntmp-gen-cons-1066 syntmp-x-1144 syntmp-y-1146) syntmp-maps-1147)))))) syntmp-tmp-1141) ((lambda (syntmp-tmp-1148) (if syntmp-tmp-1148 (apply (lambda (syntmp-e1-1149 syntmp-e2-1150) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-src-1097 (cons syntmp-e1-1149 syntmp-e2-1150) syntmp-r-1099 syntmp-maps-1100 syntmp-ellipsis?-1101)) (lambda (syntmp-e-1152 syntmp-maps-1153) (values (syntmp-gen-vector-1068 syntmp-e-1152) syntmp-maps-1153)))) syntmp-tmp-1148) ((lambda (syntmp-_-1154) (values (list (quote quote) syntmp-e-1098) syntmp-maps-1100)) syntmp-tmp-1107))) (syntax-dispatch syntmp-tmp-1107 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1107 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1107 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1107 (quote (any any))))) syntmp-e-1098))))) (lambda (syntmp-e-1155 syntmp-r-1156 syntmp-w-1157 syntmp-s-1158) (let ((syntmp-e-1159 (syntmp-source-wrap-131 syntmp-e-1155 syntmp-w-1157 syntmp-s-1158))) ((lambda (syntmp-tmp-1160) ((lambda (syntmp-tmp-1161) (if syntmp-tmp-1161 (apply (lambda (syntmp-_-1162 syntmp-x-1163) (call-with-values (lambda () (syntmp-gen-syntax-1062 syntmp-e-1159 syntmp-x-1163 syntmp-r-1156 (quote ()) syntmp-ellipsis?-147)) (lambda (syntmp-e-1164 syntmp-maps-1165) (syntmp-regen-1069 syntmp-e-1164)))) syntmp-tmp-1161) ((lambda (syntmp-_-1166) (syntax-error syntmp-e-1159)) syntmp-tmp-1160))) (syntax-dispatch syntmp-tmp-1160 (quote (any any))))) syntmp-e-1159))))) (syntmp-global-extend-100 (quote core) (quote lambda) (lambda (syntmp-e-1167 syntmp-r-1168 syntmp-w-1169 syntmp-s-1170) ((lambda (syntmp-tmp-1171) ((lambda (syntmp-tmp-1172) (if syntmp-tmp-1172 (apply (lambda (syntmp-_-1173 syntmp-c-1174) (syntmp-chi-lambda-clause-143 (syntmp-source-wrap-131 syntmp-e-1167 syntmp-w-1169 syntmp-s-1170) syntmp-c-1174 syntmp-r-1168 syntmp-w-1169 (lambda (syntmp-vars-1175 syntmp-body-1176) (syntmp-build-annotated-81 syntmp-s-1170 (list (quote lambda) syntmp-vars-1175 syntmp-body-1176))))) syntmp-tmp-1172) (syntax-error syntmp-tmp-1171))) (syntax-dispatch syntmp-tmp-1171 (quote (any . any))))) syntmp-e-1167))) (syntmp-global-extend-100 (quote core) (quote let) (letrec ((syntmp-chi-let-1177 (lambda (syntmp-e-1178 syntmp-r-1179 syntmp-w-1180 syntmp-s-1181 syntmp-constructor-1182 syntmp-ids-1183 syntmp-vals-1184 syntmp-exps-1185) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-1183)) (syntax-error syntmp-e-1178 "duplicate bound variable in") (let ((syntmp-labels-1186 (syntmp-gen-labels-108 syntmp-ids-1183)) (syntmp-new-vars-1187 (map syntmp-gen-var-150 syntmp-ids-1183))) (let ((syntmp-nw-1188 (syntmp-make-binding-wrap-119 syntmp-ids-1183 syntmp-labels-1186 syntmp-w-1180)) (syntmp-nr-1189 (syntmp-extend-var-env-97 syntmp-labels-1186 syntmp-new-vars-1187 syntmp-r-1179))) (syntmp-constructor-1182 syntmp-s-1181 syntmp-new-vars-1187 (map (lambda (syntmp-x-1190) (syntmp-chi-138 syntmp-x-1190 syntmp-r-1179 syntmp-w-1180)) syntmp-vals-1184) (syntmp-chi-body-142 syntmp-exps-1185 (syntmp-source-wrap-131 syntmp-e-1178 syntmp-nw-1188 syntmp-s-1181) syntmp-nr-1189 syntmp-nw-1188)))))))) (lambda (syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194) ((lambda (syntmp-tmp-1195) ((lambda (syntmp-tmp-1196) (if syntmp-tmp-1196 (apply (lambda (syntmp-_-1197 syntmp-id-1198 syntmp-val-1199 syntmp-e1-1200 syntmp-e2-1201) (syntmp-chi-let-1177 syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194 syntmp-build-let-84 syntmp-id-1198 syntmp-val-1199 (cons syntmp-e1-1200 syntmp-e2-1201))) syntmp-tmp-1196) ((lambda (syntmp-tmp-1205) (if (if syntmp-tmp-1205 (apply (lambda (syntmp-_-1206 syntmp-f-1207 syntmp-id-1208 syntmp-val-1209 syntmp-e1-1210 syntmp-e2-1211) (syntmp-id?-102 syntmp-f-1207)) syntmp-tmp-1205) #f) (apply (lambda (syntmp-_-1212 syntmp-f-1213 syntmp-id-1214 syntmp-val-1215 syntmp-e1-1216 syntmp-e2-1217) (syntmp-chi-let-1177 syntmp-e-1191 syntmp-r-1192 syntmp-w-1193 syntmp-s-1194 syntmp-build-named-let-85 (cons syntmp-f-1213 syntmp-id-1214) syntmp-val-1215 (cons syntmp-e1-1216 syntmp-e2-1217))) syntmp-tmp-1205) ((lambda (syntmp-_-1221) (syntax-error (syntmp-source-wrap-131 syntmp-e-1191 syntmp-w-1193 syntmp-s-1194))) syntmp-tmp-1195))) (syntax-dispatch syntmp-tmp-1195 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1195 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1191)))) (syntmp-global-extend-100 (quote core) (quote letrec) (lambda (syntmp-e-1222 syntmp-r-1223 syntmp-w-1224 syntmp-s-1225) ((lambda (syntmp-tmp-1226) ((lambda (syntmp-tmp-1227) (if syntmp-tmp-1227 (apply (lambda (syntmp-_-1228 syntmp-id-1229 syntmp-val-1230 syntmp-e1-1231 syntmp-e2-1232) (let ((syntmp-ids-1233 syntmp-id-1229)) (if (not (syntmp-valid-bound-ids?-127 syntmp-ids-1233)) (syntax-error syntmp-e-1222 "duplicate bound variable in") (let ((syntmp-labels-1235 (syntmp-gen-labels-108 syntmp-ids-1233)) (syntmp-new-vars-1236 (map syntmp-gen-var-150 syntmp-ids-1233))) (let ((syntmp-w-1237 (syntmp-make-binding-wrap-119 syntmp-ids-1233 syntmp-labels-1235 syntmp-w-1224)) (syntmp-r-1238 (syntmp-extend-var-env-97 syntmp-labels-1235 syntmp-new-vars-1236 syntmp-r-1223))) (syntmp-build-letrec-86 syntmp-s-1225 syntmp-new-vars-1236 (map (lambda (syntmp-x-1239) (syntmp-chi-138 syntmp-x-1239 syntmp-r-1238 syntmp-w-1237)) syntmp-val-1230) (syntmp-chi-body-142 (cons syntmp-e1-1231 syntmp-e2-1232) (syntmp-source-wrap-131 syntmp-e-1222 syntmp-w-1237 syntmp-s-1225) syntmp-r-1238 syntmp-w-1237))))))) syntmp-tmp-1227) ((lambda (syntmp-_-1242) (syntax-error (syntmp-source-wrap-131 syntmp-e-1222 syntmp-w-1224 syntmp-s-1225))) syntmp-tmp-1226))) (syntax-dispatch syntmp-tmp-1226 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1222))) (syntmp-global-extend-100 (quote core) (quote set!) (lambda (syntmp-e-1243 syntmp-r-1244 syntmp-w-1245 syntmp-s-1246) ((lambda (syntmp-tmp-1247) ((lambda (syntmp-tmp-1248) (if (if syntmp-tmp-1248 (apply (lambda (syntmp-_-1249 syntmp-id-1250 syntmp-val-1251) (syntmp-id?-102 syntmp-id-1250)) syntmp-tmp-1248) #f) (apply (lambda (syntmp-_-1252 syntmp-id-1253 syntmp-val-1254) (let ((syntmp-val-1255 (syntmp-chi-138 syntmp-val-1254 syntmp-r-1244 syntmp-w-1245)) (syntmp-n-1256 (syntmp-id-var-name-124 syntmp-id-1253 syntmp-w-1245))) (let ((syntmp-b-1257 (syntmp-lookup-99 syntmp-n-1256 syntmp-r-1244))) (let ((syntmp-t-1258 (syntmp-binding-type-94 syntmp-b-1257))) (if (memv syntmp-t-1258 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1246 (list (quote set!) (syntmp-binding-value-95 syntmp-b-1257) syntmp-val-1255)) (if (memv syntmp-t-1258 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1246 (list (quote set!) syntmp-n-1256 syntmp-val-1255)) (if (memv syntmp-t-1258 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-130 syntmp-id-1253 syntmp-w-1245) "identifier out of context") (syntax-error (syntmp-source-wrap-131 syntmp-e-1243 syntmp-w-1245 syntmp-s-1246))))))))) syntmp-tmp-1248) ((lambda (syntmp-tmp-1259) (if syntmp-tmp-1259 (apply (lambda (syntmp-_-1260 syntmp-getter-1261 syntmp-arg-1262 syntmp-val-1263) (syntmp-build-annotated-81 syntmp-s-1246 (cons (syntmp-chi-138 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-getter-1261) syntmp-r-1244 syntmp-w-1245) (map (lambda (syntmp-e-1264) (syntmp-chi-138 syntmp-e-1264 syntmp-r-1244 syntmp-w-1245)) (append syntmp-arg-1262 (list syntmp-val-1263)))))) syntmp-tmp-1259) ((lambda (syntmp-_-1266) (syntax-error (syntmp-source-wrap-131 syntmp-e-1243 syntmp-w-1245 syntmp-s-1246))) syntmp-tmp-1247))) (syntax-dispatch syntmp-tmp-1247 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1247 (quote (any any any))))) syntmp-e-1243))) (syntmp-global-extend-100 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-100 (quote define) (quote define) (quote ())) (syntmp-global-extend-100 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-100 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-100 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1270 (lambda (syntmp-x-1271 syntmp-keys-1272 syntmp-clauses-1273 syntmp-r-1274) (if (null? syntmp-clauses-1273) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1271)) ((lambda (syntmp-tmp-1275) ((lambda (syntmp-tmp-1276) (if syntmp-tmp-1276 (apply (lambda (syntmp-pat-1277 syntmp-exp-1278) (if (and (syntmp-id?-102 syntmp-pat-1277) (andmap (lambda (syntmp-x-1279) (not (syntmp-free-id=?-125 syntmp-pat-1277 syntmp-x-1279))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-keys-1272))) (let ((syntmp-labels-1280 (list (syntmp-gen-label-107))) (syntmp-var-1281 (syntmp-gen-var-150 syntmp-pat-1277))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1281) (syntmp-chi-138 syntmp-exp-1278 (syntmp-extend-env-96 syntmp-labels-1280 (list (cons (quote syntax) (cons syntmp-var-1281 0))) syntmp-r-1274) (syntmp-make-binding-wrap-119 (list syntmp-pat-1277) syntmp-labels-1280 (quote (())))))) syntmp-x-1271))) (syntmp-gen-clause-1269 syntmp-x-1271 syntmp-keys-1272 (cdr syntmp-clauses-1273) syntmp-r-1274 syntmp-pat-1277 #t syntmp-exp-1278))) syntmp-tmp-1276) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-pat-1283 syntmp-fender-1284 syntmp-exp-1285) (syntmp-gen-clause-1269 syntmp-x-1271 syntmp-keys-1272 (cdr syntmp-clauses-1273) syntmp-r-1274 syntmp-pat-1283 syntmp-fender-1284 syntmp-exp-1285)) syntmp-tmp-1282) ((lambda (syntmp-_-1286) (syntax-error (car syntmp-clauses-1273) "invalid syntax-case clause")) syntmp-tmp-1275))) (syntax-dispatch syntmp-tmp-1275 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1275 (quote (any any))))) (car syntmp-clauses-1273))))) (syntmp-gen-clause-1269 (lambda (syntmp-x-1287 syntmp-keys-1288 syntmp-clauses-1289 syntmp-r-1290 syntmp-pat-1291 syntmp-fender-1292 syntmp-exp-1293) (call-with-values (lambda () (syntmp-convert-pattern-1267 syntmp-pat-1291 syntmp-keys-1288)) (lambda (syntmp-p-1294 syntmp-pvars-1295) (cond ((not (syntmp-distinct-bound-ids?-128 (map car syntmp-pvars-1295))) (syntax-error syntmp-pat-1291 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1296) (not (syntmp-ellipsis?-147 (car syntmp-x-1296)))) syntmp-pvars-1295)) (syntax-error syntmp-pat-1291 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1297 (syntmp-gen-var-150 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1297) (let ((syntmp-y-1298 (syntmp-build-annotated-81 #f syntmp-y-1297))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1299) ((lambda (syntmp-tmp-1300) (if syntmp-tmp-1300 (apply (lambda () syntmp-y-1298) syntmp-tmp-1300) ((lambda (syntmp-_-1301) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1298 (syntmp-build-dispatch-call-1268 syntmp-pvars-1295 syntmp-fender-1292 syntmp-y-1298 syntmp-r-1290) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1299))) (syntax-dispatch syntmp-tmp-1299 (quote #(atom #t))))) syntmp-fender-1292) (syntmp-build-dispatch-call-1268 syntmp-pvars-1295 syntmp-exp-1293 syntmp-y-1298 syntmp-r-1290) (syntmp-gen-syntax-case-1270 syntmp-x-1287 syntmp-keys-1288 syntmp-clauses-1289 syntmp-r-1290)))))) (if (eq? syntmp-p-1294 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1287)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1287 (syntmp-build-data-82 #f syntmp-p-1294))))))))))))) (syntmp-build-dispatch-call-1268 (lambda (syntmp-pvars-1302 syntmp-exp-1303 syntmp-y-1304 syntmp-r-1305) (let ((syntmp-ids-1306 (map car syntmp-pvars-1302)) (syntmp-levels-1307 (map cdr syntmp-pvars-1302))) (let ((syntmp-labels-1308 (syntmp-gen-labels-108 syntmp-ids-1306)) (syntmp-new-vars-1309 (map syntmp-gen-var-150 syntmp-ids-1306))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1309 (syntmp-chi-138 syntmp-exp-1303 (syntmp-extend-env-96 syntmp-labels-1308 (map (lambda (syntmp-var-1310 syntmp-level-1311) (cons (quote syntax) (cons syntmp-var-1310 syntmp-level-1311))) syntmp-new-vars-1309 (map cdr syntmp-pvars-1302)) syntmp-r-1305) (syntmp-make-binding-wrap-119 syntmp-ids-1306 syntmp-labels-1308 (quote (())))))) syntmp-y-1304)))))) (syntmp-convert-pattern-1267 (lambda (syntmp-pattern-1312 syntmp-keys-1313) (let syntmp-cvt-1314 ((syntmp-p-1315 syntmp-pattern-1312) (syntmp-n-1316 0) (syntmp-ids-1317 (quote ()))) (if (syntmp-id?-102 syntmp-p-1315) (if (syntmp-bound-id-member?-129 syntmp-p-1315 syntmp-keys-1313) (values (vector (quote free-id) syntmp-p-1315) syntmp-ids-1317) (values (quote any) (cons (cons syntmp-p-1315 syntmp-n-1316) syntmp-ids-1317))) ((lambda (syntmp-tmp-1318) ((lambda (syntmp-tmp-1319) (if (if syntmp-tmp-1319 (apply (lambda (syntmp-x-1320 syntmp-dots-1321) (syntmp-ellipsis?-147 syntmp-dots-1321)) syntmp-tmp-1319) #f) (apply (lambda (syntmp-x-1322 syntmp-dots-1323) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1322 (syntmp-fx+-72 syntmp-n-1316 1) syntmp-ids-1317)) (lambda (syntmp-p-1324 syntmp-ids-1325) (values (if (eq? syntmp-p-1324 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1324)) syntmp-ids-1325)))) syntmp-tmp-1319) ((lambda (syntmp-tmp-1326) (if syntmp-tmp-1326 (apply (lambda (syntmp-x-1327 syntmp-y-1328) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-y-1328 syntmp-n-1316 syntmp-ids-1317)) (lambda (syntmp-y-1329 syntmp-ids-1330) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1327 syntmp-n-1316 syntmp-ids-1330)) (lambda (syntmp-x-1331 syntmp-ids-1332) (values (cons syntmp-x-1331 syntmp-y-1329) syntmp-ids-1332)))))) syntmp-tmp-1326) ((lambda (syntmp-tmp-1333) (if syntmp-tmp-1333 (apply (lambda () (values (quote ()) syntmp-ids-1317)) syntmp-tmp-1333) ((lambda (syntmp-tmp-1334) (if syntmp-tmp-1334 (apply (lambda (syntmp-x-1335) (call-with-values (lambda () (syntmp-cvt-1314 syntmp-x-1335 syntmp-n-1316 syntmp-ids-1317)) (lambda (syntmp-p-1337 syntmp-ids-1338) (values (vector (quote vector) syntmp-p-1337) syntmp-ids-1338)))) syntmp-tmp-1334) ((lambda (syntmp-x-1339) (values (vector (quote atom) (syntmp-strip-149 syntmp-p-1315 (quote (())))) syntmp-ids-1317)) syntmp-tmp-1318))) (syntax-dispatch syntmp-tmp-1318 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1318 (quote ()))))) (syntax-dispatch syntmp-tmp-1318 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1318 (quote (any any))))) syntmp-p-1315)))))) (lambda (syntmp-e-1340 syntmp-r-1341 syntmp-w-1342 syntmp-s-1343) (let ((syntmp-e-1344 (syntmp-source-wrap-131 syntmp-e-1340 syntmp-w-1342 syntmp-s-1343))) ((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if syntmp-tmp-1346 (apply (lambda (syntmp-_-1347 syntmp-val-1348 syntmp-key-1349 syntmp-m-1350) (if (andmap (lambda (syntmp-x-1351) (and (syntmp-id?-102 syntmp-x-1351) (not (syntmp-ellipsis?-147 syntmp-x-1351)))) syntmp-key-1349) (let ((syntmp-x-1353 (syntmp-gen-var-150 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1343 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1353) (syntmp-gen-syntax-case-1270 (syntmp-build-annotated-81 #f syntmp-x-1353) syntmp-key-1349 syntmp-m-1350 syntmp-r-1341))) (syntmp-chi-138 syntmp-val-1348 syntmp-r-1341 (quote (())))))) (syntax-error syntmp-e-1344 "invalid literals list in"))) syntmp-tmp-1346) (syntax-error syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any any each-any . each-any))))) syntmp-e-1344))))) (set! sc-expand (let ((syntmp-m-1356 (quote e)) (syntmp-esew-1357 (quote (eval)))) (lambda (syntmp-x-1358) (if (and (pair? syntmp-x-1358) (equal? (car syntmp-x-1358) syntmp-noexpand-71)) (cadr syntmp-x-1358) (syntmp-chi-top-137 syntmp-x-1358 (quote ()) (quote ((top))) syntmp-m-1356 syntmp-esew-1357))))) (set! sc-expand3 (let ((syntmp-m-1359 (quote e)) (syntmp-esew-1360 (quote (eval)))) (lambda (syntmp-x-1362 . syntmp-rest-1361) (if (and (pair? syntmp-x-1362) (equal? (car syntmp-x-1362) syntmp-noexpand-71)) (cadr syntmp-x-1362) (syntmp-chi-top-137 syntmp-x-1362 (quote ()) (quote ((top))) (if (null? syntmp-rest-1361) syntmp-m-1359 (car syntmp-rest-1361)) (if (or (null? syntmp-rest-1361) (null? (cdr syntmp-rest-1361))) syntmp-esew-1360 (cadr syntmp-rest-1361))))))) (set! identifier? (lambda (syntmp-x-1363) (syntmp-nonsymbol-id?-101 syntmp-x-1363))) (set! datum->syntax-object (lambda (syntmp-id-1364 syntmp-datum-1365) (syntmp-make-syntax-object-87 syntmp-datum-1365 (syntmp-syntax-object-wrap-90 syntmp-id-1364)))) (set! syntax-object->datum (lambda (syntmp-x-1366) (syntmp-strip-149 syntmp-x-1366 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1367) (begin (let ((syntmp-x-1368 syntmp-ls-1367)) (if (not (list? syntmp-x-1368)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1368))) (map (lambda (syntmp-x-1369) (syntmp-wrap-130 (gensym) (quote ((top))))) syntmp-ls-1367)))) (set! free-identifier=? (lambda (syntmp-x-1370 syntmp-y-1371) (begin (let ((syntmp-x-1372 syntmp-x-1370)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1372)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1372))) (let ((syntmp-x-1373 syntmp-y-1371)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1373)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1373))) (syntmp-free-id=?-125 syntmp-x-1370 syntmp-y-1371)))) (set! bound-identifier=? (lambda (syntmp-x-1374 syntmp-y-1375) (begin (let ((syntmp-x-1376 syntmp-x-1374)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1376)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1376))) (let ((syntmp-x-1377 syntmp-y-1375)) (if (not (syntmp-nonsymbol-id?-101 syntmp-x-1377)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1377))) (syntmp-bound-id=?-126 syntmp-x-1374 syntmp-y-1375)))) (set! syntax-error (lambda (syntmp-object-1379 . syntmp-messages-1378) (begin (for-each (lambda (syntmp-x-1380) (let ((syntmp-x-1381 syntmp-x-1380)) (if (not (string? syntmp-x-1381)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1381)))) syntmp-messages-1378) (let ((syntmp-message-1382 (if (null? syntmp-messages-1378) "invalid syntax" (apply string-append syntmp-messages-1378)))) (syntmp-error-hook-78 #f syntmp-message-1382 (syntmp-strip-149 syntmp-object-1379 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1383 syntmp-v-1384) (begin (let ((syntmp-x-1385 syntmp-sym-1383)) (if (not (symbol? syntmp-x-1385)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1385))) (let ((syntmp-x-1386 syntmp-v-1384)) (if (not (procedure? syntmp-x-1386)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1386))) (syntmp-global-extend-100 (quote macro) syntmp-sym-1383 syntmp-v-1384)))) (letrec ((syntmp-match-1391 (lambda (syntmp-e-1392 syntmp-p-1393 syntmp-w-1394 syntmp-r-1395) (cond ((not syntmp-r-1395) #f) ((eq? syntmp-p-1393 (quote any)) (cons (syntmp-wrap-130 syntmp-e-1392 syntmp-w-1394) syntmp-r-1395)) ((syntmp-syntax-object?-88 syntmp-e-1392) (syntmp-match*-1390 (let ((syntmp-e-1396 (syntmp-syntax-object-expression-89 syntmp-e-1392))) (if (annotation? syntmp-e-1396) (annotation-expression syntmp-e-1396) syntmp-e-1396)) syntmp-p-1393 (syntmp-join-wraps-121 syntmp-w-1394 (syntmp-syntax-object-wrap-90 syntmp-e-1392)) syntmp-r-1395)) (else (syntmp-match*-1390 (let ((syntmp-e-1397 syntmp-e-1392)) (if (annotation? syntmp-e-1397) (annotation-expression syntmp-e-1397) syntmp-e-1397)) syntmp-p-1393 syntmp-w-1394 syntmp-r-1395))))) (syntmp-match*-1390 (lambda (syntmp-e-1398 syntmp-p-1399 syntmp-w-1400 syntmp-r-1401) (cond ((null? syntmp-p-1399) (and (null? syntmp-e-1398) syntmp-r-1401)) ((pair? syntmp-p-1399) (and (pair? syntmp-e-1398) (syntmp-match-1391 (car syntmp-e-1398) (car syntmp-p-1399) syntmp-w-1400 (syntmp-match-1391 (cdr syntmp-e-1398) (cdr syntmp-p-1399) syntmp-w-1400 syntmp-r-1401)))) ((eq? syntmp-p-1399 (quote each-any)) (let ((syntmp-l-1402 (syntmp-match-each-any-1388 syntmp-e-1398 syntmp-w-1400))) (and syntmp-l-1402 (cons syntmp-l-1402 syntmp-r-1401)))) (else (let ((syntmp-t-1403 (vector-ref syntmp-p-1399 0))) (if (memv syntmp-t-1403 (quote (each))) (if (null? syntmp-e-1398) (syntmp-match-empty-1389 (vector-ref syntmp-p-1399 1) syntmp-r-1401) (let ((syntmp-l-1404 (syntmp-match-each-1387 syntmp-e-1398 (vector-ref syntmp-p-1399 1) syntmp-w-1400))) (and syntmp-l-1404 (let syntmp-collect-1405 ((syntmp-l-1406 syntmp-l-1404)) (if (null? (car syntmp-l-1406)) syntmp-r-1401 (cons (map car syntmp-l-1406) (syntmp-collect-1405 (map cdr syntmp-l-1406)))))))) (if (memv syntmp-t-1403 (quote (free-id))) (and (syntmp-id?-102 syntmp-e-1398) (syntmp-free-id=?-125 (syntmp-wrap-130 syntmp-e-1398 syntmp-w-1400) (vector-ref syntmp-p-1399 1)) syntmp-r-1401) (if (memv syntmp-t-1403 (quote (atom))) (and (equal? (vector-ref syntmp-p-1399 1) (syntmp-strip-149 syntmp-e-1398 syntmp-w-1400)) syntmp-r-1401) (if (memv syntmp-t-1403 (quote (vector))) (and (vector? syntmp-e-1398) (syntmp-match-1391 (vector->list syntmp-e-1398) (vector-ref syntmp-p-1399 1) syntmp-w-1400 syntmp-r-1401))))))))))) (syntmp-match-empty-1389 (lambda (syntmp-p-1407 syntmp-r-1408) (cond ((null? syntmp-p-1407) syntmp-r-1408) ((eq? syntmp-p-1407 (quote any)) (cons (quote ()) syntmp-r-1408)) ((pair? syntmp-p-1407) (syntmp-match-empty-1389 (car syntmp-p-1407) (syntmp-match-empty-1389 (cdr syntmp-p-1407) syntmp-r-1408))) ((eq? syntmp-p-1407 (quote each-any)) (cons (quote ()) syntmp-r-1408)) (else (let ((syntmp-t-1409 (vector-ref syntmp-p-1407 0))) (if (memv syntmp-t-1409 (quote (each))) (syntmp-match-empty-1389 (vector-ref syntmp-p-1407 1) syntmp-r-1408) (if (memv syntmp-t-1409 (quote (free-id atom))) syntmp-r-1408 (if (memv syntmp-t-1409 (quote (vector))) (syntmp-match-empty-1389 (vector-ref syntmp-p-1407 1) syntmp-r-1408))))))))) (syntmp-match-each-any-1388 (lambda (syntmp-e-1410 syntmp-w-1411) (cond ((annotation? syntmp-e-1410) (syntmp-match-each-any-1388 (annotation-expression syntmp-e-1410) syntmp-w-1411)) ((pair? syntmp-e-1410) (let ((syntmp-l-1412 (syntmp-match-each-any-1388 (cdr syntmp-e-1410) syntmp-w-1411))) (and syntmp-l-1412 (cons (syntmp-wrap-130 (car syntmp-e-1410) syntmp-w-1411) syntmp-l-1412)))) ((null? syntmp-e-1410) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1410) (syntmp-match-each-any-1388 (syntmp-syntax-object-expression-89 syntmp-e-1410) (syntmp-join-wraps-121 syntmp-w-1411 (syntmp-syntax-object-wrap-90 syntmp-e-1410)))) (else #f)))) (syntmp-match-each-1387 (lambda (syntmp-e-1413 syntmp-p-1414 syntmp-w-1415) (cond ((annotation? syntmp-e-1413) (syntmp-match-each-1387 (annotation-expression syntmp-e-1413) syntmp-p-1414 syntmp-w-1415)) ((pair? syntmp-e-1413) (let ((syntmp-first-1416 (syntmp-match-1391 (car syntmp-e-1413) syntmp-p-1414 syntmp-w-1415 (quote ())))) (and syntmp-first-1416 (let ((syntmp-rest-1417 (syntmp-match-each-1387 (cdr syntmp-e-1413) syntmp-p-1414 syntmp-w-1415))) (and syntmp-rest-1417 (cons syntmp-first-1416 syntmp-rest-1417)))))) ((null? syntmp-e-1413) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1413) (syntmp-match-each-1387 (syntmp-syntax-object-expression-89 syntmp-e-1413) syntmp-p-1414 (syntmp-join-wraps-121 syntmp-w-1415 (syntmp-syntax-object-wrap-90 syntmp-e-1413)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1418 syntmp-p-1419) (cond ((eq? syntmp-p-1419 (quote any)) (list syntmp-e-1418)) ((syntmp-syntax-object?-88 syntmp-e-1418) (syntmp-match*-1390 (let ((syntmp-e-1420 (syntmp-syntax-object-expression-89 syntmp-e-1418))) (if (annotation? syntmp-e-1420) (annotation-expression syntmp-e-1420) syntmp-e-1420)) syntmp-p-1419 (syntmp-syntax-object-wrap-90 syntmp-e-1418) (quote ()))) (else (syntmp-match*-1390 (let ((syntmp-e-1421 syntmp-e-1418)) (if (annotation? syntmp-e-1421) (annotation-expression syntmp-e-1421) syntmp-e-1421)) syntmp-p-1419 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-138)))))
-(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1422) ((lambda (syntmp-tmp-1423) ((lambda (syntmp-tmp-1424) (if syntmp-tmp-1424 (apply (lambda (syntmp-_-1425 syntmp-e1-1426 syntmp-e2-1427) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1426 syntmp-e2-1427))) syntmp-tmp-1424) ((lambda (syntmp-tmp-1429) (if syntmp-tmp-1429 (apply (lambda (syntmp-_-1430 syntmp-out-1431 syntmp-in-1432 syntmp-e1-1433 syntmp-e2-1434) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1432 (quote ()) (list syntmp-out-1431 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1433 syntmp-e2-1434))))) syntmp-tmp-1429) ((lambda (syntmp-tmp-1436) (if syntmp-tmp-1436 (apply (lambda (syntmp-_-1437 syntmp-out-1438 syntmp-in-1439 syntmp-e1-1440 syntmp-e2-1441) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1439) (quote ()) (list syntmp-out-1438 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1440 syntmp-e2-1441))))) syntmp-tmp-1436) (syntax-error syntmp-tmp-1423))) (syntax-dispatch syntmp-tmp-1423 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1423 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1423 (quote (any () any . each-any))))) syntmp-x-1422)))
-(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1463) ((lambda (syntmp-tmp-1464) ((lambda (syntmp-tmp-1465) (if syntmp-tmp-1465 (apply (lambda (syntmp-_-1466 syntmp-k-1467 syntmp-keyword-1468 syntmp-pattern-1469 syntmp-template-1470) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-k-1467 (map (lambda (syntmp-tmp-1473 syntmp-tmp-1472) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1472) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1473))) syntmp-template-1470 syntmp-pattern-1469)))))) syntmp-tmp-1465) (syntax-error syntmp-tmp-1464))) (syntax-dispatch syntmp-tmp-1464 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1463)))
-(install-global-transformer (quote let*) (lambda (syntmp-x-1484) ((lambda (syntmp-tmp-1485) ((lambda (syntmp-tmp-1486) (if (if syntmp-tmp-1486 (apply (lambda (syntmp-let*-1487 syntmp-x-1488 syntmp-v-1489 syntmp-e1-1490 syntmp-e2-1491) (andmap identifier? syntmp-x-1488)) syntmp-tmp-1486) #f) (apply (lambda (syntmp-let*-1493 syntmp-x-1494 syntmp-v-1495 syntmp-e1-1496 syntmp-e2-1497) (let syntmp-f-1498 ((syntmp-bindings-1499 (map list syntmp-x-1494 syntmp-v-1495))) (if (null? syntmp-bindings-1499) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons syntmp-e1-1496 syntmp-e2-1497))) ((lambda (syntmp-tmp-1503) ((lambda (syntmp-tmp-1504) (if syntmp-tmp-1504 (apply (lambda (syntmp-body-1505 syntmp-binding-1506) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list syntmp-binding-1506) syntmp-body-1505)) syntmp-tmp-1504) (syntax-error syntmp-tmp-1503))) (syntax-dispatch syntmp-tmp-1503 (quote (any any))))) (list (syntmp-f-1498 (cdr syntmp-bindings-1499)) (car syntmp-bindings-1499)))))) syntmp-tmp-1486) (syntax-error syntmp-tmp-1485))) (syntax-dispatch syntmp-tmp-1485 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1484)))
-(install-global-transformer (quote do) (lambda (syntmp-orig-x-1526) ((lambda (syntmp-tmp-1527) ((lambda (syntmp-tmp-1528) (if syntmp-tmp-1528 (apply (lambda (syntmp-_-1529 syntmp-var-1530 syntmp-init-1531 syntmp-step-1532 syntmp-e0-1533 syntmp-e1-1534 syntmp-c-1535) ((lambda (syntmp-tmp-1536) ((lambda (syntmp-tmp-1537) (if syntmp-tmp-1537 (apply (lambda (syntmp-step-1538) ((lambda (syntmp-tmp-1539) ((lambda (syntmp-tmp-1540) (if syntmp-tmp-1540 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1530 syntmp-init-1531) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1533) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1535 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1538))))))) syntmp-tmp-1540) ((lambda (syntmp-tmp-1545) (if syntmp-tmp-1545 (apply (lambda (syntmp-e1-1546 syntmp-e2-1547) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1530 syntmp-init-1531) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1533 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons syntmp-e1-1546 syntmp-e2-1547)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1535 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1538))))))) syntmp-tmp-1545) (syntax-error syntmp-tmp-1539))) (syntax-dispatch syntmp-tmp-1539 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1539 (quote ())))) syntmp-e1-1534)) syntmp-tmp-1537) (syntax-error syntmp-tmp-1536))) (syntax-dispatch syntmp-tmp-1536 (quote each-any)))) (map (lambda (syntmp-v-1554 syntmp-s-1555) ((lambda (syntmp-tmp-1556) ((lambda (syntmp-tmp-1557) (if syntmp-tmp-1557 (apply (lambda () syntmp-v-1554) syntmp-tmp-1557) ((lambda (syntmp-tmp-1558) (if syntmp-tmp-1558 (apply (lambda (syntmp-e-1559) syntmp-e-1559) syntmp-tmp-1558) ((lambda (syntmp-_-1560) (syntax-error syntmp-orig-x-1526)) syntmp-tmp-1556))) (syntax-dispatch syntmp-tmp-1556 (quote (any)))))) (syntax-dispatch syntmp-tmp-1556 (quote ())))) syntmp-s-1555)) syntmp-var-1530 syntmp-step-1532))) syntmp-tmp-1528) (syntax-error syntmp-tmp-1527))) (syntax-dispatch syntmp-tmp-1527 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1526)))
-(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1588 (lambda (syntmp-x-1592 syntmp-y-1593) ((lambda (syntmp-tmp-1594) ((lambda (syntmp-tmp-1595) (if syntmp-tmp-1595 (apply (lambda (syntmp-x-1596 syntmp-y-1597) ((lambda (syntmp-tmp-1598) ((lambda (syntmp-tmp-1599) (if syntmp-tmp-1599 (apply (lambda (syntmp-dy-1600) ((lambda (syntmp-tmp-1601) ((lambda (syntmp-tmp-1602) (if syntmp-tmp-1602 (apply (lambda (syntmp-dx-1603) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-dx-1603 syntmp-dy-1600))) syntmp-tmp-1602) ((lambda (syntmp-_-1604) (if (null? syntmp-dy-1600) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596 syntmp-y-1597))) syntmp-tmp-1601))) (syntax-dispatch syntmp-tmp-1601 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-x-1596)) syntmp-tmp-1599) ((lambda (syntmp-tmp-1605) (if syntmp-tmp-1605 (apply (lambda (syntmp-stuff-1606) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-x-1596 syntmp-stuff-1606))) syntmp-tmp-1605) ((lambda (syntmp-else-1607) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1596 syntmp-y-1597)) syntmp-tmp-1598))) (syntax-dispatch syntmp-tmp-1598 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch syntmp-tmp-1598 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-y-1597)) syntmp-tmp-1595) (syntax-error syntmp-tmp-1594))) (syntax-dispatch syntmp-tmp-1594 (quote (any any))))) (list syntmp-x-1592 syntmp-y-1593)))) (syntmp-quasiappend-1589 (lambda (syntmp-x-1608 syntmp-y-1609) ((lambda (syntmp-tmp-1610) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda (syntmp-x-1612 syntmp-y-1613) ((lambda (syntmp-tmp-1614) ((lambda (syntmp-tmp-1615) (if syntmp-tmp-1615 (apply (lambda () syntmp-x-1612) syntmp-tmp-1615) ((lambda (syntmp-_-1616) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1612 syntmp-y-1613)) syntmp-tmp-1614))) (syntax-dispatch syntmp-tmp-1614 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) syntmp-y-1613)) syntmp-tmp-1611) (syntax-error syntmp-tmp-1610))) (syntax-dispatch syntmp-tmp-1610 (quote (any any))))) (list syntmp-x-1608 syntmp-y-1609)))) (syntmp-quasivector-1590 (lambda (syntmp-x-1617) ((lambda (syntmp-tmp-1618) ((lambda (syntmp-x-1619) ((lambda (syntmp-tmp-1620) ((lambda (syntmp-tmp-1621) (if syntmp-tmp-1621 (apply (lambda (syntmp-x-1622) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector syntmp-x-1622))) syntmp-tmp-1621) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-x-1625) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1625)) syntmp-tmp-1624) ((lambda (syntmp-_-1627) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1619)) syntmp-tmp-1620))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1620 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) syntmp-x-1619)) syntmp-tmp-1618)) syntmp-x-1617))) (syntmp-quasi-1591 (lambda (syntmp-p-1628 syntmp-lev-1629) ((lambda (syntmp-tmp-1630) ((lambda (syntmp-tmp-1631) (if syntmp-tmp-1631 (apply (lambda (syntmp-p-1632) (if (= syntmp-lev-1629 0) syntmp-p-1632 (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1632) (- syntmp-lev-1629 1))))) syntmp-tmp-1631) ((lambda (syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-p-1634 syntmp-q-1635) (if (= syntmp-lev-1629 0) (syntmp-quasiappend-1589 syntmp-p-1634 (syntmp-quasi-1591 syntmp-q-1635 syntmp-lev-1629)) (syntmp-quasicons-1588 (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1634) (- syntmp-lev-1629 1))) (syntmp-quasi-1591 syntmp-q-1635 syntmp-lev-1629)))) syntmp-tmp-1633) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda (syntmp-p-1637) (syntmp-quasicons-1588 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1591 (list syntmp-p-1637) (+ syntmp-lev-1629 1)))) syntmp-tmp-1636) ((lambda (syntmp-tmp-1638) (if syntmp-tmp-1638 (apply (lambda (syntmp-p-1639 syntmp-q-1640) (syntmp-quasicons-1588 (syntmp-quasi-1591 syntmp-p-1639 syntmp-lev-1629) (syntmp-quasi-1591 syntmp-q-1640 syntmp-lev-1629))) syntmp-tmp-1638) ((lambda (syntmp-tmp-1641) (if syntmp-tmp-1641 (apply (lambda (syntmp-x-1642) (syntmp-quasivector-1590 (syntmp-quasi-1591 syntmp-x-1642 syntmp-lev-1629))) syntmp-tmp-1641) ((lambda (syntmp-p-1644) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-p-1644)) syntmp-tmp-1630))) (syntax-dispatch syntmp-tmp-1630 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch syntmp-tmp-1630 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1630 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-p-1628)))) (lambda (syntmp-x-1645) ((lambda (syntmp-tmp-1646) ((lambda (syntmp-tmp-1647) (if syntmp-tmp-1647 (apply (lambda (syntmp-_-1648 syntmp-e-1649) (syntmp-quasi-1591 syntmp-e-1649 0)) syntmp-tmp-1647) (syntax-error syntmp-tmp-1646))) (syntax-dispatch syntmp-tmp-1646 (quote (any any))))) syntmp-x-1645))))
-(install-global-transformer (quote include) (lambda (syntmp-x-1709) (letrec ((syntmp-read-file-1710 (lambda (syntmp-fn-1711 syntmp-k-1712) (let ((syntmp-p-1713 (open-input-file syntmp-fn-1711))) (let syntmp-f-1714 ((syntmp-x-1715 (read syntmp-p-1713))) (if (eof-object? syntmp-x-1715) (begin (close-input-port syntmp-p-1713) (quote ())) (cons (datum->syntax-object syntmp-k-1712 syntmp-x-1715) (syntmp-f-1714 (read syntmp-p-1713))))))))) ((lambda (syntmp-tmp-1716) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-k-1718 syntmp-filename-1719) (let ((syntmp-fn-1720 (syntax-object->datum syntmp-filename-1719))) ((lambda (syntmp-tmp-1721) ((lambda (syntmp-tmp-1722) (if syntmp-tmp-1722 (apply (lambda (syntmp-exp-1723) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) syntmp-exp-1723)) syntmp-tmp-1722) (syntax-error syntmp-tmp-1721))) (syntax-dispatch syntmp-tmp-1721 (quote each-any)))) (syntmp-read-file-1710 syntmp-fn-1720 syntmp-k-1718)))) syntmp-tmp-1717) (syntax-error syntmp-tmp-1716))) (syntax-dispatch syntmp-tmp-1716 (quote (any any))))) syntmp-x-1709))))
-(install-global-transformer (quote unquote) (lambda (syntmp-x-1740) ((lambda (syntmp-tmp-1741) ((lambda (syntmp-tmp-1742) (if syntmp-tmp-1742 (apply (lambda (syntmp-_-1743 syntmp-e-1744) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1744))) syntmp-tmp-1742) (syntax-error syntmp-tmp-1741))) (syntax-dispatch syntmp-tmp-1741 (quote (any any))))) syntmp-x-1740)))
-(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1750) ((lambda (syntmp-tmp-1751) ((lambda (syntmp-tmp-1752) (if syntmp-tmp-1752 (apply (lambda (syntmp-_-1753 syntmp-e-1754) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1754))) syntmp-tmp-1752) (syntax-error syntmp-tmp-1751))) (syntax-dispatch syntmp-tmp-1751 (quote (any any))))) syntmp-x-1750)))
-(install-global-transformer (quote case) (lambda (syntmp-x-1760) ((lambda (syntmp-tmp-1761) ((lambda (syntmp-tmp-1762) (if syntmp-tmp-1762 (apply (lambda (syntmp-_-1763 syntmp-e-1764 syntmp-m1-1765 syntmp-m2-1766) ((lambda (syntmp-tmp-1767) ((lambda (syntmp-body-1768) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1764)) syntmp-body-1768)) syntmp-tmp-1767)) (let syntmp-f-1769 ((syntmp-clause-1770 syntmp-m1-1765) (syntmp-clauses-1771 syntmp-m2-1766)) (if (null? syntmp-clauses-1771) ((lambda (syntmp-tmp-1773) ((lambda (syntmp-tmp-1774) (if syntmp-tmp-1774 (apply (lambda (syntmp-e1-1775 syntmp-e2-1776) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1775 syntmp-e2-1776))) syntmp-tmp-1774) ((lambda (syntmp-tmp-1778) (if syntmp-tmp-1778 (apply (lambda (syntmp-k-1779 syntmp-e1-1780 syntmp-e2-1781) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1779)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1780 syntmp-e2-1781)))) syntmp-tmp-1778) ((lambda (syntmp-_-1784) (syntax-error syntmp-x-1760)) syntmp-tmp-1773))) (syntax-dispatch syntmp-tmp-1773 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1773 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) syntmp-clause-1770) ((lambda (syntmp-tmp-1785) ((lambda (syntmp-rest-1786) ((lambda (syntmp-tmp-1787) ((lambda (syntmp-tmp-1788) (if syntmp-tmp-1788 (apply (lambda (syntmp-k-1789 syntmp-e1-1790 syntmp-e2-1791) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1789)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1790 syntmp-e2-1791)) syntmp-rest-1786)) syntmp-tmp-1788) ((lambda (syntmp-_-1794) (syntax-error syntmp-x-1760)) syntmp-tmp-1787))) (syntax-dispatch syntmp-tmp-1787 (quote (each-any any . each-any))))) syntmp-clause-1770)) syntmp-tmp-1785)) (syntmp-f-1769 (car syntmp-clauses-1771) (cdr syntmp-clauses-1771))))))) syntmp-tmp-1762) (syntax-error syntmp-tmp-1761))) (syntax-dispatch syntmp-tmp-1761 (quote (any any any . each-any))))) syntmp-x-1760)))
-(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1824) ((lambda (syntmp-tmp-1825) ((lambda (syntmp-tmp-1826) (if syntmp-tmp-1826 (apply (lambda (syntmp-_-1827 syntmp-e-1828) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1828)) (list (cons syntmp-_-1827 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1828 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1826) (syntax-error syntmp-tmp-1825))) (syntax-dispatch syntmp-tmp-1825 (quote (any any))))) syntmp-x-1824)))
+(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
+(if #f #f)
+
+(letrec ((#{and-map*\ 1199}#
+ (lambda (#{f\ 1239}# #{first\ 1238}# . #{rest\ 1237}#)
+ (let ((#{t\ 1240}# (null? #{first\ 1238}#)))
+ (if #{t\ 1240}#
+ #{t\ 1240}#
+ (if (null? #{rest\ 1237}#)
+ (letrec ((#{andmap\ 1241}#
+ (lambda (#{first\ 1242}#)
+ (let ((#{x\ 1243}# (car #{first\ 1242}#))
+ (#{first\ 1244}# (cdr #{first\ 1242}#)))
+ (if (null? #{first\ 1244}#)
+ (#{f\ 1239}# #{x\ 1243}#)
+ (if (#{f\ 1239}# #{x\ 1243}#)
+ (#{andmap\ 1241}# #{first\ 1244}#)
+ #f))))))
+ (#{andmap\ 1241}# #{first\ 1238}#))
+ (letrec ((#{andmap\ 1245}#
+ (lambda (#{first\ 1246}# #{rest\ 1247}#)
+ (let ((#{x\ 1248}# (car #{first\ 1246}#))
+ (#{xr\ 1249}# (map car #{rest\ 1247}#))
+ (#{first\ 1250}# (cdr #{first\ 1246}#))
+ (#{rest\ 1251}#
+ (map cdr #{rest\ 1247}#)))
+ (if (null? #{first\ 1250}#)
+ (apply #{f\ 1239}#
+ (cons #{x\ 1248}# #{xr\ 1249}#))
+ (if (apply #{f\ 1239}#
+ (cons #{x\ 1248}# #{xr\ 1249}#))
+ (#{andmap\ 1245}#
+ #{first\ 1250}#
+ #{rest\ 1251}#)
+ #f))))))
+ (#{andmap\ 1245}# #{first\ 1238}# #{rest\ 1237}#))))))))
+ (letrec ((#{lambda-var-list\ 1345}#
+ (lambda (#{vars\ 1469}#)
+ (letrec ((#{lvl\ 1470}#
+ (lambda (#{vars\ 1471}# #{ls\ 1472}# #{w\ 1473}#)
+ (if (pair? #{vars\ 1471}#)
+ (#{lvl\ 1470}#
+ (cdr #{vars\ 1471}#)
+ (cons (#{wrap\ 1325}#
+ (car #{vars\ 1471}#)
+ #{w\ 1473}#
+ #f)
+ #{ls\ 1472}#)
+ #{w\ 1473}#)
+ (if (#{id?\ 1297}# #{vars\ 1471}#)
+ (cons (#{wrap\ 1325}#
+ #{vars\ 1471}#
+ #{w\ 1473}#
+ #f)
+ #{ls\ 1472}#)
+ (if (null? #{vars\ 1471}#)
+ #{ls\ 1472}#
+ (if (#{syntax-object?\ 1281}# #{vars\ 1471}#)
+ (#{lvl\ 1470}#
+ (#{syntax-object-expression\ 1282}#
+ #{vars\ 1471}#)
+ #{ls\ 1472}#
+ (#{join-wraps\ 1316}#
+ #{w\ 1473}#
+ (#{syntax-object-wrap\ 1283}#
+ #{vars\ 1471}#)))
+ (cons #{vars\ 1471}# #{ls\ 1472}#))))))))
+ (#{lvl\ 1470}#
+ #{vars\ 1469}#
+ '()
+ '(())))))
+ (#{gen-var\ 1344}#
+ (lambda (#{id\ 1474}#)
+ (let ((#{id\ 1475}#
+ (if (#{syntax-object?\ 1281}# #{id\ 1474}#)
+ (#{syntax-object-expression\ 1282}# #{id\ 1474}#)
+ #{id\ 1474}#)))
+ (gensym
+ (string-append (symbol->string #{id\ 1475}#) " ")))))
+ (#{strip\ 1343}#
+ (lambda (#{x\ 1476}# #{w\ 1477}#)
+ (if (memq 'top
+ (#{wrap-marks\ 1300}# #{w\ 1477}#))
+ #{x\ 1476}#
+ (letrec ((#{f\ 1478}#
+ (lambda (#{x\ 1479}#)
+ (if (#{syntax-object?\ 1281}# #{x\ 1479}#)
+ (#{strip\ 1343}#
+ (#{syntax-object-expression\ 1282}#
+ #{x\ 1479}#)
+ (#{syntax-object-wrap\ 1283}# #{x\ 1479}#))
+ (if (pair? #{x\ 1479}#)
+ (let ((#{a\ 1480}#
+ (#{f\ 1478}# (car #{x\ 1479}#)))
+ (#{d\ 1481}#
+ (#{f\ 1478}# (cdr #{x\ 1479}#))))
+ (if (if (eq? #{a\ 1480}# (car #{x\ 1479}#))
+ (eq? #{d\ 1481}# (cdr #{x\ 1479}#))
+ #f)
+ #{x\ 1479}#
+ (cons #{a\ 1480}# #{d\ 1481}#)))
+ (if (vector? #{x\ 1479}#)
+ (let ((#{old\ 1482}#
+ (vector->list #{x\ 1479}#)))
+ (let ((#{new\ 1483}#
+ (map #{f\ 1478}# #{old\ 1482}#)))
+ (if (#{and-map*\ 1199}#
+ eq?
+ #{old\ 1482}#
+ #{new\ 1483}#)
+ #{x\ 1479}#
+ (list->vector #{new\ 1483}#))))
+ #{x\ 1479}#))))))
+ (#{f\ 1478}# #{x\ 1476}#)))))
+ (#{ellipsis?\ 1342}#
+ (lambda (#{x\ 1484}#)
+ (if (#{nonsymbol-id?\ 1296}# #{x\ 1484}#)
+ (#{free-id=?\ 1320}#
+ #{x\ 1484}#
+ '#(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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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-void\ 1341}#
+ (lambda () (#{build-void\ 1263}# #f)))
+ (#{eval-local-transformer\ 1340}#
+ (lambda (#{expanded\ 1485}# #{mod\ 1486}#)
+ (let ((#{p\ 1487}#
+ (#{local-eval-hook\ 1259}#
+ #{expanded\ 1485}#
+ #{mod\ 1486}#)))
+ (if (procedure? #{p\ 1487}#)
+ #{p\ 1487}#
+ (syntax-violation
+ #f
+ "nonprocedure transformer"
+ #{p\ 1487}#)))))
+ (#{chi-local-syntax\ 1339}#
+ (lambda (#{rec?\ 1488}#
+ #{e\ 1489}#
+ #{r\ 1490}#
+ #{w\ 1491}#
+ #{s\ 1492}#
+ #{mod\ 1493}#
+ #{k\ 1494}#)
+ ((lambda (#{tmp\ 1495}#)
+ ((lambda (#{tmp\ 1496}#)
+ (if #{tmp\ 1496}#
+ (apply (lambda (#{_\ 1497}#
+ #{id\ 1498}#
+ #{val\ 1499}#
+ #{e1\ 1500}#
+ #{e2\ 1501}#)
+ (let ((#{ids\ 1502}# #{id\ 1498}#))
+ (if (not (#{valid-bound-ids?\ 1322}#
+ #{ids\ 1502}#))
+ (syntax-violation
+ #f
+ "duplicate bound keyword"
+ #{e\ 1489}#)
+ (let ((#{labels\ 1504}#
+ (#{gen-labels\ 1303}#
+ #{ids\ 1502}#)))
+ (let ((#{new-w\ 1505}#
+ (#{make-binding-wrap\ 1314}#
+ #{ids\ 1502}#
+ #{labels\ 1504}#
+ #{w\ 1491}#)))
+ (#{k\ 1494}#
+ (cons #{e1\ 1500}# #{e2\ 1501}#)
+ (#{extend-env\ 1291}#
+ #{labels\ 1504}#
+ (let ((#{w\ 1507}#
+ (if #{rec?\ 1488}#
+ #{new-w\ 1505}#
+ #{w\ 1491}#))
+ (#{trans-r\ 1508}#
+ (#{macros-only-env\ 1293}#
+ #{r\ 1490}#)))
+ (map (lambda (#{x\ 1509}#)
+ (cons 'macro
+ (#{eval-local-transformer\ 1340}#
+ (#{chi\ 1333}#
+ #{x\ 1509}#
+ #{trans-r\ 1508}#
+ #{w\ 1507}#
+ #{mod\ 1493}#)
+ #{mod\ 1493}#)))
+ #{val\ 1499}#))
+ #{r\ 1490}#)
+ #{new-w\ 1505}#
+ #{s\ 1492}#
+ #{mod\ 1493}#))))))
+ #{tmp\ 1496}#)
+ ((lambda (#{_\ 1511}#)
+ (syntax-violation
+ #f
+ "bad local syntax definition"
+ (#{source-wrap\ 1326}#
+ #{e\ 1489}#
+ #{w\ 1491}#
+ #{s\ 1492}#
+ #{mod\ 1493}#)))
+ #{tmp\ 1495}#)))
+ ($sc-dispatch
+ #{tmp\ 1495}#
+ '(any #(each (any any)) any . each-any))))
+ #{e\ 1489}#)))
+ (#{chi-lambda-clause\ 1338}#
+ (lambda (#{e\ 1512}#
+ #{docstring\ 1513}#
+ #{c\ 1514}#
+ #{r\ 1515}#
+ #{w\ 1516}#
+ #{mod\ 1517}#
+ #{k\ 1518}#)
+ ((lambda (#{tmp\ 1519}#)
+ ((lambda (#{tmp\ 1520}#)
+ (if (if #{tmp\ 1520}#
+ (apply (lambda (#{args\ 1521}#
+ #{doc\ 1522}#
+ #{e1\ 1523}#
+ #{e2\ 1524}#)
+ (if (string? (syntax->datum #{doc\ 1522}#))
+ (not #{docstring\ 1513}#)
+ #f))
+ #{tmp\ 1520}#)
+ #f)
+ (apply (lambda (#{args\ 1525}#
+ #{doc\ 1526}#
+ #{e1\ 1527}#
+ #{e2\ 1528}#)
+ (#{chi-lambda-clause\ 1338}#
+ #{e\ 1512}#
+ #{doc\ 1526}#
+ (cons #{args\ 1525}#
+ (cons #{e1\ 1527}# #{e2\ 1528}#))
+ #{r\ 1515}#
+ #{w\ 1516}#
+ #{mod\ 1517}#
+ #{k\ 1518}#))
+ #{tmp\ 1520}#)
+ ((lambda (#{tmp\ 1530}#)
+ (if #{tmp\ 1530}#
+ (apply (lambda (#{id\ 1531}#
+ #{e1\ 1532}#
+ #{e2\ 1533}#)
+ (let ((#{ids\ 1534}# #{id\ 1531}#))
+ (if (not (#{valid-bound-ids?\ 1322}#
+ #{ids\ 1534}#))
+ (syntax-violation
+ 'lambda
+ "invalid parameter list"
+ #{e\ 1512}#)
+ (let ((#{labels\ 1536}#
+ (#{gen-labels\ 1303}#
+ #{ids\ 1534}#))
+ (#{new-vars\ 1537}#
+ (map #{gen-var\ 1344}#
+ #{ids\ 1534}#)))
+ (#{k\ 1518}#
+ (map syntax->datum #{ids\ 1534}#)
+ #{new-vars\ 1537}#
+ (if #{docstring\ 1513}#
+ (syntax->datum
+ #{docstring\ 1513}#)
+ #f)
+ (#{chi-body\ 1337}#
+ (cons #{e1\ 1532}# #{e2\ 1533}#)
+ #{e\ 1512}#
+ (#{extend-var-env\ 1292}#
+ #{labels\ 1536}#
+ #{new-vars\ 1537}#
+ #{r\ 1515}#)
+ (#{make-binding-wrap\ 1314}#
+ #{ids\ 1534}#
+ #{labels\ 1536}#
+ #{w\ 1516}#)
+ #{mod\ 1517}#))))))
+ #{tmp\ 1530}#)
+ ((lambda (#{tmp\ 1539}#)
+ (if #{tmp\ 1539}#
+ (apply (lambda (#{ids\ 1540}#
+ #{e1\ 1541}#
+ #{e2\ 1542}#)
+ (let ((#{old-ids\ 1543}#
+ (#{lambda-var-list\ 1345}#
+ #{ids\ 1540}#)))
+ (if (not (#{valid-bound-ids?\ 1322}#
+ #{old-ids\ 1543}#))
+ (syntax-violation
+ 'lambda
+ "invalid parameter list"
+ #{e\ 1512}#)
+ (let ((#{labels\ 1544}#
+ (#{gen-labels\ 1303}#
+ #{old-ids\ 1543}#))
+ (#{new-vars\ 1545}#
+ (map #{gen-var\ 1344}#
+ #{old-ids\ 1543}#)))
+ (#{k\ 1518}#
+ (letrec ((#{f\ 1546}#
+ (lambda (#{ls1\ 1547}#
+ #{ls2\ 1548}#)
+ (if (null? #{ls1\ 1547}#)
+ (syntax->datum
+ #{ls2\ 1548}#)
+ (#{f\ 1546}#
+ (cdr #{ls1\ 1547}#)
+ (cons (syntax->datum
+ (car #{ls1\ 1547}#))
+ #{ls2\ 1548}#))))))
+ (#{f\ 1546}#
+ (cdr #{old-ids\ 1543}#)
+ (car #{old-ids\ 1543}#)))
+ (letrec ((#{f\ 1549}#
+ (lambda (#{ls1\ 1550}#
+ #{ls2\ 1551}#)
+ (if (null? #{ls1\ 1550}#)
+ #{ls2\ 1551}#
+ (#{f\ 1549}#
+ (cdr #{ls1\ 1550}#)
+ (cons (car #{ls1\ 1550}#)
+ #{ls2\ 1551}#))))))
+ (#{f\ 1549}#
+ (cdr #{new-vars\ 1545}#)
+ (car #{new-vars\ 1545}#)))
+ (if #{docstring\ 1513}#
+ (syntax->datum
+ #{docstring\ 1513}#)
+ #f)
+ (#{chi-body\ 1337}#
+ (cons #{e1\ 1541}#
+ #{e2\ 1542}#)
+ #{e\ 1512}#
+ (#{extend-var-env\ 1292}#
+ #{labels\ 1544}#
+ #{new-vars\ 1545}#
+ #{r\ 1515}#)
+ (#{make-binding-wrap\ 1314}#
+ #{old-ids\ 1543}#
+ #{labels\ 1544}#
+ #{w\ 1516}#)
+ #{mod\ 1517}#))))))
+ #{tmp\ 1539}#)
+ ((lambda (#{_\ 1553}#)
+ (syntax-violation
+ 'lambda
+ "bad lambda"
+ #{e\ 1512}#))
+ #{tmp\ 1519}#)))
+ ($sc-dispatch
+ #{tmp\ 1519}#
+ '(any any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 1519}#
+ '(each-any any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 1519}#
+ '(any any any . each-any))))
+ #{c\ 1514}#)))
+ (#{chi-body\ 1337}#
+ (lambda (#{body\ 1554}#
+ #{outer-form\ 1555}#
+ #{r\ 1556}#
+ #{w\ 1557}#
+ #{mod\ 1558}#)
+ (let ((#{r\ 1559}#
+ (cons '("placeholder" placeholder)
+ #{r\ 1556}#)))
+ (let ((#{ribcage\ 1560}#
+ (#{make-ribcage\ 1304}#
+ '()
+ '()
+ '())))
+ (let ((#{w\ 1561}#
+ (#{make-wrap\ 1299}#
+ (#{wrap-marks\ 1300}# #{w\ 1557}#)
+ (cons #{ribcage\ 1560}#
+ (#{wrap-subst\ 1301}# #{w\ 1557}#)))))
+ (letrec ((#{parse\ 1562}#
+ (lambda (#{body\ 1563}#
+ #{ids\ 1564}#
+ #{labels\ 1565}#
+ #{var-ids\ 1566}#
+ #{vars\ 1567}#
+ #{vals\ 1568}#
+ #{bindings\ 1569}#)
+ (if (null? #{body\ 1563}#)
+ (syntax-violation
+ #f
+ "no expressions in body"
+ #{outer-form\ 1555}#)
+ (let ((#{e\ 1571}# (cdar #{body\ 1563}#))
+ (#{er\ 1572}# (caar #{body\ 1563}#)))
+ (call-with-values
+ (lambda ()
+ (#{syntax-type\ 1331}#
+ #{e\ 1571}#
+ #{er\ 1572}#
+ '(())
+ (#{source-annotation\ 1288}#
+ #{er\ 1572}#)
+ #{ribcage\ 1560}#
+ #{mod\ 1558}#
+ #f))
+ (lambda (#{type\ 1573}#
+ #{value\ 1574}#
+ #{e\ 1575}#
+ #{w\ 1576}#
+ #{s\ 1577}#
+ #{mod\ 1578}#)
+ (if (memv #{type\ 1573}#
+ '(define-form))
+ (let ((#{id\ 1579}#
+ (#{wrap\ 1325}#
+ #{value\ 1574}#
+ #{w\ 1576}#
+ #{mod\ 1578}#))
+ (#{label\ 1580}#
+ (#{gen-label\ 1302}#)))
+ (let ((#{var\ 1581}#
+ (#{gen-var\ 1344}#
+ #{id\ 1579}#)))
+ (begin
+ (#{extend-ribcage!\ 1313}#
+ #{ribcage\ 1560}#
+ #{id\ 1579}#
+ #{label\ 1580}#)
+ (#{parse\ 1562}#
+ (cdr #{body\ 1563}#)
+ (cons #{id\ 1579}#
+ #{ids\ 1564}#)
+ (cons #{label\ 1580}#
+ #{labels\ 1565}#)
+ (cons #{id\ 1579}#
+ #{var-ids\ 1566}#)
+ (cons #{var\ 1581}#
+ #{vars\ 1567}#)
+ (cons (cons #{er\ 1572}#
+ (#{wrap\ 1325}#
+ #{e\ 1575}#
+ #{w\ 1576}#
+ #{mod\ 1578}#))
+ #{vals\ 1568}#)
+ (cons (cons 'lexical
+ #{var\ 1581}#)
+ #{bindings\ 1569}#)))))
+ (if (memv #{type\ 1573}#
+ '(define-syntax-form))
+ (let ((#{id\ 1582}#
+ (#{wrap\ 1325}#
+ #{value\ 1574}#
+ #{w\ 1576}#
+ #{mod\ 1578}#))
+ (#{label\ 1583}#
+ (#{gen-label\ 1302}#)))
+ (begin
+ (#{extend-ribcage!\ 1313}#
+ #{ribcage\ 1560}#
+ #{id\ 1582}#
+ #{label\ 1583}#)
+ (#{parse\ 1562}#
+ (cdr #{body\ 1563}#)
+ (cons #{id\ 1582}#
+ #{ids\ 1564}#)
+ (cons #{label\ 1583}#
+ #{labels\ 1565}#)
+ #{var-ids\ 1566}#
+ #{vars\ 1567}#
+ #{vals\ 1568}#
+ (cons (cons 'macro
+ (cons #{er\ 1572}#
+ (#{wrap\ 1325}#
+ #{e\ 1575}#
+ #{w\ 1576}#
+ #{mod\ 1578}#)))
+ #{bindings\ 1569}#))))
+ (if (memv #{type\ 1573}#
+ '(begin-form))
+ ((lambda (#{tmp\ 1584}#)
+ ((lambda (#{tmp\ 1585}#)
+ (if #{tmp\ 1585}#
+ (apply (lambda (#{_\ 1586}#
+ #{e1\ 1587}#)
+ (#{parse\ 1562}#
+ (letrec ((#{f\ 1588}#
+ (lambda (#{forms\ 1589}#)
+ (if (null? #{forms\ 1589}#)
+ (cdr #{body\ 1563}#)
+ (cons (cons #{er\ 1572}#
+ (#{wrap\ 1325}#
+ (car #{forms\ 1589}#)
+ #{w\ 1576}#
+ #{mod\ 1578}#))
+ (#{f\ 1588}#
+ (cdr #{forms\ 1589}#)))))))
+ (#{f\ 1588}#
+ #{e1\ 1587}#))
+ #{ids\ 1564}#
+ #{labels\ 1565}#
+ #{var-ids\ 1566}#
+ #{vars\ 1567}#
+ #{vals\ 1568}#
+ #{bindings\ 1569}#))
+ #{tmp\ 1585}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 1584}#)))
+ ($sc-dispatch
+ #{tmp\ 1584}#
+ '(any . each-any))))
+ #{e\ 1575}#)
+ (if (memv #{type\ 1573}#
+ '(local-syntax-form))
+ (#{chi-local-syntax\ 1339}#
+ #{value\ 1574}#
+ #{e\ 1575}#
+ #{er\ 1572}#
+ #{w\ 1576}#
+ #{s\ 1577}#
+ #{mod\ 1578}#
+ (lambda (#{forms\ 1591}#
+ #{er\ 1592}#
+ #{w\ 1593}#
+ #{s\ 1594}#
+ #{mod\ 1595}#)
+ (#{parse\ 1562}#
+ (letrec ((#{f\ 1596}#
+ (lambda (#{forms\ 1597}#)
+ (if (null? #{forms\ 1597}#)
+ (cdr #{body\ 1563}#)
+ (cons (cons #{er\ 1592}#
+ (#{wrap\ 1325}#
+ (car #{forms\ 1597}#)
+ #{w\ 1593}#
+ #{mod\ 1595}#))
+ (#{f\ 1596}#
+ (cdr #{forms\ 1597}#)))))))
+ (#{f\ 1596}#
+ #{forms\ 1591}#))
+ #{ids\ 1564}#
+ #{labels\ 1565}#
+ #{var-ids\ 1566}#
+ #{vars\ 1567}#
+ #{vals\ 1568}#
+ #{bindings\ 1569}#)))
+ (if (null? #{ids\ 1564}#)
+ (#{build-sequence\ 1276}#
+ #f
+ (map (lambda (#{x\ 1598}#)
+ (#{chi\ 1333}#
+ (cdr #{x\ 1598}#)
+ (car #{x\ 1598}#)
+ '(())
+ #{mod\ 1578}#))
+ (cons (cons #{er\ 1572}#
+ (#{source-wrap\ 1326}#
+ #{e\ 1575}#
+ #{w\ 1576}#
+ #{s\ 1577}#
+ #{mod\ 1578}#))
+ (cdr #{body\ 1563}#))))
+ (begin
+ (if (not (#{valid-bound-ids?\ 1322}#
+ #{ids\ 1564}#))
+ (syntax-violation
+ #f
+ "invalid or duplicate identifier in definition"
+ #{outer-form\ 1555}#))
+ (letrec ((#{loop\ 1599}#
+ (lambda (#{bs\ 1600}#
+ #{er-cache\ 1601}#
+ #{r-cache\ 1602}#)
+ (if (not (null? #{bs\ 1600}#))
+ (let ((#{b\ 1603}#
+ (car #{bs\ 1600}#)))
+ (if (eq? (car #{b\ 1603}#)
+ 'macro)
+ (let ((#{er\ 1604}#
+ (cadr #{b\ 1603}#)))
+ (let ((#{r-cache\ 1605}#
+ (if (eq? #{er\ 1604}#
+ #{er-cache\ 1601}#)
+ #{r-cache\ 1602}#
+ (#{macros-only-env\ 1293}#
+ #{er\ 1604}#))))
+ (begin
+ (set-cdr!
+ #{b\ 1603}#
+ (#{eval-local-transformer\ 1340}#
+ (#{chi\ 1333}#
+ (cddr #{b\ 1603}#)
+ #{r-cache\ 1605}#
+ '(())
+ #{mod\ 1578}#)
+ #{mod\ 1578}#))
+ (#{loop\ 1599}#
+ (cdr #{bs\ 1600}#)
+ #{er\ 1604}#
+ #{r-cache\ 1605}#))))
+ (#{loop\ 1599}#
+ (cdr #{bs\ 1600}#)
+ #{er-cache\ 1601}#
+ #{r-cache\ 1602}#)))))))
+ (#{loop\ 1599}#
+ #{bindings\ 1569}#
+ #f
+ #f))
+ (set-cdr!
+ #{r\ 1559}#
+ (#{extend-env\ 1291}#
+ #{labels\ 1565}#
+ #{bindings\ 1569}#
+ (cdr #{r\ 1559}#)))
+ (#{build-letrec\ 1279}#
+ #f
+ (map syntax->datum
+ #{var-ids\ 1566}#)
+ #{vars\ 1567}#
+ (map (lambda (#{x\ 1606}#)
+ (#{chi\ 1333}#
+ (cdr #{x\ 1606}#)
+ (car #{x\ 1606}#)
+ '(())
+ #{mod\ 1578}#))
+ #{vals\ 1568}#)
+ (#{build-sequence\ 1276}#
+ #f
+ (map (lambda (#{x\ 1607}#)
+ (#{chi\ 1333}#
+ (cdr #{x\ 1607}#)
+ (car #{x\ 1607}#)
+ '(())
+ #{mod\ 1578}#))
+ (cons (cons #{er\ 1572}#
+ (#{source-wrap\ 1326}#
+ #{e\ 1575}#
+ #{w\ 1576}#
+ #{s\ 1577}#
+ #{mod\ 1578}#))
+ (cdr #{body\ 1563}#))))))))))))))))))
+ (#{parse\ 1562}#
+ (map (lambda (#{x\ 1570}#)
+ (cons #{r\ 1559}#
+ (#{wrap\ 1325}#
+ #{x\ 1570}#
+ #{w\ 1561}#
+ #{mod\ 1558}#)))
+ #{body\ 1554}#)
+ '()
+ '()
+ '()
+ '()
+ '()
+ '())))))))
+ (#{chi-macro\ 1336}#
+ (lambda (#{p\ 1608}#
+ #{e\ 1609}#
+ #{r\ 1610}#
+ #{w\ 1611}#
+ #{rib\ 1612}#
+ #{mod\ 1613}#)
+ (letrec ((#{rebuild-macro-output\ 1614}#
+ (lambda (#{x\ 1615}# #{m\ 1616}#)
+ (if (pair? #{x\ 1615}#)
+ (cons (#{rebuild-macro-output\ 1614}#
+ (car #{x\ 1615}#)
+ #{m\ 1616}#)
+ (#{rebuild-macro-output\ 1614}#
+ (cdr #{x\ 1615}#)
+ #{m\ 1616}#))
+ (if (#{syntax-object?\ 1281}# #{x\ 1615}#)
+ (let ((#{w\ 1617}#
+ (#{syntax-object-wrap\ 1283}#
+ #{x\ 1615}#)))
+ (let ((#{ms\ 1618}#
+ (#{wrap-marks\ 1300}# #{w\ 1617}#))
+ (#{s\ 1619}#
+ (#{wrap-subst\ 1301}# #{w\ 1617}#)))
+ (if (if (pair? #{ms\ 1618}#)
+ (eq? (car #{ms\ 1618}#) #f)
+ #f)
+ (#{make-syntax-object\ 1280}#
+ (#{syntax-object-expression\ 1282}#
+ #{x\ 1615}#)
+ (#{make-wrap\ 1299}#
+ (cdr #{ms\ 1618}#)
+ (if #{rib\ 1612}#
+ (cons #{rib\ 1612}#
+ (cdr #{s\ 1619}#))
+ (cdr #{s\ 1619}#)))
+ (#{syntax-object-module\ 1284}#
+ #{x\ 1615}#))
+ (#{make-syntax-object\ 1280}#
+ (#{syntax-object-expression\ 1282}#
+ #{x\ 1615}#)
+ (#{make-wrap\ 1299}#
+ (cons #{m\ 1616}# #{ms\ 1618}#)
+ (if #{rib\ 1612}#
+ (cons #{rib\ 1612}#
+ (cons 'shift
+ #{s\ 1619}#))
+ (cons (quote shift) #{s\ 1619}#)))
+ (let ((#{pmod\ 1620}#
+ (procedure-module
+ #{p\ 1608}#)))
+ (if #{pmod\ 1620}#
+ (cons 'hygiene
+ (module-name #{pmod\ 1620}#))
+ '(hygiene guile)))))))
+ (if (vector? #{x\ 1615}#)
+ (let ((#{n\ 1621}#
+ (vector-length #{x\ 1615}#)))
+ (let ((#{v\ 1622}#
+ (make-vector #{n\ 1621}#)))
+ (letrec ((#{loop\ 1623}#
+ (lambda (#{i\ 1624}#)
+ (if (#{fx=\ 1256}#
+ #{i\ 1624}#
+ #{n\ 1621}#)
+ (begin
+ (if #f #f)
+ #{v\ 1622}#)
+ (begin
+ (vector-set!
+ #{v\ 1622}#
+ #{i\ 1624}#
+ (#{rebuild-macro-output\ 1614}#
+ (vector-ref
+ #{x\ 1615}#
+ #{i\ 1624}#)
+ #{m\ 1616}#))
+ (#{loop\ 1623}#
+ (#{fx+\ 1254}#
+ #{i\ 1624}#
+ 1)))))))
+ (#{loop\ 1623}# 0))))
+ (if (symbol? #{x\ 1615}#)
+ (syntax-violation
+ #f
+ "encountered raw symbol in macro output"
+ (#{source-wrap\ 1326}#
+ #{e\ 1609}#
+ #{w\ 1611}#
+ s
+ #{mod\ 1613}#)
+ #{x\ 1615}#)
+ #{x\ 1615}#)))))))
+ (#{rebuild-macro-output\ 1614}#
+ (#{p\ 1608}#
+ (#{wrap\ 1325}#
+ #{e\ 1609}#
+ (#{anti-mark\ 1312}# #{w\ 1611}#)
+ #{mod\ 1613}#))
+ (string #\m)))))
+ (#{chi-application\ 1335}#
+ (lambda (#{x\ 1625}#
+ #{e\ 1626}#
+ #{r\ 1627}#
+ #{w\ 1628}#
+ #{s\ 1629}#
+ #{mod\ 1630}#)
+ ((lambda (#{tmp\ 1631}#)
+ ((lambda (#{tmp\ 1632}#)
+ (if #{tmp\ 1632}#
+ (apply (lambda (#{e0\ 1633}# #{e1\ 1634}#)
+ (#{build-application\ 1264}#
+ #{s\ 1629}#
+ #{x\ 1625}#
+ (map (lambda (#{e\ 1635}#)
+ (#{chi\ 1333}#
+ #{e\ 1635}#
+ #{r\ 1627}#
+ #{w\ 1628}#
+ #{mod\ 1630}#))
+ #{e1\ 1634}#)))
+ #{tmp\ 1632}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 1631}#)))
+ ($sc-dispatch
+ #{tmp\ 1631}#
+ '(any . each-any))))
+ #{e\ 1626}#)))
+ (#{chi-expr\ 1334}#
+ (lambda (#{type\ 1637}#
+ #{value\ 1638}#
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (lexical)))
+ (#{build-lexical-reference\ 1266}#
+ 'value
+ #{s\ 1642}#
+ #{e\ 1639}#
+ #{value\ 1638}#)
+ (if (memv #{type\ 1637}# (quote (core core-form)))
+ (#{value\ 1638}#
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (module-ref)))
+ (call-with-values
+ (lambda () (#{value\ 1638}# #{e\ 1639}#))
+ (lambda (#{id\ 1644}# #{mod\ 1645}#)
+ (#{build-global-reference\ 1269}#
+ #{s\ 1642}#
+ #{id\ 1644}#
+ #{mod\ 1645}#)))
+ (if (memv #{type\ 1637}# (quote (lexical-call)))
+ (#{chi-application\ 1335}#
+ (#{build-lexical-reference\ 1266}#
+ 'fun
+ (#{source-annotation\ 1288}# (car #{e\ 1639}#))
+ (car #{e\ 1639}#)
+ #{value\ 1638}#)
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (global-call)))
+ (#{chi-application\ 1335}#
+ (#{build-global-reference\ 1269}#
+ (#{source-annotation\ 1288}# (car #{e\ 1639}#))
+ (if (#{syntax-object?\ 1281}# #{value\ 1638}#)
+ (#{syntax-object-expression\ 1282}#
+ #{value\ 1638}#)
+ #{value\ 1638}#)
+ (if (#{syntax-object?\ 1281}# #{value\ 1638}#)
+ (#{syntax-object-module\ 1284}# #{value\ 1638}#)
+ #{mod\ 1643}#))
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (constant)))
+ (#{build-data\ 1275}#
+ #{s\ 1642}#
+ (#{strip\ 1343}#
+ (#{source-wrap\ 1326}#
+ #{e\ 1639}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ '(())))
+ (if (memv #{type\ 1637}# (quote (global)))
+ (#{build-global-reference\ 1269}#
+ #{s\ 1642}#
+ #{value\ 1638}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (call)))
+ (#{chi-application\ 1335}#
+ (#{chi\ 1333}#
+ (car #{e\ 1639}#)
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{mod\ 1643}#)
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (begin-form)))
+ ((lambda (#{tmp\ 1646}#)
+ ((lambda (#{tmp\ 1647}#)
+ (if #{tmp\ 1647}#
+ (apply (lambda (#{_\ 1648}#
+ #{e1\ 1649}#
+ #{e2\ 1650}#)
+ (#{chi-sequence\ 1327}#
+ (cons #{e1\ 1649}#
+ #{e2\ 1650}#)
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#))
+ #{tmp\ 1647}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 1646}#)))
+ ($sc-dispatch
+ #{tmp\ 1646}#
+ '(any any . each-any))))
+ #{e\ 1639}#)
+ (if (memv #{type\ 1637}#
+ '(local-syntax-form))
+ (#{chi-local-syntax\ 1339}#
+ #{value\ 1638}#
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#
+ #{chi-sequence\ 1327}#)
+ (if (memv #{type\ 1637}#
+ '(eval-when-form))
+ ((lambda (#{tmp\ 1652}#)
+ ((lambda (#{tmp\ 1653}#)
+ (if #{tmp\ 1653}#
+ (apply (lambda (#{_\ 1654}#
+ #{x\ 1655}#
+ #{e1\ 1656}#
+ #{e2\ 1657}#)
+ (let ((#{when-list\ 1658}#
+ (#{chi-when-list\ 1330}#
+ #{e\ 1639}#
+ #{x\ 1655}#
+ #{w\ 1641}#)))
+ (if (memq 'eval
+ #{when-list\ 1658}#)
+ (#{chi-sequence\ 1327}#
+ (cons #{e1\ 1656}#
+ #{e2\ 1657}#)
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (#{chi-void\ 1341}#))))
+ #{tmp\ 1653}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 1652}#)))
+ ($sc-dispatch
+ #{tmp\ 1652}#
+ '(any each-any any . each-any))))
+ #{e\ 1639}#)
+ (if (memv #{type\ 1637}#
+ '(define-form
+ define-syntax-form))
+ (syntax-violation
+ #f
+ "definition in expression context"
+ #{e\ 1639}#
+ (#{wrap\ 1325}#
+ #{value\ 1638}#
+ #{w\ 1641}#
+ #{mod\ 1643}#))
+ (if (memv #{type\ 1637}#
+ '(syntax))
+ (syntax-violation
+ #f
+ "reference to pattern variable outside syntax form"
+ (#{source-wrap\ 1326}#
+ #{e\ 1639}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#))
+ (if (memv #{type\ 1637}#
+ '(displaced-lexical))
+ (syntax-violation
+ #f
+ "reference to identifier outside its scope"
+ (#{source-wrap\ 1326}#
+ #{e\ 1639}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#))
+ (syntax-violation
+ #f
+ "unexpected syntax"
+ (#{source-wrap\ 1326}#
+ #{e\ 1639}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#))))))))))))))))))
+ (#{chi\ 1333}#
+ (lambda (#{e\ 1661}#
+ #{r\ 1662}#
+ #{w\ 1663}#
+ #{mod\ 1664}#)
+ (call-with-values
+ (lambda ()
+ (#{syntax-type\ 1331}#
+ #{e\ 1661}#
+ #{r\ 1662}#
+ #{w\ 1663}#
+ (#{source-annotation\ 1288}# #{e\ 1661}#)
+ #f
+ #{mod\ 1664}#
+ #f))
+ (lambda (#{type\ 1665}#
+ #{value\ 1666}#
+ #{e\ 1667}#
+ #{w\ 1668}#
+ #{s\ 1669}#
+ #{mod\ 1670}#)
+ (#{chi-expr\ 1334}#
+ #{type\ 1665}#
+ #{value\ 1666}#
+ #{e\ 1667}#
+ #{r\ 1662}#
+ #{w\ 1668}#
+ #{s\ 1669}#
+ #{mod\ 1670}#)))))
+ (#{chi-top\ 1332}#
+ (lambda (#{e\ 1671}#
+ #{r\ 1672}#
+ #{w\ 1673}#
+ #{m\ 1674}#
+ #{esew\ 1675}#
+ #{mod\ 1676}#)
+ (call-with-values
+ (lambda ()
+ (#{syntax-type\ 1331}#
+ #{e\ 1671}#
+ #{r\ 1672}#
+ #{w\ 1673}#
+ (#{source-annotation\ 1288}# #{e\ 1671}#)
+ #f
+ #{mod\ 1676}#
+ #f))
+ (lambda (#{type\ 1684}#
+ #{value\ 1685}#
+ #{e\ 1686}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ #{mod\ 1689}#)
+ (if (memv #{type\ 1684}# (quote (begin-form)))
+ ((lambda (#{tmp\ 1690}#)
+ ((lambda (#{tmp\ 1691}#)
+ (if #{tmp\ 1691}#
+ (apply (lambda (#{_\ 1692}#) (#{chi-void\ 1341}#))
+ #{tmp\ 1691}#)
+ ((lambda (#{tmp\ 1693}#)
+ (if #{tmp\ 1693}#
+ (apply (lambda (#{_\ 1694}#
+ #{e1\ 1695}#
+ #{e2\ 1696}#)
+ (#{chi-top-sequence\ 1328}#
+ (cons #{e1\ 1695}# #{e2\ 1696}#)
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ #{m\ 1674}#
+ #{esew\ 1675}#
+ #{mod\ 1689}#))
+ #{tmp\ 1693}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 1690}#)))
+ ($sc-dispatch
+ #{tmp\ 1690}#
+ '(any any . each-any)))))
+ ($sc-dispatch #{tmp\ 1690}# (quote (any)))))
+ #{e\ 1686}#)
+ (if (memv #{type\ 1684}# (quote (local-syntax-form)))
+ (#{chi-local-syntax\ 1339}#
+ #{value\ 1685}#
+ #{e\ 1686}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ #{mod\ 1689}#
+ (lambda (#{body\ 1698}#
+ #{r\ 1699}#
+ #{w\ 1700}#
+ #{s\ 1701}#
+ #{mod\ 1702}#)
+ (#{chi-top-sequence\ 1328}#
+ #{body\ 1698}#
+ #{r\ 1699}#
+ #{w\ 1700}#
+ #{s\ 1701}#
+ #{m\ 1674}#
+ #{esew\ 1675}#
+ #{mod\ 1702}#)))
+ (if (memv #{type\ 1684}# (quote (eval-when-form)))
+ ((lambda (#{tmp\ 1703}#)
+ ((lambda (#{tmp\ 1704}#)
+ (if #{tmp\ 1704}#
+ (apply (lambda (#{_\ 1705}#
+ #{x\ 1706}#
+ #{e1\ 1707}#
+ #{e2\ 1708}#)
+ (let ((#{when-list\ 1709}#
+ (#{chi-when-list\ 1330}#
+ #{e\ 1686}#
+ #{x\ 1706}#
+ #{w\ 1687}#))
+ (#{body\ 1710}#
+ (cons #{e1\ 1707}#
+ #{e2\ 1708}#)))
+ (if (eq? #{m\ 1674}# (quote e))
+ (if (memq 'eval
+ #{when-list\ 1709}#)
+ (#{chi-top-sequence\ 1328}#
+ #{body\ 1710}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ 'e
+ '(eval)
+ #{mod\ 1689}#)
+ (#{chi-void\ 1341}#))
+ (if (memq 'load
+ #{when-list\ 1709}#)
+ (if (let ((#{t\ 1713}#
+ (memq 'compile
+ #{when-list\ 1709}#)))
+ (if #{t\ 1713}#
+ #{t\ 1713}#
+ (if (eq? #{m\ 1674}#
+ 'c&e)
+ (memq 'eval
+ #{when-list\ 1709}#)
+ #f)))
+ (#{chi-top-sequence\ 1328}#
+ #{body\ 1710}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ 'c&e
+ '(compile load)
+ #{mod\ 1689}#)
+ (if (memq #{m\ 1674}#
+ '(c c&e))
+ (#{chi-top-sequence\ 1328}#
+ #{body\ 1710}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ 'c
+ '(load)
+ #{mod\ 1689}#)
+ (#{chi-void\ 1341}#)))
+ (if (let ((#{t\ 1714}#
+ (memq 'compile
+ #{when-list\ 1709}#)))
+ (if #{t\ 1714}#
+ #{t\ 1714}#
+ (if (eq? #{m\ 1674}#
+ 'c&e)
+ (memq 'eval
+ #{when-list\ 1709}#)
+ #f)))
+ (begin
+ (#{top-level-eval-hook\ 1258}#
+ (#{chi-top-sequence\ 1328}#
+ #{body\ 1710}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ 'e
+ '(eval)
+ #{mod\ 1689}#)
+ #{mod\ 1689}#)
+ (#{chi-void\ 1341}#))
+ (#{chi-void\ 1341}#))))))
+ #{tmp\ 1704}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 1703}#)))
+ ($sc-dispatch
+ #{tmp\ 1703}#
+ '(any each-any any . each-any))))
+ #{e\ 1686}#)
+ (if (memv #{type\ 1684}#
+ '(define-syntax-form))
+ (let ((#{n\ 1715}#
+ (#{id-var-name\ 1319}#
+ #{value\ 1685}#
+ #{w\ 1687}#))
+ (#{r\ 1716}#
+ (#{macros-only-env\ 1293}# #{r\ 1672}#)))
+ (if (memv #{m\ 1674}# (quote (c)))
+ (if (memq (quote compile) #{esew\ 1675}#)
+ (let ((#{e\ 1717}#
+ (#{chi-install-global\ 1329}#
+ #{n\ 1715}#
+ (#{chi\ 1333}#
+ #{e\ 1686}#
+ #{r\ 1716}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))))
+ (begin
+ (#{top-level-eval-hook\ 1258}#
+ #{e\ 1717}#
+ #{mod\ 1689}#)
+ (if (memq (quote load) #{esew\ 1675}#)
+ #{e\ 1717}#
+ (#{chi-void\ 1341}#))))
+ (if (memq (quote load) #{esew\ 1675}#)
+ (#{chi-install-global\ 1329}#
+ #{n\ 1715}#
+ (#{chi\ 1333}#
+ #{e\ 1686}#
+ #{r\ 1716}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))
+ (#{chi-void\ 1341}#)))
+ (if (memv #{m\ 1674}# (quote (c&e)))
+ (let ((#{e\ 1718}#
+ (#{chi-install-global\ 1329}#
+ #{n\ 1715}#
+ (#{chi\ 1333}#
+ #{e\ 1686}#
+ #{r\ 1716}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))))
+ (begin
+ (#{top-level-eval-hook\ 1258}#
+ #{e\ 1718}#
+ #{mod\ 1689}#)
+ #{e\ 1718}#))
+ (begin
+ (if (memq (quote eval) #{esew\ 1675}#)
+ (#{top-level-eval-hook\ 1258}#
+ (#{chi-install-global\ 1329}#
+ #{n\ 1715}#
+ (#{chi\ 1333}#
+ #{e\ 1686}#
+ #{r\ 1716}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))
+ #{mod\ 1689}#))
+ (#{chi-void\ 1341}#)))))
+ (if (memv #{type\ 1684}# (quote (define-form)))
+ (let ((#{n\ 1719}#
+ (#{id-var-name\ 1319}#
+ #{value\ 1685}#
+ #{w\ 1687}#)))
+ (let ((#{type\ 1720}#
+ (#{binding-type\ 1289}#
+ (#{lookup\ 1294}#
+ #{n\ 1719}#
+ #{r\ 1672}#
+ #{mod\ 1689}#))))
+ (if (memv #{type\ 1720}#
+ '(global core macro module-ref))
+ (begin
+ (if (if (not (module-local-variable
+ (current-module)
+ #{n\ 1719}#))
+ (current-module)
+ #f)
+ (let ((#{old\ 1721}#
+ (module-variable
+ (current-module)
+ #{n\ 1719}#)))
+ (module-define!
+ (current-module)
+ #{n\ 1719}#
+ (if (variable? #{old\ 1721}#)
+ (variable-ref #{old\ 1721}#)
+ #f))))
+ (let ((#{x\ 1722}#
+ (#{build-global-definition\ 1272}#
+ #{s\ 1688}#
+ #{n\ 1719}#
+ (#{chi\ 1333}#
+ #{e\ 1686}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))))
+ (begin
+ (if (eq? #{m\ 1674}# (quote c&e))
+ (#{top-level-eval-hook\ 1258}#
+ #{x\ 1722}#
+ #{mod\ 1689}#))
+ #{x\ 1722}#)))
+ (if (memv #{type\ 1720}#
+ '(displaced-lexical))
+ (syntax-violation
+ #f
+ "identifier out of context"
+ #{e\ 1686}#
+ (#{wrap\ 1325}#
+ #{value\ 1685}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))
+ (syntax-violation
+ #f
+ "cannot define keyword at top level"
+ #{e\ 1686}#
+ (#{wrap\ 1325}#
+ #{value\ 1685}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))))))
+ (let ((#{x\ 1723}#
+ (#{chi-expr\ 1334}#
+ #{type\ 1684}#
+ #{value\ 1685}#
+ #{e\ 1686}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ #{mod\ 1689}#)))
+ (begin
+ (if (eq? #{m\ 1674}# (quote c&e))
+ (#{top-level-eval-hook\ 1258}#
+ #{x\ 1723}#
+ #{mod\ 1689}#))
+ #{x\ 1723}#)))))))))))
+ (#{syntax-type\ 1331}#
+ (lambda (#{e\ 1724}#
+ #{r\ 1725}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ #{mod\ 1729}#
+ #{for-car?\ 1730}#)
+ (if (symbol? #{e\ 1724}#)
+ (let ((#{n\ 1731}#
+ (#{id-var-name\ 1319}# #{e\ 1724}# #{w\ 1726}#)))
+ (let ((#{b\ 1732}#
+ (#{lookup\ 1294}#
+ #{n\ 1731}#
+ #{r\ 1725}#
+ #{mod\ 1729}#)))
+ (let ((#{type\ 1733}#
+ (#{binding-type\ 1289}# #{b\ 1732}#)))
+ (if (memv #{type\ 1733}# (quote (lexical)))
+ (values
+ #{type\ 1733}#
+ (#{binding-value\ 1290}# #{b\ 1732}#)
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{type\ 1733}# (quote (global)))
+ (values
+ #{type\ 1733}#
+ #{n\ 1731}#
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{type\ 1733}# (quote (macro)))
+ (if #{for-car?\ 1730}#
+ (values
+ #{type\ 1733}#
+ (#{binding-value\ 1290}# #{b\ 1732}#)
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (#{syntax-type\ 1331}#
+ (#{chi-macro\ 1336}#
+ (#{binding-value\ 1290}# #{b\ 1732}#)
+ #{e\ 1724}#
+ #{r\ 1725}#
+ #{w\ 1726}#
+ #{rib\ 1728}#
+ #{mod\ 1729}#)
+ #{r\ 1725}#
+ '(())
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ #{mod\ 1729}#
+ #f))
+ (values
+ #{type\ 1733}#
+ (#{binding-value\ 1290}# #{b\ 1732}#)
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)))))))
+ (if (pair? #{e\ 1724}#)
+ (let ((#{first\ 1734}# (car #{e\ 1724}#)))
+ (call-with-values
+ (lambda ()
+ (#{syntax-type\ 1331}#
+ #{first\ 1734}#
+ #{r\ 1725}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ #{mod\ 1729}#
+ #t))
+ (lambda (#{ftype\ 1735}#
+ #{fval\ 1736}#
+ #{fe\ 1737}#
+ #{fw\ 1738}#
+ #{fs\ 1739}#
+ #{fmod\ 1740}#)
+ (if (memv #{ftype\ 1735}# (quote (lexical)))
+ (values
+ 'lexical-call
+ #{fval\ 1736}#
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}# (quote (global)))
+ (values
+ 'global-call
+ (#{make-syntax-object\ 1280}#
+ #{fval\ 1736}#
+ #{w\ 1726}#
+ #{fmod\ 1740}#)
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}# (quote (macro)))
+ (#{syntax-type\ 1331}#
+ (#{chi-macro\ 1336}#
+ #{fval\ 1736}#
+ #{e\ 1724}#
+ #{r\ 1725}#
+ #{w\ 1726}#
+ #{rib\ 1728}#
+ #{mod\ 1729}#)
+ #{r\ 1725}#
+ '(())
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ #{mod\ 1729}#
+ #{for-car?\ 1730}#)
+ (if (memv #{ftype\ 1735}# (quote (module-ref)))
+ (call-with-values
+ (lambda () (#{fval\ 1736}# #{e\ 1724}#))
+ (lambda (#{sym\ 1741}# #{mod\ 1742}#)
+ (#{syntax-type\ 1331}#
+ #{sym\ 1741}#
+ #{r\ 1725}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ #{mod\ 1742}#
+ #{for-car?\ 1730}#)))
+ (if (memv #{ftype\ 1735}# (quote (core)))
+ (values
+ 'core-form
+ #{fval\ 1736}#
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}#
+ '(local-syntax))
+ (values
+ 'local-syntax-form
+ #{fval\ 1736}#
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}# (quote (begin)))
+ (values
+ 'begin-form
+ #f
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}#
+ '(eval-when))
+ (values
+ 'eval-when-form
+ #f
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}#
+ '(define))
+ ((lambda (#{tmp\ 1743}#)
+ ((lambda (#{tmp\ 1744}#)
+ (if (if #{tmp\ 1744}#
+ (apply (lambda (#{_\ 1745}#
+ #{name\ 1746}#
+ #{val\ 1747}#)
+ (#{id?\ 1297}#
+ #{name\ 1746}#))
+ #{tmp\ 1744}#)
+ #f)
+ (apply (lambda (#{_\ 1748}#
+ #{name\ 1749}#
+ #{val\ 1750}#)
+ (values
+ 'define-form
+ #{name\ 1749}#
+ #{val\ 1750}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#))
+ #{tmp\ 1744}#)
+ ((lambda (#{tmp\ 1751}#)
+ (if (if #{tmp\ 1751}#
+ (apply (lambda (#{_\ 1752}#
+ #{name\ 1753}#
+ #{args\ 1754}#
+ #{e1\ 1755}#
+ #{e2\ 1756}#)
+ (if (#{id?\ 1297}#
+ #{name\ 1753}#)
+ (#{valid-bound-ids?\ 1322}#
+ (#{lambda-var-list\ 1345}#
+ #{args\ 1754}#))
+ #f))
+ #{tmp\ 1751}#)
+ #f)
+ (apply (lambda (#{_\ 1757}#
+ #{name\ 1758}#
+ #{args\ 1759}#
+ #{e1\ 1760}#
+ #{e2\ 1761}#)
+ (values
+ 'define-form
+ (#{wrap\ 1325}#
+ #{name\ 1758}#
+ #{w\ 1726}#
+ #{mod\ 1729}#)
+ (#{decorate-source\ 1262}#
+ (cons '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_
+ name
+ args
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(ftype
+ fval
+ fe
+ fw
+ fs
+ fmod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(first)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ rib
+ mod
+ for-car?)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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))
+ (#{wrap\ 1325}#
+ (cons #{args\ 1759}#
+ (cons #{e1\ 1760}#
+ #{e2\ 1761}#))
+ #{w\ 1726}#
+ #{mod\ 1729}#))
+ #{s\ 1727}#)
+ '(())
+ #{s\ 1727}#
+ #{mod\ 1729}#))
+ #{tmp\ 1751}#)
+ ((lambda (#{tmp\ 1763}#)
+ (if (if #{tmp\ 1763}#
+ (apply (lambda (#{_\ 1764}#
+ #{name\ 1765}#)
+ (#{id?\ 1297}#
+ #{name\ 1765}#))
+ #{tmp\ 1763}#)
+ #f)
+ (apply (lambda (#{_\ 1766}#
+ #{name\ 1767}#)
+ (values
+ 'define-form
+ (#{wrap\ 1325}#
+ #{name\ 1767}#
+ #{w\ 1726}#
+ #{mod\ 1729}#)
+ '(#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(_
+ name)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(ftype
+ fval
+ fe
+ fw
+ fs
+ fmod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(first)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ rib
+ mod
+ for-car?)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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
+ #(ftype
+ fval
+ fe
+ fw
+ fs
+ fmod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(first)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ rib
+ mod
+ for-car?)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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
+ #(ftype
+ fval
+ fe
+ fw
+ fs
+ fmod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(first)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ rib
+ mod
+ for-car?)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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)))
+ '(())
+ #{s\ 1727}#
+ #{mod\ 1729}#))
+ #{tmp\ 1763}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 1743}#)))
+ ($sc-dispatch
+ #{tmp\ 1743}#
+ '(any any)))))
+ ($sc-dispatch
+ #{tmp\ 1743}#
+ '(any (any . any)
+ any
+ .
+ each-any)))))
+ ($sc-dispatch
+ #{tmp\ 1743}#
+ '(any any any))))
+ #{e\ 1724}#)
+ (if (memv #{ftype\ 1735}#
+ '(define-syntax))
+ ((lambda (#{tmp\ 1768}#)
+ ((lambda (#{tmp\ 1769}#)
+ (if (if #{tmp\ 1769}#
+ (apply (lambda (#{_\ 1770}#
+ #{name\ 1771}#
+ #{val\ 1772}#)
+ (#{id?\ 1297}#
+ #{name\ 1771}#))
+ #{tmp\ 1769}#)
+ #f)
+ (apply (lambda (#{_\ 1773}#
+ #{name\ 1774}#
+ #{val\ 1775}#)
+ (values
+ 'define-syntax-form
+ #{name\ 1774}#
+ #{val\ 1775}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#))
+ #{tmp\ 1769}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 1768}#)))
+ ($sc-dispatch
+ #{tmp\ 1768}#
+ '(any any any))))
+ #{e\ 1724}#)
+ (values
+ 'call
+ #f
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#))))))))))))))
+ (if (#{syntax-object?\ 1281}# #{e\ 1724}#)
+ (#{syntax-type\ 1331}#
+ (#{syntax-object-expression\ 1282}# #{e\ 1724}#)
+ #{r\ 1725}#
+ (#{join-wraps\ 1316}#
+ #{w\ 1726}#
+ (#{syntax-object-wrap\ 1283}# #{e\ 1724}#))
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ (let ((#{t\ 1776}#
+ (#{syntax-object-module\ 1284}# #{e\ 1724}#)))
+ (if #{t\ 1776}# #{t\ 1776}# #{mod\ 1729}#))
+ #{for-car?\ 1730}#)
+ (if (self-evaluating? #{e\ 1724}#)
+ (values
+ 'constant
+ #f
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (values
+ 'other
+ #f
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)))))))
+ (#{chi-when-list\ 1330}#
+ (lambda (#{e\ 1777}# #{when-list\ 1778}# #{w\ 1779}#)
+ (letrec ((#{f\ 1780}#
+ (lambda (#{when-list\ 1781}# #{situations\ 1782}#)
+ (if (null? #{when-list\ 1781}#)
+ #{situations\ 1782}#
+ (#{f\ 1780}#
+ (cdr #{when-list\ 1781}#)
+ (cons (let ((#{x\ 1783}#
+ (car #{when-list\ 1781}#)))
+ (if (#{free-id=?\ 1320}#
+ #{x\ 1783}#
+ '#(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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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)))
+ 'compile
+ (if (#{free-id=?\ 1320}#
+ #{x\ 1783}#
+ '#(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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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)))
+ 'load
+ (if (#{free-id=?\ 1320}#
+ #{x\ 1783}#
+ '#(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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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)))
+ 'eval
+ (syntax-violation
+ 'eval-when
+ "invalid situation"
+ #{e\ 1777}#
+ (#{wrap\ 1325}#
+ #{x\ 1783}#
+ #{w\ 1779}#
+ #f))))))
+ #{situations\ 1782}#))))))
+ (#{f\ 1780}# #{when-list\ 1778}# (quote ())))))
+ (#{chi-install-global\ 1329}#
+ (lambda (#{name\ 1784}# #{e\ 1785}#)
+ (#{build-global-definition\ 1272}#
+ #f
+ #{name\ 1784}#
+ (if (let ((#{v\ 1786}#
+ (module-variable
+ (current-module)
+ #{name\ 1784}#)))
+ (if #{v\ 1786}#
+ (if (variable-bound? #{v\ 1786}#)
+ (if (macro? (variable-ref #{v\ 1786}#))
+ (not (eq? (macro-type (variable-ref #{v\ 1786}#))
+ 'syncase-macro))
+ #f)
+ #f)
+ #f))
+ (#{build-application\ 1264}#
+ #f
+ (#{build-primref\ 1274}#
+ #f
+ 'make-extended-syncase-macro)
+ (list (#{build-application\ 1264}#
+ #f
+ (#{build-primref\ 1274}# #f (quote module-ref))
+ (list (#{build-application\ 1264}#
+ #f
+ (#{build-primref\ 1274}#
+ #f
+ 'current-module)
+ '())
+ (#{build-data\ 1275}# #f #{name\ 1784}#)))
+ (#{build-data\ 1275}# #f (quote macro))
+ #{e\ 1785}#))
+ (#{build-application\ 1264}#
+ #f
+ (#{build-primref\ 1274}#
+ #f
+ 'make-syncase-macro)
+ (list (#{build-data\ 1275}# #f (quote macro))
+ #{e\ 1785}#))))))
+ (#{chi-top-sequence\ 1328}#
+ (lambda (#{body\ 1787}#
+ #{r\ 1788}#
+ #{w\ 1789}#
+ #{s\ 1790}#
+ #{m\ 1791}#
+ #{esew\ 1792}#
+ #{mod\ 1793}#)
+ (#{build-sequence\ 1276}#
+ #{s\ 1790}#
+ (letrec ((#{dobody\ 1794}#
+ (lambda (#{body\ 1795}#
+ #{r\ 1796}#
+ #{w\ 1797}#
+ #{m\ 1798}#
+ #{esew\ 1799}#
+ #{mod\ 1800}#)
+ (if (null? #{body\ 1795}#)
+ '()
+ (let ((#{first\ 1801}#
+ (#{chi-top\ 1332}#
+ (car #{body\ 1795}#)
+ #{r\ 1796}#
+ #{w\ 1797}#
+ #{m\ 1798}#
+ #{esew\ 1799}#
+ #{mod\ 1800}#)))
+ (cons #{first\ 1801}#
+ (#{dobody\ 1794}#
+ (cdr #{body\ 1795}#)
+ #{r\ 1796}#
+ #{w\ 1797}#
+ #{m\ 1798}#
+ #{esew\ 1799}#
+ #{mod\ 1800}#)))))))
+ (#{dobody\ 1794}#
+ #{body\ 1787}#
+ #{r\ 1788}#
+ #{w\ 1789}#
+ #{m\ 1791}#
+ #{esew\ 1792}#
+ #{mod\ 1793}#)))))
+ (#{chi-sequence\ 1327}#
+ (lambda (#{body\ 1802}#
+ #{r\ 1803}#
+ #{w\ 1804}#
+ #{s\ 1805}#
+ #{mod\ 1806}#)
+ (#{build-sequence\ 1276}#
+ #{s\ 1805}#
+ (letrec ((#{dobody\ 1807}#
+ (lambda (#{body\ 1808}#
+ #{r\ 1809}#
+ #{w\ 1810}#
+ #{mod\ 1811}#)
+ (if (null? #{body\ 1808}#)
+ '()
+ (let ((#{first\ 1812}#
+ (#{chi\ 1333}#
+ (car #{body\ 1808}#)
+ #{r\ 1809}#
+ #{w\ 1810}#
+ #{mod\ 1811}#)))
+ (cons #{first\ 1812}#
+ (#{dobody\ 1807}#
+ (cdr #{body\ 1808}#)
+ #{r\ 1809}#
+ #{w\ 1810}#
+ #{mod\ 1811}#)))))))
+ (#{dobody\ 1807}#
+ #{body\ 1802}#
+ #{r\ 1803}#
+ #{w\ 1804}#
+ #{mod\ 1806}#)))))
+ (#{source-wrap\ 1326}#
+ (lambda (#{x\ 1813}#
+ #{w\ 1814}#
+ #{s\ 1815}#
+ #{defmod\ 1816}#)
+ (#{wrap\ 1325}#
+ (#{decorate-source\ 1262}#
+ #{x\ 1813}#
+ #{s\ 1815}#)
+ #{w\ 1814}#
+ #{defmod\ 1816}#)))
+ (#{wrap\ 1325}#
+ (lambda (#{x\ 1817}# #{w\ 1818}# #{defmod\ 1819}#)
+ (if (if (null? (#{wrap-marks\ 1300}# #{w\ 1818}#))
+ (null? (#{wrap-subst\ 1301}# #{w\ 1818}#))
+ #f)
+ #{x\ 1817}#
+ (if (#{syntax-object?\ 1281}# #{x\ 1817}#)
+ (#{make-syntax-object\ 1280}#
+ (#{syntax-object-expression\ 1282}# #{x\ 1817}#)
+ (#{join-wraps\ 1316}#
+ #{w\ 1818}#
+ (#{syntax-object-wrap\ 1283}# #{x\ 1817}#))
+ (#{syntax-object-module\ 1284}# #{x\ 1817}#))
+ (if (null? #{x\ 1817}#)
+ #{x\ 1817}#
+ (#{make-syntax-object\ 1280}#
+ #{x\ 1817}#
+ #{w\ 1818}#
+ #{defmod\ 1819}#))))))
+ (#{bound-id-member?\ 1324}#
+ (lambda (#{x\ 1820}# #{list\ 1821}#)
+ (if (not (null? #{list\ 1821}#))
+ (let ((#{t\ 1822}#
+ (#{bound-id=?\ 1321}#
+ #{x\ 1820}#
+ (car #{list\ 1821}#))))
+ (if #{t\ 1822}#
+ #{t\ 1822}#
+ (#{bound-id-member?\ 1324}#
+ #{x\ 1820}#
+ (cdr #{list\ 1821}#))))
+ #f)))
+ (#{distinct-bound-ids?\ 1323}#
+ (lambda (#{ids\ 1823}#)
+ (letrec ((#{distinct?\ 1824}#
+ (lambda (#{ids\ 1825}#)
+ (let ((#{t\ 1826}# (null? #{ids\ 1825}#)))
+ (if #{t\ 1826}#
+ #{t\ 1826}#
+ (if (not (#{bound-id-member?\ 1324}#
+ (car #{ids\ 1825}#)
+ (cdr #{ids\ 1825}#)))
+ (#{distinct?\ 1824}# (cdr #{ids\ 1825}#))
+ #f))))))
+ (#{distinct?\ 1824}# #{ids\ 1823}#))))
+ (#{valid-bound-ids?\ 1322}#
+ (lambda (#{ids\ 1827}#)
+ (if (letrec ((#{all-ids?\ 1828}#
+ (lambda (#{ids\ 1829}#)
+ (let ((#{t\ 1830}# (null? #{ids\ 1829}#)))
+ (if #{t\ 1830}#
+ #{t\ 1830}#
+ (if (#{id?\ 1297}# (car #{ids\ 1829}#))
+ (#{all-ids?\ 1828}# (cdr #{ids\ 1829}#))
+ #f))))))
+ (#{all-ids?\ 1828}# #{ids\ 1827}#))
+ (#{distinct-bound-ids?\ 1323}# #{ids\ 1827}#)
+ #f)))
+ (#{bound-id=?\ 1321}#
+ (lambda (#{i\ 1831}# #{j\ 1832}#)
+ (if (if (#{syntax-object?\ 1281}# #{i\ 1831}#)
+ (#{syntax-object?\ 1281}# #{j\ 1832}#)
+ #f)
+ (if (eq? (#{syntax-object-expression\ 1282}# #{i\ 1831}#)
+ (#{syntax-object-expression\ 1282}# #{j\ 1832}#))
+ (#{same-marks?\ 1318}#
+ (#{wrap-marks\ 1300}#
+ (#{syntax-object-wrap\ 1283}# #{i\ 1831}#))
+ (#{wrap-marks\ 1300}#
+ (#{syntax-object-wrap\ 1283}# #{j\ 1832}#)))
+ #f)
+ (eq? #{i\ 1831}# #{j\ 1832}#))))
+ (#{free-id=?\ 1320}#
+ (lambda (#{i\ 1833}# #{j\ 1834}#)
+ (if (eq? (let ((#{x\ 1835}# #{i\ 1833}#))
+ (if (#{syntax-object?\ 1281}# #{x\ 1835}#)
+ (#{syntax-object-expression\ 1282}# #{x\ 1835}#)
+ #{x\ 1835}#))
+ (let ((#{x\ 1836}# #{j\ 1834}#))
+ (if (#{syntax-object?\ 1281}# #{x\ 1836}#)
+ (#{syntax-object-expression\ 1282}# #{x\ 1836}#)
+ #{x\ 1836}#)))
+ (eq? (#{id-var-name\ 1319}# #{i\ 1833}# (quote (())))
+ (#{id-var-name\ 1319}# #{j\ 1834}# (quote (()))))
+ #f)))
+ (#{id-var-name\ 1319}#
+ (lambda (#{id\ 1837}# #{w\ 1838}#)
+ (letrec ((#{search-vector-rib\ 1841}#
+ (lambda (#{sym\ 1847}#
+ #{subst\ 1848}#
+ #{marks\ 1849}#
+ #{symnames\ 1850}#
+ #{ribcage\ 1851}#)
+ (let ((#{n\ 1852}#
+ (vector-length #{symnames\ 1850}#)))
+ (letrec ((#{f\ 1853}#
+ (lambda (#{i\ 1854}#)
+ (if (#{fx=\ 1256}#
+ #{i\ 1854}#
+ #{n\ 1852}#)
+ (#{search\ 1839}#
+ #{sym\ 1847}#
+ (cdr #{subst\ 1848}#)
+ #{marks\ 1849}#)
+ (if (if (eq? (vector-ref
+ #{symnames\ 1850}#
+ #{i\ 1854}#)
+ #{sym\ 1847}#)
+ (#{same-marks?\ 1318}#
+ #{marks\ 1849}#
+ (vector-ref
+ (#{ribcage-marks\ 1307}#
+ #{ribcage\ 1851}#)
+ #{i\ 1854}#))
+ #f)
+ (values
+ (vector-ref
+ (#{ribcage-labels\ 1308}#
+ #{ribcage\ 1851}#)
+ #{i\ 1854}#)
+ #{marks\ 1849}#)
+ (#{f\ 1853}#
+ (#{fx+\ 1254}#
+ #{i\ 1854}#
+ 1)))))))
+ (#{f\ 1853}# 0)))))
+ (#{search-list-rib\ 1840}#
+ (lambda (#{sym\ 1855}#
+ #{subst\ 1856}#
+ #{marks\ 1857}#
+ #{symnames\ 1858}#
+ #{ribcage\ 1859}#)
+ (letrec ((#{f\ 1860}#
+ (lambda (#{symnames\ 1861}# #{i\ 1862}#)
+ (if (null? #{symnames\ 1861}#)
+ (#{search\ 1839}#
+ #{sym\ 1855}#
+ (cdr #{subst\ 1856}#)
+ #{marks\ 1857}#)
+ (if (if (eq? (car #{symnames\ 1861}#)
+ #{sym\ 1855}#)
+ (#{same-marks?\ 1318}#
+ #{marks\ 1857}#
+ (list-ref
+ (#{ribcage-marks\ 1307}#
+ #{ribcage\ 1859}#)
+ #{i\ 1862}#))
+ #f)
+ (values
+ (list-ref
+ (#{ribcage-labels\ 1308}#
+ #{ribcage\ 1859}#)
+ #{i\ 1862}#)
+ #{marks\ 1857}#)
+ (#{f\ 1860}#
+ (cdr #{symnames\ 1861}#)
+ (#{fx+\ 1254}#
+ #{i\ 1862}#
+ 1)))))))
+ (#{f\ 1860}# #{symnames\ 1858}# 0))))
+ (#{search\ 1839}#
+ (lambda (#{sym\ 1863}#
+ #{subst\ 1864}#
+ #{marks\ 1865}#)
+ (if (null? #{subst\ 1864}#)
+ (values #f #{marks\ 1865}#)
+ (let ((#{fst\ 1866}# (car #{subst\ 1864}#)))
+ (if (eq? #{fst\ 1866}# (quote shift))
+ (#{search\ 1839}#
+ #{sym\ 1863}#
+ (cdr #{subst\ 1864}#)
+ (cdr #{marks\ 1865}#))
+ (let ((#{symnames\ 1867}#
+ (#{ribcage-symnames\ 1306}#
+ #{fst\ 1866}#)))
+ (if (vector? #{symnames\ 1867}#)
+ (#{search-vector-rib\ 1841}#
+ #{sym\ 1863}#
+ #{subst\ 1864}#
+ #{marks\ 1865}#
+ #{symnames\ 1867}#
+ #{fst\ 1866}#)
+ (#{search-list-rib\ 1840}#
+ #{sym\ 1863}#
+ #{subst\ 1864}#
+ #{marks\ 1865}#
+ #{symnames\ 1867}#
+ #{fst\ 1866}#)))))))))
+ (if (symbol? #{id\ 1837}#)
+ (let ((#{t\ 1868}#
+ (call-with-values
+ (lambda ()
+ (#{search\ 1839}#
+ #{id\ 1837}#
+ (#{wrap-subst\ 1301}# #{w\ 1838}#)
+ (#{wrap-marks\ 1300}# #{w\ 1838}#)))
+ (lambda (#{x\ 1870}# . #{ignore\ 1869}#)
+ #{x\ 1870}#))))
+ (if #{t\ 1868}# #{t\ 1868}# #{id\ 1837}#))
+ (if (#{syntax-object?\ 1281}# #{id\ 1837}#)
+ (let ((#{id\ 1871}#
+ (#{syntax-object-expression\ 1282}# #{id\ 1837}#))
+ (#{w1\ 1872}#
+ (#{syntax-object-wrap\ 1283}# #{id\ 1837}#)))
+ (let ((#{marks\ 1873}#
+ (#{join-marks\ 1317}#
+ (#{wrap-marks\ 1300}# #{w\ 1838}#)
+ (#{wrap-marks\ 1300}# #{w1\ 1872}#))))
+ (call-with-values
+ (lambda ()
+ (#{search\ 1839}#
+ #{id\ 1871}#
+ (#{wrap-subst\ 1301}# #{w\ 1838}#)
+ #{marks\ 1873}#))
+ (lambda (#{new-id\ 1874}# #{marks\ 1875}#)
+ (let ((#{t\ 1876}# #{new-id\ 1874}#))
+ (if #{t\ 1876}#
+ #{t\ 1876}#
+ (let ((#{t\ 1877}#
+ (call-with-values
+ (lambda ()
+ (#{search\ 1839}#
+ #{id\ 1871}#
+ (#{wrap-subst\ 1301}#
+ #{w1\ 1872}#)
+ #{marks\ 1875}#))
+ (lambda (#{x\ 1879}#
+ .
+ #{ignore\ 1878}#)
+ #{x\ 1879}#))))
+ (if #{t\ 1877}#
+ #{t\ 1877}#
+ #{id\ 1871}#))))))))
+ (syntax-violation
+ 'id-var-name
+ "invalid id"
+ #{id\ 1837}#))))))
+ (#{same-marks?\ 1318}#
+ (lambda (#{x\ 1880}# #{y\ 1881}#)
+ (let ((#{t\ 1882}# (eq? #{x\ 1880}# #{y\ 1881}#)))
+ (if #{t\ 1882}#
+ #{t\ 1882}#
+ (if (not (null? #{x\ 1880}#))
+ (if (not (null? #{y\ 1881}#))
+ (if (eq? (car #{x\ 1880}#) (car #{y\ 1881}#))
+ (#{same-marks?\ 1318}#
+ (cdr #{x\ 1880}#)
+ (cdr #{y\ 1881}#))
+ #f)
+ #f)
+ #f)))))
+ (#{join-marks\ 1317}#
+ (lambda (#{m1\ 1883}# #{m2\ 1884}#)
+ (#{smart-append\ 1315}#
+ #{m1\ 1883}#
+ #{m2\ 1884}#)))
+ (#{join-wraps\ 1316}#
+ (lambda (#{w1\ 1885}# #{w2\ 1886}#)
+ (let ((#{m1\ 1887}#
+ (#{wrap-marks\ 1300}# #{w1\ 1885}#))
+ (#{s1\ 1888}#
+ (#{wrap-subst\ 1301}# #{w1\ 1885}#)))
+ (if (null? #{m1\ 1887}#)
+ (if (null? #{s1\ 1888}#)
+ #{w2\ 1886}#
+ (#{make-wrap\ 1299}#
+ (#{wrap-marks\ 1300}# #{w2\ 1886}#)
+ (#{smart-append\ 1315}#
+ #{s1\ 1888}#
+ (#{wrap-subst\ 1301}# #{w2\ 1886}#))))
+ (#{make-wrap\ 1299}#
+ (#{smart-append\ 1315}#
+ #{m1\ 1887}#
+ (#{wrap-marks\ 1300}# #{w2\ 1886}#))
+ (#{smart-append\ 1315}#
+ #{s1\ 1888}#
+ (#{wrap-subst\ 1301}# #{w2\ 1886}#)))))))
+ (#{smart-append\ 1315}#
+ (lambda (#{m1\ 1889}# #{m2\ 1890}#)
+ (if (null? #{m2\ 1890}#)
+ #{m1\ 1889}#
+ (append #{m1\ 1889}# #{m2\ 1890}#))))
+ (#{make-binding-wrap\ 1314}#
+ (lambda (#{ids\ 1891}# #{labels\ 1892}# #{w\ 1893}#)
+ (if (null? #{ids\ 1891}#)
+ #{w\ 1893}#
+ (#{make-wrap\ 1299}#
+ (#{wrap-marks\ 1300}# #{w\ 1893}#)
+ (cons (let ((#{labelvec\ 1894}#
+ (list->vector #{labels\ 1892}#)))
+ (let ((#{n\ 1895}#
+ (vector-length #{labelvec\ 1894}#)))
+ (let ((#{symnamevec\ 1896}#
+ (make-vector #{n\ 1895}#))
+ (#{marksvec\ 1897}#
+ (make-vector #{n\ 1895}#)))
+ (begin
+ (letrec ((#{f\ 1898}#
+ (lambda (#{ids\ 1899}# #{i\ 1900}#)
+ (if (not (null? #{ids\ 1899}#))
+ (call-with-values
+ (lambda ()
+ (#{id-sym-name&marks\ 1298}#
+ (car #{ids\ 1899}#)
+ #{w\ 1893}#))
+ (lambda (#{symname\ 1901}#
+ #{marks\ 1902}#)
+ (begin
+ (vector-set!
+ #{symnamevec\ 1896}#
+ #{i\ 1900}#
+ #{symname\ 1901}#)
+ (vector-set!
+ #{marksvec\ 1897}#
+ #{i\ 1900}#
+ #{marks\ 1902}#)
+ (#{f\ 1898}#
+ (cdr #{ids\ 1899}#)
+ (#{fx+\ 1254}#
+ #{i\ 1900}#
+ 1)))))))))
+ (#{f\ 1898}# #{ids\ 1891}# 0))
+ (#{make-ribcage\ 1304}#
+ #{symnamevec\ 1896}#
+ #{marksvec\ 1897}#
+ #{labelvec\ 1894}#)))))
+ (#{wrap-subst\ 1301}# #{w\ 1893}#))))))
+ (#{extend-ribcage!\ 1313}#
+ (lambda (#{ribcage\ 1903}# #{id\ 1904}# #{label\ 1905}#)
+ (begin
+ (#{set-ribcage-symnames!\ 1309}#
+ #{ribcage\ 1903}#
+ (cons (#{syntax-object-expression\ 1282}# #{id\ 1904}#)
+ (#{ribcage-symnames\ 1306}# #{ribcage\ 1903}#)))
+ (#{set-ribcage-marks!\ 1310}#
+ #{ribcage\ 1903}#
+ (cons (#{wrap-marks\ 1300}#
+ (#{syntax-object-wrap\ 1283}# #{id\ 1904}#))
+ (#{ribcage-marks\ 1307}# #{ribcage\ 1903}#)))
+ (#{set-ribcage-labels!\ 1311}#
+ #{ribcage\ 1903}#
+ (cons #{label\ 1905}#
+ (#{ribcage-labels\ 1308}# #{ribcage\ 1903}#))))))
+ (#{anti-mark\ 1312}#
+ (lambda (#{w\ 1906}#)
+ (#{make-wrap\ 1299}#
+ (cons #f (#{wrap-marks\ 1300}# #{w\ 1906}#))
+ (cons 'shift
+ (#{wrap-subst\ 1301}# #{w\ 1906}#)))))
+ (#{set-ribcage-labels!\ 1311}#
+ (lambda (#{x\ 1907}# #{update\ 1908}#)
+ (vector-set! #{x\ 1907}# 3 #{update\ 1908}#)))
+ (#{set-ribcage-marks!\ 1310}#
+ (lambda (#{x\ 1909}# #{update\ 1910}#)
+ (vector-set! #{x\ 1909}# 2 #{update\ 1910}#)))
+ (#{set-ribcage-symnames!\ 1309}#
+ (lambda (#{x\ 1911}# #{update\ 1912}#)
+ (vector-set! #{x\ 1911}# 1 #{update\ 1912}#)))
+ (#{ribcage-labels\ 1308}#
+ (lambda (#{x\ 1913}#) (vector-ref #{x\ 1913}# 3)))
+ (#{ribcage-marks\ 1307}#
+ (lambda (#{x\ 1914}#) (vector-ref #{x\ 1914}# 2)))
+ (#{ribcage-symnames\ 1306}#
+ (lambda (#{x\ 1915}#) (vector-ref #{x\ 1915}# 1)))
+ (#{ribcage?\ 1305}#
+ (lambda (#{x\ 1916}#)
+ (if (vector? #{x\ 1916}#)
+ (if (= (vector-length #{x\ 1916}#) 4)
+ (eq? (vector-ref #{x\ 1916}# 0) (quote ribcage))
+ #f)
+ #f)))
+ (#{make-ribcage\ 1304}#
+ (lambda (#{symnames\ 1917}#
+ #{marks\ 1918}#
+ #{labels\ 1919}#)
+ (vector
+ 'ribcage
+ #{symnames\ 1917}#
+ #{marks\ 1918}#
+ #{labels\ 1919}#)))
+ (#{gen-labels\ 1303}#
+ (lambda (#{ls\ 1920}#)
+ (if (null? #{ls\ 1920}#)
+ '()
+ (cons (#{gen-label\ 1302}#)
+ (#{gen-labels\ 1303}# (cdr #{ls\ 1920}#))))))
+ (#{gen-label\ 1302}# (lambda () (string #\i)))
+ (#{wrap-subst\ 1301}# cdr)
+ (#{wrap-marks\ 1300}# car)
+ (#{make-wrap\ 1299}# cons)
+ (#{id-sym-name&marks\ 1298}#
+ (lambda (#{x\ 1921}# #{w\ 1922}#)
+ (if (#{syntax-object?\ 1281}# #{x\ 1921}#)
+ (values
+ (#{syntax-object-expression\ 1282}# #{x\ 1921}#)
+ (#{join-marks\ 1317}#
+ (#{wrap-marks\ 1300}# #{w\ 1922}#)
+ (#{wrap-marks\ 1300}#
+ (#{syntax-object-wrap\ 1283}# #{x\ 1921}#))))
+ (values
+ #{x\ 1921}#
+ (#{wrap-marks\ 1300}# #{w\ 1922}#)))))
+ (#{id?\ 1297}#
+ (lambda (#{x\ 1923}#)
+ (if (symbol? #{x\ 1923}#)
+ #t
+ (if (#{syntax-object?\ 1281}# #{x\ 1923}#)
+ (symbol?
+ (#{syntax-object-expression\ 1282}# #{x\ 1923}#))
+ #f))))
+ (#{nonsymbol-id?\ 1296}#
+ (lambda (#{x\ 1924}#)
+ (if (#{syntax-object?\ 1281}# #{x\ 1924}#)
+ (symbol?
+ (#{syntax-object-expression\ 1282}# #{x\ 1924}#))
+ #f)))
+ (#{global-extend\ 1295}#
+ (lambda (#{type\ 1925}# #{sym\ 1926}# #{val\ 1927}#)
+ (#{put-global-definition-hook\ 1260}#
+ #{sym\ 1926}#
+ #{type\ 1925}#
+ #{val\ 1927}#)))
+ (#{lookup\ 1294}#
+ (lambda (#{x\ 1928}# #{r\ 1929}# #{mod\ 1930}#)
+ (let ((#{t\ 1931}# (assq #{x\ 1928}# #{r\ 1929}#)))
+ (if #{t\ 1931}#
+ (cdr #{t\ 1931}#)
+ (if (symbol? #{x\ 1928}#)
+ (let ((#{t\ 1932}#
+ (#{get-global-definition-hook\ 1261}#
+ #{x\ 1928}#
+ #{mod\ 1930}#)))
+ (if #{t\ 1932}# #{t\ 1932}# (quote (global))))
+ '(displaced-lexical))))))
+ (#{macros-only-env\ 1293}#
+ (lambda (#{r\ 1933}#)
+ (if (null? #{r\ 1933}#)
+ '()
+ (let ((#{a\ 1934}# (car #{r\ 1933}#)))
+ (if (eq? (cadr #{a\ 1934}#) (quote macro))
+ (cons #{a\ 1934}#
+ (#{macros-only-env\ 1293}# (cdr #{r\ 1933}#)))
+ (#{macros-only-env\ 1293}# (cdr #{r\ 1933}#)))))))
+ (#{extend-var-env\ 1292}#
+ (lambda (#{labels\ 1935}# #{vars\ 1936}# #{r\ 1937}#)
+ (if (null? #{labels\ 1935}#)
+ #{r\ 1937}#
+ (#{extend-var-env\ 1292}#
+ (cdr #{labels\ 1935}#)
+ (cdr #{vars\ 1936}#)
+ (cons (cons (car #{labels\ 1935}#)
+ (cons (quote lexical) (car #{vars\ 1936}#)))
+ #{r\ 1937}#)))))
+ (#{extend-env\ 1291}#
+ (lambda (#{labels\ 1938}# #{bindings\ 1939}# #{r\ 1940}#)
+ (if (null? #{labels\ 1938}#)
+ #{r\ 1940}#
+ (#{extend-env\ 1291}#
+ (cdr #{labels\ 1938}#)
+ (cdr #{bindings\ 1939}#)
+ (cons (cons (car #{labels\ 1938}#)
+ (car #{bindings\ 1939}#))
+ #{r\ 1940}#)))))
+ (#{binding-value\ 1290}# cdr)
+ (#{binding-type\ 1289}# car)
+ (#{source-annotation\ 1288}#
+ (lambda (#{x\ 1941}#)
+ (if (#{syntax-object?\ 1281}# #{x\ 1941}#)
+ (#{source-annotation\ 1288}#
+ (#{syntax-object-expression\ 1282}# #{x\ 1941}#))
+ (if (pair? #{x\ 1941}#)
+ (let ((#{props\ 1942}# (source-properties #{x\ 1941}#)))
+ (if (pair? #{props\ 1942}#) #{props\ 1942}# #f))
+ #f))))
+ (#{set-syntax-object-module!\ 1287}#
+ (lambda (#{x\ 1943}# #{update\ 1944}#)
+ (vector-set! #{x\ 1943}# 3 #{update\ 1944}#)))
+ (#{set-syntax-object-wrap!\ 1286}#
+ (lambda (#{x\ 1945}# #{update\ 1946}#)
+ (vector-set! #{x\ 1945}# 2 #{update\ 1946}#)))
+ (#{set-syntax-object-expression!\ 1285}#
+ (lambda (#{x\ 1947}# #{update\ 1948}#)
+ (vector-set! #{x\ 1947}# 1 #{update\ 1948}#)))
+ (#{syntax-object-module\ 1284}#
+ (lambda (#{x\ 1949}#) (vector-ref #{x\ 1949}# 3)))
+ (#{syntax-object-wrap\ 1283}#
+ (lambda (#{x\ 1950}#) (vector-ref #{x\ 1950}# 2)))
+ (#{syntax-object-expression\ 1282}#
+ (lambda (#{x\ 1951}#) (vector-ref #{x\ 1951}# 1)))
+ (#{syntax-object?\ 1281}#
+ (lambda (#{x\ 1952}#)
+ (if (vector? #{x\ 1952}#)
+ (if (= (vector-length #{x\ 1952}#) 4)
+ (eq? (vector-ref #{x\ 1952}# 0)
+ 'syntax-object)
+ #f)
+ #f)))
+ (#{make-syntax-object\ 1280}#
+ (lambda (#{expression\ 1953}#
+ #{wrap\ 1954}#
+ #{module\ 1955}#)
+ (vector
+ 'syntax-object
+ #{expression\ 1953}#
+ #{wrap\ 1954}#
+ #{module\ 1955}#)))
+ (#{build-letrec\ 1279}#
+ (lambda (#{src\ 1956}#
+ #{ids\ 1957}#
+ #{vars\ 1958}#
+ #{val-exps\ 1959}#
+ #{body-exp\ 1960}#)
+ (if (null? #{vars\ 1958}#)
+ #{body-exp\ 1960}#
+ (let ((#{atom-key\ 1961}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1961}# (quote (c)))
+ (begin
+ (for-each
+ #{maybe-name-value!\ 1271}#
+ #{ids\ 1957}#
+ #{val-exps\ 1959}#)
+ ((@ (language tree-il) make-letrec)
+ #{src\ 1956}#
+ #{ids\ 1957}#
+ #{vars\ 1958}#
+ #{val-exps\ 1959}#
+ #{body-exp\ 1960}#))
+ (#{decorate-source\ 1262}#
+ (list 'letrec
+ (map list #{vars\ 1958}# #{val-exps\ 1959}#)
+ #{body-exp\ 1960}#)
+ #{src\ 1956}#))))))
+ (#{build-named-let\ 1278}#
+ (lambda (#{src\ 1962}#
+ #{ids\ 1963}#
+ #{vars\ 1964}#
+ #{val-exps\ 1965}#
+ #{body-exp\ 1966}#)
+ (let ((#{f\ 1967}# (car #{vars\ 1964}#))
+ (#{f-name\ 1968}# (car #{ids\ 1963}#))
+ (#{vars\ 1969}# (cdr #{vars\ 1964}#))
+ (#{ids\ 1970}# (cdr #{ids\ 1963}#)))
+ (let ((#{atom-key\ 1971}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1971}# (quote (c)))
+ (let ((#{proc\ 1972}#
+ (#{build-lambda\ 1273}#
+ #{src\ 1962}#
+ #{ids\ 1970}#
+ #{vars\ 1969}#
+ #f
+ #{body-exp\ 1966}#)))
+ (begin
+ (#{maybe-name-value!\ 1271}#
+ #{f-name\ 1968}#
+ #{proc\ 1972}#)
+ (for-each
+ #{maybe-name-value!\ 1271}#
+ #{ids\ 1970}#
+ #{val-exps\ 1965}#)
+ ((@ (language tree-il) make-letrec)
+ #{src\ 1962}#
+ (list #{f-name\ 1968}#)
+ (list #{f\ 1967}#)
+ (list #{proc\ 1972}#)
+ (#{build-application\ 1264}#
+ #{src\ 1962}#
+ (#{build-lexical-reference\ 1266}#
+ 'fun
+ #{src\ 1962}#
+ #{f-name\ 1968}#
+ #{f\ 1967}#)
+ #{val-exps\ 1965}#))))
+ (#{decorate-source\ 1262}#
+ (list 'let
+ #{f\ 1967}#
+ (map list #{vars\ 1969}# #{val-exps\ 1965}#)
+ #{body-exp\ 1966}#)
+ #{src\ 1962}#))))))
+ (#{build-let\ 1277}#
+ (lambda (#{src\ 1973}#
+ #{ids\ 1974}#
+ #{vars\ 1975}#
+ #{val-exps\ 1976}#
+ #{body-exp\ 1977}#)
+ (if (null? #{vars\ 1975}#)
+ #{body-exp\ 1977}#
+ (let ((#{atom-key\ 1978}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1978}# (quote (c)))
+ (begin
+ (for-each
+ #{maybe-name-value!\ 1271}#
+ #{ids\ 1974}#
+ #{val-exps\ 1976}#)
+ ((@ (language tree-il) make-let)
+ #{src\ 1973}#
+ #{ids\ 1974}#
+ #{vars\ 1975}#
+ #{val-exps\ 1976}#
+ #{body-exp\ 1977}#))
+ (#{decorate-source\ 1262}#
+ (list 'let
+ (map list #{vars\ 1975}# #{val-exps\ 1976}#)
+ #{body-exp\ 1977}#)
+ #{src\ 1973}#))))))
+ (#{build-sequence\ 1276}#
+ (lambda (#{src\ 1979}# #{exps\ 1980}#)
+ (if (null? (cdr #{exps\ 1980}#))
+ (car #{exps\ 1980}#)
+ (let ((#{atom-key\ 1981}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1981}# (quote (c)))
+ ((@ (language tree-il) make-sequence)
+ #{src\ 1979}#
+ #{exps\ 1980}#)
+ (#{decorate-source\ 1262}#
+ (cons (quote begin) #{exps\ 1980}#)
+ #{src\ 1979}#))))))
+ (#{build-data\ 1275}#
+ (lambda (#{src\ 1982}# #{exp\ 1983}#)
+ (let ((#{atom-key\ 1984}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1984}# (quote (c)))
+ ((@ (language tree-il) make-const)
+ #{src\ 1982}#
+ #{exp\ 1983}#)
+ (#{decorate-source\ 1262}#
+ (if (if (self-evaluating? #{exp\ 1983}#)
+ (not (vector? #{exp\ 1983}#))
+ #f)
+ #{exp\ 1983}#
+ (list (quote quote) #{exp\ 1983}#))
+ #{src\ 1982}#)))))
+ (#{build-primref\ 1274}#
+ (lambda (#{src\ 1985}# #{name\ 1986}#)
+ (if (equal?
+ (module-name (current-module))
+ '(guile))
+ (let ((#{atom-key\ 1987}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1987}# (quote (c)))
+ ((@ (language tree-il) make-toplevel-ref)
+ #{src\ 1985}#
+ #{name\ 1986}#)
+ (#{decorate-source\ 1262}#
+ #{name\ 1986}#
+ #{src\ 1985}#)))
+ (let ((#{atom-key\ 1988}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1988}# (quote (c)))
+ ((@ (language tree-il) make-module-ref)
+ #{src\ 1985}#
+ '(guile)
+ #{name\ 1986}#
+ #f)
+ (#{decorate-source\ 1262}#
+ (list (quote @@) (quote (guile)) #{name\ 1986}#)
+ #{src\ 1985}#))))))
+ (#{build-lambda\ 1273}#
+ (lambda (#{src\ 1989}#
+ #{ids\ 1990}#
+ #{vars\ 1991}#
+ #{docstring\ 1992}#
+ #{exp\ 1993}#)
+ (let ((#{atom-key\ 1994}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1994}# (quote (c)))
+ ((@ (language tree-il) make-lambda)
+ #{src\ 1989}#
+ #{ids\ 1990}#
+ #{vars\ 1991}#
+ (if #{docstring\ 1992}#
+ (list (cons (quote documentation) #{docstring\ 1992}#))
+ '())
+ #{exp\ 1993}#)
+ (#{decorate-source\ 1262}#
+ (cons 'lambda
+ (cons #{vars\ 1991}#
+ (append
+ (if #{docstring\ 1992}#
+ (list #{docstring\ 1992}#)
+ '())
+ (list #{exp\ 1993}#))))
+ #{src\ 1989}#)))))
+ (#{build-global-definition\ 1272}#
+ (lambda (#{source\ 1995}# #{var\ 1996}# #{exp\ 1997}#)
+ (let ((#{atom-key\ 1998}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1998}# (quote (c)))
+ (begin
+ (#{maybe-name-value!\ 1271}#
+ #{var\ 1996}#
+ #{exp\ 1997}#)
+ ((@ (language tree-il) make-toplevel-define)
+ #{source\ 1995}#
+ #{var\ 1996}#
+ #{exp\ 1997}#))
+ (#{decorate-source\ 1262}#
+ (list (quote define) #{var\ 1996}# #{exp\ 1997}#)
+ #{source\ 1995}#)))))
+ (#{maybe-name-value!\ 1271}#
+ (lambda (#{name\ 1999}# #{val\ 2000}#)
+ (if ((@ (language tree-il) lambda?) #{val\ 2000}#)
+ (let ((#{meta\ 2001}#
+ ((@ (language tree-il) lambda-meta)
+ #{val\ 2000}#)))
+ (if (not (assq (quote name) #{meta\ 2001}#))
+ ((setter (@ (language tree-il) lambda-meta))
+ #{val\ 2000}#
+ (acons 'name
+ #{name\ 1999}#
+ #{meta\ 2001}#)))))))
+ (#{build-global-assignment\ 1270}#
+ (lambda (#{source\ 2002}#
+ #{var\ 2003}#
+ #{exp\ 2004}#
+ #{mod\ 2005}#)
+ (#{analyze-variable\ 1268}#
+ #{mod\ 2005}#
+ #{var\ 2003}#
+ (lambda (#{mod\ 2006}# #{var\ 2007}# #{public?\ 2008}#)
+ (let ((#{atom-key\ 2009}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2009}# (quote (c)))
+ ((@ (language tree-il) make-module-set)
+ #{source\ 2002}#
+ #{mod\ 2006}#
+ #{var\ 2007}#
+ #{public?\ 2008}#
+ #{exp\ 2004}#)
+ (#{decorate-source\ 1262}#
+ (list 'set!
+ (list (if #{public?\ 2008}#
+ '@
+ '@@)
+ #{mod\ 2006}#
+ #{var\ 2007}#)
+ #{exp\ 2004}#)
+ #{source\ 2002}#))))
+ (lambda (#{var\ 2010}#)
+ (let ((#{atom-key\ 2011}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2011}# (quote (c)))
+ ((@ (language tree-il) make-toplevel-set)
+ #{source\ 2002}#
+ #{var\ 2010}#
+ #{exp\ 2004}#)
+ (#{decorate-source\ 1262}#
+ (list (quote set!) #{var\ 2010}# #{exp\ 2004}#)
+ #{source\ 2002}#)))))))
+ (#{build-global-reference\ 1269}#
+ (lambda (#{source\ 2012}# #{var\ 2013}# #{mod\ 2014}#)
+ (#{analyze-variable\ 1268}#
+ #{mod\ 2014}#
+ #{var\ 2013}#
+ (lambda (#{mod\ 2015}# #{var\ 2016}# #{public?\ 2017}#)
+ (let ((#{atom-key\ 2018}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2018}# (quote (c)))
+ ((@ (language tree-il) make-module-ref)
+ #{source\ 2012}#
+ #{mod\ 2015}#
+ #{var\ 2016}#
+ #{public?\ 2017}#)
+ (#{decorate-source\ 1262}#
+ (list (if #{public?\ 2017}# (quote @) (quote @@))
+ #{mod\ 2015}#
+ #{var\ 2016}#)
+ #{source\ 2012}#))))
+ (lambda (#{var\ 2019}#)
+ (let ((#{atom-key\ 2020}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2020}# (quote (c)))
+ ((@ (language tree-il) make-toplevel-ref)
+ #{source\ 2012}#
+ #{var\ 2019}#)
+ (#{decorate-source\ 1262}#
+ #{var\ 2019}#
+ #{source\ 2012}#)))))))
+ (#{analyze-variable\ 1268}#
+ (lambda (#{mod\ 2021}#
+ #{var\ 2022}#
+ #{modref-cont\ 2023}#
+ #{bare-cont\ 2024}#)
+ (if (not #{mod\ 2021}#)
+ (#{bare-cont\ 2024}# #{var\ 2022}#)
+ (let ((#{kind\ 2025}# (car #{mod\ 2021}#))
+ (#{mod\ 2026}# (cdr #{mod\ 2021}#)))
+ (if (memv #{kind\ 2025}# (quote (public)))
+ (#{modref-cont\ 2023}#
+ #{mod\ 2026}#
+ #{var\ 2022}#
+ #t)
+ (if (memv #{kind\ 2025}# (quote (private)))
+ (if (not (equal?
+ #{mod\ 2026}#
+ (module-name (current-module))))
+ (#{modref-cont\ 2023}#
+ #{mod\ 2026}#
+ #{var\ 2022}#
+ #f)
+ (#{bare-cont\ 2024}# #{var\ 2022}#))
+ (if (memv #{kind\ 2025}# (quote (bare)))
+ (#{bare-cont\ 2024}# #{var\ 2022}#)
+ (if (memv #{kind\ 2025}# (quote (hygiene)))
+ (if (if (not (equal?
+ #{mod\ 2026}#
+ (module-name (current-module))))
+ (module-variable
+ (resolve-module #{mod\ 2026}#)
+ #{var\ 2022}#)
+ #f)
+ (#{modref-cont\ 2023}#
+ #{mod\ 2026}#
+ #{var\ 2022}#
+ #f)
+ (#{bare-cont\ 2024}# #{var\ 2022}#))
+ (syntax-violation
+ #f
+ "bad module kind"
+ #{var\ 2022}#
+ #{mod\ 2026}#)))))))))
+ (#{build-lexical-assignment\ 1267}#
+ (lambda (#{source\ 2027}#
+ #{name\ 2028}#
+ #{var\ 2029}#
+ #{exp\ 2030}#)
+ (let ((#{atom-key\ 2031}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2031}# (quote (c)))
+ ((@ (language tree-il) make-lexical-set)
+ #{source\ 2027}#
+ #{name\ 2028}#
+ #{var\ 2029}#
+ #{exp\ 2030}#)
+ (#{decorate-source\ 1262}#
+ (list (quote set!) #{var\ 2029}# #{exp\ 2030}#)
+ #{source\ 2027}#)))))
+ (#{build-lexical-reference\ 1266}#
+ (lambda (#{type\ 2032}#
+ #{source\ 2033}#
+ #{name\ 2034}#
+ #{var\ 2035}#)
+ (let ((#{atom-key\ 2036}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2036}# (quote (c)))
+ ((@ (language tree-il) make-lexical-ref)
+ #{source\ 2033}#
+ #{name\ 2034}#
+ #{var\ 2035}#)
+ (#{decorate-source\ 1262}#
+ #{var\ 2035}#
+ #{source\ 2033}#)))))
+ (#{build-conditional\ 1265}#
+ (lambda (#{source\ 2037}#
+ #{test-exp\ 2038}#
+ #{then-exp\ 2039}#
+ #{else-exp\ 2040}#)
+ (let ((#{atom-key\ 2041}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2041}# (quote (c)))
+ ((@ (language tree-il) make-conditional)
+ #{source\ 2037}#
+ #{test-exp\ 2038}#
+ #{then-exp\ 2039}#
+ #{else-exp\ 2040}#)
+ (#{decorate-source\ 1262}#
+ (if (equal? #{else-exp\ 2040}# (quote (if #f #f)))
+ (list 'if
+ #{test-exp\ 2038}#
+ #{then-exp\ 2039}#)
+ (list 'if
+ #{test-exp\ 2038}#
+ #{then-exp\ 2039}#
+ #{else-exp\ 2040}#))
+ #{source\ 2037}#)))))
+ (#{build-application\ 1264}#
+ (lambda (#{source\ 2042}#
+ #{fun-exp\ 2043}#
+ #{arg-exps\ 2044}#)
+ (let ((#{atom-key\ 2045}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2045}# (quote (c)))
+ ((@ (language tree-il) make-application)
+ #{source\ 2042}#
+ #{fun-exp\ 2043}#
+ #{arg-exps\ 2044}#)
+ (#{decorate-source\ 1262}#
+ (cons #{fun-exp\ 2043}# #{arg-exps\ 2044}#)
+ #{source\ 2042}#)))))
+ (#{build-void\ 1263}#
+ (lambda (#{source\ 2046}#)
+ (let ((#{atom-key\ 2047}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2047}# (quote (c)))
+ ((@ (language tree-il) make-void)
+ #{source\ 2046}#)
+ (#{decorate-source\ 1262}#
+ '(if #f #f)
+ #{source\ 2046}#)))))
+ (#{decorate-source\ 1262}#
+ (lambda (#{e\ 2048}# #{s\ 2049}#)
+ (begin
+ (if (if (pair? #{e\ 2048}#) #{s\ 2049}# #f)
+ (set-source-properties! #{e\ 2048}# #{s\ 2049}#))
+ #{e\ 2048}#)))
+ (#{get-global-definition-hook\ 1261}#
+ (lambda (#{symbol\ 2050}# #{module\ 2051}#)
+ (begin
+ (if (if (not #{module\ 2051}#) (current-module) #f)
+ (warn "module system is booted, we should have a module"
+ #{symbol\ 2050}#))
+ (let ((#{v\ 2052}#
+ (module-variable
+ (if #{module\ 2051}#
+ (resolve-module (cdr #{module\ 2051}#))
+ (current-module))
+ #{symbol\ 2050}#)))
+ (if #{v\ 2052}#
+ (if (variable-bound? #{v\ 2052}#)
+ (let ((#{val\ 2053}# (variable-ref #{v\ 2052}#)))
+ (if (macro? #{val\ 2053}#)
+ (if (syncase-macro-type #{val\ 2053}#)
+ (cons (syncase-macro-type #{val\ 2053}#)
+ (syncase-macro-binding #{val\ 2053}#))
+ #f)
+ #f))
+ #f)
+ #f)))))
+ (#{put-global-definition-hook\ 1260}#
+ (lambda (#{symbol\ 2054}# #{type\ 2055}# #{val\ 2056}#)
+ (let ((#{existing\ 2057}#
+ (let ((#{v\ 2058}#
+ (module-variable
+ (current-module)
+ #{symbol\ 2054}#)))
+ (if #{v\ 2058}#
+ (if (variable-bound? #{v\ 2058}#)
+ (let ((#{val\ 2059}# (variable-ref #{v\ 2058}#)))
+ (if (macro? #{val\ 2059}#)
+ (if (not (syncase-macro-type #{val\ 2059}#))
+ #{val\ 2059}#
+ #f)
+ #f))
+ #f)
+ #f))))
+ (module-define!
+ (current-module)
+ #{symbol\ 2054}#
+ (if #{existing\ 2057}#
+ (make-extended-syncase-macro
+ #{existing\ 2057}#
+ #{type\ 2055}#
+ #{val\ 2056}#)
+ (make-syncase-macro #{type\ 2055}# #{val\ 2056}#))))))
+ (#{local-eval-hook\ 1259}#
+ (lambda (#{x\ 2060}# #{mod\ 2061}#)
+ (primitive-eval
+ (list #{noexpand\ 1252}#
+ (let ((#{atom-key\ 2062}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2062}# (quote (c)))
+ ((@ (language tree-il) tree-il->scheme)
+ #{x\ 2060}#)
+ #{x\ 2060}#))))))
+ (#{top-level-eval-hook\ 1258}#
+ (lambda (#{x\ 2063}# #{mod\ 2064}#)
+ (primitive-eval
+ (list #{noexpand\ 1252}#
+ (let ((#{atom-key\ 2065}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2065}# (quote (c)))
+ ((@ (language tree-il) tree-il->scheme)
+ #{x\ 2063}#)
+ #{x\ 2063}#))))))
+ (#{fx<\ 1257}# <)
+ (#{fx=\ 1256}# =)
+ (#{fx-\ 1255}# -)
+ (#{fx+\ 1254}# +)
+ (#{*mode*\ 1253}# (make-fluid))
+ (#{noexpand\ 1252}# "noexpand"))
+ (begin
+ (#{global-extend\ 1295}#
+ 'local-syntax
+ 'letrec-syntax
+ #t)
+ (#{global-extend\ 1295}#
+ 'local-syntax
+ 'let-syntax
+ #f)
+ (#{global-extend\ 1295}#
+ 'core
+ 'fluid-let-syntax
+ (lambda (#{e\ 2066}#
+ #{r\ 2067}#
+ #{w\ 2068}#
+ #{s\ 2069}#
+ #{mod\ 2070}#)
+ ((lambda (#{tmp\ 2071}#)
+ ((lambda (#{tmp\ 2072}#)
+ (if (if #{tmp\ 2072}#
+ (apply (lambda (#{_\ 2073}#
+ #{var\ 2074}#
+ #{val\ 2075}#
+ #{e1\ 2076}#
+ #{e2\ 2077}#)
+ (#{valid-bound-ids?\ 1322}# #{var\ 2074}#))
+ #{tmp\ 2072}#)
+ #f)
+ (apply (lambda (#{_\ 2079}#
+ #{var\ 2080}#
+ #{val\ 2081}#
+ #{e1\ 2082}#
+ #{e2\ 2083}#)
+ (let ((#{names\ 2084}#
+ (map (lambda (#{x\ 2085}#)
+ (#{id-var-name\ 1319}#
+ #{x\ 2085}#
+ #{w\ 2068}#))
+ #{var\ 2080}#)))
+ (begin
+ (for-each
+ (lambda (#{id\ 2087}# #{n\ 2088}#)
+ (let ((#{atom-key\ 2089}#
+ (#{binding-type\ 1289}#
+ (#{lookup\ 1294}#
+ #{n\ 2088}#
+ #{r\ 2067}#
+ #{mod\ 2070}#))))
+ (if (memv #{atom-key\ 2089}#
+ '(displaced-lexical))
+ (syntax-violation
+ 'fluid-let-syntax
+ "identifier out of context"
+ #{e\ 2066}#
+ (#{source-wrap\ 1326}#
+ #{id\ 2087}#
+ #{w\ 2068}#
+ #{s\ 2069}#
+ #{mod\ 2070}#)))))
+ #{var\ 2080}#
+ #{names\ 2084}#)
+ (#{chi-body\ 1337}#
+ (cons #{e1\ 2082}# #{e2\ 2083}#)
+ (#{source-wrap\ 1326}#
+ #{e\ 2066}#
+ #{w\ 2068}#
+ #{s\ 2069}#
+ #{mod\ 2070}#)
+ (#{extend-env\ 1291}#
+ #{names\ 2084}#
+ (let ((#{trans-r\ 2092}#
+ (#{macros-only-env\ 1293}#
+ #{r\ 2067}#)))
+ (map (lambda (#{x\ 2093}#)
+ (cons 'macro
+ (#{eval-local-transformer\ 1340}#
+ (#{chi\ 1333}#
+ #{x\ 2093}#
+ #{trans-r\ 2092}#
+ #{w\ 2068}#
+ #{mod\ 2070}#)
+ #{mod\ 2070}#)))
+ #{val\ 2081}#))
+ #{r\ 2067}#)
+ #{w\ 2068}#
+ #{mod\ 2070}#))))
+ #{tmp\ 2072}#)
+ ((lambda (#{_\ 2095}#)
+ (syntax-violation
+ 'fluid-let-syntax
+ "bad syntax"
+ (#{source-wrap\ 1326}#
+ #{e\ 2066}#
+ #{w\ 2068}#
+ #{s\ 2069}#
+ #{mod\ 2070}#)))
+ #{tmp\ 2071}#)))
+ ($sc-dispatch
+ #{tmp\ 2071}#
+ '(any #(each (any any)) any . each-any))))
+ #{e\ 2066}#)))
+ (#{global-extend\ 1295}#
+ 'core
+ 'quote
+ (lambda (#{e\ 2096}#
+ #{r\ 2097}#
+ #{w\ 2098}#
+ #{s\ 2099}#
+ #{mod\ 2100}#)
+ ((lambda (#{tmp\ 2101}#)
+ ((lambda (#{tmp\ 2102}#)
+ (if #{tmp\ 2102}#
+ (apply (lambda (#{_\ 2103}# #{e\ 2104}#)
+ (#{build-data\ 1275}#
+ #{s\ 2099}#
+ (#{strip\ 1343}# #{e\ 2104}# #{w\ 2098}#)))
+ #{tmp\ 2102}#)
+ ((lambda (#{_\ 2105}#)
+ (syntax-violation
+ 'quote
+ "bad syntax"
+ (#{source-wrap\ 1326}#
+ #{e\ 2096}#
+ #{w\ 2098}#
+ #{s\ 2099}#
+ #{mod\ 2100}#)))
+ #{tmp\ 2101}#)))
+ ($sc-dispatch #{tmp\ 2101}# (quote (any any)))))
+ #{e\ 2096}#)))
+ (#{global-extend\ 1295}#
+ 'core
+ 'syntax
+ (letrec ((#{regen\ 2113}#
+ (lambda (#{x\ 2114}#)
+ (let ((#{atom-key\ 2115}# (car #{x\ 2114}#)))
+ (if (memv #{atom-key\ 2115}# (quote (ref)))
+ (#{build-lexical-reference\ 1266}#
+ 'value
+ #f
+ (cadr #{x\ 2114}#)
+ (cadr #{x\ 2114}#))
+ (if (memv #{atom-key\ 2115}# (quote (primitive)))
+ (#{build-primref\ 1274}# #f (cadr #{x\ 2114}#))
+ (if (memv #{atom-key\ 2115}# (quote (quote)))
+ (#{build-data\ 1275}# #f (cadr #{x\ 2114}#))
+ (if (memv #{atom-key\ 2115}# (quote (lambda)))
+ (#{build-lambda\ 1273}#
+ #f
+ (cadr #{x\ 2114}#)
+ (cadr #{x\ 2114}#)
+ #f
+ (#{regen\ 2113}# (caddr #{x\ 2114}#)))
+ (#{build-application\ 1264}#
+ #f
+ (#{build-primref\ 1274}# #f (car #{x\ 2114}#))
+ (map #{regen\ 2113}#
+ (cdr #{x\ 2114}#))))))))))
+ (#{gen-vector\ 2112}#
+ (lambda (#{x\ 2116}#)
+ (if (eq? (car #{x\ 2116}#) (quote list))
+ (cons (quote vector) (cdr #{x\ 2116}#))
+ (if (eq? (car #{x\ 2116}#) (quote quote))
+ (list 'quote
+ (list->vector (cadr #{x\ 2116}#)))
+ (list (quote list->vector) #{x\ 2116}#)))))
+ (#{gen-append\ 2111}#
+ (lambda (#{x\ 2117}# #{y\ 2118}#)
+ (if (equal? #{y\ 2118}# (quote (quote ())))
+ #{x\ 2117}#
+ (list (quote append) #{x\ 2117}# #{y\ 2118}#))))
+ (#{gen-cons\ 2110}#
+ (lambda (#{x\ 2119}# #{y\ 2120}#)
+ (let ((#{atom-key\ 2121}# (car #{y\ 2120}#)))
+ (if (memv #{atom-key\ 2121}# (quote (quote)))
+ (if (eq? (car #{x\ 2119}#) (quote quote))
+ (list 'quote
+ (cons (cadr #{x\ 2119}#) (cadr #{y\ 2120}#)))
+ (if (eq? (cadr #{y\ 2120}#) (quote ()))
+ (list (quote list) #{x\ 2119}#)
+ (list (quote cons) #{x\ 2119}# #{y\ 2120}#)))
+ (if (memv #{atom-key\ 2121}# (quote (list)))
+ (cons 'list
+ (cons #{x\ 2119}# (cdr #{y\ 2120}#)))
+ (list (quote cons) #{x\ 2119}# #{y\ 2120}#))))))
+ (#{gen-map\ 2109}#
+ (lambda (#{e\ 2122}# #{map-env\ 2123}#)
+ (let ((#{formals\ 2124}# (map cdr #{map-env\ 2123}#))
+ (#{actuals\ 2125}#
+ (map (lambda (#{x\ 2126}#)
+ (list (quote ref) (car #{x\ 2126}#)))
+ #{map-env\ 2123}#)))
+ (if (eq? (car #{e\ 2122}#) (quote ref))
+ (car #{actuals\ 2125}#)
+ (if (and-map
+ (lambda (#{x\ 2127}#)
+ (if (eq? (car #{x\ 2127}#) (quote ref))
+ (memq (cadr #{x\ 2127}#) #{formals\ 2124}#)
+ #f))
+ (cdr #{e\ 2122}#))
+ (cons 'map
+ (cons (list 'primitive
+ (car #{e\ 2122}#))
+ (map (let ((#{r\ 2128}#
+ (map cons
+ #{formals\ 2124}#
+ #{actuals\ 2125}#)))
+ (lambda (#{x\ 2129}#)
+ (cdr (assq (cadr #{x\ 2129}#)
+ #{r\ 2128}#))))
+ (cdr #{e\ 2122}#))))
+ (cons 'map
+ (cons (list 'lambda
+ #{formals\ 2124}#
+ #{e\ 2122}#)
+ #{actuals\ 2125}#)))))))
+ (#{gen-mappend\ 2108}#
+ (lambda (#{e\ 2130}# #{map-env\ 2131}#)
+ (list 'apply
+ '(primitive append)
+ (#{gen-map\ 2109}# #{e\ 2130}# #{map-env\ 2131}#))))
+ (#{gen-ref\ 2107}#
+ (lambda (#{src\ 2132}#
+ #{var\ 2133}#
+ #{level\ 2134}#
+ #{maps\ 2135}#)
+ (if (#{fx=\ 1256}# #{level\ 2134}# 0)
+ (values #{var\ 2133}# #{maps\ 2135}#)
+ (if (null? #{maps\ 2135}#)
+ (syntax-violation
+ 'syntax
+ "missing ellipsis"
+ #{src\ 2132}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-ref\ 2107}#
+ #{src\ 2132}#
+ #{var\ 2133}#
+ (#{fx-\ 1255}# #{level\ 2134}# 1)
+ (cdr #{maps\ 2135}#)))
+ (lambda (#{outer-var\ 2136}# #{outer-maps\ 2137}#)
+ (let ((#{b\ 2138}#
+ (assq #{outer-var\ 2136}#
+ (car #{maps\ 2135}#))))
+ (if #{b\ 2138}#
+ (values (cdr #{b\ 2138}#) #{maps\ 2135}#)
+ (let ((#{inner-var\ 2139}#
+ (#{gen-var\ 1344}# (quote tmp))))
+ (values
+ #{inner-var\ 2139}#
+ (cons (cons (cons #{outer-var\ 2136}#
+ #{inner-var\ 2139}#)
+ (car #{maps\ 2135}#))
+ #{outer-maps\ 2137}#)))))))))))
+ (#{gen-syntax\ 2106}#
+ (lambda (#{src\ 2140}#
+ #{e\ 2141}#
+ #{r\ 2142}#
+ #{maps\ 2143}#
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#)
+ (if (#{id?\ 1297}# #{e\ 2141}#)
+ (let ((#{label\ 2146}#
+ (#{id-var-name\ 1319}#
+ #{e\ 2141}#
+ '(()))))
+ (let ((#{b\ 2147}#
+ (#{lookup\ 1294}#
+ #{label\ 2146}#
+ #{r\ 2142}#
+ #{mod\ 2145}#)))
+ (if (eq? (#{binding-type\ 1289}# #{b\ 2147}#)
+ 'syntax)
+ (call-with-values
+ (lambda ()
+ (let ((#{var.lev\ 2148}#
+ (#{binding-value\ 1290}#
+ #{b\ 2147}#)))
+ (#{gen-ref\ 2107}#
+ #{src\ 2140}#
+ (car #{var.lev\ 2148}#)
+ (cdr #{var.lev\ 2148}#)
+ #{maps\ 2143}#)))
+ (lambda (#{var\ 2149}# #{maps\ 2150}#)
+ (values
+ (list (quote ref) #{var\ 2149}#)
+ #{maps\ 2150}#)))
+ (if (#{ellipsis?\ 2144}# #{e\ 2141}#)
+ (syntax-violation
+ 'syntax
+ "misplaced ellipsis"
+ #{src\ 2140}#)
+ (values
+ (list (quote quote) #{e\ 2141}#)
+ #{maps\ 2143}#)))))
+ ((lambda (#{tmp\ 2151}#)
+ ((lambda (#{tmp\ 2152}#)
+ (if (if #{tmp\ 2152}#
+ (apply (lambda (#{dots\ 2153}# #{e\ 2154}#)
+ (#{ellipsis?\ 2144}#
+ #{dots\ 2153}#))
+ #{tmp\ 2152}#)
+ #f)
+ (apply (lambda (#{dots\ 2155}# #{e\ 2156}#)
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ #{e\ 2156}#
+ #{r\ 2142}#
+ #{maps\ 2143}#
+ (lambda (#{x\ 2157}#) #f)
+ #{mod\ 2145}#))
+ #{tmp\ 2152}#)
+ ((lambda (#{tmp\ 2158}#)
+ (if (if #{tmp\ 2158}#
+ (apply (lambda (#{x\ 2159}#
+ #{dots\ 2160}#
+ #{y\ 2161}#)
+ (#{ellipsis?\ 2144}#
+ #{dots\ 2160}#))
+ #{tmp\ 2158}#)
+ #f)
+ (apply (lambda (#{x\ 2162}#
+ #{dots\ 2163}#
+ #{y\ 2164}#)
+ (letrec ((#{f\ 2165}#
+ (lambda (#{y\ 2166}#
+ #{k\ 2167}#)
+ ((lambda (#{tmp\ 2171}#)
+ ((lambda (#{tmp\ 2172}#)
+ (if (if #{tmp\ 2172}#
+ (apply (lambda (#{dots\ 2173}#
+ #{y\ 2174}#)
+ (#{ellipsis?\ 2144}#
+ #{dots\ 2173}#))
+ #{tmp\ 2172}#)
+ #f)
+ (apply (lambda (#{dots\ 2175}#
+ #{y\ 2176}#)
+ (#{f\ 2165}#
+ #{y\ 2176}#
+ (lambda (#{maps\ 2177}#)
+ (call-with-values
+ (lambda ()
+ (#{k\ 2167}#
+ (cons '()
+ #{maps\ 2177}#)))
+ (lambda (#{x\ 2178}#
+ #{maps\ 2179}#)
+ (if (null? (car #{maps\ 2179}#))
+ (syntax-violation
+ 'syntax
+ "extra ellipsis"
+ #{src\ 2140}#)
+ (values
+ (#{gen-mappend\ 2108}#
+ #{x\ 2178}#
+ (car #{maps\ 2179}#))
+ (cdr #{maps\ 2179}#))))))))
+ #{tmp\ 2172}#)
+ ((lambda (#{_\ 2180}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ #{y\ 2166}#
+ #{r\ 2142}#
+ #{maps\ 2143}#
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#))
+ (lambda (#{y\ 2181}#
+ #{maps\ 2182}#)
+ (call-with-values
+ (lambda ()
+ (#{k\ 2167}#
+ #{maps\ 2182}#))
+ (lambda (#{x\ 2183}#
+ #{maps\ 2184}#)
+ (values
+ (#{gen-append\ 2111}#
+ #{x\ 2183}#
+ #{y\ 2181}#)
+ #{maps\ 2184}#))))))
+ #{tmp\ 2171}#)))
+ ($sc-dispatch
+ #{tmp\ 2171}#
+ '(any . any))))
+ #{y\ 2166}#))))
+ (#{f\ 2165}#
+ #{y\ 2164}#
+ (lambda (#{maps\ 2168}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ #{x\ 2162}#
+ #{r\ 2142}#
+ (cons '()
+ #{maps\ 2168}#)
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#))
+ (lambda (#{x\ 2169}#
+ #{maps\ 2170}#)
+ (if (null? (car #{maps\ 2170}#))
+ (syntax-violation
+ 'syntax
+ "extra ellipsis"
+ #{src\ 2140}#)
+ (values
+ (#{gen-map\ 2109}#
+ #{x\ 2169}#
+ (car #{maps\ 2170}#))
+ (cdr #{maps\ 2170}#)))))))))
+ #{tmp\ 2158}#)
+ ((lambda (#{tmp\ 2185}#)
+ (if #{tmp\ 2185}#
+ (apply (lambda (#{x\ 2186}#
+ #{y\ 2187}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ #{x\ 2186}#
+ #{r\ 2142}#
+ #{maps\ 2143}#
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#))
+ (lambda (#{x\ 2188}#
+ #{maps\ 2189}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ #{y\ 2187}#
+ #{r\ 2142}#
+ #{maps\ 2189}#
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#))
+ (lambda (#{y\ 2190}#
+ #{maps\ 2191}#)
+ (values
+ (#{gen-cons\ 2110}#
+ #{x\ 2188}#
+ #{y\ 2190}#)
+ #{maps\ 2191}#))))))
+ #{tmp\ 2185}#)
+ ((lambda (#{tmp\ 2192}#)
+ (if #{tmp\ 2192}#
+ (apply (lambda (#{e1\ 2193}#
+ #{e2\ 2194}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ (cons #{e1\ 2193}#
+ #{e2\ 2194}#)
+ #{r\ 2142}#
+ #{maps\ 2143}#
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#))
+ (lambda (#{e\ 2196}#
+ #{maps\ 2197}#)
+ (values
+ (#{gen-vector\ 2112}#
+ #{e\ 2196}#)
+ #{maps\ 2197}#))))
+ #{tmp\ 2192}#)
+ ((lambda (#{_\ 2198}#)
+ (values
+ (list 'quote
+ #{e\ 2141}#)
+ #{maps\ 2143}#))
+ #{tmp\ 2151}#)))
+ ($sc-dispatch
+ #{tmp\ 2151}#
+ '#(vector (any . each-any))))))
+ ($sc-dispatch
+ #{tmp\ 2151}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 2151}#
+ '(any any . any)))))
+ ($sc-dispatch #{tmp\ 2151}# (quote (any any)))))
+ #{e\ 2141}#)))))
+ (lambda (#{e\ 2199}#
+ #{r\ 2200}#
+ #{w\ 2201}#
+ #{s\ 2202}#
+ #{mod\ 2203}#)
+ (let ((#{e\ 2204}#
+ (#{source-wrap\ 1326}#
+ #{e\ 2199}#
+ #{w\ 2201}#
+ #{s\ 2202}#
+ #{mod\ 2203}#)))
+ ((lambda (#{tmp\ 2205}#)
+ ((lambda (#{tmp\ 2206}#)
+ (if #{tmp\ 2206}#
+ (apply (lambda (#{_\ 2207}# #{x\ 2208}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax\ 2106}#
+ #{e\ 2204}#
+ #{x\ 2208}#
+ #{r\ 2200}#
+ '()
+ #{ellipsis?\ 1342}#
+ #{mod\ 2203}#))
+ (lambda (#{e\ 2209}# #{maps\ 2210}#)
+ (#{regen\ 2113}# #{e\ 2209}#))))
+ #{tmp\ 2206}#)
+ ((lambda (#{_\ 2211}#)
+ (syntax-violation
+ 'syntax
+ "bad `syntax' form"
+ #{e\ 2204}#))
+ #{tmp\ 2205}#)))
+ ($sc-dispatch #{tmp\ 2205}# (quote (any any)))))
+ #{e\ 2204}#)))))
+ (#{global-extend\ 1295}#
+ 'core
+ 'lambda
+ (lambda (#{e\ 2212}#
+ #{r\ 2213}#
+ #{w\ 2214}#
+ #{s\ 2215}#
+ #{mod\ 2216}#)
+ ((lambda (#{tmp\ 2217}#)
+ ((lambda (#{tmp\ 2218}#)
+ (if #{tmp\ 2218}#
+ (apply (lambda (#{_\ 2219}# #{c\ 2220}#)
+ (#{chi-lambda-clause\ 1338}#
+ (#{source-wrap\ 1326}#
+ #{e\ 2212}#
+ #{w\ 2214}#
+ #{s\ 2215}#
+ #{mod\ 2216}#)
+ #f
+ #{c\ 2220}#
+ #{r\ 2213}#
+ #{w\ 2214}#
+ #{mod\ 2216}#
+ (lambda (#{names\ 2221}#
+ #{vars\ 2222}#
+ #{docstring\ 2223}#
+ #{body\ 2224}#)
+ (#{build-lambda\ 1273}#
+ #{s\ 2215}#
+ #{names\ 2221}#
+ #{vars\ 2222}#
+ #{docstring\ 2223}#
+ #{body\ 2224}#))))
+ #{tmp\ 2218}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2217}#)))
+ ($sc-dispatch #{tmp\ 2217}# (quote (any . any)))))
+ #{e\ 2212}#)))
+ (#{global-extend\ 1295}#
+ 'core
+ 'let
+ (letrec ((#{chi-let\ 2225}#
+ (lambda (#{e\ 2226}#
+ #{r\ 2227}#
+ #{w\ 2228}#
+ #{s\ 2229}#
+ #{mod\ 2230}#
+ #{constructor\ 2231}#
+ #{ids\ 2232}#
+ #{vals\ 2233}#
+ #{exps\ 2234}#)
+ (if (not (#{valid-bound-ids?\ 1322}# #{ids\ 2232}#))
+ (syntax-violation
+ 'let
+ "duplicate bound variable"
+ #{e\ 2226}#)
+ (let ((#{labels\ 2235}#
+ (#{gen-labels\ 1303}# #{ids\ 2232}#))
+ (#{new-vars\ 2236}#
+ (map #{gen-var\ 1344}# #{ids\ 2232}#)))
+ (let ((#{nw\ 2237}#
+ (#{make-binding-wrap\ 1314}#
+ #{ids\ 2232}#
+ #{labels\ 2235}#
+ #{w\ 2228}#))
+ (#{nr\ 2238}#
+ (#{extend-var-env\ 1292}#
+ #{labels\ 2235}#
+ #{new-vars\ 2236}#
+ #{r\ 2227}#)))
+ (#{constructor\ 2231}#
+ #{s\ 2229}#
+ (map syntax->datum #{ids\ 2232}#)
+ #{new-vars\ 2236}#
+ (map (lambda (#{x\ 2239}#)
+ (#{chi\ 1333}#
+ #{x\ 2239}#
+ #{r\ 2227}#
+ #{w\ 2228}#
+ #{mod\ 2230}#))
+ #{vals\ 2233}#)
+ (#{chi-body\ 1337}#
+ #{exps\ 2234}#
+ (#{source-wrap\ 1326}#
+ #{e\ 2226}#
+ #{nw\ 2237}#
+ #{s\ 2229}#
+ #{mod\ 2230}#)
+ #{nr\ 2238}#
+ #{nw\ 2237}#
+ #{mod\ 2230}#))))))))
+ (lambda (#{e\ 2240}#
+ #{r\ 2241}#
+ #{w\ 2242}#
+ #{s\ 2243}#
+ #{mod\ 2244}#)
+ ((lambda (#{tmp\ 2245}#)
+ ((lambda (#{tmp\ 2246}#)
+ (if (if #{tmp\ 2246}#
+ (apply (lambda (#{_\ 2247}#
+ #{id\ 2248}#
+ #{val\ 2249}#
+ #{e1\ 2250}#
+ #{e2\ 2251}#)
+ (and-map #{id?\ 1297}# #{id\ 2248}#))
+ #{tmp\ 2246}#)
+ #f)
+ (apply (lambda (#{_\ 2253}#
+ #{id\ 2254}#
+ #{val\ 2255}#
+ #{e1\ 2256}#
+ #{e2\ 2257}#)
+ (#{chi-let\ 2225}#
+ #{e\ 2240}#
+ #{r\ 2241}#
+ #{w\ 2242}#
+ #{s\ 2243}#
+ #{mod\ 2244}#
+ #{build-let\ 1277}#
+ #{id\ 2254}#
+ #{val\ 2255}#
+ (cons #{e1\ 2256}# #{e2\ 2257}#)))
+ #{tmp\ 2246}#)
+ ((lambda (#{tmp\ 2261}#)
+ (if (if #{tmp\ 2261}#
+ (apply (lambda (#{_\ 2262}#
+ #{f\ 2263}#
+ #{id\ 2264}#
+ #{val\ 2265}#
+ #{e1\ 2266}#
+ #{e2\ 2267}#)
+ (if (#{id?\ 1297}# #{f\ 2263}#)
+ (and-map #{id?\ 1297}# #{id\ 2264}#)
+ #f))
+ #{tmp\ 2261}#)
+ #f)
+ (apply (lambda (#{_\ 2269}#
+ #{f\ 2270}#
+ #{id\ 2271}#
+ #{val\ 2272}#
+ #{e1\ 2273}#
+ #{e2\ 2274}#)
+ (#{chi-let\ 2225}#
+ #{e\ 2240}#
+ #{r\ 2241}#
+ #{w\ 2242}#
+ #{s\ 2243}#
+ #{mod\ 2244}#
+ #{build-named-let\ 1278}#
+ (cons #{f\ 2270}# #{id\ 2271}#)
+ #{val\ 2272}#
+ (cons #{e1\ 2273}# #{e2\ 2274}#)))
+ #{tmp\ 2261}#)
+ ((lambda (#{_\ 2278}#)
+ (syntax-violation
+ 'let
+ "bad let"
+ (#{source-wrap\ 1326}#
+ #{e\ 2240}#
+ #{w\ 2242}#
+ #{s\ 2243}#
+ #{mod\ 2244}#)))
+ #{tmp\ 2245}#)))
+ ($sc-dispatch
+ #{tmp\ 2245}#
+ '(any any #(each (any any)) any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 2245}#
+ '(any #(each (any any)) any . each-any))))
+ #{e\ 2240}#))))
+ (#{global-extend\ 1295}#
+ 'core
+ 'letrec
+ (lambda (#{e\ 2279}#
+ #{r\ 2280}#
+ #{w\ 2281}#
+ #{s\ 2282}#
+ #{mod\ 2283}#)
+ ((lambda (#{tmp\ 2284}#)
+ ((lambda (#{tmp\ 2285}#)
+ (if (if #{tmp\ 2285}#
+ (apply (lambda (#{_\ 2286}#
+ #{id\ 2287}#
+ #{val\ 2288}#
+ #{e1\ 2289}#
+ #{e2\ 2290}#)
+ (and-map #{id?\ 1297}# #{id\ 2287}#))
+ #{tmp\ 2285}#)
+ #f)
+ (apply (lambda (#{_\ 2292}#
+ #{id\ 2293}#
+ #{val\ 2294}#
+ #{e1\ 2295}#
+ #{e2\ 2296}#)
+ (let ((#{ids\ 2297}# #{id\ 2293}#))
+ (if (not (#{valid-bound-ids?\ 1322}#
+ #{ids\ 2297}#))
+ (syntax-violation
+ 'letrec
+ "duplicate bound variable"
+ #{e\ 2279}#)
+ (let ((#{labels\ 2299}#
+ (#{gen-labels\ 1303}# #{ids\ 2297}#))
+ (#{new-vars\ 2300}#
+ (map #{gen-var\ 1344}# #{ids\ 2297}#)))
+ (let ((#{w\ 2301}#
+ (#{make-binding-wrap\ 1314}#
+ #{ids\ 2297}#
+ #{labels\ 2299}#
+ #{w\ 2281}#))
+ (#{r\ 2302}#
+ (#{extend-var-env\ 1292}#
+ #{labels\ 2299}#
+ #{new-vars\ 2300}#
+ #{r\ 2280}#)))
+ (#{build-letrec\ 1279}#
+ #{s\ 2282}#
+ (map syntax->datum #{ids\ 2297}#)
+ #{new-vars\ 2300}#
+ (map (lambda (#{x\ 2303}#)
+ (#{chi\ 1333}#
+ #{x\ 2303}#
+ #{r\ 2302}#
+ #{w\ 2301}#
+ #{mod\ 2283}#))
+ #{val\ 2294}#)
+ (#{chi-body\ 1337}#
+ (cons #{e1\ 2295}# #{e2\ 2296}#)
+ (#{source-wrap\ 1326}#
+ #{e\ 2279}#
+ #{w\ 2301}#
+ #{s\ 2282}#
+ #{mod\ 2283}#)
+ #{r\ 2302}#
+ #{w\ 2301}#
+ #{mod\ 2283}#)))))))
+ #{tmp\ 2285}#)
+ ((lambda (#{_\ 2306}#)
+ (syntax-violation
+ 'letrec
+ "bad letrec"
+ (#{source-wrap\ 1326}#
+ #{e\ 2279}#
+ #{w\ 2281}#
+ #{s\ 2282}#
+ #{mod\ 2283}#)))
+ #{tmp\ 2284}#)))
+ ($sc-dispatch
+ #{tmp\ 2284}#
+ '(any #(each (any any)) any . each-any))))
+ #{e\ 2279}#)))
+ (#{global-extend\ 1295}#
+ 'core
+ 'set!
+ (lambda (#{e\ 2307}#
+ #{r\ 2308}#
+ #{w\ 2309}#
+ #{s\ 2310}#
+ #{mod\ 2311}#)
+ ((lambda (#{tmp\ 2312}#)
+ ((lambda (#{tmp\ 2313}#)
+ (if (if #{tmp\ 2313}#
+ (apply (lambda (#{_\ 2314}# #{id\ 2315}# #{val\ 2316}#)
+ (#{id?\ 1297}# #{id\ 2315}#))
+ #{tmp\ 2313}#)
+ #f)
+ (apply (lambda (#{_\ 2317}# #{id\ 2318}# #{val\ 2319}#)
+ (let ((#{val\ 2320}#
+ (#{chi\ 1333}#
+ #{val\ 2319}#
+ #{r\ 2308}#
+ #{w\ 2309}#
+ #{mod\ 2311}#))
+ (#{n\ 2321}#
+ (#{id-var-name\ 1319}#
+ #{id\ 2318}#
+ #{w\ 2309}#)))
+ (let ((#{b\ 2322}#
+ (#{lookup\ 1294}#
+ #{n\ 2321}#
+ #{r\ 2308}#
+ #{mod\ 2311}#)))
+ (let ((#{atom-key\ 2323}#
+ (#{binding-type\ 1289}# #{b\ 2322}#)))
+ (if (memv #{atom-key\ 2323}#
+ '(lexical))
+ (#{build-lexical-assignment\ 1267}#
+ #{s\ 2310}#
+ (syntax->datum #{id\ 2318}#)
+ (#{binding-value\ 1290}# #{b\ 2322}#)
+ #{val\ 2320}#)
+ (if (memv #{atom-key\ 2323}#
+ '(global))
+ (#{build-global-assignment\ 1270}#
+ #{s\ 2310}#
+ #{n\ 2321}#
+ #{val\ 2320}#
+ #{mod\ 2311}#)
+ (if (memv #{atom-key\ 2323}#
+ '(displaced-lexical))
+ (syntax-violation
+ 'set!
+ "identifier out of context"
+ (#{wrap\ 1325}#
+ #{id\ 2318}#
+ #{w\ 2309}#
+ #{mod\ 2311}#))
+ (syntax-violation
+ 'set!
+ "bad set!"
+ (#{source-wrap\ 1326}#
+ #{e\ 2307}#
+ #{w\ 2309}#
+ #{s\ 2310}#
+ #{mod\ 2311}#)))))))))
+ #{tmp\ 2313}#)
+ ((lambda (#{tmp\ 2324}#)
+ (if #{tmp\ 2324}#
+ (apply (lambda (#{_\ 2325}#
+ #{head\ 2326}#
+ #{tail\ 2327}#
+ #{val\ 2328}#)
+ (call-with-values
+ (lambda ()
+ (#{syntax-type\ 1331}#
+ #{head\ 2326}#
+ #{r\ 2308}#
+ '(())
+ #f
+ #f
+ #{mod\ 2311}#
+ #t))
+ (lambda (#{type\ 2329}#
+ #{value\ 2330}#
+ #{ee\ 2331}#
+ #{ww\ 2332}#
+ #{ss\ 2333}#
+ #{modmod\ 2334}#)
+ (if (memv #{type\ 2329}#
+ '(module-ref))
+ (let ((#{val\ 2335}#
+ (#{chi\ 1333}#
+ #{val\ 2328}#
+ #{r\ 2308}#
+ #{w\ 2309}#
+ #{mod\ 2311}#)))
+ (call-with-values
+ (lambda ()
+ (#{value\ 2330}#
+ (cons #{head\ 2326}#
+ #{tail\ 2327}#)))
+ (lambda (#{id\ 2337}# #{mod\ 2338}#)
+ (#{build-global-assignment\ 1270}#
+ #{s\ 2310}#
+ #{id\ 2337}#
+ #{val\ 2335}#
+ #{mod\ 2338}#))))
+ (#{build-application\ 1264}#
+ #{s\ 2310}#
+ (#{chi\ 1333}#
+ (list '#(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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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))
+ #{head\ 2326}#)
+ #{r\ 2308}#
+ #{w\ 2309}#
+ #{mod\ 2311}#)
+ (map (lambda (#{e\ 2339}#)
+ (#{chi\ 1333}#
+ #{e\ 2339}#
+ #{r\ 2308}#
+ #{w\ 2309}#
+ #{mod\ 2311}#))
+ (append
+ #{tail\ 2327}#
+ (list #{val\ 2328}#))))))))
+ #{tmp\ 2324}#)
+ ((lambda (#{_\ 2341}#)
+ (syntax-violation
+ 'set!
+ "bad set!"
+ (#{source-wrap\ 1326}#
+ #{e\ 2307}#
+ #{w\ 2309}#
+ #{s\ 2310}#
+ #{mod\ 2311}#)))
+ #{tmp\ 2312}#)))
+ ($sc-dispatch
+ #{tmp\ 2312}#
+ '(any (any . each-any) any)))))
+ ($sc-dispatch
+ #{tmp\ 2312}#
+ '(any any any))))
+ #{e\ 2307}#)))
+ (#{global-extend\ 1295}#
+ 'module-ref
+ '@
+ (lambda (#{e\ 2342}#)
+ ((lambda (#{tmp\ 2343}#)
+ ((lambda (#{tmp\ 2344}#)
+ (if (if #{tmp\ 2344}#
+ (apply (lambda (#{_\ 2345}# #{mod\ 2346}# #{id\ 2347}#)
+ (if (and-map #{id?\ 1297}# #{mod\ 2346}#)
+ (#{id?\ 1297}# #{id\ 2347}#)
+ #f))
+ #{tmp\ 2344}#)
+ #f)
+ (apply (lambda (#{_\ 2349}# #{mod\ 2350}# #{id\ 2351}#)
+ (values
+ (syntax->datum #{id\ 2351}#)
+ (syntax->datum
+ (cons '#(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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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))
+ #{mod\ 2350}#))))
+ #{tmp\ 2344}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2343}#)))
+ ($sc-dispatch
+ #{tmp\ 2343}#
+ '(any each-any any))))
+ #{e\ 2342}#)))
+ (#{global-extend\ 1295}#
+ 'module-ref
+ '@@
+ (lambda (#{e\ 2353}#)
+ ((lambda (#{tmp\ 2354}#)
+ ((lambda (#{tmp\ 2355}#)
+ (if (if #{tmp\ 2355}#
+ (apply (lambda (#{_\ 2356}# #{mod\ 2357}# #{id\ 2358}#)
+ (if (and-map #{id?\ 1297}# #{mod\ 2357}#)
+ (#{id?\ 1297}# #{id\ 2358}#)
+ #f))
+ #{tmp\ 2355}#)
+ #f)
+ (apply (lambda (#{_\ 2360}# #{mod\ 2361}# #{id\ 2362}#)
+ (values
+ (syntax->datum #{id\ 2362}#)
+ (syntax->datum
+ (cons '#(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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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))
+ #{mod\ 2361}#))))
+ #{tmp\ 2355}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2354}#)))
+ ($sc-dispatch
+ #{tmp\ 2354}#
+ '(any each-any any))))
+ #{e\ 2353}#)))
+ (#{global-extend\ 1295}#
+ 'core
+ 'if
+ (lambda (#{e\ 2364}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{s\ 2367}#
+ #{mod\ 2368}#)
+ ((lambda (#{tmp\ 2369}#)
+ ((lambda (#{tmp\ 2370}#)
+ (if #{tmp\ 2370}#
+ (apply (lambda (#{_\ 2371}# #{test\ 2372}# #{then\ 2373}#)
+ (#{build-conditional\ 1265}#
+ #{s\ 2367}#
+ (#{chi\ 1333}#
+ #{test\ 2372}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{mod\ 2368}#)
+ (#{chi\ 1333}#
+ #{then\ 2373}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{mod\ 2368}#)
+ (#{build-void\ 1263}# #f)))
+ #{tmp\ 2370}#)
+ ((lambda (#{tmp\ 2374}#)
+ (if #{tmp\ 2374}#
+ (apply (lambda (#{_\ 2375}#
+ #{test\ 2376}#
+ #{then\ 2377}#
+ #{else\ 2378}#)
+ (#{build-conditional\ 1265}#
+ #{s\ 2367}#
+ (#{chi\ 1333}#
+ #{test\ 2376}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{mod\ 2368}#)
+ (#{chi\ 1333}#
+ #{then\ 2377}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{mod\ 2368}#)
+ (#{chi\ 1333}#
+ #{else\ 2378}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{mod\ 2368}#)))
+ #{tmp\ 2374}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2369}#)))
+ ($sc-dispatch
+ #{tmp\ 2369}#
+ '(any any any any)))))
+ ($sc-dispatch
+ #{tmp\ 2369}#
+ '(any any any))))
+ #{e\ 2364}#)))
+ (#{global-extend\ 1295}#
+ 'begin
+ 'begin
+ '())
+ (#{global-extend\ 1295}#
+ 'define
+ 'define
+ '())
+ (#{global-extend\ 1295}#
+ 'define-syntax
+ 'define-syntax
+ '())
+ (#{global-extend\ 1295}#
+ 'eval-when
+ 'eval-when
+ '())
+ (#{global-extend\ 1295}#
+ 'core
+ 'syntax-case
+ (letrec ((#{gen-syntax-case\ 2382}#
+ (lambda (#{x\ 2383}#
+ #{keys\ 2384}#
+ #{clauses\ 2385}#
+ #{r\ 2386}#
+ #{mod\ 2387}#)
+ (if (null? #{clauses\ 2385}#)
+ (#{build-application\ 1264}#
+ #f
+ (#{build-primref\ 1274}#
+ #f
+ 'syntax-violation)
+ (list (#{build-data\ 1275}# #f #f)
+ (#{build-data\ 1275}#
+ #f
+ "source expression failed to match any pattern")
+ #{x\ 2383}#))
+ ((lambda (#{tmp\ 2388}#)
+ ((lambda (#{tmp\ 2389}#)
+ (if #{tmp\ 2389}#
+ (apply (lambda (#{pat\ 2390}# #{exp\ 2391}#)
+ (if (if (#{id?\ 1297}# #{pat\ 2390}#)
+ (and-map
+ (lambda (#{x\ 2392}#)
+ (not (#{free-id=?\ 1320}#
+ #{pat\ 2390}#
+ #{x\ 2392}#)))
+ (cons '#(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
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "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))
+ #{keys\ 2384}#))
+ #f)
+ (let ((#{labels\ 2393}#
+ (list (#{gen-label\ 1302}#)))
+ (#{var\ 2394}#
+ (#{gen-var\ 1344}#
+ #{pat\ 2390}#)))
+ (#{build-application\ 1264}#
+ #f
+ (#{build-lambda\ 1273}#
+ #f
+ (list (syntax->datum
+ #{pat\ 2390}#))
+ (list #{var\ 2394}#)
+ #f
+ (#{chi\ 1333}#
+ #{exp\ 2391}#
+ (#{extend-env\ 1291}#
+ #{labels\ 2393}#
+ (list (cons 'syntax
+ (cons #{var\ 2394}#
+ 0)))
+ #{r\ 2386}#)
+ (#{make-binding-wrap\ 1314}#
+ (list #{pat\ 2390}#)
+ #{labels\ 2393}#
+ '(()))
+ #{mod\ 2387}#))
+ (list #{x\ 2383}#)))
+ (#{gen-clause\ 2381}#
+ #{x\ 2383}#
+ #{keys\ 2384}#
+ (cdr #{clauses\ 2385}#)
+ #{r\ 2386}#
+ #{pat\ 2390}#
+ #t
+ #{exp\ 2391}#
+ #{mod\ 2387}#)))
+ #{tmp\ 2389}#)
+ ((lambda (#{tmp\ 2395}#)
+ (if #{tmp\ 2395}#
+ (apply (lambda (#{pat\ 2396}#
+ #{fender\ 2397}#
+ #{exp\ 2398}#)
+ (#{gen-clause\ 2381}#
+ #{x\ 2383}#
+ #{keys\ 2384}#
+ (cdr #{clauses\ 2385}#)
+ #{r\ 2386}#
+ #{pat\ 2396}#
+ #{fender\ 2397}#
+ #{exp\ 2398}#
+ #{mod\ 2387}#))
+ #{tmp\ 2395}#)
+ ((lambda (#{_\ 2399}#)
+ (syntax-violation
+ 'syntax-case
+ "invalid clause"
+ (car #{clauses\ 2385}#)))
+ #{tmp\ 2388}#)))
+ ($sc-dispatch
+ #{tmp\ 2388}#
+ '(any any any)))))
+ ($sc-dispatch #{tmp\ 2388}# (quote (any any)))))
+ (car #{clauses\ 2385}#)))))
+ (#{gen-clause\ 2381}#
+ (lambda (#{x\ 2400}#
+ #{keys\ 2401}#
+ #{clauses\ 2402}#
+ #{r\ 2403}#
+ #{pat\ 2404}#
+ #{fender\ 2405}#
+ #{exp\ 2406}#
+ #{mod\ 2407}#)
+ (call-with-values
+ (lambda ()
+ (#{convert-pattern\ 2379}#
+ #{pat\ 2404}#
+ #{keys\ 2401}#))
+ (lambda (#{p\ 2408}# #{pvars\ 2409}#)
+ (if (not (#{distinct-bound-ids?\ 1323}#
+ (map car #{pvars\ 2409}#)))
+ (syntax-violation
+ 'syntax-case
+ "duplicate pattern variable"
+ #{pat\ 2404}#)
+ (if (not (and-map
+ (lambda (#{x\ 2410}#)
+ (not (#{ellipsis?\ 1342}#
+ (car #{x\ 2410}#))))
+ #{pvars\ 2409}#))
+ (syntax-violation
+ 'syntax-case
+ "misplaced ellipsis"
+ #{pat\ 2404}#)
+ (let ((#{y\ 2411}#
+ (#{gen-var\ 1344}# (quote tmp))))
+ (#{build-application\ 1264}#
+ #f
+ (#{build-lambda\ 1273}#
+ #f
+ (list (quote tmp))
+ (list #{y\ 2411}#)
+ #f
+ (let ((#{y\ 2412}#
+ (#{build-lexical-reference\ 1266}#
+ 'value
+ #f
+ 'tmp
+ #{y\ 2411}#)))
+ (#{build-conditional\ 1265}#
+ #f
+ ((lambda (#{tmp\ 2413}#)
+ ((lambda (#{tmp\ 2414}#)
+ (if #{tmp\ 2414}#
+ (apply (lambda () #{y\ 2412}#)
+ #{tmp\ 2414}#)
+ ((lambda (#{_\ 2415}#)
+ (#{build-conditional\ 1265}#
+ #f
+ #{y\ 2412}#
+ (#{build-dispatch-call\ 2380}#
+ #{pvars\ 2409}#
+ #{fender\ 2405}#
+ #{y\ 2412}#
+ #{r\ 2403}#
+ #{mod\ 2407}#)
+ (#{build-data\ 1275}#
+ #f
+ #f)))
+ #{tmp\ 2413}#)))
+ ($sc-dispatch
+ #{tmp\ 2413}#
+ '#(atom #t))))
+ #{fender\ 2405}#)
+ (#{build-dispatch-call\ 2380}#
+ #{pvars\ 2409}#
+ #{exp\ 2406}#
+ #{y\ 2412}#
+ #{r\ 2403}#
+ #{mod\ 2407}#)
+ (#{gen-syntax-case\ 2382}#
+ #{x\ 2400}#
+ #{keys\ 2401}#
+ #{clauses\ 2402}#
+ #{r\ 2403}#
+ #{mod\ 2407}#))))
+ (list (if (eq? #{p\ 2408}# (quote any))
+ (#{build-application\ 1264}#
+ #f
+ (#{build-primref\ 1274}#
+ #f
+ 'list)
+ (list #{x\ 2400}#))
+ (#{build-application\ 1264}#
+ #f
+ (#{build-primref\ 1274}#
+ #f
+ '$sc-dispatch)
+ (list #{x\ 2400}#
+ (#{build-data\ 1275}#
+ #f
+ #{p\ 2408}#)))))))))))))
+ (#{build-dispatch-call\ 2380}#
+ (lambda (#{pvars\ 2416}#
+ #{exp\ 2417}#
+ #{y\ 2418}#
+ #{r\ 2419}#
+ #{mod\ 2420}#)
+ (let ((#{ids\ 2421}# (map car #{pvars\ 2416}#))
+ (#{levels\ 2422}# (map cdr #{pvars\ 2416}#)))
+ (let ((#{labels\ 2423}#
+ (#{gen-labels\ 1303}# #{ids\ 2421}#))
+ (#{new-vars\ 2424}#
+ (map #{gen-var\ 1344}# #{ids\ 2421}#)))
+ (#{build-application\ 1264}#
+ #f
+ (#{build-primref\ 1274}# #f (quote apply))
+ (list (#{build-lambda\ 1273}#
+ #f
+ (map syntax->datum #{ids\ 2421}#)
+ #{new-vars\ 2424}#
+ #f
+ (#{chi\ 1333}#
+ #{exp\ 2417}#
+ (#{extend-env\ 1291}#
+ #{labels\ 2423}#
+ (map (lambda (#{var\ 2425}#
+ #{level\ 2426}#)
+ (cons 'syntax
+ (cons #{var\ 2425}#
+ #{level\ 2426}#)))
+ #{new-vars\ 2424}#
+ (map cdr #{pvars\ 2416}#))
+ #{r\ 2419}#)
+ (#{make-binding-wrap\ 1314}#
+ #{ids\ 2421}#
+ #{labels\ 2423}#
+ '(()))
+ #{mod\ 2420}#))
+ #{y\ 2418}#))))))
+ (#{convert-pattern\ 2379}#
+ (lambda (#{pattern\ 2427}# #{keys\ 2428}#)
+ (letrec ((#{cvt\ 2429}#
+ (lambda (#{p\ 2430}# #{n\ 2431}# #{ids\ 2432}#)
+ (if (#{id?\ 1297}# #{p\ 2430}#)
+ (if (#{bound-id-member?\ 1324}#
+ #{p\ 2430}#
+ #{keys\ 2428}#)
+ (values
+ (vector (quote free-id) #{p\ 2430}#)
+ #{ids\ 2432}#)
+ (values
+ 'any
+ (cons (cons #{p\ 2430}# #{n\ 2431}#)
+ #{ids\ 2432}#)))
+ ((lambda (#{tmp\ 2433}#)
+ ((lambda (#{tmp\ 2434}#)
+ (if (if #{tmp\ 2434}#
+ (apply (lambda (#{x\ 2435}#
+ #{dots\ 2436}#)
+ (#{ellipsis?\ 1342}#
+ #{dots\ 2436}#))
+ #{tmp\ 2434}#)
+ #f)
+ (apply (lambda (#{x\ 2437}#
+ #{dots\ 2438}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt\ 2429}#
+ #{x\ 2437}#
+ (#{fx+\ 1254}#
+ #{n\ 2431}#
+ 1)
+ #{ids\ 2432}#))
+ (lambda (#{p\ 2439}#
+ #{ids\ 2440}#)
+ (values
+ (if (eq? #{p\ 2439}#
+ 'any)
+ 'each-any
+ (vector
+ 'each
+ #{p\ 2439}#))
+ #{ids\ 2440}#))))
+ #{tmp\ 2434}#)
+ ((lambda (#{tmp\ 2441}#)
+ (if #{tmp\ 2441}#
+ (apply (lambda (#{x\ 2442}#
+ #{y\ 2443}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt\ 2429}#
+ #{y\ 2443}#
+ #{n\ 2431}#
+ #{ids\ 2432}#))
+ (lambda (#{y\ 2444}#
+ #{ids\ 2445}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt\ 2429}#
+ #{x\ 2442}#
+ #{n\ 2431}#
+ #{ids\ 2445}#))
+ (lambda (#{x\ 2446}#
+ #{ids\ 2447}#)
+ (values
+ (cons #{x\ 2446}#
+ #{y\ 2444}#)
+ #{ids\ 2447}#))))))
+ #{tmp\ 2441}#)
+ ((lambda (#{tmp\ 2448}#)
+ (if #{tmp\ 2448}#
+ (apply (lambda ()
+ (values
+ '()
+ #{ids\ 2432}#))
+ #{tmp\ 2448}#)
+ ((lambda (#{tmp\ 2449}#)
+ (if #{tmp\ 2449}#
+ (apply (lambda (#{x\ 2450}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt\ 2429}#
+ #{x\ 2450}#
+ #{n\ 2431}#
+ #{ids\ 2432}#))
+ (lambda (#{p\ 2452}#
+ #{ids\ 2453}#)
+ (values
+ (vector
+ 'vector
+ #{p\ 2452}#)
+ #{ids\ 2453}#))))
+ #{tmp\ 2449}#)
+ ((lambda (#{x\ 2454}#)
+ (values
+ (vector
+ 'atom
+ (#{strip\ 1343}#
+ #{p\ 2430}#
+ '(())))
+ #{ids\ 2432}#))
+ #{tmp\ 2433}#)))
+ ($sc-dispatch
+ #{tmp\ 2433}#
+ '#(vector
+ each-any)))))
+ ($sc-dispatch
+ #{tmp\ 2433}#
+ '()))))
+ ($sc-dispatch
+ #{tmp\ 2433}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 2433}#
+ '(any any))))
+ #{p\ 2430}#)))))
+ (#{cvt\ 2429}# #{pattern\ 2427}# 0 (quote ()))))))
+ (lambda (#{e\ 2455}#
+ #{r\ 2456}#
+ #{w\ 2457}#
+ #{s\ 2458}#
+ #{mod\ 2459}#)
+ (let ((#{e\ 2460}#
+ (#{source-wrap\ 1326}#
+ #{e\ 2455}#
+ #{w\ 2457}#
+ #{s\ 2458}#
+ #{mod\ 2459}#)))
+ ((lambda (#{tmp\ 2461}#)
+ ((lambda (#{tmp\ 2462}#)
+ (if #{tmp\ 2462}#
+ (apply (lambda (#{_\ 2463}#
+ #{val\ 2464}#
+ #{key\ 2465}#
+ #{m\ 2466}#)
+ (if (and-map
+ (lambda (#{x\ 2467}#)
+ (if (#{id?\ 1297}# #{x\ 2467}#)
+ (not (#{ellipsis?\ 1342}#
+ #{x\ 2467}#))
+ #f))
+ #{key\ 2465}#)
+ (let ((#{x\ 2469}#
+ (#{gen-var\ 1344}# (quote tmp))))
+ (#{build-application\ 1264}#
+ #{s\ 2458}#
+ (#{build-lambda\ 1273}#
+ #f
+ (list (quote tmp))
+ (list #{x\ 2469}#)
+ #f
+ (#{gen-syntax-case\ 2382}#
+ (#{build-lexical-reference\ 1266}#
+ 'value
+ #f
+ 'tmp
+ #{x\ 2469}#)
+ #{key\ 2465}#
+ #{m\ 2466}#
+ #{r\ 2456}#
+ #{mod\ 2459}#))
+ (list (#{chi\ 1333}#
+ #{val\ 2464}#
+ #{r\ 2456}#
+ '(())
+ #{mod\ 2459}#))))
+ (syntax-violation
+ 'syntax-case
+ "invalid literals list"
+ #{e\ 2460}#)))
+ #{tmp\ 2462}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2461}#)))
+ ($sc-dispatch
+ #{tmp\ 2461}#
+ '(any any each-any . each-any))))
+ #{e\ 2460}#)))))
+ (set! sc-expand
+ (lambda (#{x\ 2473}# . #{rest\ 2472}#)
+ (if (if (pair? #{x\ 2473}#)
+ (equal? (car #{x\ 2473}#) #{noexpand\ 1252}#)
+ #f)
+ (cadr #{x\ 2473}#)
+ (let ((#{m\ 2474}#
+ (if (null? #{rest\ 2472}#)
+ 'e
+ (car #{rest\ 2472}#)))
+ (#{esew\ 2475}#
+ (if (let ((#{t\ 2476}# (null? #{rest\ 2472}#)))
+ (if #{t\ 2476}#
+ #{t\ 2476}#
+ (null? (cdr #{rest\ 2472}#))))
+ '(eval)
+ (cadr #{rest\ 2472}#))))
+ (with-fluid*
+ #{*mode*\ 1253}#
+ #{m\ 2474}#
+ (lambda ()
+ (#{chi-top\ 1332}#
+ #{x\ 2473}#
+ '()
+ '((top))
+ #{m\ 2474}#
+ #{esew\ 2475}#
+ (cons 'hygiene
+ (module-name (current-module))))))))))
+ (set! identifier?
+ (lambda (#{x\ 2477}#)
+ (#{nonsymbol-id?\ 1296}# #{x\ 2477}#)))
+ (set! datum->syntax
+ (lambda (#{id\ 2478}# #{datum\ 2479}#)
+ (#{make-syntax-object\ 1280}#
+ #{datum\ 2479}#
+ (#{syntax-object-wrap\ 1283}# #{id\ 2478}#)
+ #f)))
+ (set! syntax->datum
+ (lambda (#{x\ 2480}#)
+ (#{strip\ 1343}# #{x\ 2480}# (quote (())))))
+ (set! generate-temporaries
+ (lambda (#{ls\ 2481}#)
+ (begin
+ (let ((#{x\ 2482}# #{ls\ 2481}#))
+ (if (not (list? #{x\ 2482}#))
+ (syntax-violation
+ 'generate-temporaries
+ "invalid argument"
+ #{x\ 2482}#)))
+ (map (lambda (#{x\ 2483}#)
+ (#{wrap\ 1325}# (gensym) (quote ((top))) #f))
+ #{ls\ 2481}#))))
+ (set! free-identifier=?
+ (lambda (#{x\ 2484}# #{y\ 2485}#)
+ (begin
+ (let ((#{x\ 2486}# #{x\ 2484}#))
+ (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2486}#))
+ (syntax-violation
+ 'free-identifier=?
+ "invalid argument"
+ #{x\ 2486}#)))
+ (let ((#{x\ 2487}# #{y\ 2485}#))
+ (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2487}#))
+ (syntax-violation
+ 'free-identifier=?
+ "invalid argument"
+ #{x\ 2487}#)))
+ (#{free-id=?\ 1320}# #{x\ 2484}# #{y\ 2485}#))))
+ (set! bound-identifier=?
+ (lambda (#{x\ 2488}# #{y\ 2489}#)
+ (begin
+ (let ((#{x\ 2490}# #{x\ 2488}#))
+ (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2490}#))
+ (syntax-violation
+ 'bound-identifier=?
+ "invalid argument"
+ #{x\ 2490}#)))
+ (let ((#{x\ 2491}# #{y\ 2489}#))
+ (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2491}#))
+ (syntax-violation
+ 'bound-identifier=?
+ "invalid argument"
+ #{x\ 2491}#)))
+ (#{bound-id=?\ 1321}# #{x\ 2488}# #{y\ 2489}#))))
+ (set! syntax-violation
+ (lambda (#{who\ 2495}#
+ #{message\ 2494}#
+ #{form\ 2493}#
+ .
+ #{subform\ 2492}#)
+ (begin
+ (let ((#{x\ 2496}# #{who\ 2495}#))
+ (if (not ((lambda (#{x\ 2497}#)
+ (let ((#{t\ 2498}# (not #{x\ 2497}#)))
+ (if #{t\ 2498}#
+ #{t\ 2498}#
+ (let ((#{t\ 2499}# (string? #{x\ 2497}#)))
+ (if #{t\ 2499}#
+ #{t\ 2499}#
+ (symbol? #{x\ 2497}#))))))
+ #{x\ 2496}#))
+ (syntax-violation
+ 'syntax-violation
+ "invalid argument"
+ #{x\ 2496}#)))
+ (let ((#{x\ 2500}# #{message\ 2494}#))
+ (if (not (string? #{x\ 2500}#))
+ (syntax-violation
+ 'syntax-violation
+ "invalid argument"
+ #{x\ 2500}#)))
+ (scm-error
+ 'syntax-error
+ 'sc-expand
+ (string-append
+ (if #{who\ 2495}# "~a: " "")
+ "~a "
+ (if (null? #{subform\ 2492}#)
+ "in ~a"
+ "in subform `~s' of `~s'"))
+ (let ((#{tail\ 2501}#
+ (cons #{message\ 2494}#
+ (map (lambda (#{x\ 2502}#)
+ (#{strip\ 1343}# #{x\ 2502}# (quote (()))))
+ (append
+ #{subform\ 2492}#
+ (list #{form\ 2493}#))))))
+ (if #{who\ 2495}#
+ (cons #{who\ 2495}# #{tail\ 2501}#)
+ #{tail\ 2501}#))
+ #f))))
+ (letrec ((#{match\ 2507}#
+ (lambda (#{e\ 2508}#
+ #{p\ 2509}#
+ #{w\ 2510}#
+ #{r\ 2511}#
+ #{mod\ 2512}#)
+ (if (not #{r\ 2511}#)
+ #f
+ (if (eq? #{p\ 2509}# (quote any))
+ (cons (#{wrap\ 1325}#
+ #{e\ 2508}#
+ #{w\ 2510}#
+ #{mod\ 2512}#)
+ #{r\ 2511}#)
+ (if (#{syntax-object?\ 1281}# #{e\ 2508}#)
+ (#{match*\ 2506}#
+ (#{syntax-object-expression\ 1282}# #{e\ 2508}#)
+ #{p\ 2509}#
+ (#{join-wraps\ 1316}#
+ #{w\ 2510}#
+ (#{syntax-object-wrap\ 1283}# #{e\ 2508}#))
+ #{r\ 2511}#
+ (#{syntax-object-module\ 1284}# #{e\ 2508}#))
+ (#{match*\ 2506}#
+ #{e\ 2508}#
+ #{p\ 2509}#
+ #{w\ 2510}#
+ #{r\ 2511}#
+ #{mod\ 2512}#))))))
+ (#{match*\ 2506}#
+ (lambda (#{e\ 2513}#
+ #{p\ 2514}#
+ #{w\ 2515}#
+ #{r\ 2516}#
+ #{mod\ 2517}#)
+ (if (null? #{p\ 2514}#)
+ (if (null? #{e\ 2513}#) #{r\ 2516}# #f)
+ (if (pair? #{p\ 2514}#)
+ (if (pair? #{e\ 2513}#)
+ (#{match\ 2507}#
+ (car #{e\ 2513}#)
+ (car #{p\ 2514}#)
+ #{w\ 2515}#
+ (#{match\ 2507}#
+ (cdr #{e\ 2513}#)
+ (cdr #{p\ 2514}#)
+ #{w\ 2515}#
+ #{r\ 2516}#
+ #{mod\ 2517}#)
+ #{mod\ 2517}#)
+ #f)
+ (if (eq? #{p\ 2514}# (quote each-any))
+ (let ((#{l\ 2518}#
+ (#{match-each-any\ 2504}#
+ #{e\ 2513}#
+ #{w\ 2515}#
+ #{mod\ 2517}#)))
+ (if #{l\ 2518}#
+ (cons #{l\ 2518}# #{r\ 2516}#)
+ #f))
+ (let ((#{atom-key\ 2519}# (vector-ref #{p\ 2514}# 0)))
+ (if (memv #{atom-key\ 2519}# (quote (each)))
+ (if (null? #{e\ 2513}#)
+ (#{match-empty\ 2505}#
+ (vector-ref #{p\ 2514}# 1)
+ #{r\ 2516}#)
+ (let ((#{l\ 2520}#
+ (#{match-each\ 2503}#
+ #{e\ 2513}#
+ (vector-ref #{p\ 2514}# 1)
+ #{w\ 2515}#
+ #{mod\ 2517}#)))
+ (if #{l\ 2520}#
+ (letrec ((#{collect\ 2521}#
+ (lambda (#{l\ 2522}#)
+ (if (null? (car #{l\ 2522}#))
+ #{r\ 2516}#
+ (cons (map car #{l\ 2522}#)
+ (#{collect\ 2521}#
+ (map cdr
+ #{l\ 2522}#)))))))
+ (#{collect\ 2521}# #{l\ 2520}#))
+ #f)))
+ (if (memv #{atom-key\ 2519}# (quote (free-id)))
+ (if (#{id?\ 1297}# #{e\ 2513}#)
+ (if (#{free-id=?\ 1320}#
+ (#{wrap\ 1325}#
+ #{e\ 2513}#
+ #{w\ 2515}#
+ #{mod\ 2517}#)
+ (vector-ref #{p\ 2514}# 1))
+ #{r\ 2516}#
+ #f)
+ #f)
+ (if (memv #{atom-key\ 2519}# (quote (atom)))
+ (if (equal?
+ (vector-ref #{p\ 2514}# 1)
+ (#{strip\ 1343}#
+ #{e\ 2513}#
+ #{w\ 2515}#))
+ #{r\ 2516}#
+ #f)
+ (if (memv #{atom-key\ 2519}# (quote (vector)))
+ (if (vector? #{e\ 2513}#)
+ (#{match\ 2507}#
+ (vector->list #{e\ 2513}#)
+ (vector-ref #{p\ 2514}# 1)
+ #{w\ 2515}#
+ #{r\ 2516}#
+ #{mod\ 2517}#)
+ #f)))))))))))
+ (#{match-empty\ 2505}#
+ (lambda (#{p\ 2523}# #{r\ 2524}#)
+ (if (null? #{p\ 2523}#)
+ #{r\ 2524}#
+ (if (eq? #{p\ 2523}# (quote any))
+ (cons (quote ()) #{r\ 2524}#)
+ (if (pair? #{p\ 2523}#)
+ (#{match-empty\ 2505}#
+ (car #{p\ 2523}#)
+ (#{match-empty\ 2505}#
+ (cdr #{p\ 2523}#)
+ #{r\ 2524}#))
+ (if (eq? #{p\ 2523}# (quote each-any))
+ (cons (quote ()) #{r\ 2524}#)
+ (let ((#{atom-key\ 2525}#
+ (vector-ref #{p\ 2523}# 0)))
+ (if (memv #{atom-key\ 2525}# (quote (each)))
+ (#{match-empty\ 2505}#
+ (vector-ref #{p\ 2523}# 1)
+ #{r\ 2524}#)
+ (if (memv #{atom-key\ 2525}#
+ '(free-id atom))
+ #{r\ 2524}#
+ (if (memv #{atom-key\ 2525}# (quote (vector)))
+ (#{match-empty\ 2505}#
+ (vector-ref #{p\ 2523}# 1)
+ #{r\ 2524}#)))))))))))
+ (#{match-each-any\ 2504}#
+ (lambda (#{e\ 2526}# #{w\ 2527}# #{mod\ 2528}#)
+ (if (pair? #{e\ 2526}#)
+ (let ((#{l\ 2529}#
+ (#{match-each-any\ 2504}#
+ (cdr #{e\ 2526}#)
+ #{w\ 2527}#
+ #{mod\ 2528}#)))
+ (if #{l\ 2529}#
+ (cons (#{wrap\ 1325}#
+ (car #{e\ 2526}#)
+ #{w\ 2527}#
+ #{mod\ 2528}#)
+ #{l\ 2529}#)
+ #f))
+ (if (null? #{e\ 2526}#)
+ '()
+ (if (#{syntax-object?\ 1281}# #{e\ 2526}#)
+ (#{match-each-any\ 2504}#
+ (#{syntax-object-expression\ 1282}# #{e\ 2526}#)
+ (#{join-wraps\ 1316}#
+ #{w\ 2527}#
+ (#{syntax-object-wrap\ 1283}# #{e\ 2526}#))
+ #{mod\ 2528}#)
+ #f)))))
+ (#{match-each\ 2503}#
+ (lambda (#{e\ 2530}#
+ #{p\ 2531}#
+ #{w\ 2532}#
+ #{mod\ 2533}#)
+ (if (pair? #{e\ 2530}#)
+ (let ((#{first\ 2534}#
+ (#{match\ 2507}#
+ (car #{e\ 2530}#)
+ #{p\ 2531}#
+ #{w\ 2532}#
+ '()
+ #{mod\ 2533}#)))
+ (if #{first\ 2534}#
+ (let ((#{rest\ 2535}#
+ (#{match-each\ 2503}#
+ (cdr #{e\ 2530}#)
+ #{p\ 2531}#
+ #{w\ 2532}#
+ #{mod\ 2533}#)))
+ (if #{rest\ 2535}#
+ (cons #{first\ 2534}# #{rest\ 2535}#)
+ #f))
+ #f))
+ (if (null? #{e\ 2530}#)
+ '()
+ (if (#{syntax-object?\ 1281}# #{e\ 2530}#)
+ (#{match-each\ 2503}#
+ (#{syntax-object-expression\ 1282}# #{e\ 2530}#)
+ #{p\ 2531}#
+ (#{join-wraps\ 1316}#
+ #{w\ 2532}#
+ (#{syntax-object-wrap\ 1283}# #{e\ 2530}#))
+ (#{syntax-object-module\ 1284}# #{e\ 2530}#))
+ #f))))))
+ (set! $sc-dispatch
+ (lambda (#{e\ 2536}# #{p\ 2537}#)
+ (if (eq? #{p\ 2537}# (quote any))
+ (list #{e\ 2536}#)
+ (if (#{syntax-object?\ 1281}# #{e\ 2536}#)
+ (#{match*\ 2506}#
+ (#{syntax-object-expression\ 1282}# #{e\ 2536}#)
+ #{p\ 2537}#
+ (#{syntax-object-wrap\ 1283}# #{e\ 2536}#)
+ '()
+ (#{syntax-object-module\ 1284}# #{e\ 2536}#))
+ (#{match*\ 2506}#
+ #{e\ 2536}#
+ #{p\ 2537}#
+ '(())
+ '()
+ #f)))))))))
+
+(define with-syntax
+ (make-syncase-macro
+ 'macro
+ (lambda (#{x\ 2538}#)
+ ((lambda (#{tmp\ 2539}#)
+ ((lambda (#{tmp\ 2540}#)
+ (if #{tmp\ 2540}#
+ (apply (lambda (#{_\ 2541}# #{e1\ 2542}# #{e2\ 2543}#)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ e1 e2)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ (cons #{e1\ 2542}# #{e2\ 2543}#)))
+ #{tmp\ 2540}#)
+ ((lambda (#{tmp\ 2545}#)
+ (if #{tmp\ 2545}#
+ (apply (lambda (#{_\ 2546}#
+ #{out\ 2547}#
+ #{in\ 2548}#
+ #{e1\ 2549}#
+ #{e2\ 2550}#)
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ #{in\ 2548}#
+ '()
+ (list #{out\ 2547}#
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ (cons #{e1\ 2549}#
+ #{e2\ 2550}#)))))
+ #{tmp\ 2545}#)
+ ((lambda (#{tmp\ 2552}#)
+ (if #{tmp\ 2552}#
+ (apply (lambda (#{_\ 2553}#
+ #{out\ 2554}#
+ #{in\ 2555}#
+ #{e1\ 2556}#
+ #{e2\ 2557}#)
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ (cons '#(syntax-object
+ list
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ #{in\ 2555}#)
+ '()
+ (list #{out\ 2554}#
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(_ out in e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ (cons #{e1\ 2556}#
+ #{e2\ 2557}#)))))
+ #{tmp\ 2552}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2539}#)))
+ ($sc-dispatch
+ #{tmp\ 2539}#
+ '(any #(each (any any)) any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 2539}#
+ '(any ((any any)) any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 2539}#
+ '(any () any . each-any))))
+ #{x\ 2538}#))))
+
+(define syntax-rules
+ (make-syncase-macro
+ 'macro
+ (lambda (#{x\ 2561}#)
+ ((lambda (#{tmp\ 2562}#)
+ ((lambda (#{tmp\ 2563}#)
+ (if #{tmp\ 2563}#
+ (apply (lambda (#{_\ 2564}#
+ #{k\ 2565}#
+ #{keyword\ 2566}#
+ #{pattern\ 2567}#
+ #{template\ 2568}#)
+ (list '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(_ k keyword pattern template)
+ #((top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ '(#(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 '#(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 '#(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 #{k\ 2565}#
+ (map (lambda (#{tmp\ 2571}#
+ #{tmp\ 2570}#)
+ (list (cons '#(syntax-object
+ dummy
+ ((top)
+ #(ribcage
+ #(_
+ k
+ keyword
+ pattern
+ template)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{tmp\ 2570}#)
+ (list '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_
+ k
+ keyword
+ pattern
+ template)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{tmp\ 2571}#)))
+ #{template\ 2568}#
+ #{pattern\ 2567}#))))))
+ #{tmp\ 2563}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2562}#)))
+ ($sc-dispatch
+ #{tmp\ 2562}#
+ '(any each-any . #(each ((any . any) any))))))
+ #{x\ 2561}#))))
+
+(define let*
+ (make-extended-syncase-macro
+ (module-ref (current-module) (quote let*))
+ 'macro
+ (lambda (#{x\ 2572}#)
+ ((lambda (#{tmp\ 2573}#)
+ ((lambda (#{tmp\ 2574}#)
+ (if (if #{tmp\ 2574}#
+ (apply (lambda (#{let*\ 2575}#
+ #{x\ 2576}#
+ #{v\ 2577}#
+ #{e1\ 2578}#
+ #{e2\ 2579}#)
+ (and-map identifier? #{x\ 2576}#))
+ #{tmp\ 2574}#)
+ #f)
+ (apply (lambda (#{let*\ 2581}#
+ #{x\ 2582}#
+ #{v\ 2583}#
+ #{e1\ 2584}#
+ #{e2\ 2585}#)
+ (letrec ((#{f\ 2586}#
+ (lambda (#{bindings\ 2587}#)
+ (if (null? #{bindings\ 2587}#)
+ (cons '#(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 '()
+ (cons #{e1\ 2584}#
+ #{e2\ 2585}#)))
+ ((lambda (#{tmp\ 2591}#)
+ ((lambda (#{tmp\ 2592}#)
+ (if #{tmp\ 2592}#
+ (apply (lambda (#{body\ 2593}#
+ #{binding\ 2594}#)
+ (list '#(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 #{binding\ 2594}#)
+ #{body\ 2593}#))
+ #{tmp\ 2592}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2591}#)))
+ ($sc-dispatch
+ #{tmp\ 2591}#
+ '(any any))))
+ (list (#{f\ 2586}#
+ (cdr #{bindings\ 2587}#))
+ (car #{bindings\ 2587}#)))))))
+ (#{f\ 2586}# (map list #{x\ 2582}# #{v\ 2583}#))))
+ #{tmp\ 2574}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2573}#)))
+ ($sc-dispatch
+ #{tmp\ 2573}#
+ '(any #(each (any any)) any . each-any))))
+ #{x\ 2572}#))))
+
+(define do
+ (make-extended-syncase-macro
+ (module-ref (current-module) (quote do))
+ 'macro
+ (lambda (#{orig-x\ 2595}#)
+ ((lambda (#{tmp\ 2596}#)
+ ((lambda (#{tmp\ 2597}#)
+ (if #{tmp\ 2597}#
+ (apply (lambda (#{_\ 2598}#
+ #{var\ 2599}#
+ #{init\ 2600}#
+ #{step\ 2601}#
+ #{e0\ 2602}#
+ #{e1\ 2603}#
+ #{c\ 2604}#)
+ ((lambda (#{tmp\ 2605}#)
+ ((lambda (#{tmp\ 2606}#)
+ (if #{tmp\ 2606}#
+ (apply (lambda (#{step\ 2607}#)
+ ((lambda (#{tmp\ 2608}#)
+ ((lambda (#{tmp\ 2609}#)
+ (if #{tmp\ 2609}#
+ (apply (lambda ()
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ '#(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
+ #{var\ 2599}#
+ #{init\ 2600}#)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (list '#(syntax-object
+ not
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{e0\ 2602}#)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (append
+ #{c\ 2604}#
+ (list (cons '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{step\ 2607}#)))))))
+ #{tmp\ 2609}#)
+ ((lambda (#{tmp\ 2614}#)
+ (if #{tmp\ 2614}#
+ (apply (lambda (#{e1\ 2615}#
+ #{e2\ 2616}#)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ '#(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
+ #{var\ 2599}#
+ #{init\ 2600}#)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{e0\ 2602}#
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (cons #{e1\ 2615}#
+ #{e2\ 2616}#))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (append
+ #{c\ 2604}#
+ (list (cons '#(syntax-object
+ doloop
+ ((top)
+ #(ribcage
+ #(e1
+ e2)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ #(step)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_
+ var
+ init
+ step
+ e0
+ e1
+ c)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(orig-x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{step\ 2607}#)))))))
+ #{tmp\ 2614}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2608}#)))
+ ($sc-dispatch
+ #{tmp\ 2608}#
+ '(any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 2608}#
+ '())))
+ #{e1\ 2603}#))
+ #{tmp\ 2606}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2605}#)))
+ ($sc-dispatch #{tmp\ 2605}# (quote each-any))))
+ (map (lambda (#{v\ 2623}# #{s\ 2624}#)
+ ((lambda (#{tmp\ 2625}#)
+ ((lambda (#{tmp\ 2626}#)
+ (if #{tmp\ 2626}#
+ (apply (lambda () #{v\ 2623}#)
+ #{tmp\ 2626}#)
+ ((lambda (#{tmp\ 2627}#)
+ (if #{tmp\ 2627}#
+ (apply (lambda (#{e\ 2628}#)
+ #{e\ 2628}#)
+ #{tmp\ 2627}#)
+ ((lambda (#{_\ 2629}#)
+ (syntax-violation
+ 'do
+ "bad step expression"
+ #{orig-x\ 2595}#
+ #{s\ 2624}#))
+ #{tmp\ 2625}#)))
+ ($sc-dispatch
+ #{tmp\ 2625}#
+ '(any)))))
+ ($sc-dispatch #{tmp\ 2625}# (quote ()))))
+ #{s\ 2624}#))
+ #{var\ 2599}#
+ #{step\ 2601}#)))
+ #{tmp\ 2597}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2596}#)))
+ ($sc-dispatch
+ #{tmp\ 2596}#
+ '(any #(each (any any . any))
+ (any . each-any)
+ .
+ each-any))))
+ #{orig-x\ 2595}#))))
+
+(define quasiquote
+ (make-extended-syncase-macro
+ (module-ref (current-module) (quote quasiquote))
+ 'macro
+ (letrec ((#{quasicons\ 2632}#
+ (lambda (#{x\ 2636}# #{y\ 2637}#)
+ ((lambda (#{tmp\ 2638}#)
+ ((lambda (#{tmp\ 2639}#)
+ (if #{tmp\ 2639}#
+ (apply (lambda (#{x\ 2640}# #{y\ 2641}#)
+ ((lambda (#{tmp\ 2642}#)
+ ((lambda (#{tmp\ 2643}#)
+ (if #{tmp\ 2643}#
+ (apply (lambda (#{dy\ 2644}#)
+ ((lambda (#{tmp\ 2645}#)
+ ((lambda (#{tmp\ 2646}#)
+ (if #{tmp\ 2646}#
+ (apply (lambda (#{dx\ 2647}#)
+ (list '#(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 #{dx\ 2647}#
+ #{dy\ 2644}#)))
+ #{tmp\ 2646}#)
+ ((lambda (#{_\ 2648}#)
+ (if (null? #{dy\ 2644}#)
+ (list '#(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))
+ #{x\ 2640}#)
+ (list '#(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))
+ #{x\ 2640}#
+ #{y\ 2641}#)))
+ #{tmp\ 2645}#)))
+ ($sc-dispatch
+ #{tmp\ 2645}#
+ '(#(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))))
+ #{x\ 2640}#))
+ #{tmp\ 2643}#)
+ ((lambda (#{tmp\ 2649}#)
+ (if #{tmp\ 2649}#
+ (apply (lambda (#{stuff\ 2650}#)
+ (cons '#(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 #{x\ 2640}#
+ #{stuff\ 2650}#)))
+ #{tmp\ 2649}#)
+ ((lambda (#{else\ 2651}#)
+ (list '#(syntax-object
+ cons
+ ((top)
+ #(ribcage
+ #(else)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x y)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(quasicons
+ quasiappend
+ quasivector
+ quasi)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i")))
+ (hygiene guile))
+ #{x\ 2640}#
+ #{y\ 2641}#))
+ #{tmp\ 2642}#)))
+ ($sc-dispatch
+ #{tmp\ 2642}#
+ '(#(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
+ #{tmp\ 2642}#
+ '(#(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))))
+ #{y\ 2641}#))
+ #{tmp\ 2639}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2638}#)))
+ ($sc-dispatch #{tmp\ 2638}# (quote (any any)))))
+ (list #{x\ 2636}# #{y\ 2637}#))))
+ (#{quasiappend\ 2633}#
+ (lambda (#{x\ 2652}# #{y\ 2653}#)
+ ((lambda (#{tmp\ 2654}#)
+ ((lambda (#{tmp\ 2655}#)
+ (if #{tmp\ 2655}#
+ (apply (lambda (#{x\ 2656}# #{y\ 2657}#)
+ ((lambda (#{tmp\ 2658}#)
+ ((lambda (#{tmp\ 2659}#)
+ (if #{tmp\ 2659}#
+ (apply (lambda () #{x\ 2656}#)
+ #{tmp\ 2659}#)
+ ((lambda (#{_\ 2660}#)
+ (list '#(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))
+ #{x\ 2656}#
+ #{y\ 2657}#))
+ #{tmp\ 2658}#)))
+ ($sc-dispatch
+ #{tmp\ 2658}#
+ '(#(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)))
+ ()))))
+ #{y\ 2657}#))
+ #{tmp\ 2655}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2654}#)))
+ ($sc-dispatch #{tmp\ 2654}# (quote (any any)))))
+ (list #{x\ 2652}# #{y\ 2653}#))))
+ (#{quasivector\ 2634}#
+ (lambda (#{x\ 2661}#)
+ ((lambda (#{tmp\ 2662}#)
+ ((lambda (#{x\ 2663}#)
+ ((lambda (#{tmp\ 2664}#)
+ ((lambda (#{tmp\ 2665}#)
+ (if #{tmp\ 2665}#
+ (apply (lambda (#{x\ 2666}#)
+ (list '#(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 #{x\ 2666}#)))
+ #{tmp\ 2665}#)
+ ((lambda (#{tmp\ 2668}#)
+ (if #{tmp\ 2668}#
+ (apply (lambda (#{x\ 2669}#)
+ (cons '#(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))
+ #{x\ 2669}#))
+ #{tmp\ 2668}#)
+ ((lambda (#{_\ 2671}#)
+ (list '#(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))
+ #{x\ 2663}#))
+ #{tmp\ 2664}#)))
+ ($sc-dispatch
+ #{tmp\ 2664}#
+ '(#(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
+ #{tmp\ 2664}#
+ '(#(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))))
+ #{x\ 2663}#))
+ #{tmp\ 2662}#))
+ #{x\ 2661}#)))
+ (#{quasi\ 2635}#
+ (lambda (#{p\ 2672}# #{lev\ 2673}#)
+ ((lambda (#{tmp\ 2674}#)
+ ((lambda (#{tmp\ 2675}#)
+ (if #{tmp\ 2675}#
+ (apply (lambda (#{p\ 2676}#)
+ (if (= #{lev\ 2673}# 0)
+ #{p\ 2676}#
+ (#{quasicons\ 2632}#
+ '(#(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)))
+ (#{quasi\ 2635}#
+ (list #{p\ 2676}#)
+ (- #{lev\ 2673}# 1)))))
+ #{tmp\ 2675}#)
+ ((lambda (#{tmp\ 2677}#)
+ (if (if #{tmp\ 2677}#
+ (apply (lambda (#{args\ 2678}#)
+ (= #{lev\ 2673}# 0))
+ #{tmp\ 2677}#)
+ #f)
+ (apply (lambda (#{args\ 2679}#)
+ (syntax-violation
+ 'unquote
+ "unquote takes exactly one argument"
+ #{p\ 2672}#
+ (cons '#(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))
+ #{args\ 2679}#)))
+ #{tmp\ 2677}#)
+ ((lambda (#{tmp\ 2680}#)
+ (if #{tmp\ 2680}#
+ (apply (lambda (#{p\ 2681}# #{q\ 2682}#)
+ (if (= #{lev\ 2673}# 0)
+ (#{quasiappend\ 2633}#
+ #{p\ 2681}#
+ (#{quasi\ 2635}#
+ #{q\ 2682}#
+ #{lev\ 2673}#))
+ (#{quasicons\ 2632}#
+ (#{quasicons\ 2632}#
+ '(#(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)))
+ (#{quasi\ 2635}#
+ (list #{p\ 2681}#)
+ (- #{lev\ 2673}# 1)))
+ (#{quasi\ 2635}#
+ #{q\ 2682}#
+ #{lev\ 2673}#))))
+ #{tmp\ 2680}#)
+ ((lambda (#{tmp\ 2683}#)
+ (if (if #{tmp\ 2683}#
+ (apply (lambda (#{args\ 2684}#
+ #{q\ 2685}#)
+ (= #{lev\ 2673}# 0))
+ #{tmp\ 2683}#)
+ #f)
+ (apply (lambda (#{args\ 2686}#
+ #{q\ 2687}#)
+ (syntax-violation
+ 'unquote-splicing
+ "unquote-splicing takes exactly one argument"
+ #{p\ 2672}#
+ (cons '#(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))
+ #{args\ 2686}#)))
+ #{tmp\ 2683}#)
+ ((lambda (#{tmp\ 2688}#)
+ (if #{tmp\ 2688}#
+ (apply (lambda (#{p\ 2689}#)
+ (#{quasicons\ 2632}#
+ '(#(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)))
+ (#{quasi\ 2635}#
+ (list #{p\ 2689}#)
+ (+ #{lev\ 2673}#
+ 1))))
+ #{tmp\ 2688}#)
+ ((lambda (#{tmp\ 2690}#)
+ (if #{tmp\ 2690}#
+ (apply (lambda (#{p\ 2691}#
+ #{q\ 2692}#)
+ (#{quasicons\ 2632}#
+ (#{quasi\ 2635}#
+ #{p\ 2691}#
+ #{lev\ 2673}#)
+ (#{quasi\ 2635}#
+ #{q\ 2692}#
+ #{lev\ 2673}#)))
+ #{tmp\ 2690}#)
+ ((lambda (#{tmp\ 2693}#)
+ (if #{tmp\ 2693}#
+ (apply (lambda (#{x\ 2694}#)
+ (#{quasivector\ 2634}#
+ (#{quasi\ 2635}#
+ #{x\ 2694}#
+ #{lev\ 2673}#)))
+ #{tmp\ 2693}#)
+ ((lambda (#{p\ 2696}#)
+ (list '#(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))
+ #{p\ 2696}#))
+ #{tmp\ 2674}#)))
+ ($sc-dispatch
+ #{tmp\ 2674}#
+ '#(vector each-any)))))
+ ($sc-dispatch
+ #{tmp\ 2674}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 2674}#
+ '(#(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
+ #{tmp\ 2674}#
+ '((#(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
+ #{tmp\ 2674}#
+ '((#(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
+ #{tmp\ 2674}#
+ '(#(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
+ #{tmp\ 2674}#
+ '(#(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))))
+ #{p\ 2672}#))))
+ (lambda (#{x\ 2697}#)
+ ((lambda (#{tmp\ 2698}#)
+ ((lambda (#{tmp\ 2699}#)
+ (if #{tmp\ 2699}#
+ (apply (lambda (#{_\ 2700}# #{e\ 2701}#)
+ (#{quasi\ 2635}# #{e\ 2701}# 0))
+ #{tmp\ 2699}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2698}#)))
+ ($sc-dispatch #{tmp\ 2698}# (quote (any any)))))
+ #{x\ 2697}#)))))
+
+(define include
+ (make-syncase-macro
+ 'macro
+ (lambda (#{x\ 2702}#)
+ (letrec ((#{read-file\ 2703}#
+ (lambda (#{fn\ 2704}# #{k\ 2705}#)
+ (let ((#{p\ 2706}# (open-input-file #{fn\ 2704}#)))
+ (letrec ((#{f\ 2707}#
+ (lambda (#{x\ 2708}#)
+ (if (eof-object? #{x\ 2708}#)
+ (begin
+ (close-input-port #{p\ 2706}#)
+ '())
+ (cons (datum->syntax
+ #{k\ 2705}#
+ #{x\ 2708}#)
+ (#{f\ 2707}# (read #{p\ 2706}#)))))))
+ (#{f\ 2707}# (read #{p\ 2706}#)))))))
+ ((lambda (#{tmp\ 2709}#)
+ ((lambda (#{tmp\ 2710}#)
+ (if #{tmp\ 2710}#
+ (apply (lambda (#{k\ 2711}# #{filename\ 2712}#)
+ (let ((#{fn\ 2713}#
+ (syntax->datum #{filename\ 2712}#)))
+ ((lambda (#{tmp\ 2714}#)
+ ((lambda (#{tmp\ 2715}#)
+ (if #{tmp\ 2715}#
+ (apply (lambda (#{exp\ 2716}#)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(exp)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(fn)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(k filename)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ (read-file)
+ ((top))
+ ("i"))
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ #{exp\ 2716}#))
+ #{tmp\ 2715}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2714}#)))
+ ($sc-dispatch #{tmp\ 2714}# (quote each-any))))
+ (#{read-file\ 2703}# #{fn\ 2713}# #{k\ 2711}#))))
+ #{tmp\ 2710}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2709}#)))
+ ($sc-dispatch #{tmp\ 2709}# (quote (any any)))))
+ #{x\ 2702}#)))))
+
+(define unquote
+ (make-syncase-macro
+ 'macro
+ (lambda (#{x\ 2718}#)
+ ((lambda (#{tmp\ 2719}#)
+ ((lambda (#{tmp\ 2720}#)
+ (if #{tmp\ 2720}#
+ (apply (lambda (#{_\ 2721}# #{e\ 2722}#)
+ (syntax-violation
+ 'unquote
+ "expression not valid outside of quasiquote"
+ #{x\ 2718}#))
+ #{tmp\ 2720}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2719}#)))
+ ($sc-dispatch #{tmp\ 2719}# (quote (any any)))))
+ #{x\ 2718}#))))
+
+(define unquote-splicing
+ (make-syncase-macro
+ 'macro
+ (lambda (#{x\ 2723}#)
+ ((lambda (#{tmp\ 2724}#)
+ ((lambda (#{tmp\ 2725}#)
+ (if #{tmp\ 2725}#
+ (apply (lambda (#{_\ 2726}# #{e\ 2727}#)
+ (syntax-violation
+ 'unquote-splicing
+ "expression not valid outside of quasiquote"
+ #{x\ 2723}#))
+ #{tmp\ 2725}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2724}#)))
+ ($sc-dispatch #{tmp\ 2724}# (quote (any any)))))
+ #{x\ 2723}#))))
+
+(define case
+ (make-extended-syncase-macro
+ (module-ref (current-module) (quote case))
+ 'macro
+ (lambda (#{x\ 2728}#)
+ ((lambda (#{tmp\ 2729}#)
+ ((lambda (#{tmp\ 2730}#)
+ (if #{tmp\ 2730}#
+ (apply (lambda (#{_\ 2731}#
+ #{e\ 2732}#
+ #{m1\ 2733}#
+ #{m2\ 2734}#)
+ ((lambda (#{tmp\ 2735}#)
+ ((lambda (#{body\ 2736}#)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage #(body) #((top)) #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ (list (list '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(body)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top) (top) (top) (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ #{e\ 2732}#))
+ #{body\ 2736}#))
+ #{tmp\ 2735}#))
+ (letrec ((#{f\ 2737}#
+ (lambda (#{clause\ 2738}# #{clauses\ 2739}#)
+ (if (null? #{clauses\ 2739}#)
+ ((lambda (#{tmp\ 2741}#)
+ ((lambda (#{tmp\ 2742}#)
+ (if #{tmp\ 2742}#
+ (apply (lambda (#{e1\ 2743}#
+ #{e2\ 2744}#)
+ (cons '#(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 #{e1\ 2743}#
+ #{e2\ 2744}#)))
+ #{tmp\ 2742}#)
+ ((lambda (#{tmp\ 2746}#)
+ (if #{tmp\ 2746}#
+ (apply (lambda (#{k\ 2747}#
+ #{e1\ 2748}#
+ #{e2\ 2749}#)
+ (list '#(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 '#(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))
+ '#(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 '#(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))
+ #{k\ 2747}#))
+ (cons '#(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 #{e1\ 2748}#
+ #{e2\ 2749}#))))
+ #{tmp\ 2746}#)
+ ((lambda (#{_\ 2752}#)
+ (syntax-violation
+ 'case
+ "bad clause"
+ #{x\ 2728}#
+ #{clause\ 2738}#))
+ #{tmp\ 2741}#)))
+ ($sc-dispatch
+ #{tmp\ 2741}#
+ '(each-any
+ any
+ .
+ each-any)))))
+ ($sc-dispatch
+ #{tmp\ 2741}#
+ '(#(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))))
+ #{clause\ 2738}#)
+ ((lambda (#{tmp\ 2753}#)
+ ((lambda (#{rest\ 2754}#)
+ ((lambda (#{tmp\ 2755}#)
+ ((lambda (#{tmp\ 2756}#)
+ (if #{tmp\ 2756}#
+ (apply (lambda (#{k\ 2757}#
+ #{e1\ 2758}#
+ #{e2\ 2759}#)
+ (list '#(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 '#(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))
+ '#(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 '#(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))
+ #{k\ 2757}#))
+ (cons '#(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 #{e1\ 2758}#
+ #{e2\ 2759}#))
+ #{rest\ 2754}#))
+ #{tmp\ 2756}#)
+ ((lambda (#{_\ 2762}#)
+ (syntax-violation
+ 'case
+ "bad clause"
+ #{x\ 2728}#
+ #{clause\ 2738}#))
+ #{tmp\ 2755}#)))
+ ($sc-dispatch
+ #{tmp\ 2755}#
+ '(each-any
+ any
+ .
+ each-any))))
+ #{clause\ 2738}#))
+ #{tmp\ 2753}#))
+ (#{f\ 2737}#
+ (car #{clauses\ 2739}#)
+ (cdr #{clauses\ 2739}#)))))))
+ (#{f\ 2737}# #{m1\ 2733}# #{m2\ 2734}#))))
+ #{tmp\ 2730}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2729}#)))
+ ($sc-dispatch
+ #{tmp\ 2729}#
+ '(any any any . each-any))))
+ #{x\ 2728}#))))
+
+(define identifier-syntax
+ (make-syncase-macro
+ 'macro
+ (lambda (#{x\ 2763}#)
+ ((lambda (#{tmp\ 2764}#)
+ ((lambda (#{tmp\ 2765}#)
+ (if #{tmp\ 2765}#
+ (apply (lambda (#{_\ 2766}# #{e\ 2767}#)
+ (list '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage #(_ e) #((top) (top)) #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ '(#(syntax-object
+ x
+ ((top)
+ #(ribcage #(_ e) #((top) (top)) #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile)))
+ (list '#(syntax-object
+ syntax-case
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ '#(syntax-object
+ x
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ '()
+ (list '#(syntax-object
+ id
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i")))
+ (hygiene guile))
+ '(#(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 '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ #{e\ 2767}#))
+ (list (cons #{_\ 2766}#
+ '(#(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 '#(syntax-object
+ syntax
+ ((top)
+ #(ribcage
+ #(_ e)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ (cons #{e\ 2767}#
+ '(#(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)))))))))
+ #{tmp\ 2765}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2764}#)))
+ ($sc-dispatch #{tmp\ 2764}# (quote (any any)))))
+ #{x\ 2763}#))))
+
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 687e0e5bf..cb90fcc17 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1,11 +1,11 @@
;;;; -*-scheme-*-
;;;;
-;;;; Copyright (C) 2001, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -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 <wingo@pobox.com> according to the Git
+;;; revision control logs corresponding to this file: 2009.
+
;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> 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,
@@ -49,7 +52,7 @@
;;; also documented in the R4RS and draft R5RS.
;;;
;;; bound-identifier=?
-;;; datum->syntax-object
+;;; datum->syntax
;;; define-syntax
;;; fluid-let-syntax
;;; free-identifier=?
@@ -60,7 +63,7 @@
;;; letrec-syntax
;;; syntax
;;; syntax-case
-;;; syntax-object->datum
+;;; syntax->datum
;;; syntax-rules
;;; with-syntax
;;;
@@ -79,46 +82,14 @@
;;; conditionally evaluates expr ... at compile-time or run-time
;;; depending upon situations (see the Chez Scheme System Manual,
;;; Revision 3, for a complete description)
-;;; (syntax-error object message)
+;;; (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
-;;; (syntax-dispatch e p)
+;;; ($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
@@ -209,7 +167,7 @@
;;; Objects with no standard print syntax, including objects containing
;;; cycles and syntax object, are allowed in quoted data as long as they
-;;; are contained within a syntax form or produced by datum->syntax-object.
+;;; are contained within a syntax form or produced by datum->syntax.
;;; Such objects are never copied.
;;; All identifiers that don't have macro definitions and are not bound
@@ -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:
@@ -256,23 +201,45 @@
+(eval-when (compile)
+ (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
(lambda (template-identifier . args)
- (datum->syntax-object
+ (datum->syntax
template-identifier
(string->symbol
(apply string-append
(map (lambda (x)
(if (string? x)
x
- (symbol->string (syntax-object->datum x))))
+ (symbol->string (syntax->datum x))))
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) "?"))
@@ -310,6 +277,7 @@
(let ()
(define noexpand "noexpand")
+(define *mode* (make-fluid))
;;; hooks to nonportable run-time helpers
(begin
@@ -319,143 +287,273 @@
(define fx< <)
(define top-level-eval-hook
- (lambda (x)
- (eval `(,noexpand ,x) (interaction-environment))))
+ (lambda (x mod)
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
(define local-eval-hook
- (lambda (x)
- (eval `(,noexpand ,x) (interaction-environment))))
-
-(define error-hook
- (lambda (who why what)
- (error who "~a ~s" why what)))
+ (lambda (x mod)
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
(define-syntax gensym-hook
(syntax-rules ()
((_) (gensym))))
(define put-global-definition-hook
- (lambda (symbol binding)
- (putprop symbol '*sc-expander* binding)))
+ (lambda (symbol type val)
+ (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)
- (getprop symbol '*sc-expander*)))
-)
+ (lambda (symbol module)
+ (if (and (not module) (current-module))
+ (warn "module system is booted, we should have a 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)
- (build-annotated source var))))
-
-(define-syntax build-global-assignment
- (syntax-rules ()
- ((_ source var exp)
- (build-annotated source `(set! ,var ,exp)))))
-
-(define-syntax build-global-definition
- (syntax-rules ()
- ((_ source var exp)
- (build-annotated source `(define ,var ,exp)))))
-(define-syntax build-lambda
- (syntax-rules ()
- ((_ src vars exp)
- (build-annotated src `(lambda ,vars ,exp)))))
+(define (decorate-source e s)
+ (if (and (pair? e) s)
+ (set-source-properties! e s))
+ e)
-(define-syntax build-primref
- (syntax-rules ()
- ((_ src name) (build-annotated src name))
- ((_ src level name) (build-annotated src name))))
+;;; output constructors
+(define build-void
+ (lambda (source)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-void) source))
+ (else (decorate-source '(if #f #f) source)))))
+
+(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 (decorate-source `(,fun-exp . ,arg-exps) source)))))
+
+(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 (decorate-source
+ (if (equal? else-exp '(if #f #f))
+ `(if ,test-exp ,then-exp)
+ `(if ,test-exp ,then-exp ,else-exp))
+ source)))))
+
+(define build-lexical-reference
+ (lambda (type source name var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-ref) source name var))
+ (else (decorate-source var source)))))
+
+(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 (decorate-source `(set! ,var ,exp) source)))))
+
+;; 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 (decorate-source (list (if public? '@ '@@) mod var) source))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) source var))
+ (else (decorate-source var source)))))))
+
+(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 (decorate-source `(set! ,(list (if public? '@ '@@) mod var) ,exp) source))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
+ (else (decorate-source `(set! ,var ,exp) source)))))))
+
+;; 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 (decorate-source `(define ,var ,exp) source)))))
+
+(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 (decorate-source
+ `(lambda ,vars ,@(if docstring (list docstring) '())
+ ,exp)
+ src)))))
+
+(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 (decorate-source name src)))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
+ (else (decorate-source `(@@ (guile) ,name) src))))))
(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 (decorate-source
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp))
+ src))))
(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 (decorate-source `(begin ,@exps) src))))))
(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 (decorate-source
+ `(let ,(map list vars val-exps) ,body-exp)
+ src))))))
(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 (decorate-source
+ `(let ,f ,(map list vars val-exps) ,body-exp)
+ src))))))
(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)))))
-
+ 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 (decorate-source
+ `(letrec ,(map list vars val-exps) ,body-exp)
+ src))))))
+
+;; FIXME: use a faster gensym
(define-syntax build-lexical-var
(syntax-rules ()
- ((_ src id) (build-annotated src (gensym (symbol->string id))))))
+ ((_ src id) (gensym (string-append (symbol->string id) " ")))))
-(define-structure (syntax-object expression wrap))
-
-(define-syntax unannotate
- (syntax-rules ()
- ((_ x)
- (let ((e x))
- (if (annotation? e)
- (annotation-expression e)
- e)))))
+(define-structure (syntax-object expression wrap module))
(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
@@ -479,7 +577,7 @@
;;; <binding> ::= (macro . <procedure>) macros
;;; (core . <procedure>) core forms
-;;; (external-macro . <procedure>) external-macro
+;;; (module-ref . <procedure>) @ or @@
;;; (begin) begin
;;; (define) define
;;; (define-syntax) define-syntax
@@ -555,16 +653,16 @@
; although symbols are usually global, we check the environment first
; anyway because a temporary binding may have been established by
; fluid-let-syntax
- (lambda (x r)
+ (lambda (x r mod)
(cond
((assq x r) => cdr)
((symbol? x)
- (or (get-global-definition-hook x) (make-binding 'global)))
+ (or (get-global-definition-hook x mod) (make-binding 'global)))
(else (make-binding 'displaced-lexical)))))
(define global-extend
(lambda (type sym val)
- (put-global-definition-hook sym (make-binding type val))))
+ (put-global-definition-hook sym type val)))
;;; Conceptually, identifiers are always syntax objects. Internally,
@@ -575,29 +673,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
@@ -663,7 +762,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))
@@ -763,7 +862,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))
@@ -771,10 +870,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.
@@ -791,11 +887,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
@@ -832,45 +928,68 @@
;;; wrapping expressions and identifiers
(define wrap
- (lambda (x w)
+ (lambda (x w defmod)
(cond
((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
((syntax-object? x)
(make-syntax-object
(syntax-object-expression x)
- (join-wraps w (syntax-object-wrap x))))
+ (join-wraps w (syntax-object-wrap x))
+ (syntax-object-module x)))
((null? x) x)
- (else (make-syntax-object x w)))))
+ (else (make-syntax-object x w defmod)))))
(define source-wrap
- (lambda (x w s)
- (wrap (if s (make-annotation x s #f) x) w)))
+ (lambda (x w s defmod)
+ (wrap (decorate-source x s) w defmod)))
;;; expanding
(define chi-sequence
- (lambda (body r w s)
+ (lambda (body r w s mod)
(build-sequence s
- (let dobody ((body body) (r r) (w w))
+ (let dobody ((body body) (r r) (w w) (mod mod))
(if (null? body)
'()
- (let ((first (chi (car body) r w)))
- (cons first (dobody (cdr body) r w))))))))
+ (let ((first (chi (car body) r w mod)))
+ (cons first (dobody (cdr body) r w mod))))))))
(define chi-top-sequence
- (lambda (body r w s m esew)
+ (lambda (body r w s m esew mod)
(build-sequence s
- (let dobody ((body body) (r r) (w w) (m m) (esew esew))
+ (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod))
(if (null? body)
'()
- (let ((first (chi-top (car body) r w m esew)))
- (cons first (dobody (cdr body) r w m esew))))))))
+ (let ((first (chi-top (car body) r w m esew mod)))
+ (cons first (dobody (cdr body) r w m esew mod))))))))
(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)
@@ -884,17 +1003,19 @@
((free-id=? x (syntax compile)) 'compile)
((free-id=? x (syntax load)) 'load)
((free-id=? x (syntax eval)) 'eval)
- (else (syntax-error (wrap x w)
- "invalid eval-when situation"))))
+ (else (syntax-violation 'eval-when
+ "invalid situation"
+ e (wrap x w #f)))))
situations))))))
-;;; syntax-type returns five values: type, value, e, w, and s. The first
-;;; two are described in the table below.
+;;; syntax-type returns six values: type, value, e, w, s, and mod. The
+;;; first two are described in the table below.
;;;
;;; type value explanation
;;; -------------------------------------------------------------------
-;;; core procedure core form (including singleton)
-;;; external-macro procedure external macro
+;;; core procedure core singleton
+;;; core-form procedure core form
+;;; module-ref procedure @ or @@ singleton
;;; lexical name lexical variable reference
;;; global name global variable reference
;;; begin none begin keyword
@@ -917,99 +1038,113 @@
;;;
;;; For define-form and define-syntax-form, e is the rhs expression.
;;; For all others, e is the entire form. w is the wrap for e.
-;;; s is the source for the entire form.
+;;; s is the source for the entire form. mod is the module for e.
;;;
;;; syntax-type expands macros and unwraps as necessary to get to
;;; one of the forms above. It also parses define and define-syntax
;;; forms, although perhaps this should be done by the consumer.
(define syntax-type
- (lambda (e r w s rib)
+ (lambda (e r w s rib mod for-car?)
(cond
((symbol? e)
(let* ((n (id-var-name e w))
- (b (lookup n r))
+ (b (lookup n r mod))
(type (binding-type b)))
(case type
- ((lexical) (values type (binding-value b) e w s))
- ((global) (values type n e w s))
+ ((lexical) (values type (binding-value b) e w s mod))
+ ((global) (values type n e w s mod))
((macro)
- (syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib))
- (else (values type (binding-value b) e w s)))))
+ (if for-car?
+ (values type (binding-value b) e w s mod)
+ (syntax-type (chi-macro (binding-value b) e r w rib mod)
+ r empty-wrap s rib mod #f)))
+ (else (values type (binding-value b) e w s mod)))))
((pair? e)
(let ((first (car e)))
- (if (id? first)
- (let* ((n (id-var-name first w))
- (b (lookup n r))
- (type (binding-type b)))
- (case type
- ((lexical) (values 'lexical-call (binding-value b) e w s))
- ((global) (values 'global-call n e w s))
- ((macro)
- (syntax-type (chi-macro (binding-value b) e r w rib)
- r empty-wrap s rib))
- ((core external-macro) (values type (binding-value b) e w s))
- ((local-syntax)
- (values 'local-syntax-form (binding-value b) e w s))
- ((begin) (values 'begin-form #f e w s))
- ((eval-when) (values 'eval-when-form #f e w s))
- ((define)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (values 'define-form (syntax name) (syntax val) w s))
- ((_ (name . args) e1 e2 ...)
- (and (id? (syntax name))
- (valid-bound-ids? (lambda-var-list (syntax args))))
- ; need lambda here...
- (values 'define-form (wrap (syntax name) w)
- (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
- empty-wrap s))
- ((_ name)
- (id? (syntax name))
- (values 'define-form (wrap (syntax name) w)
- (syntax (void))
- empty-wrap s))))
- ((define-syntax)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (values 'define-syntax-form (syntax name)
- (syntax val) w s))))
- (else (values 'call #f e w s))))
- (values 'call #f e w s))))
+ (call-with-values
+ (lambda () (syntax-type first r w s rib mod #t))
+ (lambda (ftype fval fe fw fs fmod)
+ (case ftype
+ ((lexical)
+ (values 'lexical-call fval e w s mod))
+ ((global)
+ ;; If we got here via an (@@ ...) expansion, we need to
+ ;; make sure the fmod information is propagated back
+ ;; correctly -- hence this consing.
+ (values 'global-call (make-syntax-object fval w fmod)
+ e w s mod))
+ ((macro)
+ (syntax-type (chi-macro fval e r w rib mod)
+ r empty-wrap s rib mod for-car?))
+ ((module-ref)
+ (call-with-values (lambda () (fval e))
+ (lambda (sym mod)
+ (syntax-type sym r w s rib mod for-car?))))
+ ((core)
+ (values 'core-form fval e w s mod))
+ ((local-syntax)
+ (values 'local-syntax-form fval e w s mod))
+ ((begin)
+ (values 'begin-form #f e w s mod))
+ ((eval-when)
+ (values 'eval-when-form #f e w s mod))
+ ((define)
+ (syntax-case e ()
+ ((_ name val)
+ (id? (syntax name))
+ (values 'define-form (syntax name) (syntax val) w s mod))
+ ((_ (name . args) e1 e2 ...)
+ (and (id? (syntax name))
+ (valid-bound-ids? (lambda-var-list (syntax args))))
+ ; need lambda here...
+ (values 'define-form (wrap (syntax name) w mod)
+ (decorate-source
+ (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod))
+ s)
+ empty-wrap s mod))
+ ((_ name)
+ (id? (syntax name))
+ (values 'define-form (wrap (syntax name) w mod)
+ (syntax (if #f #f))
+ empty-wrap s mod))))
+ ((define-syntax)
+ (syntax-case e ()
+ ((_ name val)
+ (id? (syntax name))
+ (values 'define-syntax-form (syntax name)
+ (syntax val) w s mod))))
+ (else
+ (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))
- ((annotation? e)
- (syntax-type (annotation-expression e) r w (annotation-source e) rib))
- ((self-evaluating? e) (values 'constant #f e w s))
- (else (values 'other #f e w s)))))
+ s rib (or (syntax-object-module e) mod) for-car?))
+ ((self-evaluating? e) (values 'constant #f e w s mod))
+ (else (values 'other #f e w s mod)))))
(define chi-top
- (lambda (e r w m esew)
+ (lambda (e r w m esew mod)
(define-syntax eval-if-c&e
(syntax-rules ()
- ((_ m e)
+ ((_ m e mod)
(let ((x e))
- (if (eq? m 'c&e) (top-level-eval-hook x))
+ (if (eq? m 'c&e) (top-level-eval-hook x mod))
x))))
(call-with-values
- (lambda () (syntax-type e r w no-source #f))
- (lambda (type value e w s)
+ (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+ (lambda (type value e w s mod)
(case type
((begin-form)
(syntax-case e ()
((_) (chi-void))
((_ e1 e2 ...)
- (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew))))
+ (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod))))
((local-syntax-form)
- (chi-local-syntax value e r w s
- (lambda (body r w s)
- (chi-top-sequence body r w s m esew))))
+ (chi-local-syntax value e r w s mod
+ (lambda (body r w s mod)
+ (chi-top-sequence body r w s m esew mod))))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
@@ -1018,19 +1153,20 @@
(cond
((eq? m 'e)
(if (memq 'eval when-list)
- (chi-top-sequence body r w s 'e '(eval))
+ (chi-top-sequence body r w s 'e '(eval) mod)
(chi-void)))
((memq 'load when-list)
(if (or (memq 'compile when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
- (chi-top-sequence body r w s 'c&e '(compile load))
+ (chi-top-sequence body r w s 'c&e '(compile load) mod)
(if (memq m '(c c&e))
- (chi-top-sequence body r w s 'c '(load))
+ (chi-top-sequence body r w s 'c '(load) mod)
(chi-void))))
((or (memq 'compile when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
(top-level-eval-hook
- (chi-top-sequence body r w s 'e '(eval)))
+ (chi-top-sequence body r w s 'e '(eval) mod)
+ mod)
(chi-void))
(else (chi-void)))))))
((define-syntax-form)
@@ -1038,93 +1174,118 @@
(case m
((c)
(if (memq 'compile esew)
- (let ((e (chi-install-global n (chi e r w))))
- (top-level-eval-hook e)
+ (let ((e (chi-install-global n (chi e r w mod))))
+ (top-level-eval-hook e mod)
(if (memq 'load esew) e (chi-void)))
(if (memq 'load esew)
- (chi-install-global n (chi e r w))
+ (chi-install-global n (chi e r w mod))
(chi-void))))
((c&e)
- (let ((e (chi-install-global n (chi e r w))))
- (top-level-eval-hook e)
+ (let ((e (chi-install-global n (chi e r w mod))))
+ (top-level-eval-hook e mod)
e))
(else
(if (memq 'eval esew)
(top-level-eval-hook
- (chi-install-global n (chi e r w))))
+ (chi-install-global n (chi e r w mod))
+ mod))
(chi-void)))))
((define-form)
(let* ((n (id-var-name value w))
- (type (binding-type (lookup n r))))
+ (type (binding-type (lookup n r mod))))
(case type
- ((global)
+ ((global core macro module-ref)
+ ;; affect compile-time environment (once we have booted)
+ (if (and (not (module-local-variable (current-module) n))
+ (current-module))
+ (let ((old (module-variable (current-module) n)))
+ ;; use value of the same-named imported variable, if
+ ;; any
+ (module-define! (current-module) n
+ (if (variable? old)
+ (variable-ref old)
+ #f))))
(eval-if-c&e m
- (build-global-definition s n (chi e r w))))
+ (build-global-definition s n (chi e r w mod))
+ mod))
((displaced-lexical)
- (syntax-error (wrap value w) "identifier out of context"))
+ (syntax-violation #f "identifier out of context"
+ e (wrap value w mod)))
(else
- (if (eq? type 'external-macro)
- (eval-if-c&e m
- (build-global-definition s n (chi e r w)))
- (syntax-error (wrap value w)
- "cannot define keyword at top level"))))))
- (else (eval-if-c&e m (chi-expr type value e r w s))))))))
+ (syntax-violation #f "cannot define keyword at top level"
+ e (wrap value w mod))))))
+ (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
(define chi
- (lambda (e r w)
+ (lambda (e r w mod)
(call-with-values
- (lambda () (syntax-type e r w no-source #f))
- (lambda (type value e w s)
- (chi-expr type value e r w s)))))
+ (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+ (lambda (type value e w s mod)
+ (chi-expr type value e r w s mod)))))
(define chi-expr
- (lambda (type value e r w s)
+ (lambda (type value e r w s mod)
(case type
((lexical)
- (build-lexical-reference 'value s value))
- ((core external-macro) (value e r w s))
+ (build-lexical-reference 'value s e value))
+ ((core core-form)
+ ;; apply transformer
+ (value e r w s mod))
+ ((module-ref)
+ (call-with-values (lambda () (value e))
+ ;; we could add a public? arg here
+ (lambda (id mod) (build-global-reference s id mod))))
((lexical-call)
(chi-application
- (build-lexical-reference 'fun (source-annotation (car e)) value)
- e r w s))
+ (build-lexical-reference 'fun (source-annotation (car e))
+ (car e) value)
+ e r w s mod))
((global-call)
(chi-application
- (build-global-reference (source-annotation (car e)) value)
- e r w s))
- ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
- ((global) (build-global-reference s value))
- ((call) (chi-application (chi (car e) r w) e r w s))
+ (build-global-reference (source-annotation (car e))
+ (if (syntax-object? value)
+ (syntax-object-expression value)
+ value)
+ (if (syntax-object? value)
+ (syntax-object-module value)
+ mod))
+ e r w s mod))
+ ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
+ ((global) (build-global-reference s value mod))
+ ((call) (chi-application (chi (car e) r w mod) e r w s mod))
((begin-form)
(syntax-case e ()
- ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
+ ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod))))
((local-syntax-form)
- (chi-local-syntax value e r w s chi-sequence))
+ (chi-local-syntax value e r w s mod chi-sequence))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e (syntax (x ...)) w)))
(if (memq 'eval when-list)
- (chi-sequence (syntax (e1 e2 ...)) r w s)
+ (chi-sequence (syntax (e1 e2 ...)) r w s mod)
(chi-void))))))
((define-form define-syntax-form)
- (syntax-error (wrap value w) "invalid context for definition of"))
+ (syntax-violation #f "definition in expression context"
+ e (wrap value w mod)))
((syntax)
- (syntax-error (source-wrap e w s)
- "reference to pattern variable outside syntax form"))
+ (syntax-violation #f "reference to pattern variable outside syntax form"
+ (source-wrap e w s mod)))
((displaced-lexical)
- (syntax-error (source-wrap e w s)
- "reference to identifier outside its scope"))
- (else (syntax-error (source-wrap e w s))))))
+ (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))))))
(define chi-application
- (lambda (x e r w s)
+ (lambda (x e r w s mod)
(syntax-case e ()
((e0 e1 ...)
(build-application s x
- (map (lambda (e) (chi e r w)) (syntax (e1 ...))))))))
+ (map (lambda (e) (chi e r w mod)) (syntax (e1 ...))))))))
(define chi-macro
- (lambda (p e r w rib)
+ (lambda (p e r w rib mod)
(define rebuild-macro-output
(lambda (x m)
(cond ((pair? x)
@@ -1133,14 +1294,27 @@
((syntax-object? x)
(let ((w (syntax-object-wrap x)))
(let ((ms (wrap-marks w)) (s (wrap-subst w)))
- (make-syntax-object (syntax-object-expression x)
- (if (and (pair? ms) (eq? (car ms) the-anti-mark))
- (make-wrap (cdr ms)
- (if rib (cons rib (cdr s)) (cdr s)))
- (make-wrap (cons m ms)
- (if rib
- (cons rib (cons 'shift s))
- (cons 'shift s))))))))
+ (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+ ;; output is from original text
+ (make-syntax-object
+ (syntax-object-expression x)
+ (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+ (syntax-object-module x))
+ ;; output introduced by macro
+ (make-syntax-object
+ (syntax-object-expression x)
+ (make-wrap (cons m ms)
+ (if rib
+ (cons rib (cons 'shift s))
+ (cons 'shift s)))
+ (let ((pmod (procedure-module p)))
+ (if pmod
+ ;; hither the hygiene
+ (cons 'hygiene (module-name pmod))
+ ;; but it's possible for the proc to have
+ ;; no mod, if it was made before modules
+ ;; were booted
+ '(hygiene guile))))))))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector n)))
(do ((i 0 (fx+ i 1)))
@@ -1148,9 +1322,10 @@
(vector-set! v i
(rebuild-macro-output (vector-ref x i) m)))))
((symbol? x)
- (syntax-error x "encountered raw symbol in macro output"))
+ (syntax-violation #f "encountered raw symbol in macro output"
+ (source-wrap e w s mod) x))
(else x))))
- (rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark))))
+ (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
(define chi-body
;; In processing the forms of the body, we create a new, empty wrap.
@@ -1191,34 +1366,36 @@
;; into the body.
;;
;; outer-form is fully wrapped w/source
- (lambda (body outer-form r w)
+ (lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" . (placeholder)) r))
(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))) body))
- (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
+ (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
+ (ids '()) (labels '())
+ (var-ids '()) (vars '()) (vals '()) (bindings '()))
(if (null? body)
- (syntax-error outer-form "no expressions in 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))
- (lambda (type value e w s)
+ (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f))
+ (lambda (type value e w s mod)
(case type
((define-form)
- (let ((id (wrap value w)) (label (gen-label)))
+ (let ((id (wrap value w mod)) (label (gen-label)))
(let ((var (gen-var id)))
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
- (cons var vars) (cons (cons er (wrap e w)) vals)
+ (cons id var-ids)
+ (cons var vars) (cons (cons er (wrap e w mod)) vals)
(cons (make-binding 'lexical var) bindings)))))
((define-syntax-form)
- (let ((id (wrap value w)) (label (gen-label)))
+ (let ((id (wrap value w mod)) (label (gen-label)))
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
- vars vals
- (cons (make-binding 'macro (cons er (wrap e w)))
+ var-ids vars vals
+ (cons (make-binding 'macro (cons er (wrap e w mod)))
bindings))))
((begin-form)
(syntax-case e ()
@@ -1226,29 +1403,30 @@
(parse (let f ((forms (syntax (e1 ...))))
(if (null? forms)
(cdr body)
- (cons (cons er (wrap (car forms) w))
+ (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
- (lambda (forms er w s)
+ (chi-local-syntax value e er w s mod
+ (lambda (forms er w s mod)
(parse (let f ((forms forms))
(if (null? forms)
(cdr body)
- (cons (cons er (wrap (car forms) w))
+ (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
(map (lambda (x)
- (chi (cdr x) (car x) empty-wrap))
- (cons (cons er (source-wrap e w s))
+ (chi (cdr x) (car x) empty-wrap mod))
+ (cons (cons er (source-wrap e w s mod))
(cdr body))))
(begin
(if (not (valid-bound-ids? ids))
- (syntax-error outer-form
- "invalid or duplicate identifier in definition"))
+ (syntax-violation
+ #f "invalid or duplicate identifier in definition"
+ outer-form))
(let loop ((bs bindings) (er-cache #f) (r-cache #f))
(if (not (null? bs))
(let* ((b (car bs)))
@@ -1260,58 +1438,72 @@
(macros-only-env er))))
(set-cdr! b
(eval-local-transformer
- (chi (cddr b) r-cache empty-wrap)))
+ (chi (cddr b) r-cache empty-wrap mod)
+ mod))
(loop (cdr bs) er r-cache))
(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))
+ (chi (cdr x) (car x) empty-wrap mod))
vals)
(build-sequence no-source
(map (lambda (x)
- (chi (cdr x) (car x) empty-wrap))
- (cons (cons er (source-wrap e w s))
+ (chi (cdr x) (car x) empty-wrap mod))
+ (cons (cons er (source-wrap e w s mod))
(cdr body)))))))))))))))))
(define chi-lambda-clause
- (lambda (e c r w k)
+ (lambda (e docstring c r w mod k)
(syntax-case c ()
+ ((args doc e1 e2 ...)
+ (and (string? (syntax->datum (syntax doc))) (not docstring))
+ (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
(((id ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "invalid parameter list in")
+ (syntax-violation 'lambda "invalid parameter list" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
- (k new-vars
+ (k (map syntax->datum ids)
+ new-vars
+ (and docstring (syntax->datum docstring))
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
- (make-binding-wrap ids labels w)))))))
+ (make-binding-wrap ids labels w)
+ mod))))))
((ids e1 e2 ...)
(let ((old-ids (lambda-var-list (syntax ids))))
(if (not (valid-bound-ids? old-ids))
- (syntax-error e "invalid parameter list in")
+ (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))))
+ (and docstring (syntax->datum docstring))
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
- (make-binding-wrap old-ids labels w)))))))
- (_ (syntax-error e)))))
+ (make-binding-wrap old-ids labels w)
+ mod))))))
+ (_ (syntax-violation 'lambda "bad lambda" e)))))
(define chi-local-syntax
- (lambda (rec? e r w s k)
+ (lambda (rec? e r w s mod k)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound keyword in")
+ (syntax-violation #f "duplicate bound keyword" e)
(let ((labels (gen-labels ids)))
(let ((new-w (make-binding-wrap ids labels w)))
(k (syntax (e1 e2 ...))
@@ -1321,23 +1513,27 @@
(trans-r (macros-only-env r)))
(map (lambda (x)
(make-binding 'macro
- (eval-local-transformer (chi x trans-r w))))
+ (eval-local-transformer
+ (chi x trans-r w mod)
+ mod)))
(syntax (val ...))))
r)
new-w
- s))))))
- (_ (syntax-error (source-wrap e w s))))))
+ s
+ mod))))))
+ (_ (syntax-violation #f "bad local syntax definition"
+ (source-wrap e w s mod))))))
(define eval-local-transformer
- (lambda (expanded)
- (let ((p (local-eval-hook expanded)))
+ (lambda (expanded mod)
+ (let ((p (local-eval-hook expanded mod)))
(if (procedure? p)
p
- (syntax-error p "nonprocedure transformer")))))
+ (syntax-violation #f "nonprocedure transformer" p)))))
(define chi-void
(lambda ()
- (build-application no-source (build-primref no-source 'void) '())))
+ (build-void no-source)))
(define ellipsis?
(lambda (x)
@@ -1346,32 +1542,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
@@ -1379,46 +1551,40 @@
(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)
(let lvl ((vars vars) (ls '()) (w empty-wrap))
(cond
- ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
- ((id? vars) (cons (wrap vars w) ls))
+ ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
+ ((id? vars) (cons (wrap vars w #f) ls))
((null? vars) ls)
((syntax-object? vars)
(lvl (syntax-object-expression vars)
ls
(join-wraps w (syntax-object-wrap vars))))
- ((annotation? vars)
- (lvl (annotation-expression vars) ls w))
; include anything else to be caught by subsequent error
; checking
(else (cons vars ls))))))
@@ -1429,46 +1595,52 @@
(global-extend 'local-syntax 'let-syntax #f)
(global-extend 'core 'fluid-let-syntax
- (lambda (e r w s)
+ (lambda (e r w s mod)
(syntax-case e ()
((_ ((var val) ...) e1 e2 ...)
(valid-bound-ids? (syntax (var ...)))
(let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
(for-each
(lambda (id n)
- (case (binding-type (lookup n r))
+ (case (binding-type (lookup n r mod))
((displaced-lexical)
- (syntax-error (source-wrap id w s)
- "identifier out of context"))))
+ (syntax-violation 'fluid-let-syntax
+ "identifier out of context"
+ e
+ (source-wrap id w s mod)))))
(syntax (var ...))
names)
(chi-body
(syntax (e1 e2 ...))
- (source-wrap e w s)
+ (source-wrap e w s mod)
(extend-env
names
(let ((trans-r (macros-only-env r)))
(map (lambda (x)
(make-binding 'macro
- (eval-local-transformer (chi x trans-r w))))
+ (eval-local-transformer (chi x trans-r w mod)
+ mod)))
(syntax (val ...))))
r)
- w)))
- (_ (syntax-error (source-wrap e w s))))))
+ w
+ mod)))
+ (_ (syntax-violation 'fluid-let-syntax "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'quote
- (lambda (e r w s)
+ (lambda (e r w s mod)
(syntax-case e ()
((_ e) (build-data s (strip (syntax e) w)))
- (_ (syntax-error (source-wrap e w s))))))
+ (_ (syntax-violation 'quote "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'syntax
(let ()
(define gen-syntax
- (lambda (src e r maps ellipsis?)
+ (lambda (src e r maps ellipsis? mod)
(if (id? e)
(let ((label (id-var-name e empty-wrap)))
- (let ((b (lookup label r)))
+ (let ((b (lookup label r mod)))
(if (eq? (binding-type b) 'syntax)
(call-with-values
(lambda ()
@@ -1476,12 +1648,12 @@
(gen-ref src (car var.lev) (cdr var.lev) maps)))
(lambda (var maps) (values `(ref ,var) maps)))
(if (ellipsis? e)
- (syntax-error src "misplaced ellipsis in syntax form")
+ (syntax-violation 'syntax "misplaced ellipsis" src)
(values `(quote ,e) maps)))))
(syntax-case e ()
((dots e)
(ellipsis? (syntax dots))
- (gen-syntax src (syntax e) r maps (lambda (x) #f)))
+ (gen-syntax src (syntax e) r maps (lambda (x) #f) mod))
((x dots . y)
; this could be about a dozen lines of code, except that we
; choose to handle (syntax (x ... ...)) forms
@@ -1491,11 +1663,11 @@
(call-with-values
(lambda ()
(gen-syntax src (syntax x) r
- (cons '() maps) ellipsis?))
+ (cons '() maps) ellipsis? mod))
(lambda (x maps)
(if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
+ (syntax-violation 'syntax "extra ellipsis"
+ src)
(values (gen-map x (car maps))
(cdr maps))))))))
(syntax-case y ()
@@ -1507,12 +1679,11 @@
(lambda () (k (cons '() maps)))
(lambda (x maps)
(if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
+ (syntax-violation 'syntax "extra ellipsis" src)
(values (gen-mappend x (car maps))
(cdr maps))))))))
(_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis?))
+ (lambda () (gen-syntax src y r maps ellipsis? mod))
(lambda (y maps)
(call-with-values
(lambda () (k maps))
@@ -1520,15 +1691,15 @@
(values (gen-append x y) maps)))))))))
((x . y)
(call-with-values
- (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
+ (lambda () (gen-syntax src (syntax x) r maps ellipsis? mod))
(lambda (x maps)
(call-with-values
- (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
+ (lambda () (gen-syntax src (syntax y) r maps ellipsis? mod))
(lambda (y maps) (values (gen-cons x y) maps))))))
(#(e1 e2 ...)
(call-with-values
(lambda ()
- (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
+ (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis? mod))
(lambda (e maps) (values (gen-vector e) maps))))
(_ (values `(quote ,e) maps))))))
@@ -1537,7 +1708,7 @@
(if (fx= level 0)
(values var maps)
(if (null? maps)
- (syntax-error src "missing ellipsis in syntax form")
+ (syntax-violation 'syntax "missing ellipsis" src)
(call-with-values
(lambda () (gen-ref src var (fx- level 1) (cdr maps)))
(lambda (outer-var outer-maps)
@@ -1563,7 +1734,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:
@@ -1603,110 +1774,158 @@
(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)))))))
- (lambda (e r w s)
- (let ((e (source-wrap e w s)))
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
(syntax-case e ()
((_ x)
(call-with-values
- (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
+ (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
(lambda (e maps) (regen e))))
- (_ (syntax-error e)))))))
+ (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
(global-extend 'core 'lambda
- (lambda (e r w s)
+ (lambda (e r w s mod)
(syntax-case e ()
((_ . c)
- (chi-lambda-clause (source-wrap e w s) (syntax c) r w
- (lambda (vars body) (build-lambda s vars body)))))))
+ (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
+ (lambda (names vars docstring body)
+ (build-lambda s names vars docstring body)))))))
(global-extend 'core 'let
(let ()
- (define (chi-let e r w s constructor ids vals exps)
+ (define (chi-let e r w s mod constructor ids vals exps)
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound variable in")
+ (syntax-violation 'let "duplicate bound variable" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(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)) vals)
- (chi-body exps (source-wrap e nw s) nr nw))))))
- (lambda (e r w s)
+ (map (lambda (x) (chi x r w mod)) vals)
+ (chi-body exps (source-wrap e nw s mod)
+ nr nw mod))))))
+ (lambda (e r w s mod)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
- (chi-let e r w s
+ (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))
- (chi-let e r w s
+ (and (id? (syntax f)) (and-map id? (syntax (id ...))))
+ (chi-let e r w s mod
build-named-let
(syntax (f id ...))
(syntax (val ...))
(syntax (e1 e2 ...))))
- (_ (syntax-error (source-wrap e w s)))))))
+ (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
(global-extend 'core 'letrec
- (lambda (e r w s)
+ (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-error e "duplicate bound variable in")
+ (syntax-violation 'letrec "duplicate bound variable" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(let ((w (make-binding-wrap ids labels w))
(r (extend-var-env labels new-vars r)))
(build-letrec s
+ (map syntax->datum ids)
new-vars
- (map (lambda (x) (chi x r w)) (syntax (val ...)))
- (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
- (_ (syntax-error (source-wrap e w s))))))
+ (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
+ (chi-body (syntax (e1 e2 ...))
+ (source-wrap e w s mod) r w mod)))))))
+ (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
(global-extend 'core 'set!
- (lambda (e r w s)
+ (lambda (e r w s mod)
(syntax-case e ()
((_ id val)
(id? (syntax id))
- (let ((val (chi (syntax val) r w))
+ (let ((val (chi (syntax val) r w mod))
(n (id-var-name (syntax id) w)))
- (let ((b (lookup n r)))
+ (let ((b (lookup n r mod)))
(case (binding-type b)
((lexical)
- (build-lexical-assignment s (binding-value b) val))
- ((global) (build-global-assignment s n val))
+ (build-lexical-assignment s
+ (syntax->datum (syntax id))
+ (binding-value b)
+ val))
+ ((global) (build-global-assignment s n val mod))
((displaced-lexical)
- (syntax-error (wrap (syntax id) w)
- "identifier out of context"))
- (else (syntax-error (source-wrap e w s)))))))
- ((_ (getter arg ...) val)
- (build-application s
- (chi (syntax (setter getter)) r w)
- (map (lambda (e) (chi e r w))
- (syntax (arg ... val)))))
- (_ (syntax-error (source-wrap e w s))))))
+ (syntax-violation 'set! "identifier out of context"
+ (wrap (syntax id) w mod)))
+ (else (syntax-violation 'set! "bad set!"
+ (source-wrap e w s mod)))))))
+ ((_ (head tail ...) val)
+ (call-with-values
+ (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod #t))
+ (lambda (type value ee ww ss modmod)
+ (case type
+ ((module-ref)
+ (let ((val (chi (syntax val) r w mod)))
+ (call-with-values (lambda () (value (syntax (head tail ...))))
+ (lambda (id mod)
+ (build-global-assignment s id val mod)))))
+ (else
+ (build-application s
+ (chi (syntax (setter head)) r w mod)
+ (map (lambda (e) (chi e r w mod))
+ (syntax (tail ... val)))))))))
+ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
+
+(global-extend 'module-ref '@
+ (lambda (e)
+ (syntax-case e ()
+ ((_ (mod ...) id)
+ (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
+ (values (syntax->datum (syntax id))
+ (syntax->datum
+ (syntax (public mod ...))))))))
+
+(global-extend 'module-ref '@@
+ (lambda (e)
+ (syntax-case e ()
+ ((_ (mod ...) 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 '())
@@ -1720,7 +1939,7 @@
(let ()
(define convert-pattern
; accepts pattern & keys
- ; returns syntax-dispatch pattern & ids
+ ; returns $sc-dispatch pattern & ids
(lambda (pattern keys)
(let cvt ((p pattern) (n 0) (ids '()))
(if (id? p)
@@ -1751,102 +1970,111 @@
(x (values (vector 'atom (strip p empty-wrap)) ids)))))))
(define build-dispatch-call
- (lambda (pvars exp y r)
+ (lambda (pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source
(build-primref no-source 'apply)
- (list (build-lambda no-source new-vars
+ (list (build-lambda no-source (map syntax->datum ids) new-vars #f
(chi exp
- (extend-env
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- (make-binding-wrap ids labels empty-wrap)))
+ (extend-env
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels empty-wrap)
+ mod))
y))))))
(define gen-clause
- (lambda (x keys clauses r pat fender exp)
+ (lambda (x keys clauses r pat fender exp mod)
(call-with-values
(lambda () (convert-pattern pat keys))
(lambda (p pvars)
(cond
((not (distinct-bound-ids? (map car pvars)))
- (syntax-error pat
- "duplicate pattern variable in syntax-case pattern"))
- ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
- (syntax-error pat
- "misplaced ellipsis in syntax-case pattern"))
+ (syntax-violation 'syntax-case "duplicate pattern variable" pat))
+ ((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)
(_ (build-conditional no-source
y
- (build-dispatch-call pvars fender y r)
+ (build-dispatch-call pvars fender y r mod)
(build-data no-source #f))))
- (build-dispatch-call pvars exp y r)
- (gen-syntax-case x keys clauses r))))
+ (build-dispatch-call pvars exp y r mod)
+ (gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any)
(build-application no-source
(build-primref no-source 'list)
(list x))
(build-application no-source
- (build-primref no-source 'syntax-dispatch)
+ (build-primref no-source '$sc-dispatch)
(list x (build-data no-source p)))))))))))))
(define gen-syntax-case
- (lambda (x keys clauses r)
+ (lambda (x keys clauses r mod)
(if (null? clauses)
(build-application no-source
- (build-primref no-source 'syntax-error)
- (list x))
+ (build-primref no-source 'syntax-violation)
+ (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)))
r)
(make-binding-wrap (syntax (pat))
- labels empty-wrap)))
+ labels empty-wrap)
+ mod))
(list x)))
(gen-clause x keys (cdr clauses) r
- (syntax pat) #t (syntax exp))))
+ (syntax pat) #t (syntax exp) mod)))
((pat fender exp)
(gen-clause x keys (cdr clauses) r
- (syntax pat) (syntax fender) (syntax exp)))
- (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
+ (syntax pat) (syntax fender) (syntax exp) mod))
+ (_ (syntax-violation 'syntax-case "invalid clause"
+ (car clauses)))))))
- (lambda (e r w s)
- (let ((e (source-wrap e w s)))
+ (lambda (e r w s mod)
+ (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))
- (list (chi (syntax val) r empty-wrap))))
- (syntax-error e "invalid literals list in"))))))))
+ r
+ mod))
+ (list (chi (syntax val) r empty-wrap mod))))
+ (syntax-violation 'syntax-case "invalid literals list" e))))))))
;;; The portable sc-expand seeds chi-top's mode m with 'e (for
;;; evaluating) and esew (which stands for "eval syntax expanders
@@ -1858,34 +2086,27 @@
;;; 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)))))
-
-(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)))))))
+ (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)
(nonsymbol-id? x)))
-(set! datum->syntax-object
+(set! datum->syntax
(lambda (id datum)
- (make-syntax-object datum (syntax-object-wrap id))))
+ (make-syntax-object datum (syntax-object-wrap id) #f)))
-(set! syntax-object->datum
+(set! syntax->datum
; accepts any object, since syntax objects may consist partially
; or entirely of unwrapped, nonsymbolic data
(lambda (x)
@@ -1894,7 +2115,7 @@
(set! generate-temporaries
(lambda (ls)
(arg-check list? ls 'generate-temporaries)
- (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
+ (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls)))
(set! free-identifier=?
(lambda (x y)
@@ -1908,21 +2129,23 @@
(arg-check nonsymbol-id? y 'bound-identifier=?)
(bound-id=? x y)))
-(set! syntax-error
- (lambda (object . messages)
- (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
- (let ((message (if (null? messages)
- "invalid syntax"
- (apply string-append messages))))
- (error-hook #f message (strip object empty-wrap)))))
-
-(set! install-global-transformer
- (lambda (sym v)
- (arg-check symbol? sym 'define-syntax)
- (arg-check procedure? v 'define-syntax)
- (global-extend 'macro sym v)))
-
-;;; syntax-dispatch expects an expression and a pattern. If the expression
+(set! syntax-violation
+ (lambda (who message form . subform)
+ (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+ who 'syntax-violation)
+ (arg-check string? message 'syntax-violation)
+ (scm-error 'syntax-error 'sc-expand
+ (string-append
+ (if who "~a: " "")
+ "~a "
+ (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
+ (let ((tail (cons message
+ (map (lambda (x) (strip x empty-wrap))
+ (append subform (list form))))))
+ (if who (cons who tail) tail))
+ #f)))
+
+;;; $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
;;; not work on r4rs implementations that violate the ieee requirement
@@ -1947,35 +2170,33 @@
(let ()
(define match-each
- (lambda (e p w)
+ (lambda (e p w mod)
(cond
- ((annotation? e)
- (match-each (annotation-expression e) p w))
- ((pair? e)
- (let ((first (match (car e) p w '())))
- (and first
- (let ((rest (match-each (cdr e) p w)))
- (and rest (cons first rest))))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each (syntax-object-expression e)
- p
- (join-wraps w (syntax-object-wrap e))))
- (else #f))))
+ ((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)
+ (lambda (e w mod)
(cond
- ((annotation? e)
- (match-each-any (annotation-expression e) w))
- ((pair? e)
- (let ((l (match-each-any (cdr e) w)))
- (and l (cons (wrap (car e) w) l))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each-any (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))))
- (else #f))))
+ ((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)
@@ -1991,54 +2212,55 @@
((vector) (match-empty (vector-ref p 1) r)))))))
(define match*
- (lambda (e p w r)
+ (lambda (e p w r mod)
(cond
((null? p) (and (null? e) r))
((pair? p)
(and (pair? e) (match (car e) (car p) w
- (match (cdr e) (cdr p) w r))))
+ (match (cdr e) (cdr p) w r mod)
+ mod)))
((eq? p 'each-any)
- (let ((l (match-each-any e w))) (and l (cons l r))))
+ (let ((l (match-each-any e w mod))) (and l (cons l r))))
(else
(case (vector-ref p 0)
((each)
(if (null? e)
(match-empty (vector-ref p 1) r)
- (let ((l (match-each e (vector-ref p 1) w)))
+ (let ((l (match-each e (vector-ref p 1) w mod)))
(and l
(let collect ((l l))
(if (null? (car l))
r
(cons (map car l) (collect (map cdr l)))))))))
- ((free-id) (and (id? e) (free-id=? (wrap e w) (vector-ref p 1)) r))
+ ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
((vector)
(and (vector? e)
- (match (vector->list e) (vector-ref p 1) w r))))))))
+ (match (vector->list e) (vector-ref p 1) w r mod))))))))
(define match
- (lambda (e p w r)
+ (lambda (e p w r mod)
(cond
((not r) #f)
- ((eq? p 'any) (cons (wrap e w) r))
+ ((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))
- (else (match* (unannotate e) p w r)))))
+ (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! syntax-dispatch
+(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) '()))
- (else (match* (unannotate e) p empty-wrap '())))))
+ (match* (syntax-object-expression e)
+ p (syntax-object-wrap e) '() (syntax-object-module e)))
+ (else (match* e p empty-wrap '() #f)))))
-(set! sc-chi chi)
))
)
@@ -2066,7 +2288,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 ...))
@@ -2083,7 +2305,9 @@
(syntax-case s ()
(() v)
((e) (syntax e))
- (_ (syntax-error orig-x))))
+ (_ (syntax-violation
+ 'do "bad step expression"
+ orig-x s))))
(syntax (var ...))
(syntax (step ...)))))
(syntax-case (syntax (e1 ...)) ()
@@ -2131,12 +2355,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))))
@@ -2156,29 +2390,29 @@
(let f ((x (read p)))
(if (eof-object? x)
(begin (close-input-port p) '())
- (cons (datum->syntax-object k x)
+ (cons (datum->syntax k x)
(f (read p))))))))
(syntax-case x ()
((k filename)
- (let ((fn (syntax-object->datum (syntax filename))))
+ (let ((fn (syntax->datum (syntax filename))))
(with-syntax (((exp ...) (read-file fn (syntax k))))
(syntax (begin exp ...))))))))
(define-syntax unquote
- (lambda (x)
- (syntax-case x ()
- ((_ e)
- (error 'unquote
- "expression ,~s not valid outside of quasiquote"
- (syntax-object->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-object->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)
@@ -2191,14 +2425,15 @@
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
(((k ...) e1 e2 ...)
(syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
- (_ (syntax-error x)))
+ (_ (syntax-violation 'case "bad clause" x clause)))
(with-syntax ((rest (f (car clauses) (cdr clauses))))
(syntax-case clause (else)
(((k ...) e1 e2 ...)
(syntax (if (memv t '(k ...))
(begin e1 e2 ...)
rest)))
- (_ (syntax-error x))))))))
+ (_ (syntax-violation 'case "bad clause" x
+ clause))))))))
(syntax (let ((t e)) body)))))))
(define-syntax identifier-syntax
@@ -2213,4 +2448,3 @@
(syntax e))
((_ x (... ...))
(syntax (e x (... ...)))))))))))
-
diff --git a/module/ice-9/q.scm b/module/ice-9/q.scm
index 0c12d7f40..4dc5d4953 100644
--- a/module/ice-9/q.scm
+++ b/module/ice-9/q.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm
index de2aeb2de..c23f31af1 100644
--- a/module/ice-9/r4rs.scm
+++ b/module/ice-9/r4rs.scm
@@ -6,7 +6,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -17,6 +17,9 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
;;;; apply and call-with-current-continuation
@@ -186,28 +189,3 @@ procedures, their behavior is implementation dependent."
(lambda (p) (with-error-to-port p thunk))))
(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
-
-
-;;;; Loading
-
-(if (not (defined? '%load-verbosely))
- (define %load-verbosely #f))
-(define (assert-load-verbosity v) (set! %load-verbosely v))
-
-(define (%load-announce file)
- (if %load-verbosely
- (with-output-to-port (current-error-port)
- (lambda ()
- (display ";;; ")
- (display "loading ")
- (display file)
- (newline)
- (force-output)))))
-
-(set! %load-hook %load-announce)
-
-(define (load name . reader)
- (with-fluid* current-reader (and (pair? reader) (car reader))
- (lambda ()
- (start-stack 'load-stack
- (primitive-load name)))))
diff --git a/module/ice-9/r5rs.scm b/module/ice-9/r5rs.scm
index 2b40515d3..c867f9a3c 100644
--- a/module/ice-9/r5rs.scm
+++ b/module/ice-9/r5rs.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/rdelim.scm b/module/ice-9/rdelim.scm
index d21d45c38..71aae3c8b 100644
--- a/module/ice-9/rdelim.scm
+++ b/module/ice-9/rdelim.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/receive.scm b/module/ice-9/receive.scm
index 693dfe3f4..d550c6f36 100644
--- a/module/ice-9/receive.scm
+++ b/module/ice-9/receive.scm
@@ -2,19 +2,19 @@
;;; Copyright (C) 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 receive)
:export (receive)
diff --git a/module/ice-9/regex.scm b/module/ice-9/regex.scm
index 61937d04f..2327bfe17 100644
--- a/module/ice-9/regex.scm
+++ b/module/ice-9/regex.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/runq.scm b/module/ice-9/runq.scm
index eb1e2203f..c14eb8967 100644
--- a/module/ice-9/runq.scm
+++ b/module/ice-9/runq.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/rw.scm b/module/ice-9/rw.scm
index 2731e889a..b76282a47 100644
--- a/module/ice-9/rw.scm
+++ b/module/ice-9/rw.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/safe-r5rs.scm b/module/ice-9/safe-r5rs.scm
index 13a44d23d..f728533cb 100644
--- a/module/ice-9/safe-r5rs.scm
+++ b/module/ice-9/safe-r5rs.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/safe.scm b/module/ice-9/safe.scm
index 15b77990a..1ce8f9ed9 100644
--- a/module/ice-9/safe.scm
+++ b/module/ice-9/safe.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/serialize.scm b/module/ice-9/serialize.scm
index 3c70f4421..008a70a9e 100644
--- a/module/ice-9/serialize.scm
+++ b/module/ice-9/serialize.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index aaa4f0761..1f3ec2795 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/slib.scm b/module/ice-9/slib.scm
index a2b526562..78c734e2a 100644
--- a/module/ice-9/slib.scm
+++ b/module/ice-9/slib.scm
@@ -5,13 +5,13 @@
;;;; 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.
-;;;;
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
diff --git a/module/ice-9/stack-catch.scm b/module/ice-9/stack-catch.scm
index 2f4b3d145..f7b207535 100644
--- a/module/ice-9/stack-catch.scm
+++ b/module/ice-9/stack-catch.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -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/streams.scm b/module/ice-9/streams.scm
index 317d47245..e0a17d488 100644
--- a/module/ice-9/streams.scm
+++ b/module/ice-9/streams.scm
@@ -6,7 +6,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/string-fun.scm b/module/ice-9/string-fun.scm
index d8ba21f75..c27ff847f 100644
--- a/module/ice-9/string-fun.scm
+++ b/module/ice-9/string-fun.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm
index 5a5e1a6ea..210a23280 100644
--- a/module/ice-9/syncase.scm
+++ b/module/ice-9/syncase.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -17,236 +17,15 @@
(define-module (ice-9 syncase)
- :use-module (ice-9 debug)
- :use-module (ice-9 threads)
- :export-syntax (sc-macro define-syntax define-syntax-public
- eval-when fluid-let-syntax
- identifier-syntax let-syntax
- letrec-syntax syntax syntax-case syntax-rules
- with-syntax
- include)
- :export (sc-expand sc-expand3 install-global-transformer
- syntax-dispatch syntax-error bound-identifier=?
- datum->syntax-object free-identifier=?
- generate-temporaries identifier? syntax-object->datum
- void syncase)
- :replace (eval))
+ )
-
-
-(define expansion-eval-closure (make-fluid))
-(define (current-eval-closure)
- (or (fluid-ref expansion-eval-closure)
- (module-eval-closure (current-module))))
-
-(define (env->eval-closure env)
- (and env (car (last-pair env))))
-
-(define (annotation? x) #f)
-
-(define sc-macro
- (procedure->memoizing-macro
- (lambda (exp env)
- (with-fluids ((expansion-eval-closure (env->eval-closure env)))
- (sc-expand exp)))))
-
-;;; Exported variables
-
-(define sc-expand #f)
-(define sc-expand3 #f)
-(define sc-chi #f)
-(define install-global-transformer #f)
-(define syntax-dispatch #f)
-(define syntax-error #f)
-
-(define bound-identifier=? #f)
-(define datum->syntax-object #f)
-(define free-identifier=? #f)
-(define generate-temporaries #f)
-(define identifier? #f)
-(define syntax-object->datum #f)
-
-(define primitive-syntax '(quote lambda letrec if set! begin define or
- and let let* cond do quasiquote unquote
- unquote-splicing case))
-
-(for-each (lambda (symbol)
- (set-symbol-property! symbol 'primitive-syntax #t))
- primitive-syntax)
-
-;;; Hooks needed by the syntax-case macro package
-
-(define (void) *unspecified*)
-
-(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 (error who format-string why what)
- (start-stack 'syncase-stack
- (scm-error 'misc-error
- who
- "~A ~S"
- (list why what)
- '())))
-
-(define the-syncase-module (current-module))
-(define the-syncase-eval-closure (module-eval-closure the-syncase-module))
-
-(fluid-set! expansion-eval-closure the-syncase-eval-closure)
-
-(define (putprop symbol key binding)
- (let* ((eval-closure (current-eval-closure))
- ;; Why not simply do (eval-closure symbol #t)?
- ;; Answer: That would overwrite imported bindings
- (v (or (eval-closure symbol #f) ;lookup
- (eval-closure symbol #t) ;create it locally
- )))
- ;; Don't destroy Guile macros corresponding to
- ;; primitive syntax when syncase boots.
- (if (not (and (symbol-property symbol 'primitive-syntax)
- (eq? eval-closure the-syncase-eval-closure)))
- (variable-set! v sc-macro))
- ;; Properties are tied to variable objects
- (set-object-property! v key binding)))
-
-(define (getprop symbol key)
- (let* ((v ((current-eval-closure) symbol #f)))
- (and v
- (or (object-property v key)
- (and (variable-bound? v)
- (macro? (variable-ref v))
- (macro-transformer (variable-ref v)) ;non-primitive
- guile-macro)))))
-
-(define guile-macro
- (cons 'external-macro
- (lambda (e r w s)
- (let ((e (syntax-object->datum e)))
- (if (symbol? e)
- ;; pass the expression through
- e
- (let* ((eval-closure (current-eval-closure))
- (m (variable-ref (eval-closure (car e) #f))))
- (if (eq? (macro-type m) 'syntax)
- ;; pass the expression through
- e
- ;; perform Guile macro transform
- (let ((e ((macro-transformer m)
- e
- (append r (list eval-closure)))))
- (if (variable? e)
- e
- (if (null? r)
- (sc-expand e)
- (sc-chi e r w)))))))))))
-
-(define generated-symbols (make-weak-key-hash-table 1019))
-
-;; We define our own gensym here because the Guile built-in one will
-;; eventually produce uninterned and unreadable symbols (as needed for
-;; safe macro expansions) and will the be inappropriate for dumping to
-;; pssyntax.pp.
-;;
-;; syncase is supposed to only require that gensym produce unique
-;; readable symbols, and they only need be unique with respect to
-;; multiple calls to gensym, not globally unique.
-;;
-(define gensym
- (let ((counter 0))
-
- (define next-id
- (if (provided? 'threads)
- (let ((symlock (make-mutex)))
- (lambda ()
- (let ((result #f))
- (with-mutex symlock
- (set! result counter)
- (set! counter (+ counter 1)))
- result)))
- ;; faster, non-threaded case.
- (lambda ()
- (let ((result counter))
- (set! counter (+ counter 1))
- result))))
-
- ;; actual gensym body code.
- (lambda (. rest)
- (let* ((next-val (next-id))
- (valstr (number->string next-val)))
- (cond
- ((null? rest)
- (string->symbol (string-append "syntmp-" valstr)))
- ((null? (cdr rest))
- (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
- (else
- (error
- (string-append
- "syncase's gensym expected 0 or 1 arguments, got "
- (length rest)))))))))
-
-;;; Load the preprocessed code
-
-(let ((old-debug #f)
- (old-read #f))
- (dynamic-wind (lambda ()
- (set! old-debug (debug-options))
- (set! old-read (read-options)))
- (lambda ()
- (debug-disable 'debug 'procnames)
- (read-disable 'positions)
- (load-from-path "ice-9/psyntax-pp"))
- (lambda ()
- (debug-options old-debug)
- (read-options old-read))))
-
-
-;;; The following lines are necessary only if we start making changes
-;; (use-syntax sc-expand)
-;; (load-from-path "ice-9/psyntax")
-
-(define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))
-
-(define (eval x environment)
- (internal-eval (if (and (pair? x)
- (equal? (car x) "noexpand"))
- (cadr x)
- (sc-expand x))
- environment))
+(issue-deprecation-warning
+ "Syntax-case macros are now a part of Guile core; importing (ice-9 syncase) is no longer necessary.")
;;; Hack to make syncase macros work in the slib module
-(let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
- (if m
- (set-object-property! (module-local-variable m 'define)
- '*sc-expander*
- '(define))))
-
-(define (syncase exp)
- (with-fluids ((expansion-eval-closure
- (module-eval-closure (current-module))))
- (sc-expand exp)))
-
-(set-module-transformer! the-syncase-module syncase)
-
-(define-syntax define-syntax-public
- (syntax-rules ()
- ((_ name rules ...)
- (begin
- ;(eval-case ((load-toplevel) (export-syntax name)))
- (define-syntax name rules ...)))))
-
-(fluid-set! expansion-eval-closure #f)
+;; FIXME wingo is this still necessary?
+;; (let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
+;; (if m
+;; (set-object-property! (module-local-variable m 'define)
+;; '*sc-expander*
+;; '(define))))
diff --git a/module/ice-9/test.scm b/module/ice-9/test.scm
index bed39b621..f6080e4cf 100644
--- a/module/ice-9/test.scm
+++ b/module/ice-9/test.scm
@@ -1,18 +1,18 @@
;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2006 Free Software Foundation, Inc.
;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; "test.scm" Test correctness of scheme implementations.
;;; Author: Aubrey Jaffer
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index bd0f7b745..292d3c27a 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -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 a7045969f..0fad8dfca 100644
--- a/module/ice-9/time.scm
+++ b/module/ice-9/time.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -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/ice-9/weak-vector.scm b/module/ice-9/weak-vector.scm
index 92d40d840..09e2e0a8d 100644
--- a/module/ice-9/weak-vector.scm
+++ b/module/ice-9/weak-vector.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 28dde1e1a..683da6cc1 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -2,57 +2,54 @@
;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (language assembly)
+ #:use-module (rnrs bytevector)
#:use-module (system base pmatch)
#:use-module (system vm instruction)
#:use-module ((srfi srfi-1) #:select (fold))
#:export (byte-length
- addr+ align-program
+ addr+ align-program align-code align-block
assembly-pack assembly-unpack
object->assembly assembly->object))
-;; nargs, nrest, nlocs, nexts, len, metalen
-(define *program-header-len* (+ 1 1 1 1 4 4))
+;; nargs, nrest, nlocs, len, metalen, padding
+(define *program-header-len* (+ 1 1 2 4 4 4))
;; lengths are encoded in 3 bytes
(define *len-len* 3)
+
(define (byte-length assembly)
(pmatch assembly
(,label (guard (not (pair? label)))
0)
- ((load-unsigned-integer ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-integer ,str)
- (+ 1 *len-len* (string-length str)))
((load-number ,str)
(+ 1 *len-len* (string-length str)))
((load-string ,str)
(+ 1 *len-len* (string-length str)))
+ ((load-wide-string ,str)
+ (+ 1 *len-len* (* 4 (string-length str))))
((load-symbol ,str)
(+ 1 *len-len* (string-length str)))
- ((load-keyword ,str)
- (+ 1 *len-len* (string-length str)))
- ((define ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+ ((load-array ,bv)
+ (+ 1 *len-len* (bytevector-length bv)))
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
@@ -61,18 +58,28 @@
(define *program-alignment* 8)
+(define *block-alignment* 8)
+
(define (addr+ addr code)
(fold (lambda (x len) (+ (byte-length x) len))
addr
code))
+(define (code-alignment addr alignment header-len)
+ (make-list (modulo (- alignment
+ (modulo (+ addr header-len) alignment))
+ alignment)
+ '(nop)))
+
+(define (align-block addr)
+ (code-alignment addr *block-alignment* 0))
+
+(define (align-code code addr alignment header-len)
+ `(,@(code-alignment addr alignment header-len)
+ ,code))
+
(define (align-program prog addr)
- `(,@(make-list (modulo (- *program-alignment*
- (modulo (1+ addr) *program-alignment*))
- ;; plus the one for the load-program inst itself
- *program-alignment*)
- '(nop))
- ,prog))
+ (align-code prog addr *program-alignment* 1))
;;;
;;; Code compress/decompression
@@ -104,12 +111,26 @@
((null? x) `(make-eol))
((and (integer? x) (exact? x))
(cond ((and (<= -128 x) (< x 128))
- `(make-int8 ,(modulo x 256)))
+ (assembly-pack `(make-int8 ,(modulo x 256))))
((and (<= -32768 x) (< x 32768))
(let ((n (if (< x 0) (+ x 65536) x)))
`(make-int16 ,(quotient n 256) ,(modulo n 256))))
+ ((and (<= 0 x #xffffffffffffffff))
+ `(make-uint64 ,@(bytevector->u8-list
+ (let ((bv (make-bytevector 8)))
+ (bytevector-u64-set! bv 0 x (endianness big))
+ bv))))
+ ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff))
+ `(make-int64 ,@(bytevector->u8-list
+ (let ((bv (make-bytevector 8)))
+ (bytevector-s64-set! bv 0 x (endianness big))
+ bv))))
(else #f)))
- ((char? x) `(make-char8 ,(char->integer x)))
+ ((char? x)
+ (cond ((<= (char->integer x) #xff)
+ `(make-char8 ,(char->integer x)))
+ (else
+ `(make-char32 ,(char->integer x)))))
(else #f)))
(define (assembly->object code)
@@ -122,9 +143,23 @@
((make-int16 ,n1 ,n2)
(let ((n (+ (* n1 256) n2)))
(if (< n 32768) n (- n 65536))))
+ ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
+ (bytevector-u64-ref
+ (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
+ 0
+ (endianness big)))
+ ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
+ (bytevector-s64-ref
+ (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
+ 0
+ (endianness big)))
((make-char8 ,n)
(integer->char n))
+ ((make-char32 ,n1 ,n2 ,n3 ,n4)
+ (integer->char (+ (* n1 #x1000000)
+ (* n2 #x10000)
+ (* n3 #x100)
+ n4)))
((load-string ,s) s)
((load-symbol ,s) (string->symbol s))
- ((load-keyword ,s) (symbol->keyword (string->symbol s)))
(else #f)))
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 6e7e34efc..4706cce64 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -2,20 +2,19 @@
;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -24,6 +23,7 @@
#:use-module (language assembly)
#:use-module (system vm instruction)
#:use-module (srfi srfi-4)
+ #:use-module (rnrs bytevector)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module ((system vm objcode) #:select (byte-order))
#:export (compile-bytecode write-bytecode))
@@ -40,7 +40,7 @@
(get-addr (lambda () i)))
(write-bytecode assembly write-byte get-addr '())
(if (= i (u8vector-length v))
- (values v env)
+ (values v env env)
(error "incorrect length in assembly" i (u8vector-length v)))))
(else (error "bad assembly" assembly))))
@@ -65,6 +65,14 @@
(write-byte (logand (ash x -8) 255))
(write-byte (logand (ash x -16) 255))
(write-byte (logand (ash x -24) 255)))
+ (define (write-uint32 x)
+ (case byte-order
+ ((1234) (write-uint32-le x))
+ ((4321) (write-uint32-be x))
+ (else (error "unknown endianness" byte-order))))
+ (define (write-wide-string s)
+ (write-loader-len (* 4 (string-length s)))
+ (string-for-each (lambda (c) (write-uint32 (char->integer c))) s))
(define (write-loader-len len)
(write-byte (ash len -16))
(write-byte (logand (ash len -8) 255))
@@ -72,27 +80,43 @@
(define (write-loader str)
(write-loader-len (string-length str))
(write-string str))
+ (define (write-sized-loader str)
+ (let ((len (string-length str))
+ (wid (string-width str)))
+ (write-loader-len len)
+ (write-byte wid)
+ (if (= wid 4)
+ (write-wide-string str)
+ (write-string str))))
+ (define (write-bytevector bv)
+ (write-loader-len (bytevector-length bv))
+ ;; Ew!
+ (for-each write-byte (bytevector->u8-list bv)))
(define (write-break label)
- (write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2))))
+ (let ((offset (- (assq-ref labels label)
+ (logand (+ (get-addr) 2) (lognot #x7)))))
+ (cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset))
+ ((>= offset (ash 1 18)) (error "jump too far forward" offset))
+ ((< offset (- (ash 1 18))) (error "jump too far backwards" offset))
+ (else (write-uint16-be (ash offset -3))))))
(let ((inst (car asm))
(args (cdr asm))
- (write-uint32 (case byte-order
- ((1234) write-uint32-le)
- ((4321) write-uint32-be)
+ (write-uint16 (case byte-order
+ ((1234) write-uint16-le)
+ ((4321) write-uint16-be)
(else (error "unknown endianness" byte-order)))))
(let ((opcode (instruction->opcode inst))
(len (instruction-length inst)))
(write-byte opcode)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,nexts
- ,labels ,length ,meta . ,code)
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
(write-byte nargs)
(write-byte nrest)
- (write-byte nlocs)
- (write-byte nexts)
+ (write-uint16 nlocs)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
+ (write-uint32 0) ; padding
(letrec ((i 0)
(write (lambda (x) (set! i (1+ i)) (write-byte x)))
(get-addr (lambda () i)))
@@ -106,14 +130,16 @@
(set! i (1+ i))
(if (> i 0) (write-byte x))))
(get-addr (lambda () i)))
+ ;; META's bytecode meets the alignment requirements of
+ ;; `scm_objcode', thanks to the alignment computed in
+ ;; `(language assembly)'.
(write-bytecode meta write get-addr '()))))
- ((load-unsigned-integer ,str) (write-loader str))
- ((load-integer ,str) (write-loader str))
+ ((make-char32 ,x) (write-uint32-be x))
((load-number ,str) (write-loader str))
((load-string ,str) (write-loader str))
+ ((load-wide-string ,str) (write-wide-string str))
((load-symbol ,str) (write-loader str))
- ((load-keyword ,str) (write-loader str))
- ((define ,str) (write-loader str))
+ ((load-array ,bv) (write-bytevector bv))
((br ,l) (write-break l))
((br-if ,l) (write-break l))
((br-if-not ,l) (write-break l))
diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm
index e65b2cbaa..8cdebcfd0 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -1,21 +1,20 @@
;;; 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
-;; 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.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -23,7 +22,9 @@
#:use-module (system vm instruction)
#:use-module (system base pmatch)
#:use-module (srfi srfi-4)
+ #:use-module (rnrs bytevector)
#:use-module (language assembly)
+ #:use-module ((system vm objcode) #:select (byte-order))
#:export (decompile-bytecode))
(define (decompile-bytecode x env opts)
@@ -48,17 +49,21 @@
x
(- x (ash 1 16)))))
+;; FIXME: this is a little-endian disassembly!!!
(define (decode-load-program pop)
- (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop))
+ (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop))
+ (nlocs (+ nlocs0 (ash nlocs1 8)))
(a (pop)) (b (pop)) (c (pop)) (d (pop))
(e (pop)) (f (pop)) (g (pop)) (h (pop))
(len (+ a (ash b 8) (ash c 16) (ash d 24)))
(metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
(totlen (+ len metalen))
+ (pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop))
(labels '())
(i 0))
(define (ensure-label rel1 rel2)
- (let ((where (+ i (bytes->s16 rel1 rel2))))
+ (let ((where (+ (logand i (lognot #x7))
+ (* (bytes->s16 rel1 rel2) 8))))
(or (assv-ref labels where)
(begin
(let ((l (gensym ":L")))
@@ -74,7 +79,7 @@
(cond ((> i len)
(error "error decoding program -- read too many bytes" out))
((= i len)
- `(load-program ,nargs ,nrest ,nlocs ,nexts
+ `(load-program ,nargs ,nrest ,nlocs
,(map (lambda (x) (cons (cdr x) (car x)))
(reverse labels))
,len
@@ -97,15 +102,29 @@
(cond
((eq? inst 'load-program)
(decode-load-program pop))
+
((< (instruction-length inst) 0)
- (let* ((len (let* ((a (pop)) (b (pop)) (c (pop)))
+ ;; the negative length indicates a variable length
+ ;; instruction
+ (let* ((make-sequence
+ (if (or (memq inst '(load-array load-wide-string)))
+ make-bytevector
+ make-string))
+ (sequence-set!
+ (if (or (memq inst '(load-array load-wide-string)))
+ bytevector-u8-set!
+ (lambda (str pos value)
+ (string-set! str pos (integer->char value)))))
+ (len (let* ((a (pop)) (b (pop)) (c (pop)))
(+ (ash a 16) (ash b 8) c)))
- (str (make-string len)))
+ (seq (make-sequence len)))
(let lp ((i 0))
(if (= i len)
- `(,inst ,str)
+ `(,inst ,(if (eq? inst 'load-wide-string)
+ (utf32->string seq)
+ seq))
(begin
- (string-set! str i (integer->char (pop)))
+ (sequence-set! seq i (pop))
(lp (1+ i)))))))
(else
;; fixed length
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index 2752934f9..492acb7e5 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -1,21 +1,20 @@
;;; Guile VM code converters
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Copyright (C) 2001, 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -36,12 +35,11 @@
(define (disassemble-load-program asm env)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
(let ((objs (and env (assq-ref env 'objects)))
+ (free-vars (and env (assq-ref env 'free-vars)))
(meta (and env (assq-ref env 'meta)))
- (exts (and env (assq-ref env 'exts)))
(blocs (and env (assq-ref env 'blocs)))
- (bexts (and env (assq-ref env 'bexts)))
(srcs (and env (assq-ref env 'sources))))
(let lp ((pos 0) (code code) (programs '()))
(cond
@@ -62,15 +60,17 @@
(print-info pos `(load-program ,sym) #f #f)
(lp (+ pos (byte-length asm)) (cdr code)
(acons sym asm programs))))
+ ((nop)
+ (lp (+ pos (byte-length asm)) (cdr code) programs))
(else
(print-info pos asm
- (code-annotation end asm objs nargs blocs bexts
+ (code-annotation end asm objs nargs blocs
labels)
(and=> (and srcs (assq end srcs)) source->string))
(lp (+ pos (byte-length asm)) (cdr code) programs)))))))
- (if (pair? exts)
- (disassemble-externals exts))
+ (if (pair? free-vars)
+ (disassemble-free-vars free-vars))
(if meta
(disassemble-meta meta))
@@ -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))))
@@ -93,13 +93,12 @@
((= n len) (newline))
(print-info n (vector-ref objs n) #f #f))))
-(define (disassemble-externals exts)
- (display "Externals:\n\n")
- (let ((len (length exts)))
- (do ((n 0 (1+ n))
- (l exts (cdr l)))
- ((null? l) (newline))
- (print-info n (car l) #f #f))))
+(define (disassemble-free-vars free-vars)
+ (display "Free variables:\n\n")
+ (let ((i 0))
+ (cond ((< i (vector-length free-vars))
+ (print-info i (vector-ref free-vars i) #f #f)
+ (lp (1+ i))))))
(define-macro (unless test . body)
`(if (not ,test) (begin ,@body)))
@@ -123,7 +122,7 @@
(define (make-int16 byte1 byte2)
(+ (* byte1 256) byte2))
-(define (code-annotation end-addr code objs nargs blocs bexts labels)
+(define (code-annotation end-addr code objs nargs blocs labels)
(let* ((code (assembly-unpack code))
(inst (car code))
(args (cdr code)))
@@ -134,7 +133,7 @@
(list "-> ~A" (assq-ref labels (car args))))
((object-ref)
(and objs (list "~s" (vector-ref objs (car args)))))
- ((local-ref local-set)
+ ((local-ref local-boxed-ref local-set local-boxed-set)
(and blocs
(let lp ((bindings (list-ref blocs (car args))))
(and (pair? bindings)
@@ -144,13 +143,9 @@
(list "`~a'~@[ (arg)~]"
(binding:name b) (< (binding:index b) nargs))
(lp (cdr bindings))))))))
- ((external-ref external-set)
- (and bexts
- (if (< (car args) (length bexts))
- (let ((b (list-ref bexts (car args))))
- (list "`~a'~@[ (arg)~]"
- (binding:name b) (< (binding:index b) nargs)))
- (list "(closure variable)"))))
+ ((free-ref free-boxed-ref free-boxed-set)
+ ;; FIXME: we can do better than this
+ (list "(closure variable)"))
((toplevel-ref toplevel-set)
(and objs
(let ((v (vector-ref objs (car args))))
diff --git a/module/language/assembly/spec.scm b/module/language/assembly/spec.scm
index c12808e0c..286c80511 100644
--- a/module/language/assembly/spec.scm
+++ b/module/language/assembly/spec.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/brainfuck/compile-scheme.scm b/module/language/brainfuck/compile-scheme.scm
new file mode 100644
index 000000000..86bc35fdd
--- /dev/null
+++ b/module/language/brainfuck/compile-scheme.scm
@@ -0,0 +1,126 @@
+;;; Brainfuck for GNU Guile
+
+;; 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 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language brainfuck compile-scheme)
+ #:export (compile-scheme))
+
+;; Compilation of Brainfuck to Scheme is pretty straight-forward. For all of
+;; brainfuck's instructions, there are basic representations in Scheme we
+;; only have to generate.
+;;
+;; Brainfuck's pointer and data-tape are stored in the variables pointer and
+;; tape, where tape is a vector of integer values initially set to zero. Pointer
+;; starts out at position 0.
+;; Our tape is thus of finite length, with an address range of 0..n for
+;; some defined upper bound n depending on the length of our tape.
+
+
+;; Define the length to use for the tape.
+
+(define tape-size 30000)
+
+
+;; This compiles a whole brainfuck program. This constructs a Scheme code like:
+;; (let ((pointer 0)
+;; (tape (make-vector tape-size 0)))
+;; (begin
+;; <body>
+;; (write-char #\newline)))
+;;
+;; So first the pointer and tape variables are set up correctly, then the
+;; program's body is executed in this context, and finally we output an
+;; additional newline character in case the program does not output one.
+;;
+;; TODO: Find out and explain the details about env, the three return values and
+;; how to use the options. Implement options to set the tape-size, maybe.
+
+(define (compile-scheme exp env opts)
+ (values
+ `(let ((pointer 0)
+ (tape (make-vector ,tape-size 0)))
+ ,@(if (not (eq? '<brainfuck> (car exp)))
+ (error "expected brainfuck program")
+ `(begin
+ ,@(compile-body (cdr exp))
+ (write-char #\newline))))
+ env
+ env))
+
+
+;; Compile a list of instructions to get a list of Scheme codes. As we always
+;; strip off the car of the instructions-list and cons the result onto the
+;; result-list, it will get out in reversed order first; so we have to (reverse)
+;; it on return.
+
+(define (compile-body instructions)
+ (let iterate ((cur instructions)
+ (result '()))
+ (if (null? cur)
+ (reverse result)
+ (let ((compiled (compile-instruction (car cur))))
+ (iterate (cdr cur) (cons compiled result))))))
+
+
+;; Compile a single instruction to Scheme, using the direct representations
+;; all of Brainfuck's instructions have.
+
+(define (compile-instruction ins)
+ (case (car ins)
+
+ ;; Pointer moval >< is done simply by something like:
+ ;; (set! pointer (+ pointer +-1))
+ ((<bf-move>)
+ (let ((dir (cadr ins)))
+ `(set! pointer (+ pointer ,dir))))
+
+ ;; Cell increment +- is done as:
+ ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
+ ((<bf-increment>)
+ (let ((inc (cadr ins)))
+ `(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc))))
+
+ ;; Output . is done by converting the cell's integer value to a character
+ ;; first and then printing out this character:
+ ;; (write-char (integer->char (vector-ref tape pointer)))
+ ((<bf-print>)
+ '(write-char (integer->char (vector-ref tape pointer))))
+
+ ;; Input , is done similarly, read in a character, get its ASCII code and
+ ;; store it into the current cell:
+ ;; (vector-set! tape pointer (char->integer (read-char)))
+ ((<bf-read>)
+ '(vector-set! tape pointer (char->integer (read-char))))
+
+ ;; For loops [...] we use a named let construction to execute the body until
+ ;; the current cell gets zero. The body is compiled via a recursive call
+ ;; back to (compile-body).
+ ;; (let iterate ()
+ ;; (if (not (= (vector-ref! tape pointer) 0))
+ ;; (begin
+ ;; <body>
+ ;; (iterate))))
+ ((<bf-loop>)
+ `(let iterate ()
+ (if (not (= (vector-ref tape pointer) 0))
+ (begin
+ ,@(compile-body (cdr ins))
+ (iterate)))))
+
+ (else (error "unknown brainfuck instruction " (car ins)))))
diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm
new file mode 100644
index 000000000..0aaa11274
--- /dev/null
+++ b/module/language/brainfuck/compile-tree-il.scm
@@ -0,0 +1,181 @@
+;;; Brainfuck for GNU Guile
+
+;; 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 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Commentary:
+
+;; Brainfuck is a simple language that mostly mimics the operations of a
+;; Turing machine. This file implements a compiler from Brainfuck to
+;; Guile's Tree-IL.
+
+;;; Code:
+
+(define-module (language brainfuck compile-tree-il)
+ #:use-module (system base pmatch)
+ #:use-module (language tree-il)
+ #:export (compile-tree-il))
+
+;; Compilation of Brainfuck is pretty straight-forward. For all of
+;; brainfuck's instructions, there are basic representations in Tree-IL
+;; we only have to generate.
+;;
+;; Brainfuck's pointer and data-tape are stored in the variables pointer and
+;; tape, where tape is a vector of integer values initially set to zero. Pointer
+;; starts out at position 0.
+;; Our tape is thus of finite length, with an address range of 0..n for
+;; some defined upper bound n depending on the length of our tape.
+
+
+;; Define the length to use for the tape.
+
+(define tape-size 30000)
+
+
+;; This compiles a whole brainfuck program. This constructs a Tree-IL
+;; code equivalent to Scheme code like this:
+;;
+;; (let ((pointer 0)
+;; (tape (make-vector tape-size 0)))
+;; (begin
+;; <body>
+;; (write-char #\newline)))
+;;
+;; So first the pointer and tape variables are set up correctly, then the
+;; program's body is executed in this context, and finally we output an
+;; additional newline character in case the program does not output one.
+;;
+;; The fact that we are compiling to Guile primitives gives this
+;; implementation a number of interesting characteristics. First, the
+;; values of the tape cells do not underflow or overflow. We could make
+;; them do otherwise via compiling calls to "modulo" at certain points.
+;;
+;; In addition, tape overruns or underruns will be detected, and will
+;; throw an error, whereas a number of Brainfuck compilers do not detect
+;; this.
+;;
+;; Note that we're generating the S-expression representation of
+;; Tree-IL, then using parse-tree-il to turn it into the actual Tree-IL
+;; data structures. This makes the compiler more pleasant to look at,
+;; but we do lose is the ability to propagate source information. Since
+;; Brainfuck is so obtuse anyway, this shouldn't matter ;-)
+;;
+;; `compile-tree-il' takes as its input the read expression, the
+;; environment, and some compile options. It returns the compiled
+;; expression, the environment appropriate for the next pass of the
+;; compiler -- in our case, just the environment unchanged -- and the
+;; continuation environment.
+;;
+;; The normal use of a continuation environment is if compiling one
+;; expression changes the environment, and that changed environment
+;; should be passed to the next compiled expression -- for example,
+;; changing the current module. But Brainfuck is incapable of that, so
+;; for us, the continuation environment is just the same environment we
+;; got in.
+;;
+;; FIXME: perhaps use options or the env to set the tape-size?
+
+(define (compile-tree-il exp env opts)
+ (values
+ (parse-tree-il
+ `(let (pointer tape) (pointer tape)
+ ((const 0)
+ (apply (primitive make-vector) (const ,tape-size) (const 0)))
+ ,(compile-body exp)))
+ env
+ env))
+
+
+;; Compile a list of instructions to a Tree-IL expression.
+
+(define (compile-body instructions)
+ (let lp ((in instructions) (out '()))
+ (define (emit x)
+ (lp (cdr in) (cons x out)))
+ (cond
+ ((null? in)
+ ;; No more input, build our output.
+ (cond
+ ((null? out) '(void)) ; no output
+ ((null? (cdr out)) (car out)) ; single expression
+ (else `(begin ,@(reverse out)))) ; sequence
+ )
+ (else
+ (pmatch (car in)
+
+ ;; Pointer moves >< are done simply by something like:
+ ;; (set! pointer (+ pointer +-1))
+ ((<bf-move> ,dir)
+ (emit `(set! (lexical pointer)
+ (apply (primitive +) (lexical pointer) (const ,dir)))))
+
+ ;; Cell increment +- is done as:
+ ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
+ ((<bf-increment> ,inc)
+ (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer)
+ (apply (primitive +)
+ (apply (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const ,inc)))))
+
+ ;; Output . is done by converting the cell's integer value to a
+ ;; character first and then printing out this character:
+ ;; (write-char (integer->char (vector-ref tape pointer)))
+ ((<bf-print>)
+ (emit `(apply (primitive write-char)
+ (apply (primitive integer->char)
+ (apply (primitive vector-ref)
+ (lexical tape) (lexical pointer))))))
+
+ ;; Input , is done similarly, read in a character, get its ASCII
+ ;; code and store it into the current cell:
+ ;; (vector-set! tape pointer (char->integer (read-char)))
+ ((<bf-read>)
+ (emit `(apply (primitive vector-set!)
+ (lexical tape) (lexical pointer)
+ (apply (primitive char->integer)
+ (apply (primitive read-char))))))
+
+ ;; For loops [...] we use a letrec construction to execute the body until
+ ;; the current cell gets zero. The body is compiled via a recursive call
+ ;; back to (compile-body).
+ ;; (let iterate ()
+ ;; (if (not (= (vector-ref! tape pointer) 0))
+ ;; (begin
+ ;; <body>
+ ;; (iterate))))
+ ;;
+ ;; Indeed, letrec is the only way we have to loop in Tree-IL.
+ ;; Note that this does not mean that the closure must actually
+ ;; be created; later passes can compile tail-recursive letrec
+ ;; calls into inline code with gotos. Admittedly, that part of
+ ;; the compiler is not yet in place, but it will be, and in the
+ ;; meantime the code is still reasonably efficient.
+ ((<bf-loop> . ,body)
+ (let ((iterate (gensym)))
+ (emit `(letrec (iterate) (,iterate)
+ ((lambda () ()
+ (if (apply (primitive =)
+ (apply (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const 0))
+ (void)
+ (begin ,(compile-body body)
+ (apply (lexical ,iterate))))))
+ (apply (lexical ,iterate))))))
+
+ (else (error "unknown brainfuck instruction" (car in))))))))
diff --git a/module/language/brainfuck/parse.scm b/module/language/brainfuck/parse.scm
new file mode 100644
index 000000000..0a71638d8
--- /dev/null
+++ b/module/language/brainfuck/parse.scm
@@ -0,0 +1,91 @@
+;;; Brainfuck for GNU Guile.
+
+;; 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 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Code:
+
+(define-module (language brainfuck parse)
+ #:export (read-brainfuck))
+
+; Purpose of the parse module is to read in brainfuck in text form and produce
+; the corresponding tree representing the brainfuck code.
+;
+; Each object (representing basically a single instruction) is structured like:
+; (<instruction> [arguments])
+; where <instruction> is a symbolic name representing the type of instruction
+; and the optional arguments represent further data (for instance, the body of
+; a [...] loop as a number of nested instructions).
+;
+; A full brainfuck program is represented by the (<brainfuck> instructions)
+; object.
+
+
+; While reading a number of instructions in sequence, all of them are cons'ed
+; onto a list of instructions; thus this list gets out in reverse order.
+; Additionally, for "comment characters" (everything not an instruction) we
+; generate <bf-nop> NOP instructions.
+;
+; This routine reverses a list of instructions and removes all <bf-nop>'s on the
+; way to fix these two issues for a read-in list.
+
+(define (reverse-without-nops lst)
+ (let iterate ((cur lst)
+ (result '()))
+ (if (null? cur)
+ result
+ (let ((head (car cur))
+ (tail (cdr cur)))
+ (if (eq? (car head) '<bf-nop>)
+ (iterate tail result)
+ (iterate tail (cons head result)))))))
+
+
+; Read in a set of instructions until a terminating ] character is found (or
+; end of file is reached). This is used both for loop bodies and whole
+; programs, so that a program has to be either terminated by EOF or an
+; additional ], too.
+;
+; For instance, the basic program so just echo one character would be:
+; ,.]
+
+(define (read-brainfuck p)
+ (let iterate ((parsed '()))
+ (let ((chr (read-char p)))
+ (if (or (eof-object? chr) (eq? #\] chr))
+ (reverse-without-nops parsed)
+ (iterate (cons (process-input-char chr p) parsed))))))
+
+
+; This routine processes a single character of input and builds the
+; corresponding instruction. Loop bodies are read by recursively calling
+; back (read-brainfuck).
+;
+; For the poiner movement commands >< and the cell increment/decrement +-
+; commands, we only use one instruction form each and specify the direction of
+; the pointer/value increment using an argument to the instruction form.
+
+(define (process-input-char chr p)
+ (case chr
+ ((#\>) '(<bf-move> 1))
+ ((#\<) '(<bf-move> -1))
+ ((#\+) '(<bf-increment> 1))
+ ((#\-) '(<bf-increment> -1))
+ ((#\.) '(<bf-print>))
+ ((#\,) '(<bf-read>))
+ ((#\[) `(<bf-loop> ,@(read-brainfuck p)))
+ (else '(<bf-nop>))))
diff --git a/module/language/brainfuck/spec.scm b/module/language/brainfuck/spec.scm
new file mode 100644
index 000000000..a4ba60f82
--- /dev/null
+++ b/module/language/brainfuck/spec.scm
@@ -0,0 +1,44 @@
+;;; Brainfuck for GNU Guile.
+
+;; 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 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Code:
+
+(define-module (language brainfuck spec)
+ #:use-module (language brainfuck compile-tree-il)
+ #:use-module (language brainfuck compile-scheme)
+ #:use-module (language brainfuck parse)
+ #:use-module (system base language)
+ #:export (brainfuck))
+
+
+; The new language is integrated into Guile via this (define-language)
+; specification in the special module (language [lang] spec).
+; Provided is a parser-routine in #:reader, a output routine in #:printer
+; and one or more compiler routines (as target-language - routine pairs)
+; in #:compilers. This is the basic set of fields needed to specify a new
+; language.
+
+(define-language brainfuck
+ #:title "Guile Brainfuck"
+ #:version "1.0"
+ #:reader (lambda () (read-brainfuck (current-input-port)))
+ #:compilers `((tree-il . ,compile-tree-il)
+ (scheme . ,compile-scheme))
+ #:printer write
+ )
diff --git a/module/language/bytecode/spec.scm b/module/language/bytecode/spec.scm
index 7d9b955a7..184565b04 100644
--- a/module/language/bytecode/spec.scm
+++ b/module/language/bytecode/spec.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -25,7 +24,7 @@
#:export (bytecode))
(define (compile-objcode x e opts)
- (values (bytecode->objcode x) e))
+ (values (bytecode->objcode x) e e))
(define (decompile-objcode x e opts)
(values (objcode->bytecode x) e))
diff --git a/module/language/ecmascript/array.scm b/module/language/ecmascript/array.scm
index a9f499a22..e9fc3c6f4 100644
--- a/module/language/ecmascript/array.scm
+++ b/module/language/ecmascript/array.scm
@@ -2,20 +2,19 @@
;; Copyright (C) 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm
index 1463d358b..1d031fcde 100644
--- a/module/language/ecmascript/base.scm
+++ b/module/language/ecmascript/base.scm
@@ -2,20 +2,19 @@
;; Copyright (C) 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/ecmascript/compile-ghil.scm b/module/language/ecmascript/compile-ghil.scm
deleted file mode 100644
index d4c2261a0..000000000
--- a/module/language/ecmascript/compile-ghil.scm
+++ /dev/null
@@ -1,572 +0,0 @@
-;;; ECMAScript for Guile
-
-;; Copyright (C) 2009 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(define-module (language ecmascript compile-ghil)
- #:use-module (language ghil)
- #:use-module (ice-9 receive)
- #:use-module (system base pmatch)
- #:export (compile-ghil))
-
-(define-macro (-> form)
- `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form)))
-
-(define-macro (@implv sym)
- `(-> (ref (ghil-var-at-module! e '(language ecmascript impl) ',sym #t))))
-(define-macro (@impl sym args)
- `(-> (call (@implv ,sym) ,args)))
-
-(define (compile-ghil exp env opts)
- (values
- (call-with-ghil-environment (make-ghil-toplevel-env) '()
- (lambda (e vars)
- (let ((l #f))
- (-> (lambda vars #f '()
- (-> (begin (list (@impl js-init '())
- (comp exp e)))))))))
- env))
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- props))))
-
-;; The purpose, you ask? To avoid non-tail recursion when expanding a
-;; long pmatch sequence.
-(define-macro (ormatch x . clauses)
- (let ((X (gensym)))
- `(let ((,X ,x))
- (or ,@(map (lambda (c)
- (if (eq? (car c) 'else)
- `(begin . ,(cdr c))
- `(pmatch ,X ,c (else #f))))
- clauses)))))
-
-(define (comp x e)
- (let ((l (location x)))
- (define (let1 what proc)
- (call-with-ghil-bindings e '(%tmp)
- (lambda (vars)
- (-> (bind vars (list what)
- (proc (car vars)))))))
- (define (begin1 what proc)
- (call-with-ghil-bindings e '(%tmp)
- (lambda (vars)
- (-> (bind vars (list what)
- (-> (begin (list (proc (car vars))
- (-> (ref (car vars)))))))))))
- (ormatch x
- (null
- ;; FIXME, null doesn't have much relation to EOL...
- (-> (quote '())))
- (true
- (-> (quote #t)))
- (false
- (-> (quote #f)))
- ((number ,num)
- (-> (quote num)))
- ((string ,str)
- (-> (quote str)))
- (this
- (@impl get-this '()))
- ((+ ,a)
- (-> (inline 'add
- (list (@impl ->number (list (comp a e)))
- (-> (quote 0))))))
- ((- ,a)
- (-> (inline 'sub (list (-> (quote 0)) (comp a e)))))
- ((~ ,a)
- (@impl bitwise-not (list (comp a e))))
- ((! ,a)
- (@impl logical-not (list (comp a e))))
- ((+ ,a ,b)
- (-> (inline 'add (list (comp a e) (comp b e)))))
- ((- ,a ,b)
- (-> (inline 'sub (list (comp a e) (comp b e)))))
- ((/ ,a ,b)
- (-> (inline 'div (list (comp a e) (comp b e)))))
- ((* ,a ,b)
- (-> (inline 'mul (list (comp a e) (comp b e)))))
- ((% ,a ,b)
- (@impl mod (list (comp a e) (comp b e))))
- ((<< ,a ,b)
- (@impl shift (list (comp a e) (comp b e))))
- ((>> ,a ,b)
- (@impl shift (list (comp a e) (comp `(- ,b) e))))
- ((< ,a ,b)
- (-> (inline 'lt? (list (comp a e) (comp b e)))))
- ((<= ,a ,b)
- (-> (inline 'le? (list (comp a e) (comp b e)))))
- ((> ,a ,b)
- (-> (inline 'gt? (list (comp a e) (comp b e)))))
- ((>= ,a ,b)
- (-> (inline 'ge? (list (comp a e) (comp b e)))))
- ((in ,a ,b)
- (@impl has-property? (list (comp a e) (comp b e))))
- ((== ,a ,b)
- (-> (inline 'equal? (list (comp a e) (comp b e)))))
- ((!= ,a ,b)
- (-> (inline 'not
- (list (-> (inline 'equal?
- (list (comp a e) (comp b e))))))))
- ((=== ,a ,b)
- (-> (inline 'eqv? (list (comp a e) (comp b e)))))
- ((!== ,a ,b)
- (-> (inline 'not
- (list (-> (inline 'eqv?
- (list (comp a e) (comp b e))))))))
- ((& ,a ,b)
- (@impl band (list (comp a e) (comp b e))))
- ((^ ,a ,b)
- (@impl bxor (list (comp a e) (comp b e))))
- ((bor ,a ,b)
- (@impl bior (list (comp a e) (comp b e))))
- ((and ,a ,b)
- (-> (and (list (comp a e) (comp b e)))))
- ((or ,a ,b)
- (-> (or (list (comp a e) (comp b e)))))
- ((if ,test ,then ,else)
- (-> (if (@impl ->boolean (list (comp test e)))
- (comp then e)
- (comp else e))))
- ((if ,test ,then ,else)
- (-> (if (@impl ->boolean (list (comp test e)))
- (comp then e)
- (@implv *undefined*))))
- ((postinc (ref ,foo))
- (begin1 (comp `(ref ,foo) e)
- (lambda (var)
- (-> (set (ghil-var-for-set! e foo)
- (-> (inline 'add
- (list (-> (ref var))
- (-> (quote 1))))))))))
- ((postinc (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (@impl pget
- (list (-> (ref objvar))
- (-> (quote prop))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (quote prop))
- (-> (inline 'add
- (list (-> (ref tmpvar))
- (-> (quote 1))))))))))))
- ((postinc (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (@impl pget
- (list (-> (ref objvar))
- (-> (ref propvar))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (ref propvar))
- (-> (inline 'add
- (list (-> (ref tmpvar))
- (-> (quote 1))))))))))))))
- ((postdec (ref ,foo))
- (begin1 (comp `(ref ,foo) e)
- (lambda (var)
- (-> (set (ghil-var-for-set! e foo)
- (-> (inline 'sub
- (list (-> (ref var))
- (-> (quote 1))))))))))
- ((postdec (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (@impl pget
- (list (-> (ref objvar))
- (-> (quote prop))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (quote prop))
- (-> (inline 'sub
- (list (-> (ref tmpvar))
- (-> (quote 1))))))))))))
- ((postdec (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (@impl pget
- (list (-> (ref objvar))
- (-> (ref propvar))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (ref propvar))
- (-> (inline
- 'sub (list (-> (ref tmpvar))
- (-> (quote 1))))))))))))))
- ((preinc (ref ,foo))
- (let ((v (ghil-var-for-set! e foo)))
- (-> (begin
- (list
- (-> (set v
- (-> (inline 'add
- (list (-> (ref v))
- (-> (quote 1)))))))
- (-> (ref v)))))))
- ((preinc (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (-> (inline 'add
- (list (@impl pget
- (list (-> (ref objvar))
- (-> (quote prop))))
- (-> (quote 1)))))
- (lambda (tmpvar)
- (@impl pput (list (-> (ref objvar))
- (-> (quote prop))
- (-> (ref tmpvar)))))))))
- ((preinc (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (-> (inline 'add
- (list (@impl pget
- (list (-> (ref objvar))
- (-> (ref propvar))))
- (-> (quote 1)))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (ref propvar))
- (-> (ref tmpvar)))))))))))
- ((predec (ref ,foo))
- (let ((v (ghil-var-for-set! e foo)))
- (-> (begin
- (list
- (-> (set v
- (-> (inline 'sub
- (list (-> (ref v))
- (-> (quote 1)))))))
- (-> (ref v)))))))
- ((predec (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (-> (inline 'sub
- (list (@impl pget
- (list (-> (ref objvar))
- (-> (quote prop))))
- (-> (quote 1)))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (quote prop))
- (-> (ref tmpvar)))))))))
- ((predec (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (-> (inline 'sub
- (list (@impl pget
- (list (-> (ref objvar))
- (-> (ref propvar))))
- (-> (quote 1)))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (ref propvar))
- (-> (ref tmpvar)))))))))))
- ((ref ,id)
- (-> (ref (ghil-var-for-ref! e id))))
- ((var . ,forms)
- (-> (begin
- (map (lambda (form)
- (pmatch form
- ((,x ,y)
- (-> (define (ghil-var-define! (ghil-env-parent e) x)
- (comp y e))))
- ((,x)
- (-> (define (ghil-var-define! (ghil-env-parent e) x)
- (@implv *undefined*))))
- (else (error "bad var form" form))))
- forms))))
- ((begin . ,forms)
- (-> (begin
- (map (lambda (x) (comp x e)) forms))))
- ((lambda ,formals ,body)
- (call-with-ghil-environment e '(%args)
- (lambda (e vars)
- (-> (lambda vars #t '()
- (comp-body env l body formals '%args))))))
- ((call/this ,obj ,prop ,args)
- (@impl call/this*
- (list obj
- (-> (lambda '() #f '()
- (-> (call (@impl pget (list obj prop))
- args)))))))
- ((call (pref ,obj ,prop) ,args)
- (comp `(call/this ,(comp obj e)
- ,(-> (quote prop))
- ,(map (lambda (x) (comp x e)) args))
- e))
- ((call (aref ,obj ,prop) ,args)
- (comp `(call/this ,(comp obj e)
- ,(comp prop e)
- ,(map (lambda (x) (comp x e)) args))
- e))
- ((call ,proc ,args)
- (-> (call (comp proc e)
- (map (lambda (x) (comp x e)) args))))
- ((return ,expr)
- (-> (inline 'return
- (list (comp expr e)))))
- ((array . ,args)
- (@impl new-array
- (map (lambda (x) (comp x e)) args)))
- ((object . ,args)
- (@impl new-object
- (map (lambda (x)
- (pmatch x
- ((,prop ,val)
- (-> (inline 'cons
- (list (-> (quote prop))
- (comp val e)))))
- (else
- (error "bad prop-val pair" x))))
- args)))
- ((pref ,obj ,prop)
- (@impl pget
- (list (comp obj e)
- (-> (quote prop)))))
- ((aref ,obj ,index)
- (@impl pget
- (list (comp obj e)
- (comp index e))))
- ((= (ref ,name) ,val)
- (let ((v (ghil-var-for-set! e name)))
- (-> (begin
- (list (-> (set v (comp val e)))
- (-> (ref v)))))))
- ((= (pref ,obj ,prop) ,val)
- (@impl pput
- (list (comp obj e)
- (-> (quote prop))
- (comp val e))))
- ((= (aref ,obj ,prop) ,val)
- (@impl pput
- (list (comp obj e)
- (comp prop e)
- (comp val e))))
- ((+= ,what ,val)
- (comp `(= ,what (+ ,what ,val)) e))
- ((-= ,what ,val)
- (comp `(= ,what (- ,what ,val)) e))
- ((/= ,what ,val)
- (comp `(= ,what (/ ,what ,val)) e))
- ((*= ,what ,val)
- (comp `(= ,what (* ,what ,val)) e))
- ((%= ,what ,val)
- (comp `(= ,what (% ,what ,val)) e))
- ((>>= ,what ,val)
- (comp `(= ,what (>> ,what ,val)) e))
- ((<<= ,what ,val)
- (comp `(= ,what (<< ,what ,val)) e))
- ((>>>= ,what ,val)
- (comp `(= ,what (>>> ,what ,val)) e))
- ((&= ,what ,val)
- (comp `(= ,what (& ,what ,val)) e))
- ((bor= ,what ,val)
- (comp `(= ,what (bor ,what ,val)) e))
- ((^= ,what ,val)
- (comp `(= ,what (^ ,what ,val)) e))
- ((new ,what ,args)
- (@impl new
- (map (lambda (x) (comp x e))
- (cons what args))))
- ((delete (pref ,obj ,prop))
- (@impl pdel
- (list (comp obj e)
- (-> (quote prop)))))
- ((delete (aref ,obj ,prop))
- (@impl pdel
- (list (comp obj e)
- (comp prop e))))
- ((void ,expr)
- (-> (begin
- (list (comp expr e)
- (@implv *undefined*)))))
- ((typeof ,expr)
- (@impl typeof
- (list (comp expr e))))
- ((do ,statement ,test)
- (call-with-ghil-bindings e '(%loop %continue)
- (lambda (vars)
- (-> (bind vars
- (list (call-with-ghil-environment e '()
- (lambda (e _)
- (-> (lambda '() #f '()
- (-> (begin
- (list (comp statement e)
- (-> (call
- (-> (ref (ghil-var-for-ref! e '%continue)))
- '())))))))))
- (call-with-ghil-environment e '()
- (lambda (e _)
- (-> (lambda '() #f '()
- (-> (if (@impl ->boolean (list (comp test e)))
- (-> (call
- (-> (ref (ghil-var-for-ref! e '%loop)))
- '()))
- (@implv *undefined*))))))))
- (-> (call (-> (ref (car vars))) '())))))))
- ((while ,test ,statement)
- (call-with-ghil-bindings e '(%continue)
- (lambda (vars)
- (-> (begin
- (list
- (-> (set (car vars)
- (call-with-ghil-environment e '()
- (lambda (e _)
- (-> (lambda '() #f '()
- (-> (if (@impl ->boolean (list (comp test e)))
- (-> (begin
- (list (comp statement e)
- (-> (call
- (-> (ref (ghil-var-for-ref! e '%continue)))
- '())))))
- (@implv *undefined*)))))))))
- (-> (call (-> (ref (car vars))) '()))))))))
- ((for ,init ,test ,inc ,statement)
- (call-with-ghil-bindings e '(%continue)
- (lambda (vars)
- (-> (begin
- (list
- (comp (or init '(begin)) e)
- (-> (set (car vars)
- (call-with-ghil-environment e '()
- (lambda (e _)
- (-> (lambda '() #f '()
- (-> (if (if test
- (@impl ->boolean (list (comp test e)))
- (comp 'true e))
- (-> (begin
- (list (comp statement e)
- (comp (or inc '(begin)) e)
- (-> (call
- (-> (ref (ghil-var-for-ref! e '%continue)))
- '())))))
- (@implv *undefined*)))))))))
- (-> (call (-> (ref (car vars))) '()))))))))
- ((for-in ,var ,object ,statement)
- (call-with-ghil-bindings e '(%continue %enum)
- (lambda (vars)
- (-> (begin
- (list
- (-> (set (car vars)
- (call-with-ghil-environment e '()
- (lambda (e _)
- (-> (lambda '() #f '()
- (-> (if (@impl ->boolean
- (list (@impl pget
- (list (-> (ref (ghil-var-for-ref! e '%enum)))
- (-> (quote 'length))))))
- (-> (begin
- (list
- (comp `(= ,var (call/this ,(-> (ref (ghil-var-for-ref! e '%enum)))
- ,(-> (quote 'pop))
- ()))
- e)
- (comp statement e)
- (-> (call (-> (ref (ghil-var-for-ref! e '%continue)))
- '())))))
- (@implv *undefined*)))))))))
- (-> (set (cadr vars)
- (@impl make-enumerator (list (comp object e)))))
- (-> (call (-> (ref (car vars))) '()))))))))
- ((break)
- (let ((var (ghil-var-for-ref! e '%continue)))
- (if (and (ghil-env? (ghil-var-env var))
- (eq? (ghil-var-env var) (ghil-env-parent e)))
- (-> (inline 'return (@implv *undefined*)))
- (error "bad break, yo"))))
- ((continue)
- (let ((var (ghil-var-for-ref! e '%continue)))
- (if (and (ghil-env? (ghil-var-env var))
- (eq? (ghil-var-env var) (ghil-env-parent e)))
- (-> (inline 'goto/args (list (-> (ref var)))))
- (error "bad continue, yo"))))
- ((block ,x)
- (comp x e))
- (else
- (error "compilation not yet implemented:" x)))))
-
-(define (comp-body e l body formals %args)
- (define (process)
- (let lp ((in body) (out '()) (rvars (reverse formals)))
- (pmatch in
- (((var (,x) . ,morevars) . ,rest)
- (lp `((var . ,morevars) . ,rest)
- out
- (if (memq x rvars) rvars (cons x rvars))))
- (((var (,x ,y) . ,morevars) . ,rest)
- (lp `((var . ,morevars) . ,rest)
- `((= (ref ,x) ,y) . ,out)
- (if (memq x rvars) rvars (cons x rvars))))
- (((var) . ,rest)
- (lp rest out rvars))
- ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
- (lp rest
- (cons x out)
- rvars))
- ((,x . ,rest) (guard (pair? x))
- (receive (sub-out rvars)
- (lp x '() rvars)
- (lp rest
- (cons sub-out out)
- rvars)))
- ((,x . ,rest)
- (lp rest
- (cons x out)
- rvars))
- (()
- (values (reverse! out)
- rvars)))))
- (receive (out rvars)
- (process)
- (call-with-ghil-bindings e (reverse rvars)
- (lambda (vars)
- (let ((%argv (assq-ref (ghil-env-table e) %args)))
- (-> (begin
- `(,@(map
- (lambda (f)
- (-> (if (-> (inline 'null?
- (list (-> (ref %argv)))))
- (-> (begin '()))
- (-> (begin
- (list (-> (set (ghil-var-for-ref! e f)
- (-> (inline 'car
- (list (-> (ref %argv)))))))
- (-> (set %argv
- (-> (inline 'cdr
- (list (-> (ref %argv)))))))))))))
- formals)
- ;; fixme: here check for too many args
- ,(comp out e)))))))))
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
new file mode 100644
index 000000000..88f3db76f
--- /dev/null
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -0,0 +1,549 @@
+;;; ECMAScript for Guile
+
+;; 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language ecmascript compile-tree-il)
+ #:use-module (language tree-il)
+ #:use-module (ice-9 receive)
+ #:use-module (system base pmatch)
+ #:use-module (srfi srfi-1)
+ #:export (compile-tree-il))
+
+(define-syntax ->
+ (syntax-rules ()
+ ((_ (type arg ...))
+ `(type ,arg ...))))
+
+(define-syntax @implv
+ (syntax-rules ()
+ ((_ sym)
+ (-> (module-ref '(language ecmascript impl) 'sym #t)))))
+
+(define-syntax @impl
+ (syntax-rules ()
+ ((_ sym arg ...)
+ (-> (apply (@implv sym) arg ...)))))
+
+(define (empty-lexical-environment)
+ '())
+
+(define (econs name gensym env)
+ (acons name gensym env))
+
+(define (lookup name env)
+ (or (assq-ref env name)
+ (-> (toplevel name))))
+
+(define (compile-tree-il exp env opts)
+ (values
+ (parse-tree-il (comp exp (empty-lexical-environment)))
+ env
+ env))
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ props))))
+
+;; for emacs:
+;; (put 'pmatch/source 'scheme-indent-function 1)
+
+(define-syntax pmatch/source
+ (syntax-rules ()
+ ((_ x clause ...)
+ (let ((x x))
+ (let ((res (pmatch x
+ clause ...)))
+ (let ((loc (location x)))
+ (if loc
+ (set-source-properties! res (location x))))
+ res)))))
+
+(define (comp x e)
+ (let ((l (location x)))
+ (define (let1 what proc)
+ (let ((sym (gensym)))
+ (-> (let (list sym) (list sym) (list what)
+ (proc sym)))))
+ (define (begin1 what proc)
+ (let1 what (lambda (v)
+ (-> (begin (proc v)
+ (-> (lexical v v)))))))
+ (pmatch/source x
+ (null
+ ;; FIXME, null doesn't have much relation to EOL...
+ (-> (const '())))
+ (true
+ (-> (const #t)))
+ (false
+ (-> (const #f)))
+ ((number ,num)
+ (-> (const num)))
+ ((string ,str)
+ (-> (const str)))
+ (this
+ (@impl get-this '()))
+ ((+ ,a)
+ (-> (apply (-> (primitive '+))
+ (@impl ->number (comp a e))
+ (-> (const 0)))))
+ ((- ,a)
+ (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
+ ((~ ,a)
+ (@impl bitwise-not (comp a e)))
+ ((! ,a)
+ (@impl logical-not (comp a e)))
+ ((+ ,a ,b)
+ (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
+ ((- ,a ,b)
+ (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
+ ((/ ,a ,b)
+ (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
+ ((* ,a ,b)
+ (-> (apply (-> (primitive '*)) (comp a e) (comp b e))))
+ ((% ,a ,b)
+ (@impl mod (comp a e) (comp b e)))
+ ((<< ,a ,b)
+ (@impl shift (comp a e) (comp b e)))
+ ((>> ,a ,b)
+ (@impl shift (comp a e) (comp `(- ,b) e)))
+ ((< ,a ,b)
+ (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
+ ((<= ,a ,b)
+ (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
+ ((> ,a ,b)
+ (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
+ ((>= ,a ,b)
+ (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
+ ((in ,a ,b)
+ (@impl has-property? (comp a e) (comp b e)))
+ ((== ,a ,b)
+ (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
+ ((!= ,a ,b)
+ (-> (apply (-> (primitive 'not))
+ (-> (apply (-> (primitive 'equal?))
+ (comp a e) (comp b e))))))
+ ((=== ,a ,b)
+ (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+ ((!== ,a ,b)
+ (-> (apply (-> (primitive 'not))
+ (-> (apply (-> (primitive 'eqv?))
+ (comp a e) (comp b e))))))
+ ((& ,a ,b)
+ (@impl band (comp a e) (comp b e)))
+ ((^ ,a ,b)
+ (@impl bxor (comp a e) (comp b e)))
+ ((bor ,a ,b)
+ (@impl bior (comp a e) (comp b e)))
+ ((and ,a ,b)
+ (-> (if (@impl ->boolean (comp a e))
+ (comp b e)
+ (-> (const #f)))))
+ ((or ,a ,b)
+ (let1 (comp a e)
+ (lambda (v)
+ (-> (if (@impl ->boolean (-> (lexical v v)))
+ (-> (lexical v v))
+ (comp b e))))))
+ ((if ,test ,then ,else)
+ (-> (if (@impl ->boolean (comp test e))
+ (comp then e)
+ (comp else e))))
+ ((if ,test ,then ,else)
+ (-> (if (@impl ->boolean (comp test e))
+ (comp then e)
+ (@implv *undefined*))))
+ ((postinc (ref ,foo))
+ (begin1 (comp `(ref ,foo) e)
+ (lambda (var)
+ (-> (set! (lookup foo e)
+ (-> (apply (-> (primitive '+))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
+ ((postinc (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (apply (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
+ ((postinc (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (apply (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
+ ((postdec (ref ,foo))
+ (begin1 (comp `(ref ,foo) e)
+ (lambda (var)
+ (-> (set (lookup foo e)
+ (-> (apply (-> (primitive '-))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
+ ((postdec (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (apply (-> (primitive '-))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
+ ((postdec (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (inline
+ '- (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
+ ((preinc (ref ,foo))
+ (let ((v (lookup foo e)))
+ (-> (begin
+ (-> (set! v
+ (-> (apply (-> (primitive '+))
+ v
+ (-> (const 1))))))
+ v))))
+ ((preinc (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (-> (apply (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (lexical tmpvar tmpvar))))))))
+ ((preinc (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (-> (apply (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (lexical tmpvar tmpvar))))))))))
+ ((predec (ref ,foo))
+ (let ((v (lookup foo e)))
+ (-> (begin
+ (-> (set! v
+ (-> (apply (-> (primitive '-))
+ v
+ (-> (const 1))))))
+ v))))
+ ((predec (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (-> (apply (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (lexical tmpvar tmpvar))))))))
+ ((predec (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (-> (apply (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (lexical tmpvar tmpvar))))))))))
+ ((ref ,id)
+ (lookup id e))
+ ((var . ,forms)
+ (-> (begin
+ (map (lambda (form)
+ (pmatch form
+ ((,x ,y)
+ (-> (define x (comp y e))))
+ ((,x)
+ (-> (define x (@implv *undefined*))))
+ (else (error "bad var form" form))))
+ forms))))
+ ((begin . ,forms)
+ `(begin ,@(map (lambda (x) (comp x e)) forms)))
+ ((lambda ,formals ,body)
+ (let ((%args (gensym "%args ")))
+ (-> (lambda '%args %args '()
+ (comp-body (econs '%args %args e) body formals '%args)))))
+ ((call/this ,obj ,prop . ,args)
+ (@impl call/this*
+ obj
+ (-> (lambda '() '() '()
+ `(apply ,(@impl pget obj prop) ,@args)))))
+ ((call (pref ,obj ,prop) ,args)
+ (comp `(call/this ,(comp obj e)
+ ,(-> (const prop))
+ ,@(map (lambda (x) (comp x e)) args))
+ e))
+ ((call (aref ,obj ,prop) ,args)
+ (comp `(call/this ,(comp obj e)
+ ,(comp prop e)
+ ,@(map (lambda (x) (comp x e)) args))
+ e))
+ ((call ,proc ,args)
+ `(apply ,(comp proc e)
+ ,@(map (lambda (x) (comp x e)) args)))
+ ((return ,expr)
+ (-> (apply (-> (primitive 'return))
+ (comp expr e))))
+ ((array . ,args)
+ `(apply ,(@implv new-array)
+ ,@(map (lambda (x) (comp x e)) args)))
+ ((object . ,args)
+ (@impl new-object
+ (map (lambda (x)
+ (pmatch x
+ ((,prop ,val)
+ (-> (apply (-> (primitive 'cons))
+ (-> (const prop))
+ (comp val e))))
+ (else
+ (error "bad prop-val pair" x))))
+ args)))
+ ((pref ,obj ,prop)
+ (@impl pget
+ (comp obj e)
+ (-> (const prop))))
+ ((aref ,obj ,index)
+ (@impl pget
+ (comp obj e)
+ (comp index e)))
+ ((= (ref ,name) ,val)
+ (let ((v (lookup name e)))
+ (-> (begin
+ (-> (set! v (comp val e)))
+ v))))
+ ((= (pref ,obj ,prop) ,val)
+ (@impl pput
+ (comp obj e)
+ (-> (const prop))
+ (comp val e)))
+ ((= (aref ,obj ,prop) ,val)
+ (@impl pput
+ (comp obj e)
+ (comp prop e)
+ (comp val e)))
+ ((+= ,what ,val)
+ (comp `(= ,what (+ ,what ,val)) e))
+ ((-= ,what ,val)
+ (comp `(= ,what (- ,what ,val)) e))
+ ((/= ,what ,val)
+ (comp `(= ,what (/ ,what ,val)) e))
+ ((*= ,what ,val)
+ (comp `(= ,what (* ,what ,val)) e))
+ ((%= ,what ,val)
+ (comp `(= ,what (% ,what ,val)) e))
+ ((>>= ,what ,val)
+ (comp `(= ,what (>> ,what ,val)) e))
+ ((<<= ,what ,val)
+ (comp `(= ,what (<< ,what ,val)) e))
+ ((>>>= ,what ,val)
+ (comp `(= ,what (>>> ,what ,val)) e))
+ ((&= ,what ,val)
+ (comp `(= ,what (& ,what ,val)) e))
+ ((bor= ,what ,val)
+ (comp `(= ,what (bor ,what ,val)) e))
+ ((^= ,what ,val)
+ (comp `(= ,what (^ ,what ,val)) e))
+ ((new ,what ,args)
+ (@impl new
+ (map (lambda (x) (comp x e))
+ (cons what args))))
+ ((delete (pref ,obj ,prop))
+ (@impl pdel
+ (comp obj e)
+ (-> (const prop))))
+ ((delete (aref ,obj ,prop))
+ (@impl pdel
+ (comp obj e)
+ (comp prop e)))
+ ((void ,expr)
+ (-> (begin
+ (comp expr e)
+ (@implv *undefined*))))
+ ((typeof ,expr)
+ (@impl typeof
+ (comp expr e)))
+ ((do ,statement ,test)
+ (let ((%loop (gensym "%loop "))
+ (%continue (gensym "%continue ")))
+ (let ((e (econs '%loop %loop (econs '%continue %continue e))))
+ (-> (letrec '(%loop %continue) (list %loop %continue)
+ (list (-> (lambda '() '() '()
+ (-> (begin
+ (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue)))
+ )))))
+
+ (-> (lambda '() '() '()
+ (-> (if (@impl ->boolean (comp test e))
+ (-> (apply (-> (lexical '%loop %loop))))
+ (@implv *undefined*))))))
+ (-> (apply (-> (lexical '%loop %loop)))))))))
+ ((while ,test ,statement)
+ (let ((%continue (gensym "%continue ")))
+ (let ((e (econs '%continue %continue e)))
+ (-> (letrec '(%continue) (list %continue)
+ (list (-> (lambda '() '() '()
+ (-> (if (@impl ->boolean (comp test e))
+ (-> (begin (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*))))))
+ (-> (apply (-> (lexical '%continue %continue)))))))))
+
+ ((for ,init ,test ,inc ,statement)
+ (let ((%continue (gensym "%continue ")))
+ (let ((e (econs '%continue %continue e)))
+ (-> (letrec '(%continue) (list %continue)
+ (list (-> (lambda '() '() '()
+ (-> (if (if test
+ (@impl ->boolean (comp test e))
+ (comp 'true e))
+ (-> (begin (comp statement e)
+ (comp (or inc '(begin)) e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*))))))
+ (-> (begin (comp (or init '(begin)) e)
+ (-> (apply (-> (lexical '%continue %continue)))))))))))
+
+ ((for-in ,var ,object ,statement)
+ (let ((%enum (gensym "%enum "))
+ (%continue (gensym "%continue ")))
+ (let ((e (econs '%enum %enum (econs '%continue %continue e))))
+ (-> (letrec '(%enum %continue) (list %enum %continue)
+ (list (@impl make-enumerator (comp object e))
+ (-> (lambda '() '() '()
+ (-> (if (@impl ->boolean
+ (@impl pget
+ (-> (lexical '%enum %enum))
+ (-> (const 'length))))
+ (-> (begin
+ (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
+ ,(-> (const 'pop))))
+ e)
+ (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*))))))
+ (-> (apply (-> (lexical '%continue %continue)))))))))
+
+ ((block ,x)
+ (comp x e))
+ (else
+ (error "compilation not yet implemented:" x)))))
+
+(define (comp-body e body formals %args)
+ (define (process)
+ (let lp ((in body) (out '()) (rvars (reverse formals)))
+ (pmatch in
+ (((var (,x) . ,morevars) . ,rest)
+ (lp `((var . ,morevars) . ,rest)
+ out
+ (if (memq x rvars) rvars (cons x rvars))))
+ (((var (,x ,y) . ,morevars) . ,rest)
+ (lp `((var . ,morevars) . ,rest)
+ `((= (ref ,x) ,y) . ,out)
+ (if (memq x rvars) rvars (cons x rvars))))
+ (((var) . ,rest)
+ (lp rest out rvars))
+ ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
+ (lp rest
+ (cons x out)
+ rvars))
+ ((,x . ,rest) (guard (pair? x))
+ (receive (sub-out rvars)
+ (lp x '() rvars)
+ (lp rest
+ (cons sub-out out)
+ rvars)))
+ ((,x . ,rest)
+ (lp rest
+ (cons x out)
+ rvars))
+ (()
+ (values (reverse! out)
+ rvars)))))
+ (receive (out rvars)
+ (process)
+ (let* ((names (reverse rvars))
+ (syms (map (lambda (x)
+ (gensym (string-append (symbol->string x) " ")))
+ names))
+ (e (fold acons e names syms)))
+ (let ((%argv (lookup %args e)))
+ (let lp ((names names) (syms syms))
+ (if (null? names)
+ ;; fixme: here check for too many args
+ (comp out e)
+ (-> (let (list (car names)) (list (car syms))
+ (list (-> (if (-> (apply (-> (primitive 'null?)) %argv))
+ (-> (@implv *undefined*))
+ (-> (let1 (-> (apply (-> (primitive 'car)) %argv))
+ (lambda (v)
+ (-> (set! %argv
+ (-> (apply (-> (primitive 'cdr)) %argv))))
+ (-> (lexical v v))))))))
+ (lp (cdr names) (cdr syms))))))))))
diff --git a/module/language/ecmascript/function.scm b/module/language/ecmascript/function.scm
index 1e2d726ca..710c5cb1c 100644
--- a/module/language/ecmascript/function.scm
+++ b/module/language/ecmascript/function.scm
@@ -2,20 +2,19 @@
;; Copyright (C) 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/ecmascript/impl.scm b/module/language/ecmascript/impl.scm
index be4c751cb..27c077aed 100644
--- a/module/language/ecmascript/impl.scm
+++ b/module/language/ecmascript/impl.scm
@@ -2,20 +2,19 @@
;; Copyright (C) 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/ecmascript/parse-lalr.scm b/module/language/ecmascript/parse-lalr.scm
index 6378d087c..b702511ca 100644
--- a/module/language/ecmascript/parse-lalr.scm
+++ b/module/language/ecmascript/parse-lalr.scm
@@ -2,18 +2,19 @@
;; Copyright (C) 1984,1989,1990 Free Software Foundation, Inc.
;; Copyright (C) 1996-2002 Dominique Boucher
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;; ---------------------------------------------------------------------- ;;
diff --git a/module/language/ecmascript/parse.scm b/module/language/ecmascript/parse.scm
index 169c992fd..ce731a736 100644
--- a/module/language/ecmascript/parse.scm
+++ b/module/language/ecmascript/parse.scm
@@ -2,20 +2,19 @@
;; Copyright (C) 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm
index 550a0b734..7a1ea465c 100644
--- a/module/language/ecmascript/spec.scm
+++ b/module/language/ecmascript/spec.scm
@@ -2,27 +2,26 @@
;; Copyright (C) 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (language ecmascript spec)
#:use-module (system base language)
#:use-module (language ecmascript parse)
- #:use-module (language ecmascript compile-ghil)
+ #:use-module (language ecmascript compile-tree-il)
#:export (ecmascript))
;;;
@@ -33,8 +32,7 @@
#:title "Guile ECMAScript"
#:version "3.0"
#:reader (lambda () (read-ecmascript/1 (current-input-port)))
- #:read-file read-ecmascript
- #:compilers `((ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il))
;; a pretty-printer would be interesting.
#:printer write
)
diff --git a/module/language/ecmascript/tokenize.scm b/module/language/ecmascript/tokenize.scm
index 2beda23b7..1b6a7eeaf 100644
--- a/module/language/ecmascript/tokenize.scm
+++ b/module/language/ecmascript/tokenize.scm
@@ -2,20 +2,19 @@
;; Copyright (C) 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -366,7 +365,7 @@
. ,(cdar puncs))))))
(lp nodes (cdr puncs))))
(else
- (lp (cons `(,(string-ref (caar puncs) 0) #f) nodes)
+ (lp (cons (list (string-ref (caar puncs) 0) #f) nodes)
puncs))))))
(lambda (port)
(let lp ((c (peek-char port)) (tree punc-tree) (candidate #f))
diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm
index a35c44112..617e4e3c5 100644
--- a/module/language/elisp/spec.scm
+++ b/module/language/elisp/spec.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/ghil.scm b/module/language/ghil.scm
index 00a2c9afd..84cc83de5 100644
--- a/module/language/ghil.scm
+++ b/module/language/ghil.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -432,7 +431,10 @@
((<ghil-quote> env loc obj)
`(,'quote ,obj))
((<ghil-quasiquote> env loc exp)
- `(,'quasiquote ,(map unparse-ghil exp)))
+ `(,'quasiquote ,(let lp ((x exp))
+ (cond ((struct? x) (unparse-ghil x))
+ ((pair? x) (cons (lp (car x)) (lp (cdr x))))
+ (else x)))))
((<ghil-unquote> env loc exp)
`(,'unquote ,(unparse-ghil exp)))
((<ghil-unquote-splicing> env loc exp)
diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm
index c816b0e6c..47e15c797 100644
--- a/module/language/ghil/compile-glil.scm
+++ b/module/language/ghil/compile-glil.scm
@@ -2,25 +2,24 @@
;; 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.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (language ghil compile-glil)
- #:use-syntax (system base syntax)
+ #:use-module (system base syntax)
#:use-module (language glil)
#:use-module (language ghil)
#:use-module (ice-9 common-list)
@@ -29,7 +28,8 @@
(define (compile-glil x e opts)
(if (memq #:O opts) (set! x (optimize x)))
(values (codegen x)
- (and e (cons (car e) (cddr e)))))
+ (and e (cons (car e) (cddr e)))
+ e))
;;;
@@ -186,7 +186,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)
@@ -216,7 +216,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)))))
@@ -495,7 +497,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)
@@ -508,7 +510,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)
@@ -522,8 +524,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/ghil/spec.scm b/module/language/ghil/spec.scm
index ee574b50b..f2bc19b61 100644
--- a/module/language/ghil/spec.scm
+++ b/module/language/ghil/spec.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -34,11 +33,30 @@
(lambda (env vars)
(make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
+(define (join exps env)
+ (if (or-map (lambda (x)
+ (or (not (ghil-lambda? x))
+ (ghil-lambda-rest x)
+ (memq 'argument
+ (map ghil-var-kind
+ (ghil-env-variables (ghil-lambda-env x))))))
+ exps)
+ (error "GHIL expressions to join must be thunks"))
+
+ (let ((env (make-ghil-env env '()
+ (apply append
+ (map ghil-env-variables
+ (map ghil-lambda-env exps))))))
+ (make-ghil-lambda env #f '() #f '()
+ (make-ghil-begin env #f
+ (map ghil-lambda-body exps)))))
+
(define-language ghil
#:title "Guile High Intermediate Language (GHIL)"
#:version "0.3"
#:reader read
#:printer write-ghil
#:parser parse
+ #:joiner join
#:compilers `((glil . ,compile-glil))
)
diff --git a/module/language/glil.scm b/module/language/glil.scm
index 01b680194..0777073f6 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -1,21 +1,20 @@
;;; Guile Low Intermediate Language
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Copyright (C) 2001, 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -25,9 +24,9 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:export
(<glil-program> make-glil-program glil-program?
- glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts
- glil-program-meta glil-program-body glil-program-closure-level
-
+ glil-program-nargs glil-program-nrest glil-program-nlocs
+ glil-program-meta glil-program-body
+
<glil-bind> make-glil-bind glil-bind?
glil-bind-vars
@@ -44,14 +43,8 @@
<glil-const> make-glil-const glil-const?
glil-const-obj
- <glil-argument> make-glil-argument glil-argument?
- glil-argument-op glil-argument-index
-
- <glil-local> make-glil-local glil-local?
- glil-local-op glil-local-index
-
- <glil-external> make-glil-external glil-external?
- glil-external-op glil-external-depth glil-external-index
+ <glil-lexical> make-glil-lexical glil-lexical?
+ glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
<glil-toplevel> make-glil-toplevel glil-toplevel?
glil-toplevel-op glil-toplevel-name
@@ -78,7 +71,7 @@
(define-type (<glil> #:printer print-glil)
;; Meta operations
- (<glil-program> nargs nrest nlocs nexts meta body (closure-level #f))
+ (<glil-program> nargs nrest nlocs meta body)
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
(<glil-unbind>)
@@ -87,9 +80,7 @@
(<glil-void>)
(<glil-const> obj)
;; Variables
- (<glil-argument> op index)
- (<glil-local> op index)
- (<glil-external> op depth index)
+ (<glil-lexical> local? boxed? op index)
(<glil-toplevel> op name)
(<glil-module> op mod name public?)
;; Controls
@@ -98,40 +89,23 @@
(<glil-call> inst nargs)
(<glil-mv-call> nargs ra))
-(define (compute-closure-level body)
- (fold (lambda (x ret)
- (record-case x
- ((<glil-program> closure-level) (max ret closure-level))
- ((<glil-external> depth) (max ret depth))
- (else ret)))
- 0 body))
-
-(define %make-glil-program make-glil-program)
-(define (make-glil-program . args)
- (let ((prog (apply %make-glil-program args)))
- (if (not (glil-program-closure-level prog))
- (set! (glil-program-closure-level prog)
- (compute-closure-level (glil-program-body prog))))
- prog))
-
+
(define (parse-glil x)
(pmatch x
- ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
- (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
+ ((program ,nargs ,nrest ,nlocs ,meta . ,body)
+ (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind))
((source ,props) (make-glil-source props))
((void) (make-glil-void))
((const ,obj) (make-glil-const obj))
- ((argument ,op ,index) (make-glil-argument op index))
- ((local ,op ,index) (make-glil-local op index))
- ((external ,op ,depth ,index) (make-glil-external op depth index))
+ ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
((toplevel ,op ,name) (make-glil-toplevel op name))
((module public ,op ,mod ,name) (make-glil-module op mod name #t))
((module private ,op ,mod ,name) (make-glil-module op mod name #f))
- ((label ,label) (make-label ,label))
+ ((label ,label) (make-label label))
((branch ,inst ,label) (make-glil-branch inst label))
((call ,inst ,nargs) (make-glil-call inst nargs))
((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
@@ -140,8 +114,8 @@
(define (unparse-glil glil)
(record-case glil
;; meta
- ((<glil-program> nargs nrest nlocs nexts meta body)
- `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
+ ((<glil-program> nargs nrest nlocs meta body)
+ `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind))
@@ -150,12 +124,8 @@
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
;; variables
- ((<glil-argument> op index)
- `(argument ,op ,index))
- ((<glil-local> op index)
- `(local ,op ,index))
- ((<glil-external> op depth index)
- `(external ,op ,depth ,index))
+ ((<glil-lexical> local? boxed? op index)
+ `(lexical ,local? ,boxed? ,op ,index))
((<glil-toplevel> op name)
`(toplevel ,op ,name))
((<glil-module> op mod name public?)
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index ffac9dbfb..c67ef694b 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -2,20 +2,19 @@
;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -28,6 +27,7 @@
#:use-module ((system vm program) #:select (make-binding))
#:use-module (ice-9 receive)
#:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (rnrs bytevector)
#:export (compile-assembly))
;; Variable cache cells go in the object table, and serialize as their
@@ -72,27 +72,26 @@
(if (and (null? bindings) (null? sources) (null? tail))
#f
(compile-assembly
- (make-glil-program 0 0 0 0 '()
+ (make-glil-program 0 0 0 '()
(list
(make-glil-const `(,bindings ,sources ,@tail))
(make-glil-call 'return 1))))))
;; A functional stack of names of live variables.
-(define (make-open-binding name ext? index)
- (list name ext? index))
+(define (make-open-binding name boxed? index)
+ (list name boxed? index))
(define (make-closed-binding open-binding start end)
(make-binding (car open-binding) (cadr open-binding)
(caddr open-binding) start end))
-(define (open-binding bindings vars nargs start)
+(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 external ,i) (make-open-binding name #t i))
- (else (error "unknown binding type" name type))))
+ ((,name ,boxed? ,i)
+ (make-open-binding name boxed? i))
+ (else (error "unknown binding type" v))))
vars)
(car bindings))
(cdr bindings)))
@@ -129,81 +128,88 @@
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil 0 '() '(()) '() '() #f -1)
+ (glil->assembly glil #t '(()) '() '() #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 toplevel? bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
- (values (map assembly-pack x) bindings source-alist label-alist object-alist))
+ (values x bindings source-alist label-alist object-alist))
(define (emit-code/object x object-alist)
- (values (map assembly-pack x) bindings source-alist label-alist object-alist))
+ (values x bindings source-alist label-alist object-alist))
(record-case glil
- ((<glil-program> nargs nrest nlocs nexts meta body closure-level)
- (let ((toplevel? (null? nexts-stack)))
- (define (process-body)
- (let ((nexts-stack (cons nexts nexts-stack)))
- (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
- (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+ ((<glil-program> nargs nrest nlocs meta body)
+ (define (process-body)
+ (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
+ (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+ (cond
+ ((null? body)
+ (values (reverse code)
+ (close-all-bindings bindings addr)
+ (limn-sources (reverse! source-alist))
+ (reverse label-alist)
+ (and object-alist (map car (reverse object-alist)))
+ addr))
+ (else
+ (receive (subcode bindings source-alist label-alist object-alist)
+ (glil->assembly (car body) #f bindings
+ source-alist label-alist object-alist addr)
+ (lp (cdr body) (append (reverse subcode) code)
+ bindings source-alist label-alist object-alist
+ (addr+ addr subcode)))))))
+
+ (receive (code bindings sources labels objects len)
+ (process-body)
+ (let* ((meta (make-meta bindings sources meta))
+ (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
+ (prog `(load-program ,nargs ,nrest ,nlocs ,labels
+ ,(+ len meta-pad)
+ ,meta
+ ,@code
+ ,@(if meta
+ (make-list meta-pad '(nop))
+ '()))))
+ (cond
+ (toplevel?
+ ;; toplevel bytecode isn't loaded by the vm, no way to do
+ ;; object table or closure capture (not in the bytecode,
+ ;; anyway)
+ (emit-code (align-program prog addr)))
+ (else
+ (let ((table (make-object-table objects)))
(cond
- ((null? body)
- (values (reverse code)
- (close-all-bindings bindings addr)
- (limn-sources (reverse! source-alist))
- (reverse label-alist)
- (and object-alist (map car (reverse object-alist)))
- addr))
+ (object-alist
+ ;; if we are being compiled from something with an object
+ ;; table, cache the program there
+ (receive (i object-alist)
+ (object-index-and-alist (make-subprogram table prog)
+ object-alist)
+ (emit-code/object `(,(if (< i 256)
+ `(object-ref ,i)
+ `(long-object-ref ,(quotient i 256)
+ ,(modulo i 256))))
+ object-alist)))
(else
- (receive (subcode bindings source-alist label-alist object-alist)
- (glil->assembly (car body) nargs nexts-stack bindings
- source-alist label-alist object-alist addr)
- (lp (cdr body) (append (reverse subcode) code)
- bindings source-alist label-alist object-alist
- (addr+ addr subcode))))))))
-
- (receive (code bindings sources labels objects len)
- (process-body)
- (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
- ,len
- ,(make-meta bindings sources meta)
- . ,code)))
- (cond
- (toplevel?
- ;; toplevel bytecode isn't loaded by the vm, no way to do
- ;; object table or closure capture (not in the bytecode,
- ;; anyway)
- (emit-code (align-program prog addr)))
- (else
- (let ((table (dump-object (make-object-table objects) addr))
- (closure (if (> closure-level 0) '((make-closure)) '())))
- (cond
- (object-alist
- ;; if we are being compiled from something with an object
- ;; table, cache the program there
- (receive (i object-alist)
- (object-index-and-alist (make-subprogram table prog)
- object-alist)
- (emit-code/object `((object-ref ,i) ,@closure)
- object-alist)))
- (else
- ;; otherwise emit a load directly
- (emit-code `(,@table ,@(align-program prog (addr+ addr table))
- ,@closure)))))))))))
+ ;; otherwise emit a load directly
+ (let ((table-code (dump-object table addr)))
+ (emit-code
+ `(,@table-code
+ ,@(align-program prog (addr+ addr table-code)))))))))))))
((<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))
@@ -235,27 +241,57 @@
(else
(receive (i object-alist)
(object-index-and-alist obj object-alist)
- (emit-code/object `((object-ref ,i))
+ (emit-code/object (if (< i 256)
+ `((object-ref ,i))
+ `((long-object-ref ,(quotient i 256)
+ ,(modulo i 256))))
object-alist)))))
- ((<glil-argument> op index)
- (emit-code (if (eq? op 'ref)
- `((local-ref ,index))
- `((local-set ,index)))))
-
- ((<glil-local> op index)
- (emit-code (if (eq? op 'ref)
- `((local-ref ,(+ nargs index)))
- `((local-set ,(+ nargs index))))))
-
- ((<glil-external> op depth index)
- (emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
- (if (> d 0)
- (lp (1- d) (+ n (car stack)) (cdr stack))
- (if (eq? op 'ref)
- `((external-ref ,(+ n index)))
- `((external-set ,(+ n index))))))))
-
+ ((<glil-lexical> local? boxed? op index)
+ (emit-code
+ (if local?
+ (if (< index 256)
+ (case op
+ ((ref) (if boxed?
+ `((local-boxed-ref ,index))
+ `((local-ref ,index))))
+ ((set) (if boxed?
+ `((local-boxed-set ,index))
+ `((local-set ,index))))
+ ((box) `((box ,index)))
+ ((empty-box) `((empty-box ,index)))
+ ((fix) `((fix-closure 0 ,index)))
+ (else (error "what" op)))
+ (let ((a (quotient i 256))
+ (b (modulo i 256)))
+ `((,(case op
+ ((ref)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-ref))
+ `((long-local-ref ,a ,b))))
+ ((set)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-set))
+ `((long-local-set ,a ,b))))
+ ((box)
+ `((make-variable)
+ (variable-set)
+ (long-local-set ,a ,b)))
+ ((empty-box)
+ `((make-variable)
+ (long-local-set ,a ,b)))
+ ((fix)
+ `((fix-closure ,a ,b)))
+ (else (error "what" op)))
+ ,index))))
+ `((,(case op
+ ((ref) (if boxed? 'free-boxed-ref 'free-ref))
+ ((set) (if boxed? 'free-boxed-set (error "what." glil)))
+ (else (error "what" op)))
+ ,index)))))
+
((<glil-toplevel> op name)
(case op
((ref set)
@@ -270,13 +306,20 @@
(receive (i object-alist)
(object-index-and-alist (make-variable-cache-cell name)
object-alist)
- (emit-code/object (case op
- ((ref) `((toplevel-ref ,i)))
- ((set) `((toplevel-set ,i))))
+ (emit-code/object (if (< i 256)
+ `((,(case op
+ ((ref) 'toplevel-ref)
+ ((set) 'toplevel-set))
+ ,i))
+ `((,(case op
+ ((ref) 'long-toplevel-ref)
+ ((set) 'long-toplevel-set))
+ ,(quotient i 256)
+ ,(modulo i 256))))
object-alist)))))
((define)
- (emit-code `((define ,(symbol->string name))
- (variable-set))))
+ (emit-code `(,@(dump-object name addr)
+ (define))))
(else
(error "unknown toplevel var kind" op name))))
@@ -303,11 +346,12 @@
(error "unknown module var kind" op key)))))
((<glil-label> label)
- (values '()
- bindings
- source-alist
- (acons label addr label-alist)
- object-alist))
+ (let ((code (align-block addr)))
+ (values code
+ bindings
+ source-alist
+ (acons label (addr+ addr code) label-alist)
+ object-alist)))
((<glil-branch> inst label)
(emit-code `((,inst ,label))))
@@ -318,7 +362,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
@@ -335,25 +384,27 @@
((object->assembly x) => list)
((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
((subprogram? x)
- `(,@(subprogram-table x)
- ,@(align-program (subprogram-prog x)
- (addr+ addr (subprogram-table x)))))
- ((and (integer? x) (exact? x))
- (let ((str (do ((n x (quotient n 256))
- (l '() (cons (modulo n 256) l)))
- ((= n 0)
- (list->string (map integer->char l))))))
- (if (< x 0)
- `((load-integer ,str))
- `((load-unsigned-integer ,str)))))
+ (let ((table-code (dump-object (subprogram-table x) addr)))
+ `(,@table-code
+ ,@(align-program (subprogram-prog x)
+ (addr+ addr table-code)))))
((number? x)
`((load-number ,(number->string x))))
((string? x)
- `((load-string ,x)))
+ (case (string-width x)
+ ((1) `((load-string ,x)))
+ ((4) (align-code `(load-wide-string ,x) addr 4 4))
+ (else (error "bad string width" x))))
((symbol? x)
- `((load-symbol ,(symbol->string x))))
+ (let ((str (symbol->string x)))
+ (case (string-width str)
+ ((1) `((load-symbol ,str)))
+ ((4) `(,@(dump-object str addr)
+ (make-symbol)))
+ (else (error "bad string width" str)))))
((keyword? x)
- `((load-keyword ,(symbol->string (keyword->symbol x)))))
+ `(,@(dump-object (keyword->symbol x) addr)
+ (make-keyword)))
((list? x)
(let ((tail (let ((len (length x)))
(if (>= len 65536) (too-long "list"))
@@ -380,6 +431,16 @@
(let ((code (dump-object (vector-ref x i) addr)))
(dump-objects (1+ i) (cons code codes)
(addr+ addr code)))))))
+ ((and (array? x) (symbol? (array-type x)))
+ (let* ((type (dump-object (array-type x) addr))
+ (shape (dump-object (array-shape x) (addr+ addr type))))
+ `(,@type
+ ,@shape
+ ,@(align-code
+ `(load-array ,(uniform-array->bytevector x))
+ (addr+ (addr+ addr type) shape)
+ 8
+ 4))))
(else
(error "assemble: unrecognized object" x))))
diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm
index a98c39975..3cb887d44 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -1,21 +1,20 @@
;;; 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
-;; 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.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -32,8 +31,8 @@
(define (decompile-toplevel x)
(pmatch x
- ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body)
- (decompile-load-program nargs nrest nlocs nexts
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
+ (decompile-load-program nargs nrest nlocs
(decompile-meta meta)
body labels #f))
(else
@@ -57,7 +56,7 @@
((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
(else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
-(define (decompile-load-program nargs nrest nlocs nexts meta body labels
+(define (decompile-load-program nargs nrest nlocs meta body labels
objects)
(let ((glil-labels (sort (map (lambda (x)
(cons (cdr x) (make-glil-label (car x))))
@@ -101,19 +100,11 @@
(cond
((null? in)
(or (null? stack) (error "leftover stack insts" stack body))
- (make-glil-program nargs nrest nlocs nexts props (reverse out) #f))
+ (make-glil-program nargs nrest nlocs props (reverse out) #f))
((pop-bindings! pos)
=> (lambda (bindings)
(lp in stack
- (cons (make-glil-bind
- (map (lambda (x)
- (let ((name (binding:name x))
- (i (binding:index x)))
- (cond
- ((binding:extp x) `(,name external ,i))
- ((< i nargs) `(,name argument ,i))
- (else `(,name local ,(- i nargs))))))
- bindings))
+ (cons (make-glil-bind bindings)
out)
pos)))
((pop-unbindings! pos)
@@ -175,15 +166,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/glil/spec.scm b/module/language/glil/spec.scm
index 3e4e10c6a..d5291a211 100644
--- a/module/language/glil/spec.scm
+++ b/module/language/glil/spec.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -30,7 +29,7 @@
(apply write (unparse-glil exp) port))
(define (compile-asm x e opts)
- (values (compile-assembly x) e))
+ (values (compile-assembly x) e e))
(define-language glil
#:title "Guile Lowlevel Intermediate Language (GLIL)"
diff --git a/module/language/objcode.scm b/module/language/objcode.scm
index aea546c66..d8bcda879 100644
--- a/module/language/objcode.scm
+++ b/module/language/objcode.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index 9ce8bf5e5..4cb600f1d 100644
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -1,21 +1,20 @@
;;; Guile Lowlevel Intermediate Language
-;; 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
-;; 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.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -32,7 +31,7 @@
(if env (car env) (current-module)))
(define (objcode-env-externals env)
- (if env (cdr env) '()))
+ (and env (vector? (cdr env)) (cdr env)))
(define (objcode->value x e opts)
(let ((thunk (make-program x #f (objcode-env-externals e))))
@@ -40,8 +39,8 @@
(save-module-excursion
(lambda ()
(set-current-module (objcode-env-module e))
- (values (thunk) #f)))
- (values (thunk) #f))))
+ (values (thunk) #f e)))
+ (values (thunk) #f e))))
;; since locals are allocated on the stack and can have limited scope,
;; in many cases we use one local for more than one lexical variable. so
@@ -67,23 +66,16 @@
((program? x)
(let ((objs (program-objects x))
(meta (program-meta x))
- (exts (program-external x))
+ (free-vars (program-free-variables x))
(binds (program-bindings x))
(srcs (program-sources x))
(nargs (arity:nargs (program-arity x))))
- (let ((blocs (and binds
- (collapse-locals
- (append (list-head binds nargs)
- (filter (lambda (x) (not (binding:extp x)))
- (list-tail binds nargs))))))
- (bexts (and binds
- (filter binding:extp binds))))
+ (let ((blocs (and binds (collapse-locals binds))))
(values (program-objcode x)
`((objects . ,objs)
(meta . ,(and meta (meta)))
- (exts . ,exts)
+ (free-vars . ,free-vars)
(blocs . ,blocs)
- (bexts . ,bexts)
(sources . ,srcs))))))
((objcode? x)
(values x #f))
diff --git a/module/language/r5rs/core.il b/module/language/r5rs/core.il
index ad40fcc1a..c614a6fe2 100644
--- a/module/language/r5rs/core.il
+++ b/module/language/r5rs/core.il
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/r5rs/expand.scm b/module/language/r5rs/expand.scm
index 45b722717..e8910ae1b 100644
--- a/module/language/r5rs/expand.scm
+++ b/module/language/r5rs/expand.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/r5rs/null.il b/module/language/r5rs/null.il
index efdc5f398..a290025de 100644
--- a/module/language/r5rs/null.il
+++ b/module/language/r5rs/null.il
@@ -2,19 +2,18 @@
;; 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.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/r5rs/spec.scm b/module/language/r5rs/spec.scm
index b5d19e6d4..67f8d74cf 100644
--- a/module/language/r5rs/spec.scm
+++ b/module/language/r5rs/spec.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/scheme/amatch.scm b/module/language/scheme/amatch.scm
deleted file mode 100644
index 4ac973620..000000000
--- a/module/language/scheme/amatch.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-(define-module (language scheme amatch)
- #:use-module (ice-9 syncase)
- #:export (amatch apat))
-;; FIXME: shouldn't have to export apat...
-
-;; This is exactly the same as pmatch except that it unpacks annotations
-;; as needed.
-
-(define-syntax amatch
- (syntax-rules (else guard)
- ((_ (op arg ...) cs ...)
- (let ((v (op arg ...)))
- (amatch v cs ...)))
- ((_ v) (if #f #f))
- ((_ v (else e0 e ...)) (begin e0 e ...))
- ((_ v (pat (guard g ...) e0 e ...) cs ...)
- (let ((fk (lambda () (amatch v cs ...))))
- (apat v pat
- (if (and g ...) (begin e0 e ...) (fk))
- (fk))))
- ((_ v (pat e0 e ...) cs ...)
- (let ((fk (lambda () (amatch v cs ...))))
- (apat v pat (begin e0 e ...) (fk))))))
-
-(define-syntax apat
- (syntax-rules (_ quote unquote)
- ((_ v _ kt kf) kt)
- ((_ v () kt kf) (if (null? v) kt kf))
- ((_ v (quote lit) kt kf)
- (if (equal? v (quote lit)) kt kf))
- ((_ v (unquote var) kt kf) (let ((var v)) kt))
- ((_ v (x . y) kt kf)
- (if (apair? v)
- (let ((vx (acar v)) (vy (acdr v)))
- (apat vx x (apat vy y kt kf) kf))
- kf))
- ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm
index 587a173fe..dc03af6cf 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -27,16 +26,15 @@
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
- #:use-module ((ice-9 syncase) #:select (sc-macro))
+ #:use-module (language tree-il)
#:use-module ((system base compile) #:select (syntax-error))
#:export (compile-ghil translate-1
*translate-table* define-scheme-translator))
-
;;; environment := #f
;;; | MODULE
;;; | COMPILE-ENV
-;;; compile-env := (MODULE LEXICALS . EXTERNALS)
+;;; compile-env := (MODULE LEXICALS|GHIL-ENV . EXTERNALS)
(define (cenv-module env)
(cond ((not env) #f)
((module? env) env)
@@ -47,7 +45,9 @@
(cond ((not env) (make-ghil-toplevel-env))
((module? env) (make-ghil-toplevel-env))
((pair? env)
- (ghil-env-dereify (cadr env)))
+ (if (struct? (cadr env))
+ (cadr env)
+ (ghil-env-dereify (cadr env))))
(else (error "bad environment" env))))
(define (cenv-externals env)
@@ -56,6 +56,8 @@
((pair? env) (cddr env))
(else (error "bad environment" env))))
+(define (make-cenv module lexicals externals)
+ (cons module (cons lexicals externals)))
@@ -65,11 +67,14 @@
(and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars)
- (values (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))
- (and e
- (cons* (cenv-module e)
- (ghil-env-parent env)
- (cenv-externals e)))))))))
+ (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)
+ (ghil-env-parent env)
+ (if e (cenv-externals e) '()))))
+ (values x cenv cenv))))))))
;;;
@@ -88,37 +93,26 @@
;;
;; FIXME shadowing lexicals?
(define (lookup-transformer head retrans)
+ (define (module-ref/safe mod sym)
+ (and mod
+ (and=> (module-variable mod sym)
+ (lambda (var)
+ ;; unbound vars can happen if the module
+ ;; definition forward-declared them
+ (and (variable-bound? var) (variable-ref var))))))
(let* ((mod (current-module))
(val (cond
- ((symbol? head)
- (and=> (module-variable mod head)
- (lambda (var)
- ;; unbound vars can happen if the module
- ;; definition forward-declared them
- (and (variable-bound? var) (variable-ref var)))))
- ;; allow macros to be unquoted into the output of a macro
- ;; expansion
- ((macro? head) head)
+ ((symbol? head) (module-ref/safe mod head))
+ ((pmatch head
+ ((@ ,modname ,sym)
+ (module-ref/safe (resolve-interface modname) sym))
+ ((@@ ,modname ,sym)
+ (module-ref/safe (resolve-module modname) sym))
+ (else #f)))
(else #f))))
(cond
((hashq-ref *translate-table* val))
- ((defmacro? val)
- (lambda (env loc exp)
- (retrans (apply (defmacro-transformer val) (cdr exp)))))
-
- ((eq? val sc-macro)
- ;; syncase!
- (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure))
- (sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
- (lambda (env loc exp)
- (retrans
- (with-fluids ((eec (module-eval-closure mod)))
- (sc-expand3 exp 'c '(compile load eval)))))))
-
- ((primitive-macro? val)
- (syntax-error #f "unhandled primitive macro" head))
-
((macro? val)
(syntax-error #f "unknown kind of macro" head))
@@ -167,7 +161,7 @@
(define-macro (define-scheme-translator sym . clauses)
`(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
- ,sym
+ (module-ref (current-module) ',sym)
(lambda (e l exp)
(define (retrans x)
((@ (language scheme compile-ghil) translate-1)
@@ -419,16 +413,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 000000000..4ac33d77e
--- /dev/null
+++ b/module/language/scheme/compile-tree-il.scm
@@ -0,0 +1,63 @@
+;;; Guile Scheme specification
+
+;; 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; 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/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm
new file mode 100644
index 000000000..9243f4e6a
--- /dev/null
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -0,0 +1,26 @@
+;;; Guile VM code converters
+
+;; Copyright (C) 2001,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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; 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/expand.scm b/module/language/scheme/expand.scm
deleted file mode 100644
index ee689a092..000000000
--- a/module/language/scheme/expand.scm
+++ /dev/null
@@ -1,307 +0,0 @@
-;;; Guile Scheme specification
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(define-module (language scheme expand)
- #:use-module (language scheme amatch)
- #:use-module (ice-9 annotate)
- #:use-module (ice-9 optargs)
- #:use-module ((ice-9 syncase) #:select (sc-macro))
- #:use-module ((system base compile) #:select (syntax-error))
- #:export (expand *expand-table* define-scheme-expander))
-
-(define (aref x) (if (annotation? x) (annotation-expression x) x))
-(define (apair? x) (pair? (aref x)))
-(define (acar x) (car (aref x)))
-(define (acdr x) (cdr (aref x)))
-(define (acaar x) (acar (acar x)))
-(define (acdar x) (acdr (acar x)))
-(define (acadr x) (acar (acdr x)))
-(define (acddr x) (acdr (acdr x)))
-(define (aloc x) (and (annotation? x) (annotation-source x)))
-(define (re-annotate x y)
- (if (annotation? x)
- (make-annotation y (annotation-source x))
- y))
-(define-macro (-> exp) `(re-annotate x ,exp))
-
-(define* (expand x #:optional (mod (current-module)) (once? #f))
- (define re-expand
- (if once?
- (lambda (x) x)
- (lambda (x) (expand x mod once?))))
- (let ((exp (if (annotation? x) (annotation-expression x) x)))
- (cond
- ((pair? exp)
- (let ((head (car exp)) (tail (cdr exp)))
- (cond
- ;; allow macros to be unquoted into the output of a macro
- ;; expansion
- ((or (symbol? head) (macro? head))
- (let ((val (cond
- ((macro? head) head)
- ((module-variable mod head)
- => (lambda (var)
- ;; unbound vars can happen if the module
- ;; definition forward-declared them
- (and (variable-bound? var) (variable-ref var))))
- (else #f))))
- (cond
- ((hashq-ref *expand-table* val)
- => (lambda (expand1) (expand1 x re-expand)))
-
- ((defmacro? val)
- (re-expand (-> (apply (defmacro-transformer val)
- (deannotate tail)))))
-
- ((eq? val sc-macro)
- ;; syncase!
- (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure))
- (sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
- (re-expand
- (with-fluids ((eec (module-eval-closure mod)))
- ;; fixme
- (sc-expand3 (deannotate exp) 'c '(compile load eval))))))
-
- ((primitive-macro? val)
- (syntax-error (aloc x) "unhandled primitive macro" head))
-
- ((macro? val)
- (syntax-error (aloc x) "unknown kind of macro" head))
-
- (else
- (-> (cons head (map re-expand tail)))))))
-
- (else
- (-> (map re-expand exp))))))
-
- (else x))))
-
-
-(define *expand-table* (make-hash-table))
-
-(define-macro (define-scheme-expander sym . clauses)
- `(hashq-set! (@ (language scheme expand) *expand-table*)
- ,sym
- (lambda (x re-expand)
- (define syntax-error (@ (system base compile) syntax-error))
- (amatch (acdr x)
- ,@clauses
- ,@(if (assq 'else clauses) '()
- `((else
- (syntax-error (aloc x) (format #f "bad ~A" ',sym) x))))))))
-
-(define-scheme-expander quote
- ;; (quote OBJ)
- ((,obj) x))
-
-(define-scheme-expander quasiquote
- ;; (quasiquote OBJ)
- ((,obj)
- (-> `(,'quasiquote
- ,(let lp ((x obj) (level 0))
- (cond ((not (apair? x)) x)
- ;; FIXME: hygiene regarding imported , / ,@ rebinding
- ((memq (acar x) '(unquote unquote-splicing))
- (amatch (acdr x)
- ((,obj)
- (cond
- ((zero? level)
- (-> `(,(acar x) ,(re-expand obj))))
- (else
- (-> `(,(acar x) ,(lp obj (1- level)))))))
- (else (syntax-error (aloc x) (format #f "bad ~A" (acar x)) x))))
- ((eq? (acar x) 'quasiquote)
- (amatch (acdr x)
- ((,obj) (-> `(,'quasiquote ,(lp obj (1+ level)))))
- (else (syntax-error (aloc x) "bad quasiquote" x))))
- (else (-> (cons (lp (acar x) level) (lp (acdr x) level))))))))))
-
-(define-scheme-expander define
- ;; (define NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> `(define ,name ,(re-expand val))))
- ;; (define (NAME FORMALS...) BODY...)
- (((,name . ,formals) . ,body) (guard (symbol? name))
- ;; -> (define NAME (lambda FORMALS BODY...))
- (re-expand (-> `(define ,name (lambda ,formals . ,body))))))
-
-(define-scheme-expander set!
- ;; (set! (NAME ARGS...) VAL)
- (((,name . ,args) ,val) (guard (symbol? name)
- (not (eq? name '@)) (not (eq? name '@@)))
- ;; -> ((setter NAME) ARGS... VAL)
- (re-expand (-> `((setter ,name) ,@args ,val))))
-
- ;; (set! NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> `(set! ,name ,(re-expand val)))))
-
-(define-scheme-expander if
- ;; (if TEST THEN [ELSE])
- ((,test ,then)
- (-> `(if ,(re-expand test) ,(re-expand then))))
- ((,test ,then ,else)
- (-> `(if ,(re-expand test) ,(re-expand then) ,(re-expand else)))))
-
-(define-scheme-expander and
- ;; (and EXPS...)
- (,tail
- (-> `(and . ,(map re-expand tail)))))
-
-(define-scheme-expander or
- ;; (or EXPS...)
- (,tail
- (-> `(or . ,(map re-expand tail)))))
-
-(define-scheme-expander begin
- ;; (begin EXPS...)
- ((,single-exp)
- (-> (re-expand single-exp)))
- (,tail
- (-> `(begin . ,(map re-expand tail)))))
-
-(define (valid-bindings? bindings . it-is-for-do)
- (define (valid-binding? b)
- (amatch b
- ((,sym ,var) (guard (symbol? sym)) #t)
- ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
- (else #f)))
- (and (list? (aref bindings))
- (and-map valid-binding? (aref bindings))))
-
-(define-scheme-expander let
- ;; (let NAME ((SYM VAL) ...) BODY...)
- ((,name ,bindings . ,body) (guard (symbol? name)
- (valid-bindings? bindings))
- ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
- (re-expand (-> `(letrec ((,name (lambda ,(map acar (aref bindings))
- . ,body)))
- (,name . ,(map acadr (aref bindings)))))))
-
- ((() . ,body)
- (re-expand (expand-internal-defines body)))
-
- ;; (let ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (-> `(let ,(map (lambda (x)
- ;; nb, relies on -> non-hygiene
- (-> `(,(acar x) ,(re-expand (acadr x)))))
- (aref bindings))
- ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander let*
- ;; (let* ((SYM VAL) ...) BODY...)
- ((() . ,body)
- (re-expand (-> `(let () . ,body))))
- ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
- (re-expand (-> `(let ((,sym ,val)) (let* ,rest . ,body))))))
-
-(define-scheme-expander letrec
- ;; (letrec ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (-> `(letrec ,(map (lambda (x)
- ;; nb, relies on -> non-hygiene
- (-> `(,(acar x) ,(re-expand (acadr x)))))
- (aref bindings))
- ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander cond
- ;; (cond (CLAUSE BODY...) ...)
- (() (-> '(begin)))
- (((else . ,body)) (re-expand (-> `(begin ,@body))))
- (((,test) . ,rest) (re-expand (-> `(or ,test (cond ,@rest)))))
- (((,test => ,proc) . ,rest)
- ;; FIXME hygiene!
- (re-expand (-> `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))))
- (((,test . ,body) . ,rest)
- (re-expand (-> `(if ,test (begin ,@body) (cond ,@rest))))))
-
-(define-scheme-expander case
- ;; (case EXP ((KEY...) BODY...) ...)
- ((,exp . ,clauses)
- ;; FIXME hygiene!
- (re-expand
- (->`(let ((_t ,exp))
- ,(let loop ((ls clauses))
- (cond ((null? ls) '(begin))
- ((eq? (acaar ls) 'else) `(begin ,@(acdar ls)))
- (else `(if (memv _t ',(acaar ls))
- (begin ,@(acdar ls))
- ,(loop (acdr ls)))))))))))
-
-(define-scheme-expander do
- ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
- ((,bindings (,test . ,result) . ,body) (guard (valid-bindings? bindings #t))
- (let ((sym (map acar (aref bindings)))
- (val (map acadr (aref bindings)))
- (update (map acddr (aref bindings))))
- (define (next s x) (if (pair? x) (car x) s))
- (re-expand
- ;; FIXME hygiene!
- (-> `(letrec ((_l (lambda ,sym
- (if ,test
- (begin ,@result)
- (begin ,@body
- (_l ,@(map next sym update)))))))
- (_l ,@val)))))))
-
-(define-scheme-expander lambda
- ;; (lambda FORMALS BODY...)
- ((,formals ,docstring ,body1 . ,body) (guard (string? docstring))
- (-> `(lambda ,formals ,docstring ,(expand-internal-defines
- (map re-expand (cons body1 body))))))
- ((,formals . ,body)
- (-> `(lambda ,formals ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander delay
- ;; FIXME not hygienic
- ((,expr)
- (re-expand `(make-promise (lambda () ,expr)))))
-
-(define-scheme-expander @
- ((,modname ,sym)
- x))
-
-(define-scheme-expander @@
- ((,modname ,sym)
- x))
-
-(define-scheme-expander eval-when
- ((,when . ,body) (guard (list? when) (and-map symbol? when))
- (if (memq 'compile when)
- (primitive-eval `(begin . ,body)))
- (if (memq 'load when)
- (-> `(begin . ,body))
- (-> `(begin)))))
-
-;;; Hum, I don't think this takes imported modifications to `define'
-;;; properly into account. (Lexical bindings are OK because of alpha
-;;; renaming.)
-(define (expand-internal-defines body)
- (let loop ((ls body) (ds '()))
- (amatch ls
- (() (syntax-error l "bad body" body))
- (((define ,name ,val) . _)
- (loop (acdr ls) (cons (list name val) ds)))
- (else
- (if (null? ds)
- (if (null? (cdr ls)) (car ls) `(begin ,@ls))
- `(letrec ,ds ,(if (null? (cdr ls)) (car ls) `(begin ,@ls))))))))
diff --git a/module/language/scheme/inline.scm b/module/language/scheme/inline.scm
index 462fe7f2f..b178b2adc 100644
--- a/module/language/scheme/inline.scm
+++ b/module/language/scheme/inline.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 8f958eb63..df618581f 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -1,27 +1,27 @@
;;; 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.
+;; Copyright (C) 2001, 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(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 +30,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 +38,8 @@
#:title "Guile Scheme"
#:version "0.5"
#:reader read
- #:read-file read-file
- #:compilers `((ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il))
+ #: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 000000000..ad8b73176
--- /dev/null
+++ b/module/language/tree-il.scm
@@ -0,0 +1,474 @@
+;;;; 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+
+(define-module (language tree-il)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #: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-body
+ <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
+ <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
+ <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
+
+ parse-tree-il
+ unparse-tree-il
+ tree-il->scheme
+
+ tree-il-fold
+ make-tree-il-folder
+ 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 body)
+ (<letrec> names vars vals body)
+ (<fix> names vars vals body)
+ (<let-values> names vars exp body))
+
+
+
+(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) ,exp) (guard (symbol? name))
+ (make-lexical-set loc name name (retrans exp)))
+
+ ((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 ,body)
+ (make-let loc names vars (map retrans vals) (retrans body)))
+
+ ((letrec ,names ,vars ,vals ,body)
+ (make-letrec loc names vars (map retrans vals) (retrans body)))
+
+ ((fix ,names ,vars ,vals ,body)
+ (make-fix loc names vars (map retrans vals) (retrans body)))
+
+ ((let-values ,names ,vars ,exp ,body)
+ (make-let-values loc names vars (retrans exp) (retrans body)))
+
+ (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 body)
+ `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+
+ ((<letrec> names vars vals body)
+ `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+
+ ((<fix> names vars vals body)
+ `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+
+ ((<let-values> names vars exp body)
+ `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
+
+(define (tree-il->scheme 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 body)
+ `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+
+ ((<letrec> vars vals body)
+ `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+
+ ((<fix> vars vals body)
+ ;; not a typo, we really do translate back to letrec
+ `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+
+ ((<let-values> vars exp body)
+ `(call-with-values (lambda () ,(tree-il->scheme exp))
+ (lambda ,vars ,(tree-il->scheme body))))))
+
+
+(define (tree-il-fold leaf down up seed tree)
+ "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
+into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is
+invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
+and SEED is the current result, intially seeded with SEED.
+
+This is an implementation of `foldts' as described by Andy Wingo in
+``Applications of fold to XML transformation''."
+ (let loop ((tree tree)
+ (result seed))
+ (if (or (null? tree) (pair? tree))
+ (fold loop result tree)
+ (record-case tree
+ ((<lexical-set> exp)
+ (up tree (loop exp (down tree result))))
+ ((<module-set> exp)
+ (up tree (loop exp (down tree result))))
+ ((<toplevel-set> exp)
+ (up tree (loop exp (down tree result))))
+ ((<toplevel-define> exp)
+ (up tree (loop exp (down tree result))))
+ ((<conditional> test then else)
+ (up tree (loop else
+ (loop then
+ (loop test (down tree result))))))
+ ((<application> proc args)
+ (up tree (loop (cons proc args) (down tree result))))
+ ((<sequence> exps)
+ (up tree (loop exps (down tree result))))
+ ((<lambda> body)
+ (up tree (loop body (down tree result))))
+ ((<let> vals body)
+ (up tree (loop body
+ (loop vals
+ (down tree result)))))
+ ((<letrec> vals body)
+ (up tree (loop body
+ (loop vals
+ (down tree result)))))
+ ((<fix> vals body)
+ (up tree (loop body
+ (loop vals
+ (down tree result)))))
+ ((<let-values> exp body)
+ (up tree (loop body (loop exp (down tree result)))))
+ (else
+ (leaf tree result))))))
+
+
+(define-syntax make-tree-il-folder
+ (syntax-rules ()
+ ((_ seed ...)
+ (lambda (tree down up seed ...)
+ (define (fold-values proc exps seed ...)
+ (if (null? exps)
+ (values seed ...)
+ (let-values (((seed ...) (proc (car exps) seed ...)))
+ (fold-values proc (cdr exps) seed ...))))
+ (let foldts ((tree tree) (seed seed) ...)
+ (let*-values
+ (((seed ...) (down tree seed ...))
+ ((seed ...)
+ (record-case tree
+ ((<lexical-set> exp)
+ (foldts exp seed ...))
+ ((<module-set> exp)
+ (foldts exp seed ...))
+ ((<toplevel-set> exp)
+ (foldts exp seed ...))
+ ((<toplevel-define> exp)
+ (foldts exp seed ...))
+ ((<conditional> test then else)
+ (let*-values (((seed ...) (foldts test seed ...))
+ ((seed ...) (foldts then seed ...)))
+ (foldts else seed ...)))
+ ((<application> proc args)
+ (let-values (((seed ...) (foldts proc seed ...)))
+ (fold-values foldts args seed ...)))
+ ((<sequence> exps)
+ (fold-values foldts exps seed ...))
+ ((<lambda> body)
+ (foldts body seed ...))
+ ((<let> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<letrec> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<fix> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<let-values> exp body)
+ (let*-values (((seed ...) (foldts exp seed ...)))
+ (foldts body seed ...)))
+ (else
+ (values seed ...)))))
+ (up tree seed ...)))))))
+
+(define (post-order! f x)
+ (let lp ((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 body)
+ (set! (let-vals x) (map lp vals))
+ (set! (let-body x) (lp body)))
+
+ ((<letrec> vars vals body)
+ (set! (letrec-vals x) (map lp vals))
+ (set! (letrec-body x) (lp body)))
+
+ ((<fix> vars vals body)
+ (set! (fix-vals x) (map lp vals))
+ (set! (fix-body x) (lp body)))
+
+ ((<let-values> vars exp body)
+ (set! (let-values-exp x) (lp exp))
+ (set! (let-values-body x) (lp body)))
+
+ (else #f))
+
+ (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 body)
+ (set! (let-vals x) (map lp vals))
+ (set! (let-body x) (lp body)))
+
+ ((<letrec> vars vals body)
+ (set! (letrec-vals x) (map lp vals))
+ (set! (letrec-body x) (lp body)))
+
+ ((<fix> vars vals body)
+ (set! (fix-vals x) (map lp vals))
+ (set! (fix-body x) (lp body)))
+
+ ((<let-values> vars exp body)
+ (set! (let-values-exp x) (lp exp))
+ (set! (let-values-body x) (lp body)))
+
+ (else #f))
+ x)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
new file mode 100644
index 000000000..b93a0bd7e
--- /dev/null
+++ b/module/language/tree-il/analyze.scm
@@ -0,0 +1,617 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language tree-il analyze)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (system base syntax)
+ #:use-module (system base message)
+ #:use-module (language tree-il)
+ #:export (analyze-lexicals
+ report-unused-variables))
+
+;; Allocation is the process of assigning storage locations for lexical
+;; variables. A lexical variable has a distinct "address", or storage
+;; location, for each procedure in which it is referenced.
+;;
+;; A variable is "local", i.e., allocated on the stack, if it is
+;; referenced from within the procedure that defined it. Otherwise it is
+;; a "closure" variable. For example:
+;;
+;; (lambda (a) a) ; a will be local
+;; `a' is local to the procedure.
+;;
+;; (lambda (a) (lambda () a))
+;; `a' is local to the outer procedure, but a closure variable with
+;; respect to the inner procedure.
+;;
+;; If a variable is ever assigned, it needs to be heap-allocated
+;; ("boxed"). This is so that closures and continuations capture the
+;; variable's identity, not just one of the values it may have over the
+;; course of program execution. If the variable is never assigned, there
+;; is no distinction between value and identity, so closing over its
+;; identity (whether through closures or continuations) can make a copy
+;; of its value instead.
+;;
+;; Local variables are stored on the stack within a procedure's call
+;; frame. Their index into the stack is determined from their linear
+;; postion within a procedure's 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.
+;;
+;; Closure variables are captured when a closure is created, and stored
+;; in a vector. Each closure variable has a unique index into that
+;; vector.
+;;
+;; There is one more complication. Procedures bound by <fix> may, in
+;; some cases, be rendered inline to their parent procedure. That is to
+;; say,
+;;
+;; (letrec ((lp (lambda () (lp)))) (lp))
+;; => (fix ((lp (lambda () (lp)))) (lp))
+;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
+;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop
+;;
+;; The upshot is that we don't have to allocate any space for the `lp'
+;; closure at all, as it can be rendered inline as a loop. So there is
+;; another kind of allocation, "label allocation", in which the
+;; procedure is simply a label, placed at the start of the lambda body.
+;; The label is the gensym under which the lambda expression is bound.
+;;
+;; The analyzer checks to see that the label is called with the correct
+;; number of arguments. Calls to labels compile to rename + goto.
+;; Lambda, the ultimate goto!
+;;
+;;
+;; The return value of `analyze-lexicals' is a hash table, the
+;; "allocation".
+;;
+;; The allocation maps gensyms -- recall that each lexically bound
+;; variable has a unique gensym -- to storage locations ("addresses").
+;; Since one gensym may have many storage locations, if it is referenced
+;; in many procedures, it is a two-level map.
+;;
+;; The allocation also stored information on how many local variables
+;; need to be allocated for each procedure, lexicals that have been
+;; translated into labels, and information on what free variables to
+;; capture from its lexical parent procedure.
+;;
+;; That is:
+;;
+;; sym -> {lambda -> address}
+;; lambda -> (nlocs labels . free-locs)
+;;
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda-vars) ...)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
+
+(define (make-hashq k v)
+ (let ((res (make-hash-table)))
+ (hashq-set! res k v)
+ res))
+
+(define (analyze-lexicals x)
+ ;; bound-vars: lambda -> (sym ...)
+ ;; all identifiers bound within a lambda
+ (define bound-vars (make-hash-table))
+ ;; free-vars: lambda -> (sym ...)
+ ;; all identifiers referenced in a lambda, but not bound
+ ;; NB, this includes identifiers referenced by contained lambdas
+ (define free-vars (make-hash-table))
+ ;; assigned: sym -> #t
+ ;; variables that are assigned
+ (define assigned (make-hash-table))
+ ;; refcounts: sym -> count
+ ;; allows us to detect the or-expansion in O(1) time
+ (define refcounts (make-hash-table))
+ ;; labels: sym -> lambda-vars
+ ;; for determining if fixed-point procedures can be rendered as
+ ;; labels. lambda-vars may be an improper list.
+ (define labels (make-hash-table))
+
+ ;; returns variables referenced in expr
+ (define (analyze! x proc labels-in-proc tail? tail-call-args)
+ (define (step y) (analyze! y proc labels-in-proc #f #f))
+ (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
+ (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
+ (and tail? args)))
+ (define (recur/labels x new-proc labels)
+ (analyze! x new-proc (append labels labels-in-proc) #t #f))
+ (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
+ (record-case x
+ ((<application> proc args)
+ (apply lset-union eq? (step-tail-call proc args)
+ (map step args)))
+
+ ((<conditional> test then else)
+ (lset-union eq? (step test) (step-tail then) (step-tail else)))
+
+ ((<lexical-ref> name gensym)
+ (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+ (if (not (and tail-call-args
+ (memq gensym labels-in-proc)
+ (let ((args (hashq-ref labels gensym)))
+ (and (list? args)
+ (= (length args) (length tail-call-args))))))
+ (hashq-set! labels gensym #f))
+ (list gensym))
+
+ ((<lexical-set> name gensym exp)
+ (hashq-set! assigned gensym #t)
+ (hashq-set! labels gensym #f)
+ (lset-adjoin eq? (step exp) gensym))
+
+ ((<module-set> mod name public? exp)
+ (step exp))
+
+ ((<toplevel-set> name exp)
+ (step exp))
+
+ ((<toplevel-define> name exp)
+ (step exp))
+
+ ((<sequence> exps)
+ (let lp ((exps exps) (ret '()))
+ (cond ((null? exps) '())
+ ((null? (cdr exps))
+ (lset-union eq? ret (step-tail (car exps))))
+ (else
+ (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
+
+ ((<lambda> vars meta body)
+ (let ((locally-bound (let rev* ((vars vars) (out '()))
+ (cond ((null? vars) out)
+ ((pair? vars) (rev* (cdr vars)
+ (cons (car vars) out)))
+ (else (cons vars out))))))
+ (hashq-set! bound-vars x locally-bound)
+ (let* ((referenced (recur body x))
+ (free (lset-difference eq? referenced locally-bound))
+ (all-bound (reverse! (hashq-ref bound-vars x))))
+ (hashq-set! bound-vars x all-bound)
+ (hashq-set! free-vars x free)
+ free)))
+
+ ((<let> vars vals body)
+ (hashq-set! bound-vars proc
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ (lset-difference eq?
+ (apply lset-union eq? (step-tail body) (map step vals))
+ vars))
+
+ ((<letrec> vars vals body)
+ (hashq-set! bound-vars proc
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
+ (lset-difference eq?
+ (apply lset-union eq? (step-tail body) (map step vals))
+ vars))
+
+ ((<fix> vars vals body)
+ ;; Try to allocate these procedures as labels.
+ (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val)))
+ vars vals)
+ (hashq-set! bound-vars proc
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ ;; Step into subexpressions.
+ (let* ((var-refs
+ (map
+ ;; Since we're trying to label-allocate the lambda,
+ ;; pretend it's not a closure, and just recurse into its
+ ;; body directly. (Otherwise, recursing on a closure
+ ;; that references one of the fix's bound vars would
+ ;; prevent label allocation.)
+ (lambda (x)
+ (record-case x
+ ((<lambda> (lvars vars) body)
+ (let ((locally-bound
+ (let rev* ((lvars lvars) (out '()))
+ (cond ((null? lvars) out)
+ ((pair? lvars) (rev* (cdr lvars)
+ (cons (car lvars) out)))
+ (else (cons lvars out))))))
+ (hashq-set! bound-vars x locally-bound)
+ ;; recur/labels, the difference from the closure case
+ (let* ((referenced (recur/labels body x vars))
+ (free (lset-difference eq? referenced locally-bound))
+ (all-bound (reverse! (hashq-ref bound-vars x))))
+ (hashq-set! bound-vars x all-bound)
+ (hashq-set! free-vars x free)
+ free)))))
+ vals))
+ (vars-with-refs (map cons vars var-refs))
+ (body-refs (recur/labels body proc vars)))
+ (define (delabel-dependents! sym)
+ (let ((refs (assq-ref vars-with-refs sym)))
+ (if refs
+ (for-each (lambda (sym)
+ (if (hashq-ref labels sym)
+ (begin
+ (hashq-set! labels sym #f)
+ (delabel-dependents! sym))))
+ refs))))
+ ;; Stepping into the lambdas and the body might have made some
+ ;; procedures not label-allocatable -- which might have
+ ;; knock-on effects. For example:
+ ;; (fix ((a (lambda () (b)))
+ ;; (b (lambda () a)))
+ ;; (a))
+ ;; As far as `a' is concerned, both `a' and `b' are
+ ;; label-allocatable. But `b' references `a' not in a proc-tail
+ ;; position, which makes `a' not label-allocatable. The
+ ;; knock-on effect is that, when back-propagating this
+ ;; information to `a', `b' will also become not
+ ;; label-allocatable, as it is referenced within `a', which is
+ ;; allocated as a closure. This is a transitive relationship.
+ (for-each (lambda (sym)
+ (if (not (hashq-ref labels sym))
+ (delabel-dependents! sym)))
+ vars)
+ ;; Now lift bound variables with label-allocated lambdas to the
+ ;; parent procedure.
+ (for-each
+ (lambda (sym val)
+ (if (hashq-ref labels sym)
+ ;; Remove traces of the label-bound lambda. The free
+ ;; vars will propagate up via the return val.
+ (begin
+ (hashq-set! bound-vars proc
+ (append (hashq-ref bound-vars val)
+ (hashq-ref bound-vars proc)))
+ (hashq-remove! bound-vars val)
+ (hashq-remove! free-vars val))))
+ vars vals)
+ (lset-difference eq?
+ (apply lset-union eq? body-refs var-refs)
+ vars)))
+
+ ((<let-values> vars exp body)
+ (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
+ (if (pair? in)
+ (lp (cons (car in) out) (cdr in))
+ (if (null? in) out (cons in out))))))
+ (hashq-set! bound-vars proc bound)
+ (lset-difference eq?
+ (lset-union eq? (step exp) (step-tail body))
+ bound)))
+
+ (else '())))
+
+ ;; allocation: sym -> {lambda -> address}
+ ;; lambda -> (nlocs labels . free-locs)
+ (define allocation (make-hash-table))
+
+ (define (allocate! x proc n)
+ (define (recur y) (allocate! y proc 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)
+ ;; allocate closure vars in order
+ (let lp ((c (hashq-ref free-vars x)) (n 0))
+ (if (pair? c)
+ (begin
+ (hashq-set! (hashq-ref allocation (car c))
+ x
+ `(#f ,(hashq-ref assigned (car c)) . ,n))
+ (lp (cdr c) (1+ n)))))
+
+ (let ((nlocs
+ (let lp ((vars vars) (n 0))
+ (if (not (null? vars))
+ ;; allocate args
+ (let ((v (if (pair? vars) (car vars) vars)))
+ (hashq-set! allocation v
+ (make-hashq
+ x `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
+ ;; allocate body, return number of additional locals
+ (- (allocate! body x n) n))))
+ (free-addresses
+ (map (lambda (v)
+ (hashq-ref (hashq-ref allocation v) proc))
+ (hashq-ref free-vars x)))
+ (labels (filter cdr
+ (map (lambda (sym)
+ (cons sym (hashq-ref labels sym)))
+ (hashq-ref bound-vars x)))))
+ ;; set procedure allocations
+ (hashq-set! allocation x (cons* nlocs labels free-addresses)))
+ n)
+
+ ((<let> vars vals body)
+ (let ((nmax (apply max (map recur vals))))
+ (cond
+ ;; the `or' hack
+ ((and (conditional? body)
+ (= (length vars) 1)
+ (let ((v (car vars)))
+ (and (not (hashq-ref assigned v))
+ (= (hashq-ref refcounts v 0) 2)
+ (lexical-ref? (conditional-test body))
+ (eq? (lexical-ref-gensym (conditional-test body)) v)
+ (lexical-ref? (conditional-then body))
+ (eq? (lexical-ref-gensym (conditional-then body)) v))))
+ (hashq-set! allocation (car vars)
+ (make-hashq proc `(#t #f . ,n)))
+ ;; the 1+ for this var
+ (max nmax (1+ n) (allocate! (conditional-else body) proc n)))
+ (else
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (max nmax (allocate! body proc n))
+ (let ((v (car vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (cdr vars) (1+ n)))))))))
+
+ ((<letrec> vars vals body)
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (let ((nmax (apply max
+ (map (lambda (x)
+ (allocate! x proc n))
+ vals))))
+ (max nmax (allocate! body proc n)))
+ (let ((v (car vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (cdr vars) (1+ n))))))
+
+ ((<fix> vars vals body)
+ (let lp ((in vars) (n n))
+ (if (null? in)
+ (let lp ((vars vars) (vals vals) (nmax n))
+ (cond
+ ((null? vars)
+ (max nmax (allocate! body proc n)))
+ ((hashq-ref labels (car vars))
+ ;; allocate label bindings & body inline to proc
+ (lp (cdr vars)
+ (cdr vals)
+ (record-case (car vals)
+ ((<lambda> vars body)
+ (let lp ((vars vars) (n n))
+ (if (not (null? vars))
+ ;; allocate bindings
+ (let ((v (if (pair? vars) (car vars) vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq
+ proc `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
+ ;; allocate body
+ (max nmax (allocate! body proc n))))))))
+ (else
+ ;; allocate closure
+ (lp (cdr vars)
+ (cdr vals)
+ (max nmax (allocate! (car vals) proc n))))))
+
+ (let ((v (car in)))
+ (cond
+ ((hashq-ref assigned v)
+ (error "fixpoint procedures may not be assigned" x))
+ ((hashq-ref labels v)
+ ;; no binding, it's a label
+ (lp (cdr in) n))
+ (else
+ ;; allocate closure binding
+ (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
+ (lp (cdr in) (1+ n))))))))
+
+ ((<let-values> vars exp body)
+ (let ((nmax (recur exp)))
+ (let lp ((vars vars) (n n))
+ (cond
+ ((null? vars)
+ (max nmax (allocate! body proc n)))
+ ((not (pair? vars))
+ (hashq-set! allocation vars
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned vars) . ,n)))
+ ;; the 1+ for this var
+ (max nmax (allocate! body proc (1+ n))))
+ (else
+ (let ((v (car vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (cdr vars) (1+ n))))))))
+
+ (else n)))
+
+ (analyze! x #f '() #t #f)
+ (allocate! x #f 0)
+
+ allocation)
+
+
+;;;
+;;; Unused variable analysis.
+;;;
+
+;; <binding-info> records are used during tree traversals in
+;; `report-unused-variables'. They contain a list of the local vars
+;; currently in scope, a list of locals vars that have been referenced, and a
+;; "location stack" (the stack of `tree-il-src' values for each parent tree).
+(define-record-type <binding-info>
+ (make-binding-info vars refs locs)
+ binding-info?
+ (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...)
+ (refs binding-info-refs) ;; (GENSYM ...)
+ (locs binding-info-locs)) ;; (LOCATION ...)
+
+(define (report-unused-variables tree)
+ "Report about unused variables in TREE. Return TREE."
+
+ (define (dotless-list lst)
+ ;; If LST is a dotted list, return a proper list equal to LST except that
+ ;; the very last element is a pair; otherwise return LST.
+ (let loop ((lst lst)
+ (result '()))
+ (cond ((null? lst)
+ (reverse result))
+ ((pair? lst)
+ (loop (cdr lst) (cons (car lst) result)))
+ (else
+ (loop '() (cons lst result))))))
+
+ (tree-il-fold (lambda (x info)
+ ;; X is a leaf: extend INFO's refs accordingly.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info)))
+ (record-case x
+ ((<lexical-ref> gensym)
+ (make-binding-info vars (cons gensym refs) locs))
+ (else info))))
+
+ (lambda (x info)
+ ;; Going down into X: extend INFO's variable list
+ ;; accordingly.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info))
+ (src (tree-il-src x)))
+ (define (extend inner-vars inner-names)
+ (append (map (lambda (var name)
+ (list var name src))
+ inner-vars
+ inner-names)
+ vars))
+ (record-case x
+ ((<lexical-set> gensym)
+ (make-binding-info vars (cons gensym refs)
+ (cons src locs)))
+ ((<lambda> vars names)
+ (let ((vars (dotless-list vars))
+ (names (dotless-list names)))
+ (make-binding-info (extend vars names) refs
+ (cons src locs))))
+ ((<let> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ ((<letrec> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ ((<fix> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ ((<let-values> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ (else info))))
+
+ (lambda (x info)
+ ;; Leaving X's scope: shrink INFO's variable list
+ ;; accordingly and reported unused nested variables.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info)))
+ (define (shrink inner-vars refs)
+ (for-each (lambda (var)
+ (let ((gensym (car var)))
+ ;; Don't report lambda parameters as
+ ;; unused.
+ (if (and (not (memq gensym refs))
+ (not (and (lambda? x)
+ (memq gensym
+ inner-vars))))
+ (let ((name (cadr var))
+ ;; We can get approximate
+ ;; source location by going up
+ ;; the LOCS location stack.
+ (loc (or (caddr var)
+ (find pair? locs))))
+ (warning 'unused-variable loc name)))))
+ (filter (lambda (var)
+ (memq (car var) inner-vars))
+ vars))
+ (fold alist-delete vars inner-vars))
+
+ ;; For simplicity, we leave REFS untouched, i.e., with
+ ;; names of variables that are now going out of scope.
+ ;; It doesn't hurt as these are unique names, it just
+ ;; makes REFS unnecessarily fat.
+ (record-case x
+ ((<lambda> vars)
+ (let ((vars (dotless-list vars)))
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs))))
+ ((<let> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<letrec> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<fix> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<let-values> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ (else info))))
+ (make-binding-info '() '() '())
+ tree)
+ tree)
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
new file mode 100644
index 000000000..8886fa352
--- /dev/null
+++ b/module/language/tree-il/compile-glil.scm
@@ -0,0 +1,723 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language tree-il compile-glil)
+ #:use-module (system base syntax)
+ #:use-module (system base pmatch)
+ #:use-module (system base message)
+ #:use-module (ice-9 receive)
+ #:use-module (language glil)
+ #:use-module (system vm instruction)
+ #: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 -> {lambda -> address}
+;; lambda -> (nlocs labels . free-locs)
+;;
+;; address := (local? boxed? . index)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
+
+(define *comp-module* (make-fluid))
+
+(define %warning-passes
+ `((unused-variable . ,report-unused-variables)))
+
+(define (compile-glil x e opts)
+ (define warnings
+ (or (and=> (memq #:warnings opts) cadr)
+ '()))
+
+ ;; Go throught the warning passes.
+ (for-each (lambda (kind)
+ (let ((warn (assoc-ref %warning-passes kind)))
+ (and (procedure? warn)
+ (warn x))))
+ warnings)
+
+ (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 #f 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)
+ ((1+ . 1) . add1)
+ ((1- . 1) . sub1)
+ ((* . 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)
+ ((vector-ref . 2) . vector-ref)
+ ((vector-set! . 3) . vector-set)
+
+ ((bytevector-u8-ref . 2) . bv-u8-ref)
+ ((bytevector-u8-set! . 3) . bv-u8-set)
+ ((bytevector-s8-ref . 2) . bv-s8-ref)
+ ((bytevector-s8-set! . 3) . bv-s8-set)
+
+ ((bytevector-u16-ref . 3) . bv-u16-ref)
+ ((bytevector-u16-set! . 4) . bv-u16-set)
+ ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
+ ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
+ ((bytevector-s16-ref . 3) . bv-s16-ref)
+ ((bytevector-s16-set! . 4) . bv-s16-set)
+ ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
+ ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
+
+ ((bytevector-u32-ref . 3) . bv-u32-ref)
+ ((bytevector-u32-set! . 4) . bv-u32-set)
+ ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
+ ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
+ ((bytevector-s32-ref . 3) . bv-s32-ref)
+ ((bytevector-s32-set! . 4) . bv-s32-set)
+ ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
+ ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
+
+ ((bytevector-u64-ref . 3) . bv-u64-ref)
+ ((bytevector-u64-set! . 4) . bv-u64-set)
+ ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
+ ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
+ ((bytevector-s64-ref . 3) . bv-s64-ref)
+ ((bytevector-s64-set! . 4) . bv-s64-set)
+ ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
+ ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
+
+ ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
+ ((bytevector-ieee-single-set! . 4) . bv-f32-set)
+ ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
+ ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
+ ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
+ ((bytevector-ieee-double-set! . 4) . bv-f64-set)
+ ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
+ ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
+
+
+
+
+(define (make-label) (gensym ":L"))
+
+(define (vars->bind-list ids vars allocation proc)
+ (map (lambda (id v)
+ (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ ((#t ,boxed? . ,n)
+ (list id boxed? n))
+ (,x (error "badness" x))))
+ ids
+ vars))
+
+;; FIXME: always emit? otherwise it's hard to pair bind with unbind
+(define (emit-bindings src ids vars allocation proc emit-code)
+ (emit-code src (make-glil-bind
+ (vars->bind-list ids vars allocation proc))))
+
+(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 self-label allocation)
+ (receive (ids vars nargs nrest)
+ (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
+ (oids '()) (ovars '()) (n 0))
+ (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
+ ((pair? vars) (lp (cdr ids) (cdr vars)
+ (cons (car ids) oids) (cons (car vars) ovars)
+ (1+ n)))
+ (else (values (reverse (cons ids oids))
+ (reverse (cons vars ovars))
+ (1+ n) 1))))
+ (let ((nlocs (car (hashq-ref allocation x)))
+ (labels (cadr (hashq-ref allocation x))))
+ (make-glil-program
+ nargs nrest nlocs (lambda-meta x)
+ (with-output-to-code
+ (lambda (emit-code)
+ ;; emit label for self tail calls
+ (if self-label
+ (emit-code #f (make-glil-label self-label)))
+ ;; write bindings and source debugging info
+ (if (not (null? ids))
+ (emit-bindings #f ids vars allocation x emit-code))
+ (if (lambda-src x)
+ (emit-code #f (make-glil-source (lambda-src x))))
+ ;; box args if necessary
+ (for-each
+ (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) x)
+ ((#t #t . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'ref n))
+ (emit-code #f (make-glil-lexical #t #t 'box n)))))
+ vars)
+ ;; and here, here, dear reader: we compile.
+ (flatten (lambda-body x) allocation x self-label
+ labels emit-code)))))))
+
+(define (flatten x allocation self self-label fix-labels 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)))
+
+ ;; RA: "return address"; #f unless we're in a non-tail fix with labels
+ ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
+ (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
+ (define (comp-tail tree) (comp tree context RA MVRA))
+ (define (comp-push tree) (comp tree 'push #f #f))
+ (define (comp-drop tree) (comp tree 'drop #f #f))
+ (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
+ (define (comp-fix tree RA) (comp tree context RA MVRA))
+
+ ;; A couple of helpers. Note that if we are in tail context, we
+ ;; won't have an RA.
+ (define (maybe-emit-return)
+ (if RA
+ (emit-branch #f 'br RA)
+ (if (eq? context 'tail)
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ (record-case x
+ ((<void>)
+ (case context
+ ((push vals tail)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ((<const> src exp)
+ (case context
+ ((push vals tail)
+ (emit-code src (make-glil-const exp))))
+ (maybe-emit-return))
+
+ ;; 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)) (not (eq? context 'vals)))
+ ;; 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) (maybe-emit-return))
+ ((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))))
+ (maybe-emit-return))
+ ((vals)
+ (comp-vals
+ (make-application src (make-primitive-ref #f 'apply)
+ (cons proc args))
+ MVRA)
+ (maybe-emit-return))
+ ((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)))
+ (maybe-emit-return)))))))
+
+ ((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))
+ ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((vals)
+ (for-each comp-push args)
+ (emit-code #f (make-glil-const (length args)))
+ (emit-branch src 'br MVRA))
+ ((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)
+ (case context
+ ((vals)
+ ;; Fall back.
+ (comp-vals
+ (make-application src (make-primitive-ref #f 'call-with-values)
+ args)
+ MVRA)
+ (maybe-emit-return))
+ (else
+ (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)))
+ (maybe-emit-return)))))))
+
+ ((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)))
+ ((vals)
+ (comp-vals
+ (make-application
+ src (make-primitive-ref #f 'call-with-current-continuation)
+ args)
+ MVRA)
+ (maybe-emit-return))
+ ((push)
+ (comp-push (car args))
+ (emit-code src (make-glil-call 'call/cc 1))
+ (maybe-emit-return))
+ ((drop)
+ ;; Crap. Just like `apply' in drop context.
+ (comp-drop
+ (make-application
+ src (make-primitive-ref #f 'call-with-current-continuation)
+ args))
+ (maybe-emit-return))))
+
+ ((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 (instruction-pushes op)
+ ((0)
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+ ((1)
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+ (else
+ (error "bad primitive op: too many pushes"
+ op (instruction-pushes op))))))
+
+ ;; da capo al fine
+ ((and (lexical-ref? proc)
+ self-label (eq? (lexical-ref-gensym proc) self-label)
+ ;; self-call in tail position is a goto
+ (eq? context 'tail)
+ ;; make sure the arity is right
+ (list? (lambda-vars self))
+ (= (length args) (length (lambda-vars self))))
+ ;; evaluate new values
+ (for-each comp-push args)
+ ;; rename & goto
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t ,boxed? . ,index)
+ ;; set unboxed, as the proc prelude will box if needed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ (,x (error "what" x))))
+ (reverse (lambda-vars self)))
+ (emit-branch src 'br self-label))
+
+ ;; lambda, the ultimate goto
+ ((and (lexical-ref? proc)
+ (assq (lexical-ref-gensym proc) fix-labels))
+ ;; evaluate new values, assuming that analyze-lexicals did its
+ ;; job, and that the arity was right
+ (for-each comp-push args)
+ ;; rename
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index)
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index)
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "what" x))))
+ (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
+ ;; goto!
+ (emit-branch src 'br (lexical-ref-gensym proc)))
+
+ (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))
+ (maybe-emit-return))
+ ((vals) (emit-code src (make-glil-mv-call len MVRA))
+ (maybe-emit-return))
+ ((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 (or RA POST))
+ (emit-label MV)
+ (emit-code #f (make-glil-mv-bind '() #f))
+ (emit-code #f (make-glil-unbind))
+ (if RA
+ (emit-branch #f 'br RA)
+ (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 there is an RA, comp-tail will cause a jump to it -- just
+ ;; have to clean up here if there is no RA.
+ (if (and (not RA) (not (eq? context 'tail)))
+ (emit-branch #f 'br L2))
+ (emit-label L1)
+ (comp-tail else)
+ (if (and (not RA) (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
+ ((tail push vals)
+ (emit-code src (make-glil-toplevel 'ref name))))
+ (maybe-emit-return))
+ ((module-variable the-root-module name)
+ (case context
+ ((tail push vals)
+ (emit-code src (make-glil-module 'ref '(guile) name #f))))
+ (maybe-emit-return))
+ (else
+ (case context
+ ((tail push vals)
+ (emit-code src (make-glil-module
+ 'ref (module-name (fluid-ref *comp-module*)) name #f))))
+ (maybe-emit-return))))
+
+ ((<lexical-ref> src name gensym)
+ (case context
+ ((push vals tail)
+ (pmatch (hashq-ref (hashq-ref allocation gensym) self)
+ ((,local? ,boxed? . ,index)
+ (emit-code src (make-glil-lexical local? boxed? 'ref index)))
+ (,loc
+ (error "badness" x loc)))))
+ (maybe-emit-return))
+
+ ((<lexical-set> src name gensym exp)
+ (comp-push exp)
+ (pmatch (hashq-ref (hashq-ref allocation gensym) self)
+ ((,local? ,boxed? . ,index)
+ (emit-code src (make-glil-lexical local? boxed? 'set index)))
+ (,loc
+ (error "badness" x loc)))
+ (case context
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ((<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))))
+ (maybe-emit-return))
+
+ ((<module-set> src mod name public? exp)
+ (comp-push exp)
+ (emit-code src (make-glil-module 'set mod name public?))
+ (case context
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ((<toplevel-ref> src name)
+ (emit-code src (make-glil-toplevel 'ref name))
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+
+ ((<toplevel-set> src name exp)
+ (comp-push exp)
+ (emit-code src (make-glil-toplevel 'set name))
+ (case context
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ((<toplevel-define> src name exp)
+ (comp-push exp)
+ (emit-code src (make-glil-toplevel 'define name))
+ (case context
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ((<lambda>)
+ (let ((free-locs (cddr (hashq-ref allocation x))))
+ (case context
+ ((push vals tail)
+ (emit-code #f (flatten-lambda x #f allocation))
+ (if (not (null? free-locs))
+ (begin
+ (for-each
+ (lambda (loc)
+ (pmatch loc
+ ((,local? ,boxed? . ,n)
+ (emit-code #f (make-glil-lexical local? #f 'ref n)))
+ (else (error "what" x loc))))
+ free-locs)
+ (emit-code #f (make-glil-call 'vector (length free-locs)))
+ (emit-code #f (make-glil-call 'make-closure 2)))))))
+ (maybe-emit-return))
+
+ ((<let> src names vars vals body)
+ (for-each comp-push vals)
+ (emit-bindings src names vars allocation self emit-code)
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "badness" x loc))))
+ (reverse vars))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind)))
+
+ ((<letrec> src names vars vals body)
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'empty-box n)))
+ (,loc (error "badness" x loc))))
+ vars)
+ (for-each comp-push vals)
+ (emit-bindings src names vars allocation self emit-code)
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'set n)))
+ (,loc (error "badness" x loc))))
+ (reverse vars))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind)))
+
+ ((<fix> src names vars vals body)
+ ;; The ideal here is to just render the lambda bodies inline, and
+ ;; wire the code together with gotos. We can do that if
+ ;; analyze-lexicals has determined that a given var has "label"
+ ;; allocation -- which is the case if it is in `fix-labels'.
+ ;;
+ ;; But even for closures that we can't inline, we can do some
+ ;; tricks to avoid heap-allocation for the binding itself. Since
+ ;; we know the vals are lambdas, we can set them to their local
+ ;; var slots first, then capture their bindings, mutating them in
+ ;; place.
+ (let ((RA (if (eq? context 'tail) #f (make-label))))
+ (for-each
+ (lambda (x v)
+ (cond
+ ((hashq-ref allocation x)
+ ;; allocating a closure
+ (emit-code #f (flatten-lambda x v allocation))
+ (if (not (null? (cddr (hashq-ref allocation x))))
+ ;; Need to make-closure first, but with a temporary #f
+ ;; free-variables vector, so we are mutating fresh
+ ;; closures on the heap.
+ (begin
+ (emit-code #f (make-glil-const #f))
+ (emit-code #f (make-glil-call 'make-closure 2))))
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ (,loc (error "badness" x loc))))
+ (else
+ ;; labels allocation: emit label & body, but jump over it
+ (let ((POST (make-label)))
+ (emit-branch #f 'br POST)
+ (emit-label v)
+ ;; we know the lambda vars are a list
+ (emit-bindings #f (lambda-names x) (lambda-vars x)
+ allocation self emit-code)
+ (if (lambda-src x)
+ (emit-code #f (make-glil-source (lambda-src x))))
+ (comp-fix (lambda-body x) RA)
+ (emit-code #f (make-glil-unbind))
+ (emit-label POST)))))
+ vals
+ vars)
+ ;; Emit bindings metadata for closures
+ (let ((binds (let lp ((out '()) (vars vars) (names names))
+ (cond ((null? vars) (reverse! out))
+ ((assq (car vars) fix-labels)
+ (lp out (cdr vars) (cdr names)))
+ (else
+ (lp (acons (car vars) (car names) out)
+ (cdr vars) (cdr names)))))))
+ (emit-bindings src (map cdr binds) (map car binds)
+ allocation self emit-code))
+ ;; Now go back and fix up the bindings for closures.
+ (for-each
+ (lambda (x v)
+ (let ((free-locs (if (hashq-ref allocation x)
+ (cddr (hashq-ref allocation x))
+ ;; can hit this latter case for labels allocation
+ '())))
+ (if (not (null? free-locs))
+ (begin
+ (for-each
+ (lambda (loc)
+ (pmatch loc
+ ((,local? ,boxed? . ,n)
+ (emit-code #f (make-glil-lexical local? #f 'ref n)))
+ (else (error "what" x loc))))
+ free-locs)
+ (emit-code #f (make-glil-call 'vector (length free-locs)))
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'fix n)))
+ (,loc (error "badness" x loc)))))))
+ vals
+ vars)
+ (comp-tail body)
+ (emit-label RA)
+ (emit-code #f (make-glil-unbind))))
+
+ ((<let-values> src names vars exp body)
+ (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
+ (cond
+ ((pair? inames)
+ (lp (cons (car inames) names) (cons (car ivars) vars)
+ (cdr inames) (cdr ivars) #f))
+ ((not (null? inames))
+ (lp (cons inames names) (cons ivars vars) '() '() #t))
+ (else
+ (let ((names (reverse! names))
+ (vars (reverse! vars))
+ (MV (make-label)))
+ (comp-vals exp MV)
+ (emit-code #f (make-glil-const 1))
+ (emit-label MV)
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list names vars allocation self)
+ rest?))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "badness" x loc))))
+ (reverse vars))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind))))))))))
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
new file mode 100644
index 000000000..9b66d9ed5
--- /dev/null
+++ b/module/language/tree-il/fix-letrec.scm
@@ -0,0 +1,240 @@
+;;; transformation of letrec into simpler forms
+
+;; 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (language tree-il fix-letrec)
+ #:use-module (system base syntax)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:export (fix-letrec!))
+
+;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
+;; Efficient Implementation of Scheme’s Recursive Binding Construct", by
+;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
+
+(define fix-fold
+ (make-tree-il-folder unref ref set simple lambda complex))
+
+(define (simple-expression? x bound-vars)
+ (record-case x
+ ((<void>) #t)
+ ((<const>) #t)
+ ((<lexical-ref> gensym)
+ (not (memq gensym bound-vars)))
+ ((<conditional> test then else)
+ (and (simple-expression? test bound-vars)
+ (simple-expression? then bound-vars)
+ (simple-expression? else bound-vars)))
+ ((<sequence> exps)
+ (and-map (lambda (x) (simple-expression? x bound-vars))
+ exps))
+ ((<application> proc args)
+ (and (primitive-ref? proc)
+ (effect-free-primitive? (primitive-ref-name proc))
+ (and-map (lambda (x) (simple-expression? x bound-vars))
+ args)))
+ (else #f)))
+
+(define (partition-vars x)
+ (let-values
+ (((unref ref set simple lambda* complex)
+ (fix-fold x
+ (lambda (x unref ref set simple lambda* complex)
+ (record-case x
+ ((<lexical-ref> gensym)
+ (values (delq gensym unref)
+ (lset-adjoin eq? ref gensym)
+ set
+ simple
+ lambda*
+ complex))
+ ((<lexical-set> gensym)
+ (values unref
+ ref
+ (lset-adjoin eq? set gensym)
+ simple
+ lambda*
+ complex))
+ ((<letrec> vars)
+ (values (append vars unref)
+ ref
+ set
+ simple
+ lambda*
+ complex))
+ ((<let> vars)
+ (values (append vars unref)
+ ref
+ set
+ simple
+ lambda*
+ complex))
+ (else
+ (values unref ref set simple lambda* complex))))
+ (lambda (x unref ref set simple lambda* complex)
+ (record-case x
+ ((<letrec> (orig-vars vars) vals)
+ (let lp ((vars orig-vars) (vals vals)
+ (s '()) (l '()) (c '()))
+ (cond
+ ((null? vars)
+ (values unref
+ ref
+ set
+ (append s simple)
+ (append l lambda*)
+ (append c complex)))
+ ((memq (car vars) unref)
+ (lp (cdr vars) (cdr vals)
+ s l c))
+ ((memq (car vars) set)
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c)))
+ ((lambda? (car vals))
+ (lp (cdr vars) (cdr vals)
+ s (cons (car vars) l) c))
+ ((simple-expression? (car vals) orig-vars)
+ (lp (cdr vars) (cdr vals)
+ (cons (car vars) s) l c))
+ (else
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c))))))
+ ((<let> (orig-vars vars) vals)
+ ;; The point is to compile let-bound lambdas as
+ ;; efficiently as we do letrec-bound lambdas, so
+ ;; we use the same algorithm for analyzing the
+ ;; vars. There is no problem recursing into the
+ ;; bindings after the let, because all variables
+ ;; have been renamed.
+ (let lp ((vars orig-vars) (vals vals)
+ (s '()) (l '()) (c '()))
+ (cond
+ ((null? vars)
+ (values unref
+ ref
+ set
+ (append s simple)
+ (append l lambda*)
+ (append c complex)))
+ ((memq (car vars) unref)
+ (lp (cdr vars) (cdr vals)
+ s l c))
+ ((memq (car vars) set)
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c)))
+ ((and (lambda? (car vals))
+ (not (memq (car vars) set)))
+ (lp (cdr vars) (cdr vals)
+ s (cons (car vars) l) c))
+ ;; There is no difference between simple and
+ ;; complex, for the purposes of let. Just lump
+ ;; them all into complex.
+ (else
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c))))))
+ (else
+ (values unref ref set simple lambda* complex))))
+ '()
+ '()
+ '()
+ '()
+ '()
+ '())))
+ (values unref simple lambda* complex)))
+
+(define (fix-letrec! x)
+ (let-values (((unref simple lambda* complex) (partition-vars x)))
+ (post-order!
+ (lambda (x)
+ (record-case x
+
+ ;; Sets to unreferenced variables may be replaced by their
+ ;; expression, called for effect.
+ ((<lexical-set> gensym exp)
+ (if (memq gensym unref)
+ (make-sequence #f (list exp (make-void #f)))
+ x))
+
+ ((<letrec> src names vars vals body)
+ (let ((binds (map list vars names vals)))
+ (define (lookup set)
+ (map (lambda (v) (assq v binds))
+ (lset-intersection eq? vars set)))
+ (let ((u (lookup unref))
+ (s (lookup simple))
+ (l (lookup lambda*))
+ (c (lookup complex)))
+ ;; Bind "simple" bindings, and locations for complex
+ ;; bindings.
+ (make-let
+ src
+ (append (map cadr s) (map cadr c))
+ (append (map car s) (map car c))
+ (append (map caddr s) (map (lambda (x) (make-void #f)) c))
+ ;; Bind lambdas using the fixpoint operator.
+ (make-fix
+ src (map cadr l) (map car l) (map caddr l)
+ (make-sequence
+ src
+ (append
+ ;; The right-hand-sides of the unreferenced
+ ;; bindings, for effect.
+ (map caddr u)
+ (if (null? c)
+ ;; No complex bindings, just emit the body.
+ (list body)
+ (list
+ ;; Evaluate the the "complex" bindings, in a `let' to
+ ;; indicate that order doesn't matter, and bind to
+ ;; their variables.
+ (let ((tmps (map (lambda (x) (gensym)) c)))
+ (make-let
+ #f (map cadr c) tmps (map caddr c)
+ (make-sequence
+ #f
+ (map (lambda (x tmp)
+ (make-lexical-set
+ #f (cadr x) (car x)
+ (make-lexical-ref #f (cadr x) tmp)))
+ c tmps))))
+ ;; Finally, the body.
+ body)))))))))
+
+ ((<let> src names vars vals body)
+ (let ((binds (map list vars names vals)))
+ (define (lookup set)
+ (map (lambda (v) (assq v binds))
+ (lset-intersection eq? vars set)))
+ (let ((u (lookup unref))
+ (l (lookup lambda*))
+ (c (lookup complex)))
+ (make-sequence
+ src
+ (append
+ ;; unreferenced bindings, called for effect.
+ (map caddr u)
+ (list
+ ;; unassigned lambdas use fix.
+ (make-fix src (map cadr l) (map car l) (map caddr l)
+ ;; and the "complex" bindings.
+ (make-let src (map cadr c) (map car c) (map caddr c)
+ body))))))))
+
+ (else x)))
+ x)))
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
new file mode 100644
index 000000000..adc3f18bd
--- /dev/null
+++ b/module/language/tree-il/inline.scm
@@ -0,0 +1,81 @@
+;;; a simple inliner
+
+;; 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (language tree-il inline)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:export (inline!))
+
+;; 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"
+
+;; This is a completely brain-dead optimization pass whose sole claim to
+;; fame is ((lambda () x)) => x.
+(define (inline! x)
+ (post-order!
+ (lambda (x)
+ (record-case x
+ ((<application> src proc args)
+ (cond
+
+ ;; ((lambda () x)) => x
+ ((and (lambda? proc) (null? (lambda-vars proc))
+ (null? args))
+ (lambda-body proc))
+
+ ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
+ ;; => (let-values (((a b . c) foo)) bar)
+ ;;
+ ;; Note that this is a singly-binding form of let-values. Also
+ ;; note that Scheme's let-values expands into call-with-values,
+ ;; then here we reduce it to tree-il's let-values.
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@call-with-values)
+ (= (length args) 2)
+ (lambda? (cadr args)))
+ (let ((producer (car args))
+ (consumer (cadr args)))
+ (make-let-values src
+ (lambda-names consumer)
+ (lambda-vars consumer)
+ (if (and (lambda? producer)
+ (null? (lambda-names producer)))
+ (lambda-body producer)
+ (make-application src producer '()))
+ (lambda-body consumer))))
+
+ (else #f)))
+
+ ((<let> vars body)
+ (if (null? vars) body x))
+
+ ((<letrec> vars body)
+ (if (null? vars) body x))
+
+ ((<fix> vars body)
+ (if (null? vars) body x))
+
+ (else #f)))
+ x))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
new file mode 100644
index 000000000..0e490a636
--- /dev/null
+++ b/module/language/tree-il/optimize.scm
@@ -0,0 +1,35 @@
+;;; Tree-il optimizer
+
+;; 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language tree-il optimize)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:use-module (language tree-il inline)
+ #:use-module (language tree-il fix-letrec)
+ #:export (optimize!))
+
+(define (env-module e)
+ (if e (car e) (current-module)))
+
+(define (optimize! x env opts)
+ (inline!
+ (fix-letrec!
+ (expand-primitives!
+ (resolve-primitives! x (env-module env))))))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
new file mode 100644
index 000000000..955c7bf25
--- /dev/null
+++ b/module/language/tree-il/primitives.scm
@@ -0,0 +1,287 @@
+;;; open-coding primitive procedures
+
+;; 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language tree-il primitives)
+ #:use-module (system base pmatch)
+ #:use-module (rnrs bytevector)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:use-module (srfi srfi-16)
+ #:export (resolve-primitives! add-interesting-primitive!
+ expand-primitives! effect-free-primitive?))
+
+(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
+
+ vector-ref vector-set!
+
+ bytevector-u8-ref bytevector-u8-set!
+ bytevector-s8-ref bytevector-s8-set!
+
+ bytevector-u16-ref bytevector-u16-set!
+ bytevector-u16-native-ref bytevector-u16-native-set!
+ bytevector-s16-ref bytevector-s16-set!
+ bytevector-s16-native-ref bytevector-s16-native-set!
+
+ bytevector-u32-ref bytevector-u32-set!
+ bytevector-u32-native-ref bytevector-u32-native-set!
+ bytevector-s32-ref bytevector-s32-set!
+ bytevector-s32-native-ref bytevector-s32-native-set!
+
+ bytevector-u64-ref bytevector-u64-set!
+ bytevector-u64-native-ref bytevector-u64-native-set!
+ bytevector-s64-ref bytevector-s64-set!
+ bytevector-s64-native-ref bytevector-s64-native-set!
+
+ bytevector-ieee-single-ref bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+ bytevector-ieee-double-ref bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!))
+
+(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 *effect-free-primitives*
+ '(values
+ eq? eqv? equal?
+ = < > <= >= zero?
+ + * - / 1- 1+ quotient remainder modulo
+ not
+ pair? null? list? acons cons cons*
+ list vector
+ car 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
+ vector-ref
+ bytevector-u8-ref bytevector-s8-ref
+ bytevector-u16-ref bytevector-u16-native-ref
+ bytevector-s16-ref bytevector-s16-native-ref
+ bytevector-u32-ref bytevector-u32-native-ref
+ bytevector-s32-ref bytevector-s32-native-ref
+ bytevector-u64-ref bytevector-u64-native-ref
+ bytevector-s64-ref bytevector-s64-native-ref
+ bytevector-ieee-single-ref bytevector-ieee-single-native-ref
+ bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+
+
+(define *effect-free-primitive-table* (make-hash-table))
+
+(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t))
+ *effect-free-primitives*)
+
+(define (effect-free-primitive? prim)
+ (hashq-ref *effect-free-primitive-table* prim))
+
+(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))
+ (lambda (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
+ (and=> (hashq-ref *interesting-primitive-vars*
+ (module-variable m name))
+ (lambda (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)
+ (pmatch exp
+ ((if ,test ,then ,else)
+ `(if ,test
+ ,(consequent then)
+ ,(consequent else)))
+ (else
+ `(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 zero? (x)
+ (= x 0))
+
+(define-primitive-expander +
+ () 0
+ (x) x
+ (x y) (if (and (const? y)
+ (let ((y (const-exp y)))
+ (and (exact? y) (= y 1))))
+ (1+ x)
+ (if (and (const? x)
+ (let ((x (const-exp x)))
+ (and (exact? x) (= x 1))))
+ (1+ y)
+ (+ x y)))
+ (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) (if (and (const? y)
+ (let ((y (const-exp y)))
+ (and (exact? y) (= y 1))))
+ (1- x)
+ (- x y))
+ (x y z . rest) (- x (+ y z . rest)))
+
+(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/tree-il/spec.scm b/module/language/tree-il/spec.scm
new file mode 100644
index 000000000..2d24f7bf6
--- /dev/null
+++ b/module/language/tree-il/spec.scm
@@ -0,0 +1,42 @@
+;;; Tree Intermediate Language
+
+;; 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language tree-il spec)
+ #:use-module (system base language)
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il compile-glil)
+ #:export (tree-il))
+
+(define (write-tree-il exp . port)
+ (apply write (unparse-tree-il exp) port))
+
+(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/language/value/spec.scm b/module/language/value/spec.scm
index 51f5e6c66..aebba8c8d 100644
--- a/module/language/value/spec.scm
+++ b/module/language/value/spec.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/oop/Makefile.am b/module/oop/Makefile.am
deleted file mode 100644
index 83c342abc..000000000
--- a/module/oop/Makefile.am
+++ /dev/null
@@ -1,30 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-##
-## Copyright (C) 2000, 2004, 2006, 2008 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE is free software; you can redistribute it and/or modify
-## it under the terms of the GNU General Public License as
-## published by the Free Software Foundation; either version 2, or
-## (at your option) any later version.
-##
-## GUILE is distributed in the hope that it will be useful, but
-## WITHOUT ANY WARRANTY; without even the implied warranty of
-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU General Public License for more details.
-##
-## You should have received a copy of the GNU General Public
-## License along with GUILE; see the file COPYING. If not, write
-## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-## Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-SUBDIRS = goops
-
-modpath = oop
-SOURCES = goops.scm
-include $(top_srcdir)/am/guilec
-
-EXTRA_DIST += ChangeLog-2008
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 2254f93e5..c1754da3e 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -154,17 +154,6 @@
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
-(define (define-class-pre-definition kw val)
- (case kw
- ((#:getter #:setter)
- `(if (or (not (defined? ',val))
- (not (is-a? ,val <generic>)))
- (define-generic ,val)))
- ((#:accessor)
- `(if (or (not (defined? ',val))
- (not (is-a? ,val <accessor>)))
- (define-accessor ,val)))
- (else #f)))
(define (kw-do-map mapper f kwargs)
(define (keywords l)
@@ -180,31 +169,37 @@
(a (args kwargs)))
(mapper f k a)))
-;;; This code should be implemented in C.
-;;;
-(define-macro (define-class name supers . slots)
- ;; Some slot options require extra definitions to be made. In
- ;; particular, we want to make sure that the generic function objects
- ;; which represent accessors exist before `make-class' tries to add
- ;; methods to them.
- ;;
- ;; Postpone some error handling to class macro.
- ;;
- `(begin
- ;; define accessors
- ,@(append-map (lambda (slot)
- (kw-do-map filter-map
- define-class-pre-definition
- (if (pair? slot) (cdr slot) '())))
- (take-while (lambda (x) (not (keyword? x))) slots))
- (if (and (defined? ',name)
- (is-a? ,name <class>)
- (memq <object> (class-precedence-list ,name)))
- (class-redefinition ,name
- (class ,supers ,@slots #:name ',name))
- (define ,name (class ,supers ,@slots #:name ',name)))))
-
-(define standard-define-class define-class)
+(define (make-class supers slots . options)
+ (let ((env (or (get-keyword #:environment options #f)
+ (top-level-env))))
+ (let* ((name (get-keyword #:name options (make-unbound)))
+ (supers (if (not (or-map (lambda (class)
+ (memq <object>
+ (class-precedence-list class)))
+ supers))
+ (append supers (list <object>))
+ supers))
+ (metaclass (or (get-keyword #:metaclass options #f)
+ (ensure-metaclass supers env))))
+
+ ;; Verify that all direct slots are different and that we don't inherit
+ ;; several time from the same class
+ (let ((tmp1 (find-duplicate supers))
+ (tmp2 (find-duplicate (map slot-definition-name slots))))
+ (if tmp1
+ (goops-error "make-class: super class ~S is duplicate in class ~S"
+ tmp1 name))
+ (if tmp2
+ (goops-error "make-class: slot ~S is duplicate in class ~S"
+ tmp2 name)))
+
+ ;; Everything seems correct, build the class
+ (apply make metaclass
+ #:dsupers supers
+ #:slots slots
+ #:name name
+ #:environment env
+ options))))
;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
@@ -229,7 +224,6 @@
(else
`(list ',def))))
slots))
-
(if (not (list? supers))
(goops-error "malformed superclass list: ~S" supers))
(let ((slot-defs (cons #f '()))
@@ -243,37 +237,71 @@
;; evaluate class options
,@options)))
-(define (make-class supers slots . options)
- (let ((env (or (get-keyword #:environment options #f)
- (top-level-env))))
- (let* ((name (get-keyword #:name options (make-unbound)))
- (supers (if (not (or-map (lambda (class)
- (memq <object>
- (class-precedence-list class)))
- supers))
- (append supers (list <object>))
- supers))
- (metaclass (or (get-keyword #:metaclass options #f)
- (ensure-metaclass supers env))))
-
- ;; Verify that all direct slots are different and that we don't inherit
- ;; several time from the same class
- (let ((tmp1 (find-duplicate supers))
- (tmp2 (find-duplicate (map slot-definition-name slots))))
- (if tmp1
- (goops-error "make-class: super class ~S is duplicate in class ~S"
- tmp1 name))
- (if tmp2
- (goops-error "make-class: slot ~S is duplicate in class ~S"
- tmp2 name)))
-
- ;; Everything seems correct, build the class
- (apply make metaclass
- #:dsupers supers
- #:slots slots
- #:name name
- #:environment env
- options))))
+(define-syntax define-class-pre-definition
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (k arg rest ...) out ...)
+ (keyword? (syntax->datum (syntax k)))
+ (case (syntax->datum (syntax k))
+ ((#:getter #:setter)
+ (syntax
+ (define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <generic>)))
+ (toplevel-define!
+ 'arg
+ (ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
+ ((#:accessor)
+ (syntax
+ (define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <accessor>)))
+ (toplevel-define!
+ 'arg
+ (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
+ (else
+ (syntax
+ (define-class-pre-definition (rest ...) out ...)))))
+ ((_ () out ...)
+ (syntax (begin out ...))))))
+
+;; Some slot options require extra definitions to be made. In
+;; particular, we want to make sure that the generic function objects
+;; which represent accessors exist before `make-class' tries to add
+;; methods to them.
+(define-syntax define-class-pre-definitions
+ (lambda (x)
+ (syntax-case x ()
+ ((_ () out ...)
+ (syntax (begin out ...)))
+ ((_ (slot rest ...) out ...)
+ (keyword? (syntax->datum (syntax slot)))
+ (syntax (begin out ...)))
+ ((_ (slot rest ...) out ...)
+ (identifier? (syntax slot))
+ (syntax (define-class-pre-definitions (rest ...)
+ out ...)))
+ ((_ ((slotname slotopt ...) rest ...) out ...)
+ (syntax (define-class-pre-definitions (rest ...)
+ out ... (define-class-pre-definition (slotopt ...))))))))
+
+(define-syntax define-class
+ (syntax-rules ()
+ ((_ name supers slot ...)
+ (begin
+ (define-class-pre-definitions (slot ...))
+ (if (and (defined? 'name)
+ (is-a? name <class>)
+ (memq <object> (class-precedence-list name)))
+ (class-redefinition name
+ (class supers slot ... #:name 'name))
+ (toplevel-define! 'name (class supers slot ... #:name 'name)))))))
+
+(define-syntax standard-define-class
+ (syntax-rules ()
+ ((_ arg ...) (define-class arg ...))))
;;;
;;; {Generic functions and accessors}
@@ -363,13 +391,13 @@
(else (make <generic> #:name name)))))
;; same semantics as <generic>
-(define-macro (define-accessor name)
- (if (not (symbol? name))
- (goops-error "bad accessor name: ~S" name))
- `(define ,name
- (if (and (defined? ',name) (is-a? ,name <accessor>))
- (make <accessor> #:name ',name)
- (ensure-accessor (if (defined? ',name) ,name #f) ',name))))
+(define-syntax define-accessor
+ (syntax-rules ()
+ ((_ name)
+ (define name
+ (cond ((not (defined? 'name)) (ensure-accessor #f 'name))
+ ((is-a? name <accessor>) (make <accessor> #:name 'name))
+ (else (ensure-accessor name 'name)))))))
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
@@ -424,78 +452,132 @@
;;; {Methods}
;;;
-(define-macro (define-method head . body)
- (if (not (pair? head))
- (goops-error "bad method head: ~S" head))
- (let ((gf (car head)))
- (cond ((and (pair? gf)
- (eq? (car gf) 'setter)
- (pair? (cdr gf))
- (symbol? (cadr gf))
- (null? (cddr gf)))
- ;; named setter method
- (let ((name (cadr gf)))
- (cond ((not (symbol? name))
- `(add-method! (setter ,name)
- (method ,(cdr head) ,@body)))
- (else
- `(begin
- (if (or (not (defined? ',name))
- (not (is-a? ,name <accessor>)))
- (define-accessor ,name))
- (add-method! (setter ,name)
- (method ,(cdr head) ,@body)))))))
- ((not (symbol? gf))
- `(add-method! ,gf (method ,(cdr head) ,@body)))
- (else
- `(begin
- ;; FIXME: this code is how it always was, but it's quite
- ;; cracky: it will only define the generic function if it
- ;; was undefined before (ok), or *was defined to #f*. The
- ;; latter is crack. But there are bootstrap issues about
- ;; fixing this -- change it to (is-a? ,gf <generic>) and
- ;; see.
- (if (or (not (defined? ',gf))
- (not ,gf))
- (define-generic ,gf))
- (add-method! ,gf
- (method ,(cdr head) ,@body)))))))
-
-(define-macro (method args . body)
- (letrec ((specializers
- (lambda (ls)
- (cond ((null? ls) (list (list 'quote '())))
- ((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 (toplevel-define! name val)
+ (module-define! (current-module) name val))
+
+(define-syntax define-method
+ (syntax-rules (setter)
+ ((_ ((setter name) . args) body ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (is-a? name <accessor>)))
+ (toplevel-define! 'name
+ (ensure-accessor
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! (setter name) (method args body ...))))
+ ((_ (name . args) body ...)
+ (begin
+ ;; FIXME: this code is how it always was, but it's quite cracky:
+ ;; it will only define the generic function if it was undefined
+ ;; before (ok), or *was defined to #f*. The latter is crack. But
+ ;; there are bootstrap issues about fixing this -- change it to
+ ;; (is-a? name <generic>) and see.
+ (if (or (not (defined? 'name))
+ (not name))
+ (toplevel-define! 'name (make <generic> #:name 'name)))
+ (add-method! name (method args 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!}
@@ -1046,27 +1128,9 @@
;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
(eval-when (compile)
- (use-modules ((language scheme compile-ghil) :select (define-scheme-translator))
- ((language ghil) :select (make-ghil-inline make-ghil-call))
- (system base pmatch))
-
- ;; unfortunately, can't use define-inline because these are primitive
- ;; syntaxen.
- (define-scheme-translator @slot-ref
- ((,obj ,index) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-ref
- (list (retrans obj) (retrans index))))
- (else
- (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))
-
- (define-scheme-translator @slot-set!
- ((,obj ,index ,val) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-set
- (list (retrans obj) (retrans index) (retrans val))))
- (else
- (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))))
+ (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/Makefile.am b/module/oop/goops/Makefile.am
deleted file mode 100644
index 0c90ac49f..000000000
--- a/module/oop/goops/Makefile.am
+++ /dev/null
@@ -1,30 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-##
-## Copyright (C) 2000, 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE is free software; you can redistribute it and/or modify
-## it under the terms of the GNU General Public License as
-## published by the Free Software Foundation; either version 2, or
-## (at your option) any later version.
-##
-## GUILE is distributed in the hope that it will be useful, but
-## WITHOUT ANY WARRANTY; without even the implied warranty of
-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU General Public License for more details.
-##
-## You should have received a copy of the GNU General Public
-## License along with GUILE; see the file COPYING. If not, write
-## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-## Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-modpath = oop/goops
-SOURCES = \
- active-slot.scm compile.scm composite-slot.scm describe.scm \
- dispatch.scm internal.scm save.scm stklos.scm util.scm \
- accessors.scm simple.scm
-
-include $(top_srcdir)/am/guilec
diff --git a/module/oop/goops/accessors.scm b/module/oop/goops/accessors.scm
index a7baa5c62..5b05d3b15 100644
--- a/module/oop/goops/accessors.scm
+++ b/module/oop/goops/accessors.scm
@@ -1,19 +1,18 @@
;;;; Copyright (C) 1999, 2000, 2005, 2006 Free Software Foundation, Inc.
;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
-;;;; This 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.
+;;;; 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 General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;;;; Boston, MA 02110-1301 USA
+;;;; 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
;;;;
diff --git a/module/oop/goops/active-slot.scm b/module/oop/goops/active-slot.scm
index e6b409ad0..5cd2afe10 100644
--- a/module/oop/goops/active-slot.scm
+++ b/module/oop/goops/active-slot.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm
index 3962be4bc..5db406cd0 100644
--- a/module/oop/goops/compile.scm
+++ b/module/oop/goops/compile.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -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
)
@@ -34,11 +34,12 @@
(define code-table-lookup
(letrec ((check-entry (lambda (entry types)
- (if (null? types)
- (and (not (struct? (car entry)))
- entry)
- (and (eq? (car entry) (car types))
- (check-entry (cdr entry) (cdr types)))))))
+ (cond
+ ((not (pair? entry)) (and (null? types) entry))
+ ((null? types) #f)
+ (else
+ (and (eq? (car entry) (car types))
+ (check-entry (cdr entry) (cdr types))))))))
(lambda (code-table types)
(cond ((null? code-table) #f)
((check-entry (car code-table) types))
@@ -60,9 +61,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 +70,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/oop/goops/composite-slot.scm b/module/oop/goops/composite-slot.scm
index 9bf5cf8f8..b3f8cc038 100644
--- a/module/oop/goops/composite-slot.scm
+++ b/module/oop/goops/composite-slot.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/oop/goops/describe.scm b/module/oop/goops/describe.scm
index 184fef214..fa7bc466c 100644
--- a/module/oop/goops/describe.scm
+++ b/module/oop/goops/describe.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index a54044729..0dd169d59 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -209,9 +209,8 @@
;;;
;; Backward compatibility
-(if (not (defined? 'lookup-create-cmethod))
- (define (lookup-create-cmethod gf args)
- (no-applicable-method (car args) (cadr args))))
+(define (lookup-create-cmethod gf args)
+ (no-applicable-method (car args) (cadr args)))
(define (memoize-method! gf args exp)
(if (not (slot-ref gf 'used-by))
diff --git a/module/oop/goops/internal.scm b/module/oop/goops/internal.scm
index d996805e4..15919d44b 100644
--- a/module/oop/goops/internal.scm
+++ b/module/oop/goops/internal.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm
index 4d64da8bb..0c7d71a2d 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -110,9 +110,7 @@
;;; Readables
;;;
-(if (or (not (defined? 'readables))
- (not readables))
- (define readables (make-weak-key-hash-table 61)))
+(define readables (make-weak-key-hash-table 61))
(define-macro (readable exp)
`(make-readable ,exp ',(copy-tree exp)))
diff --git a/module/oop/goops/simple.scm b/module/oop/goops/simple.scm
index 48e76f312..bc5405a8d 100644
--- a/module/oop/goops/simple.scm
+++ b/module/oop/goops/simple.scm
@@ -5,7 +5,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -23,6 +23,9 @@
:export (define-class)
:no-backtrace)
-(define define-class define-class-with-accessors-keywords)
+(define-syntax define-class
+ (syntax-rules ()
+ ((_ arg ...)
+ (define-class-with-accessors-keywords arg ...))))
(module-use! %module-public-interface (resolve-interface '(oop goops)))
diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm
index 60ab293c3..835969f13 100644
--- a/module/oop/goops/stklos.scm
+++ b/module/oop/goops/stklos.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -47,51 +47,30 @@
;;; Enable keyword support (*fixme*---currently this has global effect)
(read-set! keywords 'prefix)
-(define standard-define-class-transformer
- (macro-transformer standard-define-class))
+(define-syntax define-class
+ (syntax-rules ()
+ ((_ name supers (slot ...) rest ...)
+ (standard-define-class name supers slot ... rest ...))))
-(define define-class
- ;; Syntax
- (let ((name cadr)
- (supers caddr)
- (slots cadddr)
- (rest cddddr))
- (procedure->memoizing-macro
- (lambda (exp env)
- (standard-define-class-transformer
- `(define-class ,(name exp) ,(supers exp) ,@(slots exp)
- ,@(rest exp))
- env)))))
+(define (toplevel-define! name val)
+ (module-define! (current-module) name val))
-(define define-method
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp)))
- (if (and (pair? name)
- (eq? (car name) 'setter)
- (pair? (cdr name))
- (null? (cddr name)))
- (let ((name (cadr name)))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
- `(begin
- (if (not (is-a? ,name <generic-with-setter>))
- (define-accessor ,name))
- (add-method! (setter ,name) (method ,@(cddr exp)))))
- (else
- `(begin
- (define-accessor ,name)
- (add-method! (setter ,name) (method ,@(cddr exp)))))))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
- `(begin
- (if (not (or (is-a? ,name <generic>)
- (is-a? ,name <primitive-generic>)))
- (define-generic ,name))
- (add-method! ,name (method ,@(cddr exp)))))
- (else
- `(begin
- (define-generic ,name)
- (add-method! ,name (method ,@(cddr exp)))))))))))
+(define-syntax define-method
+ (syntax-rules (setter)
+ ((_ (setter name) rest ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (is-a? name <generic-with-setter>)))
+ (toplevel-define! 'name
+ (ensure-accessor
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! (setter name) (method rest ...))))
+ ((_ name rest ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (or (is-a? name <generic>)
+ (is-a? name <primitive-generic>))))
+ (toplevel-define! 'name
+ (ensure-generic
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! name (method rest ...))))))
diff --git a/module/oop/goops/util.scm b/module/oop/goops/util.scm
index b6276aa37..69bb898bf 100644
--- a/module/oop/goops/util.scm
+++ b/module/oop/goops/util.scm
@@ -3,7 +3,7 @@
;;;; 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.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm
new file mode 100644
index 000000000..32929c698
--- /dev/null
+++ b/module/rnrs/bytevector.scm
@@ -0,0 +1,85 @@
+;;;; bytevector.scm --- R6RS bytevector API
+
+;;;; 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+;;;
+;;; A "bytevector" is a raw bit string. This module provides procedures to
+;;; manipulate bytevectors and interpret their contents in a number of ways:
+;;; bytevector contents can be accessed as signed or unsigned integer of
+;;; various sizes and endianness, as IEEE-754 floating point numbers, or as
+;;; strings. It is a useful tool to decode binary data.
+;;;
+;;; Code:
+
+(define-module (rnrs bytevector)
+ :export-syntax (endianness)
+ :export (native-endianness bytevector?
+ make-bytevector bytevector-length bytevector=? bytevector-fill!
+ bytevector-copy! bytevector-copy
+ uniform-array->bytevector
+ bytevector-u8-ref bytevector-s8-ref
+ bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
+ u8-list->bytevector
+ bytevector-uint-ref bytevector-uint-set!
+ bytevector-sint-ref bytevector-sint-set!
+ bytevector->sint-list bytevector->uint-list
+ uint-list->bytevector sint-list->bytevector
+
+ bytevector-u16-ref bytevector-s16-ref
+ bytevector-u16-set! bytevector-s16-set!
+ bytevector-u16-native-ref bytevector-s16-native-ref
+ bytevector-u16-native-set! bytevector-s16-native-set!
+
+ bytevector-u32-ref bytevector-s32-ref
+ bytevector-u32-set! bytevector-s32-set!
+ bytevector-u32-native-ref bytevector-s32-native-ref
+ bytevector-u32-native-set! bytevector-s32-native-set!
+
+ bytevector-u64-ref bytevector-s64-ref
+ bytevector-u64-set! bytevector-s64-set!
+ bytevector-u64-native-ref bytevector-s64-native-ref
+ bytevector-u64-native-set! bytevector-s64-native-set!
+
+ bytevector-ieee-single-ref
+ bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref
+ bytevector-ieee-single-native-set!
+
+ bytevector-ieee-double-ref
+ bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref
+ bytevector-ieee-double-native-set!
+
+ string->utf8 string->utf16 string->utf32
+ utf8->string utf16->string utf32->string))
+
+
+(load-extension "libguile" "scm_init_bytevectors")
+
+(define-macro (endianness sym)
+ (if (memq sym '(big little))
+ `(quote ,sym)
+ (error "unsupported endianness" sym)))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; bytevector.scm ends here
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
new file mode 100644
index 000000000..d1b96b31a
--- /dev/null
+++ b/module/rnrs/io/ports.scm
@@ -0,0 +1,111 @@
+;;;; ports.scm --- R6RS port API
+
+;;;; 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 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+;;;
+;;; The I/O port API of the R6RS is provided by this module. In many areas
+;;; it complements or refines Guile's own historical port API. For instance,
+;;; it allows for binary I/O with bytevectors.
+;;;
+;;; Code:
+
+(define-module (rnrs io ports)
+ :re-export (eof-object? port? input-port? output-port?)
+ :export (eof-object
+
+ ;; input & output ports
+ port-transcoder binary-port? transcoded-port
+ port-position set-port-position!
+ port-has-port-position? port-has-set-port-position!?
+ call-with-port
+
+ ;; input ports
+ open-bytevector-input-port
+ make-custom-binary-input-port
+
+ ;; binary input
+ get-u8 lookahead-u8
+ get-bytevector-n get-bytevector-n!
+ get-bytevector-some get-bytevector-all
+
+ ;; output ports
+ open-bytevector-output-port
+ make-custom-binary-output-port
+
+ ;; binary output
+ put-u8 put-bytevector))
+
+(load-extension "libguile" "scm_init_r6rs_ports")
+
+
+
+;;;
+;;; Input and output ports.
+;;;
+
+(define (port-transcoder port)
+ (error "port transcoders are not supported" port))
+
+(define (binary-port? port)
+ ;; So far, we don't support transcoders other than the binary transcoder.
+ #t)
+
+(define (transcoded-port port)
+ (error "port transcoders are not supported" port))
+
+(define (port-position port)
+ "Return the offset (an integer) indicating where the next octet will be
+read from/written to in @var{port}."
+
+ ;; FIXME: We should raise an `&assertion' error when not supported.
+ (seek port 0 SEEK_CUR))
+
+(define (set-port-position! port offset)
+ "Set the position where the next octet will be read from/written to
+@var{port}."
+
+ ;; FIXME: We should raise an `&assertion' error when not supported.
+ (seek port offset SEEK_SET))
+
+(define (port-has-port-position? port)
+ "Return @code{#t} is @var{port} supports @code{port-position}."
+ (and (false-if-exception (port-position port)) #t))
+
+(define (port-has-set-port-position!? port)
+ "Return @code{#t} is @var{port} supports @code{set-port-position!}."
+ (and (false-if-exception (set-port-position! port (port-position port)))
+ #t))
+
+(define (call-with-port port proc)
+ "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
+@var{proc}. Return the return values of @var{proc}."
+ (dynamic-wind
+ (lambda ()
+ #t)
+ (lambda ()
+ (proc port))
+ (lambda ()
+ (close-port port))))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; ports.scm ends here
diff --git a/module/scripts/ChangeLog-2008 b/module/scripts/ChangeLog-2008
new file mode 100644
index 000000000..feef87dfd
--- /dev/null
+++ b/module/scripts/ChangeLog-2008
@@ -0,0 +1,319 @@
+2004-11-09 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * snarf-check-and-output-texi (process-multiline-directive): Allow
+ the fname attribute to a sequence of strings and append them all
+ to form the fname. This is needed for string literals like
+ "u8""vector?".
+
+2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am (scripts_sources): Added snarf-guile-m4-docs.
+
+2004-08-06 Kevin Ryde <user42@zip.com.au>
+
+ * scripts/read-rfc822 (parse-message): Correction to header
+ continuation, loop with read-line not cdr lines.
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.
+
+2002-10-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * lint (lint): Add message telling resolved module name.
+
+2002-10-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * snarf-check-and-output-texi (end-multiline): Use '*function-name*'
+ instead of nonexisting 'name'.
+
+2002-10-04 Rob Browning <rlb@defaultvalue.org>
+
+ * summarize-guile-TODO (as-leaf): make #\: a char-set.
+
+2002-05-18 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * api-diff (group-diff): Also output +N and -N adds and subs
+ details, respectively.
+
+2002-05-13 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * read-rfc822: New script.
+
+ * Makefile.am (scripts_sources): Add api-diff and read-rfc822.
+
+ * scan-api (scan-api): No longer include timestamp.
+
+2002-05-11 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api (scan-api): Fix bug: No longer omit `C' and `Scheme' in
+ groups in the presence of the grouper.
+
+ * api-diff: Use modules (ice-9 format), (ice-9 getopt-long).
+ Autoload module (srfi srfi-13).
+ No longer export `diff-alists'.
+
+ (diff, diff-alists, display-list): Remove.
+ (put, get, read-api-alist-file, hang-by-the-roots, diff?,
+ diff+note!, group-diff): New procs.
+ (api-diff): Rewrite.
+
+2002-05-10 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api (add-props): New proc.
+ (make-grok-proc): Renamed from `make-grok-hook'.
+ (make-members-proc): Renamed from `make-members-hook'.
+ (make-grouper): Renamed from `make-grouping-hook'. Update callers.
+ Add handling for multiple grouping-defs files.
+ (scan-api): Add handling for multiple grouping-defs files.
+ Cache `symbol->string' result; adjust `sort' usage.
+
+2002-05-09 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api (scan-C!): Use more robust regexp.
+
+2002-05-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api: New script.
+ (scan-api): Handle case where `grouping-hook' is #f.
+
+ Remove top-level `debug-enable' form.
+ Add TODO comment; nfc.
+
+ * Makefile.am (scripts_sources): Add "scan-api".
+
+2002-04-30 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO (make-display-item):
+ Hoist some lambdas; nfc.
+
+2002-04-29 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: Fix commentary typo; nfc.
+
+2002-04-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: Use (ice-9 getopt-long).
+ Autoload (ice-9 common-list).
+
+ (select-items): New proc.
+ (make-display-item): New proc.
+ (display-item): Delete.
+ (display-items): Use `make-display-item'.
+ (summarize-guile-TODO): Add option handling.
+
+2002-04-07 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: Add "Bugs" section to commentary.
+ Autoload (srfi srfi-13) on `string-tokenize'.
+
+ (as-leaf): New proc.
+ (hang-by-the-leaves): Use `as-leaf'.
+ (read-TODO-file): Expand regexp and specs
+ to handle "D", "X" and "N%". Fix regexp
+ to make isolating `who' easier.
+ (display-item): Handle "D", "X" and "N%".
+
+2002-04-06 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: New script.
+
+ * Makefile.am (scripts_sources): Add "summarize-guile-TODO".
+
+2002-04-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * read-text-outline (display-outline-tree): No longer export this proc.
+
+ (*depth-cue-rx*, *subm-number*, *level-divisor*, >>,
+ display-outline-tree): Delete these vars and procs.
+
+ (??, msub, ??-predicates, make-line-parser,
+ make-text-outline-reader): New procs.
+
+ (make-text-outline-reader): Export.
+ (read-text-outline-silently): Rewrite
+ using `make-text-outline-reader'.
+
+2002-04-04 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * lint: New script.
+
+ * Makefile.am (scripts_sources): Add "lint".
+
+2002-04-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * PROGRAM: Update copyright; nfc.
+
+ * read-text-outline: New script.
+
+ * Makefile.am (scripts_sources): Add "read-text-outline".
+
+ * read-text-outline (read-text-outline-silently):
+ Move `tp' inside `loop'; nfc.
+
+2002-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * snarf-check-and-output-texi (snarf-check-and-output-texi): If
+ supplied, the `--manual' flag arrives as a string, not a symbol,
+ so test for it as such.
+
+2002-03-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * snarf-guile-m4-docs (display-texi): Strip off `# ' from start of
+ docstring lines if possible, rather than just `#'.
+
+2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Update path to pre-inst-guile automake frag.
+
+2002-02-22 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * api-diff: New script.
+
+2002-02-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Include $(top_srcdir)/pre-inst-guile.am.
+
+ (overview): Use $(preinstguiletool).
+
+2002-01-11 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (scripts_sources): Add autofrisk.
+
+ * autofrisk: New script.
+
+ * frisk: Fix typo in commentary; nfc.
+
+ * use2dot: Autoload module (ice-9 getopt-long).
+ Use module (srfi srfi-13).
+ Export `use2dot'.
+
+ (string-append/separator, mapconcat): Delete.
+ (vv): Now take list of pairs, and return the mapping..
+ (>>header): Use `string-join'.
+ (>>): New proc.
+ (use2dot): Use `getopt-long'. Use `>>'.
+
+2002-01-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (scripts_sources): Add frisk.
+ (list): New target.
+ (overview): Also report module interfaces.
+
+ * use2dot: Rewrite using (scripts frisk).
+
+ * frisk: Initial revision.
+
+2002-01-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * snarf-guile-m4-docs: New script.
+
+2001-11-28 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * punify (write-punily): Handle symbols w/ ":" prefix specially.
+
+ * use2dot (ferret): New proc.
+ (grok): Use `ferret'.
+
+2001-11-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * snarf-check-and-output-texi: Change generated @deffn categories
+ from "function" and "primitive" to "C Function" and "Scheme
+ Procedure".
+ (end-multiline): Take out @findex generation again; not needed
+ since index entries are implicit in @deffn forms.
+
+ These changes add a @deffnx C function declaration and function
+ index entries for each Guile primitive to the copy of the doc
+ snarf output that is used for reference manual synchronization.
+ Online help is unchanged.
+
+ * snarf-check-and-output-texi (*manual-flag*,
+ snarf-check-and-output-texi): Handle `--manual' invocation arg
+ passed through from libguile/Makefile.am.
+ (*c-function-name*, begin-multiline, do-command): Pick out C
+ function name from snarfed token stream.
+ (end-multiline): Add @deffnx C declaration and function index
+ entries to output.
+ (*primitive-deffnx-signature*, *primitive-deffnx-sig-length*):
+ Fluff to help insert the C declaration after any "@deffnx
+ primitive" lines in the snarfed docstring.
+
+2001-10-05 Thien-Thi Nguyen <ttn@glug.org>
+
+ * read-scheme-source (quoted?, clump): New procs, exported.
+
+2001-09-30 Thien-Thi Nguyen <ttn@glug.org>
+
+ * display-commentary (module-name->filename-frag,
+ display-module-commentary): New procs.
+ (display-commentary): Also handle refs that look like module
+ names.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".
+
+2001-08-07 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi: print optional args in a prettier
+ manner.
+
+2001-08-01 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, README, display-commentary, doc-snarf,
+ generate-autoload, punify, read-scheme-source,
+ snarf-check-and-output-texi, use2dot:
+ In boilerplate, use -l$0.
+ Thanks to Daniel Skarda.
+
+2001-07-22 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * generate-autoload (autoload-info):
+ Also handle `defmacro-public' forms.
+
+2001-07-14 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, display-commentary, doc-snarf, generate-autoload,
+ punify, read-scheme-source, snarf-check-and-output-texi, use2dot:
+ Re-add authorship info.
+
+2001-07-12 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi (do-argpos): complain to the stderr,
+ not stdout. thanks to Dale P. Smith!
+ (nice-sig): cosmetic fix.
+
+2001-07-09 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, generate-autoload, use2dot, punify, display-commentary,
+ doc-snarf, read-scheme-source, snarf-check-and-output-texi:
+ Remove authorship info.
+
+2001-06-25 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi: rewrite.
+
+2001-05-31 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi: new file.
+
+ * Makefile.am (scripts_sources): add snarf-check-and-output-texi.
+
+2001-05-14 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, display-commentary, doc-snarf, generate-autoload,
+ punify, read-scheme-source, use2dot: Move author tag outside
+ commentary; nfc.
+
+2001-05-08 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * read-scheme-source: New file
+
+ * Makefile.am (scripts_sources): Add read-scheme-source.
+
+2001-04-29 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * Makefile.am, PROGRAM, README, display-commentary,
+ doc-snarf, generate-autoload, punify, use2dot: New file
+
diff --git a/module/scripts/PROGRAM.scm b/module/scripts/PROGRAM.scm
new file mode 100644
index 000000000..56e5cf334
--- /dev/null
+++ b/module/scripts/PROGRAM.scm
@@ -0,0 +1,40 @@
+;;; PROGRAM --- Does something
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: J.R.Hacker
+
+;;; Commentary:
+
+;; Usage: PROGRAM [ARGS]
+;;
+;; PROGRAM does something.
+;;
+;; TODO: Write it!
+
+;;; Code:
+
+(define-module (scripts PROGRAM)
+ :export (PROGRAM))
+
+(define (PROGRAM . args)
+ #t)
+
+(define main PROGRAM)
+
+;;; PROGRAM ends here
diff --git a/module/scripts/README b/module/scripts/README
new file mode 100644
index 000000000..56dd286fb
--- /dev/null
+++ b/module/scripts/README
@@ -0,0 +1,76 @@
+Overview and Usage
+------------------
+
+This directory contains Scheme programs, some useful in maintaining Guile.
+On "make install", these programs are copied to PKGDATADIR/VERSION/scripts.
+
+You can invoke a program from the shell, or alternatively, load its file
+as a Guile Scheme module, and use its exported procedure(s) from Scheme code.
+Typically for any PROGRAM:
+
+ (use-modules (scripts PROGRAM))
+ (PROGRAM ARG1 ARG2 ...)
+
+For programs that write to stdout, you might try, instead:
+
+ (use-modules (scripts PROGRAM))
+ (with-output-to-string (lambda () (PROGRAM ARG1 ARG2 ...)))
+
+Note that all args must be strings.
+
+To see PROGRAM's commentary, which may or may not be helpful:
+
+ (help (scripts PROGRAM))
+
+To see all commentaries and module dependencies, try: "make overview".
+
+If you want to try the programs before installing Guile, you will probably
+need to set environment variable GUILE_LOAD_PATH to be the parent directory.
+This can be done in Bourne-compatible shells like so:
+
+ GUILE_LOAD_PATH=`(cd .. ; pwd)`
+ export GUILE_LOAD_PATH
+
+[FIXME: Can someone supply the csh-compatible equivalent?]
+
+
+
+How to Contribute
+-----------------
+
+See template file PROGRAM for a quick start.
+
+Programs must follow the "executable module" convention, documented here:
+
+- The file name must not end in ".scm".
+
+- The file must be executable (chmod +x).
+
+- The module name must be "(scripts PROGRAM)". A procedure named PROGRAM w/
+ signature "(PROGRAM . args)" must be exported. Basically, use some variant
+ of the form:
+
+ (define-module (scripts PROGRAM)
+ :export (PROGRAM))
+
+ Feel free to export other definitions useful in the module context.
+
+- There must be the alias:
+
+ (define main PROGRAM)
+
+ However, `main' must NOT be exported.
+
+- The beginning of the file must use the following invocation sequence:
+
+ #!/bin/sh
+ main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
+ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+ !#
+
+Following these conventions allows the program file to be used as module
+(scripts PROGRAM) in addition to as a standalone executable. Please also
+include a helpful Commentary section w/ some usage info.
+
+
+[README ends here]
diff --git a/module/scripts/api-diff.scm b/module/scripts/api-diff.scm
new file mode 100644
index 000000000..b842b03ff
--- /dev/null
+++ b/module/scripts/api-diff.scm
@@ -0,0 +1,176 @@
+;;; api-diff --- diff guile-api.alist files
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B
+;;
+;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B
+;; and display a (count) summary of the groups defined therein.
+;; Optional arg "--details" (or "-d") specifies a comma-separated
+;; list of groups, in which case api-diff displays instead the
+;; elements added and deleted for each of the specified groups.
+;;
+;; For scheme programming, this module exports the proc:
+;; (api-diff A-file B-file)
+;;
+;; Note that the convention is that the "older" alist/file is
+;; specified first.
+;;
+;; TODO: Develop scheme interface.
+
+;;; Code:
+
+(define-module (scripts api-diff)
+ :use-module (ice-9 common-list)
+ :use-module (ice-9 format)
+ :use-module (ice-9 getopt-long)
+ :autoload (srfi srfi-13) (string-tokenize)
+ :export (api-diff))
+
+(define (read-alist-file file)
+ (with-input-from-file file
+ (lambda () (read))))
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (read-api-alist-file file)
+ (let* ((alist (read-alist-file file))
+ (meta (assq-ref alist 'meta))
+ (interface (assq-ref alist 'interface)))
+ (put interface 'meta meta)
+ (put interface 'groups (let ((ht (make-hash-table 31)))
+ (for-each (lambda (group)
+ (hashq-set! ht group '()))
+ (assq-ref meta 'groups))
+ ht))
+ interface))
+
+(define (hang-by-the-roots interface)
+ (let ((ht (get interface 'groups)))
+ (for-each (lambda (x)
+ (for-each (lambda (group)
+ (hashq-set! ht group
+ (cons (car x)
+ (hashq-ref ht group))))
+ (assq-ref x 'groups)))
+ interface))
+ interface)
+
+(define (diff? a b)
+ (let ((result (set-difference a b)))
+ (if (null? result)
+ #f ; CL weenies bite me
+ result)))
+
+(define (diff+note! a b note-removals note-additions note-same)
+ (let ((same? #t))
+ (cond ((diff? a b) => (lambda (x) (note-removals x) (set! same? #f))))
+ (cond ((diff? b a) => (lambda (x) (note-additions x) (set! same? #f))))
+ (and same? (note-same))))
+
+(define (group-diff i-old i-new . options)
+ (let* ((i-old (hang-by-the-roots i-old))
+ (g-old (hash-fold acons '() (get i-old 'groups)))
+ (g-old-names (map car g-old))
+ (i-new (hang-by-the-roots i-new))
+ (g-new (hash-fold acons '() (get i-new 'groups)))
+ (g-new-names (map car g-new)))
+ (cond ((null? options)
+ (diff+note! g-old-names g-new-names
+ (lambda (removals)
+ (format #t "groups-removed: ~A\n" removals))
+ (lambda (additions)
+ (format #t "groups-added: ~A\n" additions))
+ (lambda () #t))
+ (for-each (lambda (group)
+ (let* ((old (assq-ref g-old group))
+ (new (assq-ref g-new group))
+ (old-count (and old (length old)))
+ (new-count (and new (length new)))
+ (delta (and old new (- new-count old-count))))
+ (format #t " ~5@A ~5@A : "
+ (or old-count "-")
+ (or new-count "-"))
+ (cond ((and old new)
+ (let ((add-count 0) (sub-count 0))
+ (diff+note!
+ old new
+ (lambda (subs)
+ (set! sub-count (length subs)))
+ (lambda (adds)
+ (set! add-count (length adds)))
+ (lambda () #t))
+ (format #t "~5@D ~5@D : ~5@D"
+ add-count (- sub-count) delta)))
+ (else
+ (format #t "~5@A ~5@A : ~5@A" "-" "-" "-")))
+ (format #t " ~A\n" group)))
+ (sort (union g-old-names g-new-names)
+ (lambda (a b)
+ (string<? (symbol->string a)
+ (symbol->string b))))))
+ ((assq-ref options 'details)
+ => (lambda (groups)
+ (for-each (lambda (group)
+ (let* ((old (or (assq-ref g-old group) '()))
+ (new (or (assq-ref g-new group) '()))
+ (>>! (lambda (label ls)
+ (format #t "~A ~A:\n" group label)
+ (for-each (lambda (x)
+ (format #t " ~A\n" x))
+ ls))))
+ (diff+note! old new
+ (lambda (removals)
+ (>>! 'removals removals))
+ (lambda (additions)
+ (>>! 'additions additions))
+ (lambda ()
+ (format #t "~A: no changes\n"
+ group)))))
+ groups)))
+ (else
+ (error "api-diff: group-diff: bad options")))))
+
+(define (api-diff . args)
+ (let* ((p (getopt-long (cons 'api-diff args)
+ '((details (single-char #\d)
+ (value #t))
+ ;; Add options here.
+ )))
+ (rest (option-ref p '() '("/dev/null" "/dev/null")))
+ (i-old (read-api-alist-file (car rest)))
+ (i-new (read-api-alist-file (cadr rest)))
+ (options '()))
+ (cond ((option-ref p 'details #f)
+ => (lambda (groups)
+ (set! options (cons (cons 'details
+ (map string->symbol
+ (string-tokenize
+ groups
+ #\,)))
+ options)))))
+ (apply group-diff i-old i-new options)))
+
+(define main api-diff)
+
+;;; api-diff ends here
diff --git a/module/scripts/autofrisk.scm b/module/scripts/autofrisk.scm
new file mode 100644
index 000000000..e29ccc992
--- /dev/null
+++ b/module/scripts/autofrisk.scm
@@ -0,0 +1,216 @@
+;;; autofrisk --- Generate module checks for use with auto* tools
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: autofrisk [file]
+;;
+;; This program looks for the file modules.af in the current directory
+;; and writes out modules.af.m4 containing autoconf definitions.
+;; If given, look for FILE instead of modules.af and output to FILE.m4.
+;;
+;; After running autofrisk, you should add to configure.ac the lines:
+;; AUTOFRISK_CHECKS
+;; AUTOFRISK_SUMMARY
+;; Then run "aclocal -I ." to update aclocal.m4, and finally autoconf.
+;;
+;; The modules.af file consists of a series of configuration forms (Scheme
+;; lists), which have one of the following formats:
+;; (files-glob PATTERN ...)
+;; (non-critical-external MODULE ...)
+;; (non-critical-internal MODULE ...)
+;; (programs (MODULE PROG ...) ...)
+;; (pww-varname VARNAME)
+;; PATTERN is a string that may contain "*" and "?" characters to be
+;; expanded into filenames. MODULE is a list of symbols naming a
+;; module, such as `(srfi srfi-1)'. VARNAME is a shell-safe name to use
+;; instead of "probably_wont_work", the default. This var is passed to
+;; `AC_SUBST'. PROG is a string.
+;;
+;; Only the `files-glob' form is required.
+;;
+;; TODO: Write better commentary.
+;; Make "please see README" configurable.
+
+;;; Code:
+
+(define-module (scripts autofrisk)
+ :autoload (ice-9 popen) (open-input-pipe)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-8)
+ :use-module (srfi srfi-13)
+ :use-module (srfi srfi-14)
+ :use-module (scripts read-scheme-source)
+ :use-module (scripts frisk)
+ :export (autofrisk))
+
+(define *recognized-keys* '(files-glob
+ non-critical-external
+ non-critical-internal
+ programs
+ pww-varname))
+
+(define (canonical-configuration forms)
+ (let ((chk (lambda (condition . x)
+ (or condition (apply error "syntax error:" x)))))
+ (chk (list? forms) "input not a list")
+ (chk (every list? forms) "non-list element")
+ (chk (every (lambda (form) (< 1 (length form))) forms) "list too short")
+ (let ((un #f))
+ (chk (every (lambda (form)
+ (let ((key (car form)))
+ (and (symbol? key)
+ (or (eq? 'quote key)
+ (memq key *recognized-keys*)
+ (begin
+ (set! un key)
+ #f)))))
+ forms)
+ "unrecognized key:" un))
+ (let ((bunched (map (lambda (key)
+ (fold (lambda (form so-far)
+ (or (and (eq? (car form) key)
+ (cdr form)
+ (append so-far (cdr form)))
+ so-far))
+ (list key)
+ forms))
+ *recognized-keys*)))
+ (lambda (key)
+ (assq-ref bunched key)))))
+
+(define (>>strong modules)
+ (for-each (lambda (module)
+ (format #t "GUILE_MODULE_REQUIRED~A\n" module))
+ modules))
+
+(define (safe-name module)
+ (let ((var (object->string module)))
+ (string-map! (lambda (c)
+ (if (char-set-contains? char-set:letter+digit c)
+ c
+ #\_))
+ var)
+ var))
+
+(define *pww* "probably_wont_work")
+
+(define (>>weak weak-edges)
+ (for-each (lambda (edge)
+ (let* ((up (edge-up edge))
+ (down (edge-down edge))
+ (var (format #f "have_guile_module~A" (safe-name up))))
+ (format #t "GUILE_MODULE_AVAILABLE(~A, ~A)\n" var up)
+ (format #t "test \"$~A\" = no &&\n ~A=\"~A $~A\"~A"
+ var *pww* down *pww* "\n\n")))
+ weak-edges))
+
+(define (>>program module progs)
+ (let ((vars (map (lambda (prog)
+ (format #f "guile_module~Asupport_~A"
+ (safe-name module)
+ prog))
+ progs)))
+ (for-each (lambda (var prog)
+ (format #t "AC_PATH_PROG(~A, ~A)\n" var prog))
+ vars progs)
+ (format #t "test \\\n")
+ (for-each (lambda (var)
+ (format #t " \"$~A\" = \"\" -o \\\n" var))
+ vars)
+ (format #t "~A &&\n~A=\"~A $~A\"\n\n"
+ (list-ref (list "war = peace"
+ "freedom = slavery"
+ "ignorance = strength")
+ (random 3))
+ *pww* module *pww*)))
+
+(define (>>programs programs)
+ (for-each (lambda (form)
+ (>>program (car form) (cdr form)))
+ programs))
+
+(define (unglob pattern)
+ (let ((p (open-input-pipe (format #f "echo '(' ~A ')'" pattern))))
+ (map symbol->string (read p))))
+
+(define (>>checks forms)
+ (let* ((cfg (canonical-configuration forms))
+ (files (apply append (map unglob (cfg 'files-glob))))
+ (ncx (cfg 'non-critical-external))
+ (nci (cfg 'non-critical-internal))
+ (prog (cfg 'non-critical))
+ (report ((make-frisker) files))
+ (external (report 'external)))
+ (let ((pww-varname (cfg 'pww-varname)))
+ (or (null? pww-varname) (set! *pww* (car pww-varname))))
+ (receive (weak strong)
+ (partition (lambda (module)
+ (or (member module ncx)
+ (every (lambda (i)
+ (member i nci))
+ (map edge-down (mod-down-ls module)))))
+ external)
+ (format #t "AC_DEFUN([AUTOFRISK_CHECKS],[\n\n")
+ (>>strong strong)
+ (format #t "\n~A=~S\n\n" *pww* "")
+ (>>weak (fold (lambda (module so-far)
+ (append so-far (mod-down-ls module)))
+ (list)
+ weak))
+ (>>programs (cfg 'programs))
+ (format #t "AC_SUBST(~A)\n])\n\n" *pww*))))
+
+(define (>>summary)
+ (format #t
+ (symbol->string
+ '#{
+AC_DEFUN([AUTOFRISK_SUMMARY],[
+if test ! "$~A" = "" ; then
+ p=" ***"
+ echo "$p"
+ echo "$p NOTE:"
+ echo "$p The following modules probably won't work:"
+ echo "$p $~A"
+ echo "$p They can be installed anyway, and will work if their"
+ echo "$p dependencies are installed later. Please see README."
+ echo "$p"
+fi
+])
+}#)
+ *pww* *pww*))
+
+(define (autofrisk . args)
+ (let ((file (if (null? args) "modules.af" (car args))))
+ (or (file-exists? file)
+ (error "could not find input file:" file))
+ (with-output-to-file (format #f "~A.m4" file)
+ (lambda ()
+ (>>checks (read-scheme-source-silently file))
+ (>>summary)))))
+
+(define main autofrisk)
+
+;; Local variables:
+;; eval: (put 'receive 'scheme-indent-function 2)
+;; End:
+
+;;; autofrisk ends here
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
new file mode 100644
index 000000000..9b14f2fca
--- /dev/null
+++ b/module/scripts/compile.scm
@@ -0,0 +1,183 @@
+;;; Compile --- Command-line Guile Scheme compiler
+
+;; Copyright 2005,2008,2009 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+;;; Author: Andy Wingo <wingo@pobox.com>
+
+;;; Commentary:
+
+;; Usage: compile [ARGS]
+;;
+;; A command-line interface to the Guile compiler.
+
+;;; Code:
+
+(define-module (scripts compile)
+ #:use-module ((system base compile) #:select (compile-file))
+ #:use-module (system base message)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 format)
+ #:export (compile))
+
+
+(define (fail . messages)
+ (format (current-error-port)
+ (string-concatenate `("error: " ,@messages "~%")))
+ (exit 1))
+
+(define %options
+ ;; Specifications of the command-line options.
+ (list (option '(#\h "help") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'help? #t result)))
+ (option '("version") #f #f
+ (lambda (opt name arg result)
+ (show-version)
+ (exit 0)))
+
+ (option '(#\L "load-path") #t #f
+ (lambda (opt name arg result)
+ (let ((load-path (assoc-ref result 'load-path)))
+ (alist-cons 'load-path (cons arg load-path)
+ result))))
+ (option '(#\o "output") #t #f
+ (lambda (opt name arg result)
+ (if (assoc-ref result 'output-file)
+ (fail "`-o' option cannot be specified more than once")
+ (alist-cons 'output-file arg result))))
+
+ (option '(#\W "warn") #t #f
+ (lambda (opt name arg result)
+ (if (string=? arg "help")
+ (begin
+ (show-warning-help)
+ (exit 0))
+ (let ((warnings (assoc-ref result 'warnings)))
+ (alist-cons 'warnings
+ (cons (string->symbol arg) warnings)
+ (alist-delete 'warnings result))))))
+
+ (option '(#\O "optimize") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'optimize? #t result)))
+ (option '(#\f "from") #t #f
+ (lambda (opt name arg result)
+ (if (assoc-ref result 'from)
+ (fail "`--from' option cannot be specified more than once")
+ (alist-cons 'from (string->symbol arg) result))))
+ (option '(#\t "to") #t #f
+ (lambda (opt name arg result)
+ (if (assoc-ref result 'to)
+ (fail "`--to' option cannot be specified more than once")
+ (alist-cons 'to (string->symbol arg) result))))))
+
+(define (parse-args args)
+ "Parse argument list @var{args} and return an alist with all the relevant
+options."
+ (args-fold args %options
+ (lambda (opt name arg result)
+ (format (current-error-port) "~A: unrecognized option" name)
+ (exit 1))
+ (lambda (file result)
+ (let ((input-files (assoc-ref result 'input-files)))
+ (alist-cons 'input-files (cons file input-files)
+ result)))
+
+ ;; default option values
+ '((input-files)
+ (load-path)
+ (warnings unsupported-warning))))
+
+(define (show-version)
+ (format #t "compile (GNU Guile) ~A~%" (version))
+ (format #t "Copyright (C) 2009 Free Software Foundation, Inc.
+License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.~%"))
+
+(define (show-warning-help)
+ (format #t "The available warning types are:~%~%")
+ (for-each (lambda (wt)
+ (format #t " ~22A ~A~%"
+ (format #f "`~A'" (warning-type-name wt))
+ (warning-type-description wt)))
+ %warning-types)
+ (format #t "~%"))
+
+
+(define (compile . args)
+ (let* ((options (parse-args args))
+ (help? (assoc-ref options 'help?))
+ (compile-opts (let ((o `(#:warnings
+ ,(assoc-ref options 'warnings))))
+ (if (assoc-ref options 'optimize?)
+ (cons #:O o)
+ o)))
+ (from (or (assoc-ref options 'from) 'scheme))
+ (to (or (assoc-ref options 'to) 'objcode))
+ (input-files (assoc-ref options 'input-files))
+ (output-file (assoc-ref options 'output-file))
+ (load-path (assoc-ref options 'load-path)))
+ (if (or help? (null? input-files))
+ (begin
+ (format #t "Usage: compile [OPTION] FILE...
+Compile each Guile source file FILE into a Guile object.
+
+ -h, --help print this help message
+
+ -L, --load-path=DIR add DIR to the front of the module load path
+ -o, --output=OFILE write output to OFILE
+
+ -W, --warn=WARNING emit warnings of type WARNING; use `--warn=help'
+ for a list of available warnings
+
+ -f, --from=LANG specify a source language other than `scheme'
+ -t, --to=LANG specify a target language other than `objcode'
+
+Note that autocompilation will be turned off.
+
+Report bugs to <~A>.~%"
+ %guile-bug-report-address)
+ (exit 0)))
+
+ (set! %load-path (append load-path %load-path))
+ (set! %load-should-autocompile #f)
+
+ (if (and output-file
+ (or (null? input-files)
+ (not (null? (cdr input-files)))))
+ (fail "`-o' option can only be specified "
+ "when compiling a single file"))
+
+ (for-each (lambda (file)
+ (format #t "wrote `~A'\n"
+ (compile-file file
+ #:output-file output-file
+ #:from from
+ #:to to
+ #:opts compile-opts)))
+ input-files)))
+
+(define main compile)
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm
new file mode 100644
index 000000000..8907f6d08
--- /dev/null
+++ b/module/scripts/disassemble.scm
@@ -0,0 +1,40 @@
+;;; Disassemble --- Disassemble .go files into something human-readable
+
+;; Copyright 2005, 2008, 2009 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+;;; Author: Andy Wingo <wingo@pobox.com>
+
+;;; Commentary:
+
+;; Usage: disassemble [ARGS]
+
+;;; Code:
+
+(define-module (scripts disassemble)
+ #:use-module (system vm objcode)
+ #:use-module ((language assembly disassemble)
+ #:renamer (symbol-prefix-proc 'asm:))
+ #:export (disassemble))
+
+(define (disassemble . files)
+ (for-each (lambda (file)
+ (asm:disassemble (load-objcode file)))
+ files))
+
+(define main disassemble)
diff --git a/module/scripts/display-commentary.scm b/module/scripts/display-commentary.scm
new file mode 100644
index 000000000..5bd249ce9
--- /dev/null
+++ b/module/scripts/display-commentary.scm
@@ -0,0 +1,65 @@
+;;; display-commentary --- As advertized
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: display-commentary REF1 REF2 ...
+;;
+;; Display Commentary section from REF1, REF2 and so on.
+;; Each REF may be a filename or module name (list of symbols).
+;; In the latter case, a filename is computed by searching `%load-path'.
+
+;;; Code:
+
+(define-module (scripts display-commentary)
+ :use-module (ice-9 documentation)
+ :export (display-commentary))
+
+(define (display-commentary-one file)
+ (format #t "~A commentary:\n~A" file (file-commentary file)))
+
+(define (module-name->filename-frag ls) ; todo: export or move
+ (let ((ls (map symbol->string ls)))
+ (let loop ((ls (cdr ls)) (acc (car ls)))
+ (if (null? ls)
+ acc
+ (loop (cdr ls) (string-append acc "/" (car ls)))))))
+
+(define (display-module-commentary module-name)
+ (cond ((%search-load-path (module-name->filename-frag module-name))
+ => (lambda (file)
+ (format #t "module ~A\n" module-name)
+ (display-commentary-one file)))))
+
+(define (display-commentary . refs)
+ (for-each (lambda (ref)
+ (cond ((string? ref)
+ (if (equal? 0 (string-index ref #\())
+ (display-module-commentary
+ (with-input-from-string ref read))
+ (display-commentary-one ref)))
+ ((list? ref)
+ (display-module-commentary ref))))
+ refs))
+
+(define main display-commentary)
+
+;;; display-commentary ends here
diff --git a/module/scripts/doc-snarf.scm b/module/scripts/doc-snarf.scm
new file mode 100644
index 000000000..b5665b973
--- /dev/null
+++ b/module/scripts/doc-snarf.scm
@@ -0,0 +1,437 @@
+;;; doc-snarf --- Extract documentation from source files
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Martin Grabmueller
+
+;;; Commentary:
+
+;; Usage: doc-snarf FILE
+;;
+;; This program reads in a Scheme source file and extracts docstrings
+;; in the format specified below. Additionally, a procedure protoype
+;; is infered from the procedure definition line starting with
+;; (define... ).
+;;
+;; Currently, two output modi are implemented: texinfo and plaintext.
+;; Default is plaintext, texinfo can be switched on with the
+;; `--texinfo, -t' command line option.
+;;
+;; Format: A docstring can span multiple lines and a docstring line
+;; begins with `;; ' (two semicoli and a space). A docstring is ended
+;; by either a line beginning with (define ...) or one or more lines
+;; beginning with `;;-' (two semicoli and a dash). These lines are
+;; called `options' and begin with a keyword, followed by a colon and
+;; a string.
+;;
+;; Additionally, "standard internal docstrings" (for Scheme source) are
+;; recognized and output as "options". The output formatting is likely
+;; to change in the future.
+;;
+;; Example:
+
+;; This procedure foos, or bars, depending on the argument @var{braz}.
+;;-Author: Martin Grabmueller
+(define (foo/bar braz)
+ (if braz 'foo 'bar))
+
+;;; Which results in the following docstring if texinfo output is
+;;; enabled:
+#!
+ foo/bar
+@deffn procedure foo/bar braz
+This procedure foos, or bars, depending on the argument @var{braz}.
+@c Author: Martin Grabmueller
+@end deffn
+!#
+
+;;; Or in this if plaintext output is used:
+#!
+Procedure: foo/bar braz
+This procedure foos, or bars, depending on the argument @var{braz}.
+;; Author: Martin Grabmueller
+^L
+!#
+
+;; TODO: Convert option lines to alist.
+;; More parameterization.
+;; ../libguile/guile-doc-snarf emulation
+
+(define doc-snarf-version "0.0.2") ; please update before publishing!
+
+;;; Code:
+
+(define-module (scripts doc-snarf)
+ :use-module (ice-9 getopt-long)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 string-fun)
+ :use-module (ice-9 rdelim)
+ :export (doc-snarf))
+
+(define command-synopsis
+ '((version (single-char #\v) (value #f))
+ (help (single-char #\h) (value #f))
+ (output (single-char #\o) (value #t))
+ (texinfo (single-char #\t) (value #f))
+ (lang (single-char #\l) (value #t))))
+
+;; Display version information and exit.
+;;-ttn-mod: use var
+(define (display-version)
+ (display "doc-snarf ") (display doc-snarf-version) (newline))
+
+;; Display the usage help message and exit.
+;;-ttn-mod: change option "source" to "lang"
+(define (display-help)
+ (display "Usage: doc-snarf [options...] inputfile\n")
+ (display " --help, -h Show this usage information\n")
+ (display " --version, -v Show version information\n")
+ (display
+ " --output=FILE, -o Specify output file [default=stdout]\n")
+ (display " --texinfo, -t Format output as texinfo\n")
+ (display " --lang=[c,scheme], -l Specify the input language\n"))
+
+;; Main program.
+;;-ttn-mod: canonicalize lang
+(define (doc-snarf . args)
+ (let ((options (getopt-long (cons "doc-snarf" args) command-synopsis)))
+ (let ((help-wanted (option-ref options 'help #f))
+ (version-wanted (option-ref options 'version #f))
+ (texinfo-wanted (option-ref options 'texinfo #f))
+ (lang (string->symbol
+ (string-downcase (option-ref options 'lang "scheme")))))
+ (cond
+ (version-wanted (display-version))
+ (help-wanted (display-help))
+ (else
+ (let ((input (option-ref options '() #f))
+ (output (option-ref options 'output #f)))
+ (if
+ ;; Bonard B. Timmons III says `(pair? input)' alone is sufficient.
+ ;; (and input (pair? input))
+ (pair? input)
+ (snarf-file (car input) output texinfo-wanted lang)
+ (display-help))))))))
+
+(define main doc-snarf)
+
+;; Supported languages and their parameters. Each element has form:
+;; (LANG DOC-START DOC-END DOC-PREFIX OPT-PREFIX SIG-START STD-INT-DOC?)
+;; LANG is a symbol, STD-INT-DOC? is a boolean indicating whether or not
+;; LANG supports "standard internal docstring" (a string after the formals),
+;; everything else is a string specifying a regexp.
+;;-ttn-mod: new var
+(define supported-languages
+ '((c
+ "^/\\*(.*)"
+ "^ \\*/"
+ "^ \\* (.*)"
+ "^ \\*-(.*)"
+ "NOTHING AT THIS TIME!!!"
+ #f
+ )
+ (scheme
+ "^;; (.*)"
+ "^;;\\."
+ "^;; (.*)"
+ "^;;-(.*)"
+ "^\\(define"
+ #t
+ )))
+
+;; Get @var{lang}'s @var{parameter}. Both args are symbols.
+;;-ttn-mod: new proc
+(define (lang-parm lang parm)
+ (list-ref (assq-ref supported-languages lang)
+ (case parm
+ ((docstring-start) 0)
+ ((docstring-end) 1)
+ ((docstring-prefix) 2)
+ ((option-prefix) 3)
+ ((signature-start) 4)
+ ((std-int-doc?) 5))))
+
+;; Snarf all docstrings from the file @var{input} and write them to
+;; file @var{output}. Use texinfo format for the output if
+;; @var{texinfo?} is true.
+;;-ttn-mod: don't use string comparison, consult table instead
+(define (snarf-file input output texinfo? lang)
+ (or (memq lang (map car supported-languages))
+ (error "doc-snarf: input language must be c or scheme."))
+ (write-output (snarf input lang) output
+ (if texinfo? format-texinfo format-plain)))
+
+;; fixme: this comment is required to trigger standard internal
+;; docstring snarfing... ideally, it wouldn't be necessary.
+;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?)
+(define (find-std-int-doc line input-port)
+ "Unread @var{line} from @var{input-port}, then read in the entire form and
+return the standard internal docstring if found. Return #f if not."
+ (unread-string line input-port) ; ugh
+ (let ((form (read input-port)))
+ (cond ((and (list? form) ; (define (PROC ARGS) "DOC" ...)
+ (< 3 (length form))
+ (eq? 'define (car form))
+ (pair? (cadr form))
+ (symbol? (caadr form))
+ (string? (caddr form)))
+ (caddr form))
+ ((and (list? form) ; (define VAR (lambda ARGS "DOC" ...))
+ (< 2 (length form))
+ (eq? 'define (car form))
+ (symbol? (cadr form))
+ (list? (caddr form))
+ (< 3 (length (caddr form)))
+ (eq? 'lambda (car (caddr form)))
+ (string? (caddr (caddr form))))
+ (caddr (caddr form)))
+ (else #f))))
+
+;; Split @var{string} into lines, adding @var{prefix} to each.
+;;-ttn-mod: new proc
+(define (split-prefixed string prefix)
+ (separate-fields-discarding-char
+ #\newline string
+ (lambda lines
+ (map (lambda (line)
+ (string-append prefix line))
+ lines))))
+
+;; snarf input-file output-file
+;; Extract docstrings from the input file @var{input}, presumed
+;; to be written in language @var{lang}.
+;;-Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+;;-Created: 2001-02-17
+;;-ttn-mod: regluarize lang parm lookup, add "std int doc" snarfing (2 places)
+(define (snarf input-file lang)
+ (let* ((i-p (open-input-file input-file))
+ (parm-regexp (lambda (parm) (make-regexp (lang-parm lang parm))))
+ (docstring-start (parm-regexp 'docstring-start))
+ (docstring-end (parm-regexp 'docstring-end))
+ (docstring-prefix (parm-regexp 'docstring-prefix))
+ (option-prefix (parm-regexp 'option-prefix))
+ (signature-start (parm-regexp 'signature-start))
+ (augmented-options
+ (lambda (line i-p options)
+ (let ((int-doc (and (lang-parm lang 'std-int-doc?)
+ (let ((d (find-std-int-doc line i-p)))
+ (and d (split-prefixed d "internal: "))))))
+ (if int-doc
+ (append (reverse int-doc) options)
+ options)))))
+
+ (let lp ((line (read-line i-p)) (state 'neutral) (doc-strings '())
+ (options '()) (entries '()) (lno 0))
+ (cond
+ ((eof-object? line)
+ (close-input-port i-p)
+ (reverse entries))
+
+ ;; State 'neutral: we're currently not within a docstring or
+ ;; option section
+ ((eq? state 'neutral)
+ (let ((m (regexp-exec docstring-start line)))
+ (if m
+ (lp (read-line i-p) 'doc-string
+ (list (match:substring m 1)) '() entries (+ lno 1))
+ (lp (read-line i-p) state '() '() entries (+ lno 1)))))
+
+ ;; State 'doc-string: we have started reading a docstring and
+ ;; are waiting for more, for options or for a define.
+ ((eq? state 'doc-string)
+ (let ((m0 (regexp-exec docstring-prefix line))
+ (m1 (regexp-exec option-prefix line))
+ (m2 (regexp-exec signature-start line))
+ (m3 (regexp-exec docstring-end line)))
+ (cond
+ (m0
+ (lp (read-line i-p) 'doc-string
+ (cons (match:substring m0 1) doc-strings) '() entries
+ (+ lno 1)))
+ (m1
+ (lp (read-line i-p) 'options
+ doc-strings (cons (match:substring m1 1) options) entries
+ (+ lno 1)))
+ (m2
+ (let ((options (augmented-options line i-p options))) ; ttn-mod
+ (lp (read-line i-p) 'neutral '() '()
+ (cons (parse-entry doc-strings options line input-file lno)
+ entries)
+ (+ lno 1))))
+ (m3
+ (lp (read-line i-p) 'neutral '() '()
+ (cons (parse-entry doc-strings options #f input-file lno)
+ entries)
+ (+ lno 1)))
+ (else
+ (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))
+
+ ;; State 'options: We're waiting for more options or for a
+ ;; define.
+ ((eq? state 'options)
+ (let ((m1 (regexp-exec option-prefix line))
+ (m2 (regexp-exec signature-start line))
+ (m3 (regexp-exec docstring-end line)))
+ (cond
+ (m1
+ (lp (read-line i-p) 'options
+ doc-strings (cons (match:substring m1 1) options) entries
+ (+ lno 1)))
+ (m2
+ (let ((options (augmented-options line i-p options))) ; ttn-mod
+ (lp (read-line i-p) 'neutral '() '()
+ (cons (parse-entry doc-strings options line input-file lno)
+ entries)
+ (+ lno 1))))
+ (m3
+ (lp (read-line i-p) 'neutral '() '()
+ (cons (parse-entry doc-strings options #f input-file lno)
+ entries)
+ (+ lno 1)))
+ (else
+ (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))))))
+
+(define (make-entry symbol signature docstrings options filename line)
+ (vector 'entry symbol signature docstrings options filename line))
+(define (entry-symbol e)
+ (vector-ref e 1))
+(define (entry-signature e)
+ (vector-ref e 2))
+(define (entry-docstrings e)
+ (vector-ref e 3))
+(define (entry-options e)
+ (vector-ref e 4))
+(define (entry-filename e)
+ (vector-ref e 5))
+(define (entry-line e)
+ "This docstring will not be snarfed, unfortunately..."
+ (vector-ref e 6))
+
+;; Create a docstring entry from the docstring line list
+;; @var{doc-strings}, the option line list @var{options} and the
+;; define line @var{def-line}
+(define (parse-entry docstrings options def-line filename line-no)
+; (write-line docstrings)
+ (cond
+ (def-line
+ (make-entry (get-symbol def-line)
+ (make-prototype def-line) (reverse docstrings)
+ (reverse options) filename
+ (+ (- line-no (length docstrings) (length options)) 1)))
+ ((> (length docstrings) 0)
+ (make-entry (string->symbol (car (reverse docstrings)))
+ (car (reverse docstrings))
+ (cdr (reverse docstrings))
+ (reverse options) filename
+ (+ (- line-no (length docstrings) (length options)) 1)))
+ (else
+ (make-entry 'foo "" (reverse docstrings) (reverse options) filename
+ (+ (- line-no (length docstrings) (length options)) 1)))))
+
+;; Create a string which is a procedure prototype. The necessary
+;; information for constructing the prototype is taken from the line
+;; @var{def-line}, which is a line starting with @code{(define...}.
+(define (make-prototype def-line)
+ (call-with-input-string
+ def-line
+ (lambda (s-p)
+ (let* ((paren (read-char s-p))
+ (keyword (read s-p))
+ (tmp (read s-p)))
+ (cond
+ ((pair? tmp)
+ (join-symbols tmp))
+ ((symbol? tmp)
+ (symbol->string tmp))
+ (else
+ ""))))))
+
+(define (get-symbol def-line)
+ (call-with-input-string
+ def-line
+ (lambda (s-p)
+ (let* ((paren (read-char s-p))
+ (keyword (read s-p))
+ (tmp (read s-p)))
+ (cond
+ ((pair? tmp)
+ (car tmp))
+ ((symbol? tmp)
+ tmp)
+ (else
+ 'foo))))))
+
+;; Append the symbols in the string list @var{s}, separated with a
+;; space character.
+(define (join-symbols s)
+ (cond ((null? s)
+ "")
+ ((symbol? s)
+ (string-append ". " (symbol->string s)))
+ ((null? (cdr s))
+ (symbol->string (car s)))
+ (else
+ (string-append (symbol->string (car s)) " " (join-symbols (cdr s))))))
+
+;; Write @var{entries} to @var{output-file} using @var{writer}.
+;; @var{writer} is a proc that takes one entry.
+;; If @var{output-file} is #f, write to stdout.
+;;-ttn-mod: new proc
+(define (write-output entries output-file writer)
+ (with-output-to-port (cond (output-file (open-output-file output-file))
+ (else (current-output-port)))
+ (lambda () (for-each writer entries))))
+
+;; Write an @var{entry} using texinfo format.
+;;-ttn-mod: renamed from `texinfo-output', distilled
+(define (format-texinfo entry)
+ (display "\n\f")
+ (display (entry-symbol entry))
+ (newline)
+ (display "@c snarfed from ")
+ (display (entry-filename entry))
+ (display ":")
+ (display (entry-line entry))
+ (newline)
+ (display "@deffn procedure ")
+ (display (entry-signature entry))
+ (newline)
+ (for-each (lambda (s) (write-line s))
+ (entry-docstrings entry))
+ (for-each (lambda (s) (display "@c ") (write-line s))
+ (entry-options entry))
+ (write-line "@end deffn"))
+
+;; Write an @var{entry} using plain format.
+;;-ttn-mod: renamed from `texinfo-output', distilled
+(define (format-plain entry)
+ (display "Procedure: ")
+ (display (entry-signature entry))
+ (newline)
+ (for-each (lambda (s) (write-line s))
+ (entry-docstrings entry))
+ (for-each (lambda (s) (display ";; ") (write-line s))
+ (entry-options entry))
+ (display "Snarfed from ")
+ (display (entry-filename entry))
+ (display ":")
+ (display (entry-line entry))
+ (newline)
+ (write-line "\f"))
+
+;;; doc-snarf ends here
diff --git a/module/scripts/frisk.scm b/module/scripts/frisk.scm
new file mode 100644
index 000000000..0cf50d6a8
--- /dev/null
+++ b/module/scripts/frisk.scm
@@ -0,0 +1,287 @@
+;;; frisk --- Grok the module interfaces of a body of files
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: frisk [options] file ...
+;;
+;; Analyze FILE... module interfaces in aggregate (as a "body"),
+;; and display a summary. Modules that are `define-module'd are
+;; considered "internal" (and those not, "external"). When module X
+;; uses module Y, X is said to be "(a) downstream of" Y, and Y is
+;; "(an) upstream of" X.
+;;
+;; Normally, the summary displays external modules and their internal
+;; downstreams, as this is the usual question asked by a body. There
+;; are several options that modify this output.
+;;
+;; -u, --upstream show upstream edges
+;; -d, --downstream show downstream edges (default)
+;; -i, --internal show internal modules
+;; -x, --external show external modules (default)
+;;
+;; If given both `upstream' and `downstream' options ("frisk -ud"), the
+;; output is formatted: "C MODULE --- UP-LS --- DOWN-LS", where C is
+;; either `i' or `x', and each element of UP-LS and DOWN-LS is (TYPE
+;; MODULE-NAME ...).
+;;
+;; In all other cases, the "C MODULE" occupies its own line, and
+;; subsequent lines list the up- or downstream edges, respectively,
+;; indented by some non-zero amount of whitespace.
+;;
+;; Top-level `use-modules' (or `load' or 'primitive-load') forms in a
+;; file that do not follow a `define-module' result an edge where the
+;; downstream is the "default module", normally `(guile-user)'. This
+;; can be set to another value by using:
+;;
+;; -m, --default-module MOD set MOD as the default module
+
+;; Usage from a Scheme Program: (use-modules (scripts frisk))
+;;
+;; Module export list:
+;; (frisk . args)
+;; (make-frisker . options) => (lambda (files) ...) [see below]
+;; (mod-up-ls module) => upstream edges
+;; (mod-down-ls module) => downstream edges
+;; (mod-int? module) => is the module internal?
+;; (edge-type edge) => symbol: {regular,autoload,computed}
+;; (edge-up edge) => upstream module
+;; (edge-down edge) => downstream module
+;;
+;; OPTIONS is an alist. Recognized keys are:
+;; default-module
+;;
+;; `make-frisker' returns a procedure that takes a list of files, the
+;; FRISKER. FRISKER returns a closure, REPORT, that takes one of the
+;; keys:
+;; modules -- entire list of modules
+;; internal -- list of internal modules
+;; external -- list of external modules
+;; i-up -- list of modules upstream of internal modules
+;; x-up -- list of modules upstream of external modules
+;; i-down -- list of modules downstream of internal modules
+;; x-down -- list of modules downstream of external modules
+;; edges -- list of edges
+;; Note that `x-up' should always be null, since by (lack of!)
+;; definition, we only know external modules by reference.
+;;
+;; The module and edge objects managed by REPORT can be examined in
+;; detail by using the other (self-explanatory) procedures. Be careful
+;; not to confuse a freshly consed list of symbols, like `(a b c)' with
+;; the module `(a b c)'. If you want to find the module by that name,
+;; try: (cond ((member '(a b c) (REPORT 'modules)) => car)).
+
+;; TODO: Make "frisk -ud" output less ugly.
+;; Consider default module as internal; add option to invert.
+;; Support `edge-misc' data.
+
+;;; Code:
+
+(define-module (scripts frisk)
+ :autoload (ice-9 getopt-long) (getopt-long)
+ :use-module ((srfi srfi-1) :select (filter remove))
+ :export (frisk
+ make-frisker
+ mod-up-ls mod-down-ls mod-int?
+ edge-type edge-up edge-down))
+
+(define *default-module* '(guile-user))
+
+(define (grok-proc default-module note-use!)
+ (lambda (filename)
+ (let* ((p (open-file filename "r"))
+ (next (lambda () (read p)))
+ (ferret (lambda (use) ;;; handle "((foo bar) :select ...)"
+ (let ((maybe (car use)))
+ (if (list? maybe)
+ maybe
+ use))))
+ (curmod #f))
+ (let loop ((form (next)))
+ (cond ((eof-object? form))
+ ((not (list? form)) (loop (next)))
+ (else (case (car form)
+ ((define-module)
+ (let ((module (cadr form)))
+ (set! curmod module)
+ (note-use! 'def module #f)
+ (let loop ((ls form))
+ (or (null? ls)
+ (case (car ls)
+ ((:use-module)
+ (note-use! 'regular module (ferret (cadr ls)))
+ (loop (cddr ls)))
+ ((:autoload)
+ (note-use! 'autoload module (cadr ls))
+ (loop (cdddr ls)))
+ (else (loop (cdr ls))))))))
+ ((use-modules)
+ (for-each (lambda (use)
+ (note-use! 'regular
+ (or curmod default-module)
+ (ferret use)))
+ (cdr form)))
+ ((load primitive-load)
+ (note-use! 'computed
+ (or curmod default-module)
+ (let ((file (cadr form)))
+ (if (string? file)
+ file
+ (format #f "[computed in ~A]"
+ filename))))))
+ (loop (next))))))))
+
+(define up-ls (make-object-property)) ; list
+(define dn-ls (make-object-property)) ; list
+(define int? (make-object-property)) ; defined via `define-module'
+
+(define mod-up-ls up-ls)
+(define mod-down-ls dn-ls)
+(define mod-int? int?)
+
+(define (i-or-x module)
+ (if (int? module) 'i 'x))
+
+(define edge-type (make-object-property)) ; symbol
+
+(define (make-edge type up down)
+ (let ((new (cons up down)))
+ (set! (edge-type new) type)
+ new))
+
+(define edge-up car)
+(define edge-down cdr)
+
+(define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m))))
+(define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m))))
+
+(define (make-body alist)
+ (lambda (key)
+ (assq-ref alist key)))
+
+(define (scan default-module files)
+ (let* ((modules (list))
+ (edges (list))
+ (intern (lambda (module)
+ (cond ((member module modules) => car)
+ (else (set! (up-ls module) (list))
+ (set! (dn-ls module) (list))
+ (set! modules (cons module modules))
+ module))))
+ (grok (grok-proc default-module
+ (lambda (type d u)
+ (let ((d (intern d)))
+ (if (eq? type 'def)
+ (set! (int? d) #t)
+ (let* ((u (intern u))
+ (edge (make-edge type u d)))
+ (set! edges (cons edge edges))
+ (up-ls+! d edge)
+ (dn-ls+! u edge))))))))
+ (for-each grok files)
+ (make-body
+ `((modules . ,modules)
+ (internal . ,(filter int? modules))
+ (external . ,(remove int? modules))
+ (i-up . ,(filter int? (map edge-down edges)))
+ (x-up . ,(remove int? (map edge-down edges)))
+ (i-down . ,(filter int? (map edge-up edges)))
+ (x-down . ,(remove int? (map edge-up edges)))
+ (edges . ,edges)))))
+
+(define (make-frisker . options)
+ (let ((default-module (or (assq-ref options 'default-module)
+ *default-module*)))
+ (lambda (files)
+ (scan default-module files))))
+
+(define (dump-updown modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A --- ~A --- ~A\n"
+ (i-or-x m) m
+ (map (lambda (edge)
+ (cons (edge-type edge)
+ (edge-up edge)))
+ (up-ls m))
+ (map (lambda (edge)
+ (cons (edge-type edge)
+ (edge-down edge)))
+ (dn-ls m))))
+ modules))
+
+(define (dump-up modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A\n" (i-or-x m) m)
+ (for-each (lambda (edge)
+ (format #t "\t\t\t ~A\t~A\n"
+ (edge-type edge) (edge-up edge)))
+ (up-ls m)))
+ modules))
+
+(define (dump-down modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A\n" (i-or-x m) m)
+ (for-each (lambda (edge)
+ (format #t "\t\t\t ~A\t~A\n"
+ (edge-type edge) (edge-down edge)))
+ (dn-ls m)))
+ modules))
+
+(define (frisk . args)
+ (let* ((parsed-opts (getopt-long
+ (cons "frisk" args) ;;; kludge
+ '((upstream (single-char #\u))
+ (downstream (single-char #\d))
+ (internal (single-char #\i))
+ (external (single-char #\x))
+ (default-module
+ (single-char #\m)
+ (value #t)))))
+ (=u (option-ref parsed-opts 'upstream #f))
+ (=d (option-ref parsed-opts 'downstream #f))
+ (=i (option-ref parsed-opts 'internal #f))
+ (=x (option-ref parsed-opts 'external #f))
+ (files (option-ref parsed-opts '() (list)))
+ (report ((make-frisker
+ `(default-module
+ . ,(option-ref parsed-opts 'default-module
+ *default-module*)))
+ files))
+ (modules (report 'modules))
+ (internal (report 'internal))
+ (external (report 'external))
+ (edges (report 'edges)))
+ (format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n"
+ (length files) "files"
+ (length modules) "modules"
+ (length internal) "internal"
+ (length external) "external"
+ (length edges) "edges")
+ ((cond ((and =u =d) dump-updown)
+ (=u dump-up)
+ (else dump-down))
+ (cond ((and =i =x) modules)
+ (=i internal)
+ (else external)))))
+
+(define main frisk)
+
+;;; frisk ends here
diff --git a/module/scripts/generate-autoload.scm b/module/scripts/generate-autoload.scm
new file mode 100644
index 000000000..781931015
--- /dev/null
+++ b/module/scripts/generate-autoload.scm
@@ -0,0 +1,141 @@
+;;; generate-autoload --- Display define-module form with autoload info
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: generate-autoload [OPTIONS] FILE1 FILE2 ...
+;;
+;; The autoload form is displayed to standard output:
+;;
+;; (define-module (guile-user)
+;; :autoload (ZAR FOO) (FOO-1 FOO-2 ...)
+;; :
+;; :
+;; :autoload (ZAR BAR) (BAR-1 BAR-2 ...))
+;;
+;; For each file, a symbol triggers an autoload if it is found in one
+;; of these situations:
+;; - in the `:export' clause of a `define-module' form
+;; - in a top-level `export' or `export-syntax' form
+;; - in a `define-public' form
+;; - in a `defmacro-public' form
+;;
+;; The module name is inferred from the `define-module' form. If either the
+;; module name or the exports list cannot be determined, no autoload entry is
+;; generated for that file.
+;;
+;; Options:
+;; --target MODULE-NAME -- Use MODULE-NAME instead of `(guile-user)'.
+;; Note that some shells may require you to
+;; quote the argument to handle parentheses
+;; and spaces.
+;;
+;; Usage examples from Scheme code as a module:
+;; (use-modules (scripts generate-autoload))
+;; (generate-autoload "generate-autoload")
+;; (generate-autoload "--target" "(my module)" "generate-autoload")
+;; (apply generate-autoload "--target" "(my module)" '("foo" "bar" "baz"))
+
+;;; Code:
+
+(define-module (scripts generate-autoload)
+ :export (generate-autoload))
+
+(define (autoload-info file)
+ (let ((p (open-input-file file)))
+ (let loop ((form (read p)) (module-name #f) (exports '()))
+ (if (eof-object? form)
+ (and module-name
+ (not (null? exports))
+ (list module-name exports)) ; ret
+ (cond ((and (list? form)
+ (< 1 (length form))
+ (eq? 'define-module (car form)))
+ (loop (read p)
+ (cadr form)
+ (cond ((member ':export form)
+ => (lambda (val)
+ (append (cadr val) exports)))
+ (else exports))))
+ ((and (list? form)
+ (< 1 (length form))
+ (memq (car form) '(export export-syntax)))
+ (loop (read p)
+ module-name
+ (append (cdr form) exports)))
+ ((and (list? form)
+ (< 2 (length form))
+ (eq? 'define-public (car form))
+ (list? (cadr form))
+ (symbol? (caadr form)))
+ (loop (read p)
+ module-name
+ (cons (caadr form) exports)))
+ ((and (list? form)
+ (< 2 (length form))
+ (eq? 'define-public (car form))
+ (symbol? (cadr form)))
+ (loop (read p)
+ module-name
+ (cons (cadr form) exports)))
+ ((and (list? form)
+ (< 3 (length form))
+ (eq? 'defmacro-public (car form))
+ (symbol? (cadr form)))
+ (loop (read p)
+ module-name
+ (cons (cadr form) exports)))
+ (else (loop (read p) module-name exports)))))))
+
+(define (generate-autoload . args)
+ (let* ((module-count 0)
+ (syms-count 0)
+ (target-override (cond ((member "--target" args) => cadr)
+ (else #f)))
+ (files (if target-override (cddr args) (cdr args))))
+ (display ";;; do not edit --- generated ")
+ (display (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
+ (newline)
+ (display "(define-module ")
+ (display (or target-override "(guile-user)"))
+ (for-each (lambda (file)
+ (cond ((autoload-info file)
+ => (lambda (info)
+ (and info
+ (apply (lambda (module-name exports)
+ (set! module-count (1+ module-count))
+ (set! syms-count (+ (length exports)
+ syms-count))
+ (for-each display
+ (list "\n :autoload "
+ module-name " "
+ exports)))
+ info))))))
+ files)
+ (display ")")
+ (newline)
+ (for-each display (list " ;;; "
+ syms-count " symbols in "
+ module-count " modules\n"))))
+
+(define main generate-autoload)
+
+;;; generate-autoload ends here
diff --git a/module/scripts/lint.scm b/module/scripts/lint.scm
new file mode 100644
index 000000000..b4a7f530a
--- /dev/null
+++ b/module/scripts/lint.scm
@@ -0,0 +1,315 @@
+;;; lint --- Preemptive checks for coding errors in Guile Scheme code
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Neil Jerram
+
+;;; Commentary:
+
+;; Usage: lint FILE1 FILE2 ...
+;;
+;; Perform various preemptive checks for coding errors in Guile Scheme
+;; code.
+;;
+;; Right now, there is only one check available, for unresolved free
+;; variables. The intention is that future lint-like checks will be
+;; implemented by adding to this script file.
+;;
+;; Unresolved free variables
+;; -------------------------
+;;
+;; Free variables are those whose definitions come from outside the
+;; module under investigation. In Guile, these definitions are
+;; imported from other modules using `#:use-module' forms.
+;;
+;; This tool scans the specified files for unresolved free variables -
+;; i.e. variables for which you may have forgotten the appropriate
+;; `#:use-module', or for which the module that is supposed to export
+;; them forgot to.
+;;
+;; It isn't guaranteed that the scan will find absolutely all such
+;; errors. Quoted (and quasiquoted) expressions are skipped, since
+;; they are most commonly used to describe constant data, not code, so
+;; code that is explicitly evaluated using `eval' will not be checked.
+;; For example, the `unresolved-var' in `(eval 'unresolved-var
+;; (current-module))' would be missed.
+;;
+;; False positives are also possible. Firstly, the tool doesn't
+;; understand all possible forms of implicit quoting; in particular,
+;; it doesn't detect and expand uses of macros. Secondly, it picks up
+;; explicit compatibility code like `(if (defined? 'x) (define y x))'.
+;; Thirdly, there are occasional oddities like `next-method'.
+;; However, the number of false positives for realistic code is
+;; hopefully small enough that they can be individually considered and
+;; ignored.
+;;
+;; Example
+;; -------
+;;
+;; Note: most of the unresolved variables found in this example are
+;; false positives, as you would hope. => scope for improvement.
+;;
+;; $ guile-tools lint `guile-tools`
+;; No unresolved free variables in PROGRAM
+;; No unresolved free variables in autofrisk
+;; No unresolved free variables in display-commentary
+;; Unresolved free variables in doc-snarf:
+;; doc-snarf-version
+;; No unresolved free variables in frisk
+;; No unresolved free variables in generate-autoload
+;; No unresolved free variables in lint
+;; No unresolved free variables in punify
+;; No unresolved free variables in read-scheme-source
+;; Unresolved free variables in snarf-check-and-output-texi:
+;; name
+;; pos
+;; line
+;; x
+;; rest
+;; ...
+;; do-argpos
+;; do-command
+;; do-args
+;; type
+;; num
+;; file
+;; do-arglist
+;; req
+;; opt
+;; var
+;; command
+;; do-directive
+;; s
+;; ?
+;; No unresolved free variables in use2dot
+
+;;; Code:
+
+(define-module (scripts lint)
+ #:use-module (ice-9 common-list)
+ #:use-module (ice-9 format)
+ #:export (lint))
+
+(define (lint filename)
+ (let ((module-name (scan-file-for-module-name filename))
+ (free-vars (uniq (scan-file-for-free-variables filename))))
+ (let ((module (resolve-module module-name))
+ (all-resolved? #t))
+ (format #t "Resolved module: ~S\n" module)
+ (let loop ((free-vars free-vars))
+ (or (null? free-vars)
+ (begin
+ (catch #t
+ (lambda ()
+ (eval (car free-vars) module))
+ (lambda args
+ (if all-resolved?
+ (format #t
+ "Unresolved free variables in ~A:\n"
+ filename))
+ (write-char #\tab)
+ (write (car free-vars))
+ (newline)
+ (set! all-resolved? #f)))
+ (loop (cdr free-vars)))))
+ (if all-resolved?
+ (format #t
+ "No unresolved free variables in ~A\n"
+ filename)))))
+
+(define (scan-file-for-module-name filename)
+ (with-input-from-file filename
+ (lambda ()
+ (let loop ((x (read)))
+ (cond ((eof-object? x) #f)
+ ((and (pair? x)
+ (eq? (car x) 'define-module))
+ (cadr x))
+ (else (loop (read))))))))
+
+(define (scan-file-for-free-variables filename)
+ (with-input-from-file filename
+ (lambda ()
+ (let loop ((x (read)) (fvlists '()))
+ (if (eof-object? x)
+ (apply append fvlists)
+ (loop (read) (cons (detect-free-variables x '()) fvlists)))))))
+
+; guile> (detect-free-variables '(let ((a 1)) a) '())
+; ()
+; guile> (detect-free-variables '(let ((a 1)) b) '())
+; (b)
+; guile> (detect-free-variables '(let ((a 1) (b a)) b) '())
+; (a)
+; guile> (detect-free-variables '(let* ((a 1) (b a)) b) '())
+; ()
+; guile> (detect-free-variables '(define a 1) '())
+; ()
+; guile> (detect-free-variables '(define a b) '())
+; (b)
+; guile> (detect-free-variables '(define (a b c) b) '())
+; ()
+; guile> (detect-free-variables '(define (a b c) e) '())
+; (e)
+
+(define (detect-free-variables x locals)
+ ;; Given an expression @var{x} and a list @var{locals} of local
+ ;; variables (symbols) that are in scope for @var{x}, return a list
+ ;; of free variable symbols.
+ (cond ((symbol? x)
+ (if (memq x locals) '() (list x)))
+
+ ((pair? x)
+ (case (car x)
+ ((define-module define-generic quote quasiquote)
+ ;; No code of interest in these expressions.
+ '())
+
+ ((let letrec)
+ ;; Check for named let. If there is a name, transform the
+ ;; expression so that it looks like an unnamed let with
+ ;; the name as one of the bindings.
+ (if (symbol? (cadr x))
+ (set-cdr! x (cons (cons (list (cadr x) #f) (caddr x))
+ (cdddr x))))
+ ;; Unnamed let processing.
+ (let ((letrec? (eq? (car x) 'letrec))
+ (locals-for-let-body (append locals (map car (cadr x)))))
+ (append (apply append
+ (map (lambda (binding)
+ (detect-free-variables (cadr binding)
+ (if letrec?
+ locals-for-let-body
+ locals)))
+ (cadr x)))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-let-body))
+ (cddr x))))))
+
+ ((let* and-let*)
+ ;; Handle bindings recursively.
+ (if (null? (cadr x))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform locals))
+ (cddr x)))
+ (append (detect-free-variables (cadr (caadr x)) locals)
+ (detect-free-variables `(let* ,(cdadr x) ,@(cddr x))
+ (cons (caaadr x) locals)))))
+
+ ((define define-public define-macro)
+ (if (pair? (cadr x))
+ (begin
+ (set! locals (cons (caadr x) locals))
+ (detect-free-variables `(lambda ,(cdadr x) ,@(cddr x))
+ locals))
+ (begin
+ (set! locals (cons (cadr x) locals))
+ (detect-free-variables (caddr x) locals))))
+
+ ((lambda lambda*)
+ (let ((locals-for-lambda-body (let loop ((locals locals)
+ (args (cadr x)))
+ (cond ((null? args) locals)
+ ((pair? args)
+ (loop (cons (car args) locals)
+ (cdr args)))
+ (else
+ (cons args locals))))))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-lambda-body))
+ (cddr x)))))
+
+ ((receive)
+ (let ((locals-for-receive-body (append locals (cadr x))))
+ (apply append
+ (detect-free-variables (caddr x) locals)
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-receive-body))
+ (cdddr x)))))
+
+ ((define-method define*)
+ (let ((locals-for-method-body (let loop ((locals locals)
+ (args (cdadr x)))
+ (cond ((null? args) locals)
+ ((pair? args)
+ (loop (cons (if (pair? (car args))
+ (caar args)
+ (car args))
+ locals)
+ (cdr args)))
+ (else
+ (cons args locals))))))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-method-body))
+ (cddr x)))))
+
+ ((define-class)
+ ;; Avoid picking up slot names at the start of slot
+ ;; definitions.
+ (apply append
+ (map (lambda (slot/option)
+ (detect-free-variables-noncar (if (pair? slot/option)
+ (cdr slot/option)
+ slot/option)
+ locals))
+ (cdddr x))))
+
+ ((case)
+ (apply append
+ (detect-free-variables (cadr x) locals)
+ (map (lambda (case)
+ (detect-free-variables (cdr case) locals))
+ (cddr x))))
+
+ ((unquote unquote-splicing else =>)
+ (detect-free-variables-noncar (cdr x) locals))
+
+ (else (append (detect-free-variables (car x) locals)
+ (detect-free-variables-noncar (cdr x) locals)))))
+
+ (else '())))
+
+(define (detect-free-variables-noncar x locals)
+ ;; Given an expression @var{x} and a list @var{locals} of local
+ ;; variables (symbols) that are in scope for @var{x}, return a list
+ ;; of free variable symbols.
+ (cond ((symbol? x)
+ (if (memq x locals) '() (list x)))
+
+ ((pair? x)
+ (case (car x)
+ ((=>)
+ (detect-free-variables-noncar (cdr x) locals))
+
+ (else (append (detect-free-variables (car x) locals)
+ (detect-free-variables-noncar (cdr x) locals)))))
+
+ (else '())))
+
+(define (main . files)
+ (for-each lint files))
+
+;;; lint ends here
diff --git a/module/scripts/punify.scm b/module/scripts/punify.scm
new file mode 100644
index 000000000..1627722d3
--- /dev/null
+++ b/module/scripts/punify.scm
@@ -0,0 +1,84 @@
+;;; punify --- Display Scheme code w/o unnecessary comments / whitespace
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: punify FILE1 FILE2 ...
+;;
+;; Each file's forms are read and written to stdout.
+;; The effect is to remove comments and much non-essential whitespace.
+;; This is useful when installing Scheme source to space-limited media.
+;;
+;; Example:
+;; $ wc ./punify ; ./punify ./punify | wc
+;; 89 384 3031 ./punify
+;; 0 42 920
+;;
+;; TODO: Read from stdin.
+;; Handle vectors.
+;; Identifier punification.
+
+;;; Code:
+
+(define-module (scripts punify)
+ :export (punify))
+
+(define (write-punily form)
+ (cond ((and (list? form) (not (null? form)))
+ (let ((first (car form)))
+ (display "(")
+ (write-punily first)
+ (let loop ((ls (cdr form)) (last-was-list? (list? first)))
+ (if (null? ls)
+ (display ")")
+ (let* ((new-first (car ls))
+ (this-is-list? (list? new-first)))
+ (and (not last-was-list?)
+ (not this-is-list?)
+ (display " "))
+ (write-punily new-first)
+ (loop (cdr ls) this-is-list?))))))
+ ((and (symbol? form)
+ (let ((ls (string->list (symbol->string form))))
+ (and (char=? (car ls) #\:)
+ (not (memq #\space ls))
+ (list->string (cdr ls)))))
+ => (lambda (symbol-name-after-colon)
+ (display #\:)
+ (display symbol-name-after-colon)))
+ (else (write form))))
+
+(define (punify-one file)
+ (with-input-from-file file
+ (lambda ()
+ (let ((toke (lambda () (read (current-input-port)))))
+ (let loop ((form (toke)))
+ (or (eof-object? form)
+ (begin
+ (write-punily form)
+ (loop (toke)))))))))
+
+(define (punify . args)
+ (for-each punify-one args))
+
+(define main punify)
+
+;;; punify ends here
diff --git a/module/scripts/read-rfc822.scm b/module/scripts/read-rfc822.scm
new file mode 100644
index 000000000..c0a54f28c
--- /dev/null
+++ b/module/scripts/read-rfc822.scm
@@ -0,0 +1,128 @@
+;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
+
+;; Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: read-rfc822 FILE
+;;
+;; Read FILE, assumed to be in RFC822 format, and display it to stdout.
+;; This is not very interesting, admittedly.
+;;
+;; For Scheme programming, this module exports two procs:
+;; (read-rfc822 . args) ; only first arg used
+;; (read-rfc822-silently port)
+;;
+;; Parse FILE (a string) or PORT, respectively, and return a query proc that
+;; takes a symbol COMP, and returns the message component COMP. Supported
+;; values for COMP (and the associated query return values) are:
+;; from -- #f (reserved for future mbox support)
+;; headers -- alist of (HEADER-SYMBOL . "VALUE-STRING") pairs, in order
+;; body -- rest of the mail message, a string
+;; body-lines -- rest of the mail message, as a list of lines
+;; Any other query results in a "bad component" error.
+;;
+;; TODO: Add "-m" option (mbox support).
+
+;;; Code:
+
+(define-module (scripts read-rfc822)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 rdelim)
+ :autoload (srfi srfi-13) (string-join)
+ :export (read-rfc822 read-rfc822-silently))
+
+(define from-line-rx (make-regexp "^From "))
+(define header-name-rx (make-regexp "^([^:]+):[ \t]*"))
+(define header-cont-rx (make-regexp "^[ \t]+"))
+
+(define option #f) ; for future "-m"
+
+(define (drain-message port)
+ (let loop ((line (read-line port)) (acc '()))
+ (cond ((eof-object? line)
+ (reverse acc))
+ ((and option (regexp-exec from-line-rx line))
+ (for-each (lambda (c)
+ (unread-char c port))
+ (cons #\newline
+ (reverse (string->list line))))
+ (reverse acc))
+ (else
+ (loop (read-line port) (cons line acc))))))
+
+(define (parse-message port)
+ (let* ((from (and option
+ (match:suffix (regexp-exec from-line-rx
+ (read-line port)))))
+ (body-lines #f)
+ (body #f)
+ (headers '())
+ (add-header! (lambda (reversed-hlines)
+ (let* ((hlines (reverse reversed-hlines))
+ (first (car hlines))
+ (m (regexp-exec header-name-rx first))
+ (name (string->symbol (match:substring m 1)))
+ (data (string-join
+ (cons (substring first (match:end m))
+ (cdr hlines))
+ " ")))
+ (set! headers (acons name data headers))))))
+ ;; "From " is only one line
+ (let loop ((line (read-line port)) (current-header #f))
+ (cond ((string-null? line)
+ (and current-header (add-header! current-header))
+ (set! body-lines (drain-message port)))
+ ((regexp-exec header-cont-rx line)
+ => (lambda (m)
+ (loop (read-line port)
+ (cons (match:suffix m) current-header))))
+ (else
+ (and current-header (add-header! current-header))
+ (loop (read-line port) (list line)))))
+ (set! headers (reverse headers))
+ (lambda (component)
+ (case component
+ ((from) from)
+ ((body-lines) body-lines)
+ ((headers) headers)
+ ((body) (or body
+ (begin (set! body (string-join body-lines "\n" 'suffix))
+ body)))
+ (else (error "bad component:" component))))))
+
+(define (read-rfc822-silently port)
+ (parse-message port))
+
+(define (display-rfc822 parse)
+ (cond ((parse 'from) => (lambda (from) (format #t "From ~A\n" from))))
+ (for-each (lambda (header)
+ (format #t "~A: ~A\n" (car header) (cdr header)))
+ (parse 'headers))
+ (format #t "\n~A" (parse 'body)))
+
+(define (read-rfc822 . args)
+ (let ((parse (read-rfc822-silently (open-file (car args) OPEN_READ))))
+ (display-rfc822 parse))
+ #t)
+
+(define main read-rfc822)
+
+;;; read-rfc822 ends here
diff --git a/module/scripts/read-scheme-source.scm b/module/scripts/read-scheme-source.scm
new file mode 100644
index 000000000..b48a88f9b
--- /dev/null
+++ b/module/scripts/read-scheme-source.scm
@@ -0,0 +1,279 @@
+;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: read-scheme-source FILE1 FILE2 ...
+;;
+;; This program parses each FILE and writes to stdout sexps that describe the
+;; top-level structures of the file: scheme forms, single-line comments, and
+;; hash-bang comments. You can further process these (to associate comments
+;; w/ scheme forms as a kind of documentation, for example).
+;;
+;; The output sexps have one of these forms:
+;;
+;; (quote (filename FILENAME))
+;;
+;; (quote (comment :leading-semicolons N
+;; :text LINE))
+;;
+;; (quote (whitespace :text LINE))
+;;
+;; (quote (hash-bang-comment :line LINUM
+;; :line-count N
+;; :text-list (LINE1 LINE2 ...)))
+;;
+;; (quote (following-form-properties :line LINUM
+;; :line-count N)
+;; :type TYPE
+;; :signature SIGNATURE
+;; :std-int-doc DOCSTRING))
+;;
+;; SEXP
+;;
+;; The first four are straightforward (both FILENAME and LINE are strings sans
+;; newline, while LINUM and N are integers). The last two always go together,
+;; in that order. SEXP is scheme code processed only by `read' and then
+;; `write'.
+;;
+;; The :type field may be omitted if the form is not recognized. Otherwise,
+;; TYPE may be one of: procedure, alias, define-module, variable.
+;;
+;; The :signature field may be omitted if the form is not a procedure.
+;; Otherwise, SIGNATURE is a list showing the procedure's signature.
+;;
+;; If the type is `procedure' and the form has a standard internal docstring
+;; (first body form a string), that is extracted in full -- including any
+;; embedded newlines -- and recorded by field :std-int-doc.
+;;
+;;
+;; Usage from a program: The output list of sexps can be retrieved by scheme
+;; programs w/o having to capture stdout, like so:
+;;
+;; (use-modules (scripts read-scheme-source))
+;; (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...))
+;;
+;; There are also two convenience procs exported for use by Scheme programs:
+;;
+;; (clump FORMS) --- filter FORMS combining contiguous comment forms that
+;; have the same number of leading semicolons.
+;;
+;; (quoted? SYM FORM) --- see if FORM looks like: "(quote (SYM ...))", parse
+;; the ":tags", and return alist of (TAG . VAL) elems.
+;;
+;; TODO: Add option "--clump-comments", maybe w/ different clumping styles.
+;; Make `annotate!' extensible.
+
+;;; Code:
+
+(define-module (scripts read-scheme-source)
+ :use-module (ice-9 rdelim)
+ :export (read-scheme-source
+ read-scheme-source-silently
+ quoted?
+ clump))
+
+;; Try to figure out what FORM is and its various attributes.
+;; Call proc NOTE! with key (a symbol) and value.
+;;
+(define (annotate! form note!)
+ (cond ((and (list? form)
+ (< 2 (length form))
+ (eq? 'define (car form))
+ (pair? (cadr form))
+ (symbol? (caadr form)))
+ (note! ':type 'procedure)
+ (note! ':signature (cadr form))
+ (and (< 3 (length form))
+ (string? (caddr form))
+ (note! ':std-int-doc (caddr form))))
+ ((and (list? form)
+ (< 2 (length form))
+ (eq? 'define (car form))
+ (symbol? (cadr form))
+ (list? (caddr form))
+ (< 3 (length (caddr form)))
+ (eq? 'lambda (car (caddr form)))
+ (string? (caddr (caddr form))))
+ (note! ':type 'procedure)
+ (note! ':signature (cons (cadr form) (cadr (caddr form))))
+ (note! ':std-int-doc (caddr (caddr form))))
+ ((and (list? form)
+ (= 3 (length form))
+ (eq? 'define (car form))
+ (symbol? (cadr form))
+ (symbol? (caddr form)))
+ (note! ':type 'alias))
+ ((and (list? form)
+ (eq? 'define-module (car form)))
+ (note! ':type 'define-module))
+ ;; Add other types here.
+ (else (note! ':type 'variable))))
+
+;; Process FILE, calling NB! on parsed top-level elements.
+;; Recognized: #!-!# and regular comments in addition to normal forms.
+;;
+(define (process file nb!)
+ (nb! `'(filename ,file))
+ (let ((hash-bang-rx (make-regexp "^#!"))
+ (bang-hash-rx (make-regexp "^!#"))
+ (all-comment-rx (make-regexp "^[ \t]*(;+)"))
+ (all-whitespace-rx (make-regexp "^[ \t]*$"))
+ (p (open-input-file file)))
+ (let loop ((n (1+ (port-line p))) (line (read-line p)))
+ (or (not n)
+ (eof-object? line)
+ (begin
+ (cond ((regexp-exec hash-bang-rx line)
+ (let loop ((line (read-line p))
+ (text (list line)))
+ (if (or (eof-object? line)
+ (regexp-exec bang-hash-rx line))
+ (nb! `'(hash-bang-comment
+ :line ,n
+ :line-count ,(1+ (length text))
+ :text-list ,(reverse
+ (cons line text))))
+ (loop (read-line p)
+ (cons line text)))))
+ ((regexp-exec all-whitespace-rx line)
+ (nb! `'(whitespace :text ,line)))
+ ((regexp-exec all-comment-rx line)
+ => (lambda (m)
+ (nb! `'(comment
+ :leading-semicolons
+ ,(let ((m1 (vector-ref m 1)))
+ (- (cdr m1) (car m1)))
+ :text ,line))))
+ (else
+ (unread-string line p)
+ (let* ((form (read p))
+ (count (- (port-line p) n))
+ (props (let* ((props '())
+ (prop+ (lambda args
+ (set! props
+ (append props args)))))
+ (annotate! form prop+)
+ props)))
+ (or (= count 1) ; ugh
+ (begin
+ (read-line p)
+ (set! count (1+ count))))
+ (nb! `'(following-form-properties
+ :line ,n
+ :line-count ,count
+ ,@props))
+ (nb! form))))
+ (loop (1+ (port-line p)) (read-line p)))))))
+
+;;; entry points
+
+(define (read-scheme-source-silently . files)
+ "See commentary in module (scripts read-scheme-source)."
+ (let* ((res '()))
+ (for-each (lambda (file)
+ (process file (lambda (e) (set! res (cons e res)))))
+ files)
+ (reverse res)))
+
+(define (read-scheme-source . files)
+ "See commentary in module (scripts read-scheme-source)."
+ (for-each (lambda (file)
+ (process file (lambda (e) (write e) (newline))))
+ files))
+
+;; Recognize: (quote (SYM :TAG1 VAL1 :TAG2 VAL2 ...))
+;; and return alist: ((TAG1 . VAL1) (TAG2 . VAL2) ...)
+;; where the tags are symbols.
+;;
+(define (quoted? sym form)
+ (and (list? form)
+ (= 2 (length form))
+ (eq? 'quote (car form))
+ (let ((inside (cadr form)))
+ (and (list? inside)
+ (< 0 (length inside))
+ (eq? sym (car inside))
+ (let loop ((ls (cdr inside)) (alist '()))
+ (if (null? ls)
+ alist ; retval
+ (let ((first (car ls)))
+ (or (symbol? first)
+ (error "bad list!"))
+ (loop (cddr ls)
+ (acons (string->symbol
+ (substring (symbol->string first) 1))
+ (cadr ls)
+ alist)))))))))
+
+;; Filter FORMS, combining contiguous comment forms that have the same number
+;; of leading semicolons. Do not include in them whitespace lines.
+;; Whitespace lines outside of such comment groupings are ignored, as are
+;; hash-bang comments. All other forms are passed through unchanged.
+;;
+(define (clump forms)
+ (let loop ((forms forms) (acc '()) (pass-this-one-through? #f))
+ (if (null? forms)
+ (reverse acc) ; retval
+ (let ((form (car forms)))
+ (cond (pass-this-one-through?
+ (loop (cdr forms) (cons form acc) #f))
+ ((quoted? 'following-form-properties form)
+ (loop (cdr forms) (cons form acc) #t))
+ ((quoted? 'whitespace form) ;;; ignore
+ (loop (cdr forms) acc #f))
+ ((quoted? 'hash-bang-comment form) ;;; ignore for now
+ (loop (cdr forms) acc #f))
+ ((quoted? 'comment form)
+ => (lambda (alist)
+ (let cloop ((inner-forms (cdr forms))
+ (level (assq-ref alist 'leading-semicolons))
+ (text (list (assq-ref alist 'text))))
+ (let ((up (lambda ()
+ (loop inner-forms
+ (cons (cons level (reverse text))
+ acc)
+ #f))))
+ (if (null? inner-forms)
+ (up)
+ (let ((inner-form (car inner-forms)))
+ (cond ((quoted? 'comment inner-form)
+ => (lambda (inner-alist)
+ (let ((new-level
+ (assq-ref
+ inner-alist
+ 'leading-semicolons)))
+ (if (= new-level level)
+ (cloop (cdr inner-forms)
+ level
+ (cons (assq-ref
+ inner-alist
+ 'text)
+ text))
+ (up)))))
+ (else (up)))))))))
+ (else (loop (cdr forms) (cons form acc) #f)))))))
+
+;;; script entry point
+
+(define main read-scheme-source)
+
+;;; read-scheme-source ends here
diff --git a/module/scripts/read-text-outline.scm b/module/scripts/read-text-outline.scm
new file mode 100644
index 000000000..64221fbe1
--- /dev/null
+++ b/module/scripts/read-text-outline.scm
@@ -0,0 +1,250 @@
+;;; read-text-outline --- Read a text outline and display it as a sexp
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: read-text-outline OUTLINE
+;;
+;; Scan OUTLINE file and display a list of trees, the structure of
+;; each reflecting the "levels" in OUTLINE. The recognized outline
+;; format (used to indicate outline headings) is zero or more pairs of
+;; leading spaces followed by "-". Something like:
+;;
+;; - a 0
+;; - b 1
+;; - c 2
+;; - d 1
+;; - e 0
+;; - f 1
+;; - g 2
+;; - h 1
+;;
+;; In this example the levels are shown to the right. The output for
+;; such a file would be the single line:
+;;
+;; (("a" ("b" "c") "d") ("e" ("f" "g") "h"))
+;;
+;; Basically, anything at the beginning of a list is a parent, and the
+;; remaining elements of that list are its children.
+;;
+;;
+;; Usage from a Scheme program: These two procs are exported:
+;;
+;; (read-text-outline . args) ; only first arg is used
+;; (read-text-outline-silently port)
+;; (make-text-outline-reader re specs)
+;;
+;; `make-text-outline-reader' returns a proc that reads from PORT and
+;; returns a list of trees (similar to `read-text-outline-silently').
+;;
+;; RE is a regular expression (string) that is used to identify a header
+;; line of the outline (as opposed to a whitespace line or intervening
+;; text). RE must begin w/ a sub-expression to match the "level prefix"
+;; of the line. You can use `level-submatch-number' in SPECS (explained
+;; below) to specify a number other than 1, the default.
+;;
+;; Normally, the level of the line is taken directly as the length of
+;; its level prefix. This often results in adjacent levels not mapping
+;; to adjacent numbers, which confuses the tree-building portion of the
+;; program, which expects top-level to be 0, first sub-level to be 1,
+;; etc. You can use `level-substring-divisor' or `compute-level' in
+;; SPECS to specify a constant scaling factor or specify a completely
+;; alternative procedure, respectively.
+;;
+;; SPECS is an alist which may contain the following key/value pairs:
+;;
+;; - level-submatch-number NUMBER
+;; - level-substring-divisor NUMBER
+;; - compute-level PROC
+;; - body-submatch-number NUMBER
+;; - extra-fields ((FIELD-1 . SUBMATCH-1) (FIELD-2 . SUBMATCH-2) ...)
+;;
+;; The PROC value associated with key `compute-level' should take a
+;; Scheme match structure (as returned by `regexp-exec') and return a
+;; number, the normalized level for that line. If this is specified,
+;; it takes precedence over other level-computation methods.
+;;
+;; Use `body-submatch-number' if RE specifies the whole body, or if you
+;; want to make use of the extra fields parsing. The `extra-fields'
+;; value is a sub-alist, whose keys name additional fields that are to
+;; be recognized. These fields along with `level' are set as object
+;; properties of the final string ("body") that is consed into the tree.
+;; If a field name ends in "?" the field value is set to be #t if there
+;; is a match and the result is not an empty string, and #f otherwise.
+;;
+;;
+;; Bugs and caveats:
+;;
+;; (1) Only the first file specified on the command line is scanned.
+;; (2) TAB characters at the beginnings of lines are not recognized.
+;; (3) Outlines that "skip" levels signal an error. In other words,
+;; this will fail:
+;;
+;; - a 0
+;; - b 1
+;; - c 3 <-- skipped 2 -- error!
+;; - d 1
+;;
+;;
+;; TODO: Determine what's the right thing to do for skips.
+;; Handle TABs.
+;; Make line format customizable via longopts.
+
+;;; Code:
+
+(define-module (scripts read-text-outline)
+ :export (read-text-outline
+ read-text-outline-silently
+ make-text-outline-reader)
+ :use-module (ice-9 regex)
+ :autoload (ice-9 rdelim) (read-line)
+ :autoload (ice-9 getopt-long) (getopt-long))
+
+(define (?? symbol)
+ (let ((name (symbol->string symbol)))
+ (string=? "?" (substring name (1- (string-length name))))))
+
+(define (msub n)
+ (lambda (m)
+ (match:substring m n)))
+
+(define (??-predicates pair)
+ (cons (car pair)
+ (if (?? (car pair))
+ (lambda (m)
+ (not (string=? "" (match:substring m (cdr pair)))))
+ (msub (cdr pair)))))
+
+(define (make-line-parser re specs)
+ (let* ((rx (let ((fc (substring re 0 1)))
+ (make-regexp (if (string=? "^" fc)
+ re
+ (string-append "^" re)))))
+ (check (lambda (key)
+ (assq-ref specs key)))
+ (level-substring (msub (or (check 'level-submatch-number) 1)))
+ (extract-level (cond ((check 'compute-level)
+ => (lambda (proc)
+ (lambda (m)
+ (proc m))))
+ ((check 'level-substring-divisor)
+ => (lambda (n)
+ (lambda (m)
+ (/ (string-length (level-substring m))
+ n))))
+ (else
+ (lambda (m)
+ (string-length (level-substring m))))))
+ (extract-body (cond ((check 'body-submatch-number)
+ => msub)
+ (else
+ (lambda (m) (match:suffix m)))))
+ (misc-props! (cond ((check 'extra-fields)
+ => (lambda (alist)
+ (let ((new (map ??-predicates alist)))
+ (lambda (obj m)
+ (for-each
+ (lambda (pair)
+ (set-object-property!
+ obj (car pair)
+ ((cdr pair) m)))
+ new)))))
+ (else
+ (lambda (obj m) #t)))))
+ ;; retval
+ (lambda (line)
+ (cond ((regexp-exec rx line)
+ => (lambda (m)
+ (let ((level (extract-level m))
+ (body (extract-body m)))
+ (set-object-property! body 'level level)
+ (misc-props! body m)
+ body)))
+ (else #f)))))
+
+(define (make-text-outline-reader re specs)
+ (let ((parse-line (make-line-parser re specs)))
+ ;; retval
+ (lambda (port)
+ (let* ((all '(start))
+ (pchain (list))) ; parents chain
+ (let loop ((line (read-line port))
+ (prev-level -1) ; how this relates to the first input
+ ; level determines whether or not we
+ ; start in "sibling" or "child" mode.
+ ; in the end, `start' is ignored and
+ ; it's much easier to ignore parents
+ ; than siblings (sometimes). this is
+ ; not to encourage ignorance, however.
+ (tp all)) ; tail pointer
+ (or (eof-object? line)
+ (cond ((parse-line line)
+ => (lambda (w)
+ (let* ((words (list w))
+ (level (object-property w 'level))
+ (diff (- level prev-level)))
+ (cond
+
+ ;; sibling
+ ((zero? diff)
+ ;; just extend the chain
+ (set-cdr! tp words))
+
+ ;; child
+ ((positive? diff)
+ (or (= 1 diff)
+ (error "unhandled diff not 1:" diff line))
+ ;; parent may be contacted by uncle later (kids
+ ;; these days!) so save its level
+ (set-object-property! tp 'level prev-level)
+ (set! pchain (cons tp pchain))
+ ;; "push down" car into hierarchy
+ (set-car! tp (cons (car tp) words)))
+
+ ;; uncle
+ ((negative? diff)
+ ;; prune back to where levels match
+ (do ((p pchain (cdr p)))
+ ((= level (object-property (car p) 'level))
+ (set! pchain p)))
+ ;; resume at this level
+ (set-cdr! (car pchain) words)
+ (set! pchain (cdr pchain))))
+
+ (loop (read-line port) level words))))
+ (else (loop (read-line port) prev-level tp)))))
+ (set! all (car all))
+ (if (eq? 'start all)
+ '() ; wasteland
+ (cdr all))))))
+
+(define read-text-outline-silently
+ (make-text-outline-reader "(([ ][ ])*)- *"
+ '((level-substring-divisor . 2))))
+
+(define (read-text-outline . args)
+ (write (read-text-outline-silently (open-file (car args) "r")))
+ (newline)
+ #t) ; exit val
+
+(define main read-text-outline)
+
+;;; read-text-outline ends here
diff --git a/module/scripts/scan-api.scm b/module/scripts/scan-api.scm
new file mode 100644
index 000000000..9236f8742
--- /dev/null
+++ b/module/scripts/scan-api.scm
@@ -0,0 +1,220 @@
+;;; scan-api --- Scan and group interpreter and libguile interface elements
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: scan-api GUILE SOFILE [GROUPINGS ...]
+;;
+;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a
+;; shared-object library, to determine available interface elements, and
+;; display them to stdout as an alist:
+;;
+;; ((meta ...) (interface ...))
+;;
+;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile'
+;; `libguileinterface', `sofile' and `groups'. The interface elements are in
+;; turn sub-alists w/ keys `groups' and `scan-data'. Interface elements
+;; initially belong in one of two groups `Scheme' or `C' (but not both --
+;; signal error if that happens).
+;;
+;; Optional GROUPINGS ... are files each containing a single "grouping
+;; definition" alist with each entry of the form:
+;;
+;; (NAME (description "DESCRIPTION") (members SYM...))
+;;
+;; All of the SYM... should be proper subsets of the interface. In addition
+;; to `description' and `members' forms, the entry may optionally include:
+;;
+;; (grok USE-MODULES (lambda (x) CODE))
+;;
+;; where CODE implements a group-membership predicate to be applied to `x', a
+;; symbol. [When evaluated, CODE can assume (use-modules MODULE) has been
+;; executed where MODULE is an element of USE-MODULES, a list. [NOT YET
+;; IMPLEMENTED!]]
+;;
+;; Currently, there are two convenience predicates that operate on `x':
+;; (in-group? x GROUP)
+;; (name-prefix? x PREFIX)
+;;
+;; TODO: Allow for concurrent Scheme/C membership.
+;; Completely separate reporting.
+
+;;; Code:
+
+(define-module (scripts scan-api)
+ :use-module (ice-9 popen)
+ :use-module (ice-9 rdelim)
+ :use-module (ice-9 regex)
+ :export (scan-api))
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (add-props object . args)
+ (let loop ((args args))
+ (if (null? args)
+ object ; retval
+ (let ((key (car args))
+ (value (cadr args)))
+ (put object key value)
+ (loop (cddr args))))))
+
+(define (scan re command match)
+ (let ((rx (make-regexp re))
+ (port (open-pipe command OPEN_READ)))
+ (let loop ((line (read-line port)))
+ (or (eof-object? line)
+ (begin
+ (cond ((regexp-exec rx line) => match))
+ (loop (read-line port)))))))
+
+(define (scan-Scheme! ht guile)
+ (scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$"
+ (format #f "~A -c '~S ~S'"
+ guile
+ '(use-modules (ice-9 session))
+ '(apropos "."))
+ (lambda (m)
+ (let ((x (string->symbol (match:substring m 1))))
+ (put x 'Scheme (or (match:substring m 3)
+ ""))
+ (hashq-set! ht x #t)))))
+
+(define (scan-C! ht sofile)
+ (scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$"
+ (format #f "nm ~A" sofile)
+ (lambda (m)
+ (let ((x (string->symbol (match:substring m 2))))
+ (put x 'C (string->symbol (match:substring m 1)))
+ (and (hashq-get-handle ht x)
+ (error "both Scheme and C:" x))
+ (hashq-set! ht x #t)))))
+
+(define THIS-MODULE (current-module))
+
+(define (in-group? x group)
+ (memq group (get x 'groups)))
+
+(define (name-prefix? x prefix)
+ (string-match (string-append "^" prefix) (symbol->string x)))
+
+(define (add-group-name! x name)
+ (put x 'groups (cons name (get x 'groups))))
+
+(define (make-grok-proc name form)
+ (let* ((predicate? (eval form THIS-MODULE))
+ (p (lambda (x)
+ (and (predicate? x)
+ (add-group-name! x name)))))
+ (put p 'name name)
+ p))
+
+(define (make-members-proc name members)
+ (let ((p (lambda (x)
+ (and (memq x members)
+ (add-group-name! x name)))))
+ (put p 'name name)
+ p))
+
+(define (make-grouper files) ; \/^^^o/ . o
+ (let ((hook (make-hook 1))) ; /\____\
+ (for-each
+ (lambda (file)
+ (for-each
+ (lambda (gdef)
+ (let ((name (car gdef))
+ (members (assq-ref gdef 'members))
+ (grok (assq-ref gdef 'grok)))
+ (or members grok
+ (error "bad grouping, must have `members' or `grok'"))
+ (add-hook! hook
+ (if grok
+ (add-props (make-grok-proc name (cadr grok))
+ 'description
+ (assq-ref gdef 'description))
+ (make-members-proc name members))
+ #t))) ; append
+ (read (open-file file OPEN_READ))))
+ files)
+ hook))
+
+(define (scan-api . args)
+ (let ((guile (list-ref args 0))
+ (sofile (list-ref args 1))
+ (grouper (false-if-exception (make-grouper (cddr args))))
+ (ht (make-hash-table 3331)))
+ (scan-Scheme! ht guile)
+ (scan-C! ht sofile)
+ (let ((all (sort (hash-fold (lambda (key value prior-result)
+ (add-props
+ key
+ 'string (symbol->string key)
+ 'scan-data (or (get key 'Scheme)
+ (get key 'C))
+ 'groups (if (get key 'Scheme)
+ '(Scheme)
+ '(C)))
+ (and grouper (run-hook grouper key))
+ (cons key prior-result))
+ '()
+ ht)
+ (lambda (a b)
+ (string<? (get a 'string)
+ (get b 'string))))))
+ (format #t ";;; generated by scan-api -- do not edit!\n\n")
+ (format #t "(\n")
+ (format #t "(meta\n")
+ (format #t " (GUILE_LOAD_PATH . ~S)\n"
+ (or (getenv "GUILE_LOAD_PATH") ""))
+ (format #t " (LTDL_LIBRARY_PATH . ~S)\n"
+ (or (getenv "LTDL_LIBRARY_PATH") ""))
+ (format #t " (guile . ~S)\n" guile)
+ (format #t " (libguileinterface . ~S)\n"
+ (let ((i #f))
+ (scan "(.+)"
+ (format #f "~A -c '(display ~A)'"
+ guile
+ '(assq-ref %guile-build-info
+ 'libguileinterface))
+ (lambda (m) (set! i (match:substring m 1))))
+ i))
+ (format #t " (sofile . ~S)\n" sofile)
+ (format #t " ~A\n"
+ (cons 'groups (append (if grouper
+ (map (lambda (p) (get p 'name))
+ (hook->list grouper))
+ '())
+ '(Scheme C))))
+ (format #t ") ;; end of meta\n")
+ (format #t "(interface\n")
+ (for-each (lambda (x)
+ (format #t "(~A ~A (scan-data ~S))\n"
+ x
+ (cons 'groups (get x 'groups))
+ (get x 'scan-data)))
+ all)
+ (format #t ") ;; end of interface\n")
+ (format #t ") ;; eof\n")))
+ #t)
+
+(define main scan-api)
+
+;;; scan-api ends here
diff --git a/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm
new file mode 100644
index 000000000..0e7efae47
--- /dev/null
+++ b/module/scripts/snarf-check-and-output-texi.scm
@@ -0,0 +1,308 @@
+;;; snarf-check-and-output-texi --- called by the doc snarfer.
+
+;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Michael Livshin
+
+;;; Code:
+
+(define-module (scripts snarf-check-and-output-texi)
+ :use-module (ice-9 streams)
+ :use-module (ice-9 match)
+ :export (snarf-check-and-output-texi))
+
+;;; why aren't these in some module?
+
+(define-macro (when cond . body)
+ `(if ,cond (begin ,@body)))
+
+(define-macro (unless cond . body)
+ `(if (not ,cond) (begin ,@body)))
+
+(define *manual-flag* #f)
+
+(define (snarf-check-and-output-texi . flags)
+ (if (member "--manual" flags)
+ (set! *manual-flag* #t))
+ (process-stream (current-input-port)))
+
+(define (process-stream port)
+ (let loop ((input (stream-map (match-lambda
+ (('id . s)
+ (cons 'id (string->symbol s)))
+ (('int_dec . s)
+ (cons 'int (string->number s)))
+ (('int_oct . s)
+ (cons 'int (string->number s 8)))
+ (('int_hex . s)
+ (cons 'int (string->number s 16)))
+ ((and x (? symbol?))
+ (cons x x))
+ ((and x (? string?))
+ (cons 'string x))
+ (x x))
+ (make-stream (lambda (s)
+ (let loop ((s s))
+ (cond
+ ((stream-null? s) #t)
+ ((eq? 'eol (stream-car s))
+ (loop (stream-cdr s)))
+ (else (cons (stream-car s) (stream-cdr s))))))
+ (port->stream port read)))))
+
+ (unless (stream-null? input)
+ (let ((token (stream-car input)))
+ (if (eq? (car token) 'snarf_cookie)
+ (dispatch-top-cookie (stream-cdr input)
+ loop)
+ (loop (stream-cdr input)))))))
+
+(define (dispatch-top-cookie input cont)
+
+ (when (stream-null? input)
+ (error 'syntax "premature end of file"))
+
+ (let ((token (stream-car input)))
+ (cond
+ ((eq? (car token) 'brace_open)
+ (consume-multiline (stream-cdr input)
+ cont))
+ (else
+ (consume-upto-cookie process-singleline
+ input
+ cont)))))
+
+(define (consume-upto-cookie process input cont)
+ (let loop ((acc '()) (input input))
+
+ (when (stream-null? input)
+ (error 'syntax "premature end of file in directive context"))
+
+ (let ((token (stream-car input)))
+ (cond
+ ((eq? (car token) 'snarf_cookie)
+ (process (reverse! acc))
+ (cont (stream-cdr input)))
+
+ (else (loop (cons token acc) (stream-cdr input)))))))
+
+(define (consume-multiline input cont)
+ (begin-multiline)
+
+ (let loop ((input input))
+
+ (when (stream-null? input)
+ (error 'syntax "premature end of file in multiline context"))
+
+ (let ((token (stream-car input)))
+ (cond
+ ((eq? (car token) 'brace_close)
+ (end-multiline)
+ (cont (stream-cdr input)))
+
+ (else (consume-upto-cookie process-multiline-directive
+ input
+ loop))))))
+
+(define *file* #f)
+(define *line* #f)
+(define *c-function-name* #f)
+(define *function-name* #f)
+(define *snarf-type* #f)
+(define *args* #f)
+(define *sig* #f)
+(define *docstring* #f)
+
+(define (begin-multiline)
+ (set! *file* #f)
+ (set! *line* #f)
+ (set! *c-function-name* #f)
+ (set! *function-name* #f)
+ (set! *snarf-type* #f)
+ (set! *args* #f)
+ (set! *sig* #f)
+ (set! *docstring* #f))
+
+(define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
+(define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
+
+(define (end-multiline)
+ (let* ((req (car *sig*))
+ (opt (cadr *sig*))
+ (var (caddr *sig*))
+ (all (+ req opt var)))
+ (if (and (not (eqv? *snarf-type* 'register))
+ (not (= (length *args*) all)))
+ (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
+ *file* *line* *function-name* (length *args*) all)))
+ (let ((nice-sig
+ (if (eq? *snarf-type* 'register)
+ *function-name*
+ (with-output-to-string
+ (lambda ()
+ (format #t "~A" *function-name*)
+ (let loop-req ((args *args*) (r 0))
+ (if (< r req)
+ (begin
+ (format #t " ~A" (car args))
+ (loop-req (cdr args) (+ 1 r)))
+ (let loop-opt ((o 0) (args args) (tail '()))
+ (if (< o opt)
+ (begin
+ (format #t " [~A" (car args))
+ (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
+ (begin
+ (if (> var 0)
+ (format #t " . ~A"
+ (car args)))
+ (let loop-tail ((tail tail))
+ (if (not (null? tail))
+ (begin
+ (format #t "~A" (car tail))
+ (loop-tail (cdr tail))))))))))))))
+ (scm-deffnx
+ (if (and *manual-flag* (eq? *snarf-type* 'primitive))
+ (with-output-to-string
+ (lambda ()
+ (format #t "@deffnx {C Function} ~A (" *c-function-name*)
+ (unless (null? *args*)
+ (format #t "~A" (car *args*))
+ (let loop ((args (cdr *args*)))
+ (unless (null? args)
+ (format #t ", ~A" (car args))
+ (loop (cdr args)))))
+ (format #t ")\n")))
+ #f)))
+ (format #t "\n ~A\n" *function-name*)
+ (format #t "@c snarfed from ~A:~A\n" *file* *line*)
+ (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
+ (let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
+ (cond ((null? strings))
+ ((or (not scm-deffnx)
+ (and (>= (string-length (car strings))
+ *primitive-deffnx-sig-length*)
+ (string=? (substring (car strings)
+ 0 *primitive-deffnx-sig-length*)
+ *primitive-deffnx-signature*)))
+ (display (car strings))
+ (loop (cdr strings) scm-deffnx))
+ (else (display scm-deffnx)
+ (loop strings #f))))
+ (display "\n")
+ (display "@end deffn\n"))))
+
+(define (texi-quote s)
+ (let rec ((i 0))
+ (if (= i (string-length s))
+ ""
+ (string-append (let ((ss (substring s i (+ i 1))))
+ (if (string=? ss "@")
+ "@@"
+ ss))
+ (rec (+ i 1))))))
+
+(define (process-multiline-directive l)
+
+ (define do-args
+ (match-lambda
+
+ (('(paren_close . paren_close))
+ '())
+
+ (('(comma . comma) rest ...)
+ (do-args rest))
+
+ (('(id . SCM) ('id . name) rest ...)
+ (cons name (do-args rest)))
+
+ (x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
+
+ (define do-arglist
+ (match-lambda
+
+ (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
+ '())
+
+ (('(paren_open . paren_open) rest ...)
+ (do-args rest))
+
+ (x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
+
+ (define do-command
+ (match-lambda
+
+ (('cname ('id . name))
+ (set! *c-function-name* (texi-quote (symbol->string name))))
+
+ (('fname ('string . name) ...)
+ (set! *function-name* (texi-quote (apply string-append name))))
+
+ (('type ('id . type))
+ (set! *snarf-type* type))
+
+ (('type ('int . num))
+ (set! *snarf-type* num))
+
+ (('location ('string . file) ('int . line))
+ (set! *file* file)
+ (set! *line* line))
+
+ (('arglist rest ...)
+ (set! *args* (do-arglist rest)))
+
+ (('argsig ('int . req) ('int . opt) ('int . var))
+ (set! *sig* (list req opt var)))
+
+ (x (error (format #f "unknown doc attribute: ~A" x)))))
+
+ (define do-directive
+ (match-lambda
+
+ ((('id . command) rest ...)
+ (do-command (cons command rest)))
+
+ ((('string . string) ...)
+ (set! *docstring* string))
+
+ (x (error (format #f "unknown doc attribute syntax: ~A" x)))))
+
+ (do-directive l))
+
+(define (process-singleline l)
+
+ (define do-argpos
+ (match-lambda
+ ((('id . name) ('int . pos) ('int . line))
+ (let ((idx (list-index *args* name)))
+ (when idx
+ (unless (= (+ idx 1) pos)
+ (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
+ *file* line name pos (+ idx 1))
+ (current-error-port))))))
+ (x #f)))
+
+ (define do-command
+ (match-lambda
+ (('(id . argpos) rest ...)
+ (do-argpos rest))
+ (x (error (format #f "unknown check: ~A" x)))))
+
+ (when *function-name*
+ (do-command l)))
+
+(define main snarf-check-and-output-texi)
diff --git a/module/scripts/snarf-guile-m4-docs.scm b/module/scripts/snarf-guile-m4-docs.scm
new file mode 100644
index 000000000..05c305ebd
--- /dev/null
+++ b/module/scripts/snarf-guile-m4-docs.scm
@@ -0,0 +1,83 @@
+;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: snarf-guile-m4-docs FILE
+;;
+;; Grep FILE for comments preceding macro definitions, massage
+;; them into valid texi, and display to stdout. For each comment,
+;; lines preceding "^# Usage:" are discarded.
+;;
+;; TODO: Generalize.
+
+;;; Code:
+
+(define-module (scripts snarf-guile-m4-docs)
+ :use-module (ice-9 rdelim)
+ :export (snarf-guile-m4-docs))
+
+(define (display-texi lines)
+ (display "@deffn {Autoconf Macro}")
+ (for-each (lambda (line)
+ (display (cond ((and (>= (string-length line) 2)
+ (string=? "# " (substring line 0 2)))
+ (substring line 2))
+ ((string=? "#" (substring line 0 1))
+ (substring line 1))
+ (else line)))
+ (newline))
+ lines)
+ (display "@end deffn")
+ (newline) (newline))
+
+(define (prefix? line sub)
+ (false-if-exception
+ (string=? sub (substring line 0 (string-length sub)))))
+
+(define (massage-usage line)
+ (let loop ((line (string->list line)) (acc '()))
+ (if (null? line)
+ (list (list->string (reverse acc)))
+ (loop (cdr line)
+ (cons (case (car line)
+ ((#\( #\) #\,) #\space)
+ (else (car line)))
+ acc)))))
+
+(define (snarf-guile-m4-docs . args)
+ (let* ((p (open-file (car args) "r"))
+ (next (lambda () (read-line p))))
+ (let loop ((line (next)) (acc #f))
+ (or (eof-object? line)
+ (cond ((prefix? line "# Usage:")
+ (loop (next) (massage-usage (substring line 8))))
+ ((prefix? line "AC_DEFUN")
+ (display-texi (reverse acc))
+ (loop (next) #f))
+ ((and acc (prefix? line "#"))
+ (loop (next) (cons line acc)))
+ (else
+ (loop (next) #f)))))))
+
+(define main snarf-guile-m4-docs)
+
+;;; snarf-guile-m4-docs ends here
diff --git a/module/scripts/summarize-guile-TODO.scm b/module/scripts/summarize-guile-TODO.scm
new file mode 100644
index 000000000..a67c92ede
--- /dev/null
+++ b/module/scripts/summarize-guile-TODO.scm
@@ -0,0 +1,210 @@
+;;; summarize-guile-TODO --- Display Guile TODO list in various ways
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: summarize-guile-TODO TODOFILE
+;;
+;; The TODOFILE is typically Guile's (see workbook/tasks/README)
+;; presumed to serve as our signal to ourselves (lest we want real
+;; bosses hassling us) wrt to the overt message "items to do" as well as
+;; the messages that can be inferred from its structure.
+;;
+;; This program reads TODOFILE and displays interpretations on its
+;; structure, including registered markers and ownership, in various
+;; ways.
+;;
+;; A primary interest in any task is its parent task. The output
+;; summarization by default lists every item and its parent chain.
+;; Top-level parents are not items. You can use these command-line
+;; options to modify the selection and display (selection criteria
+;; are ANDed together):
+;;
+;; -i, --involved USER -- select USER-involved items
+;; -p, --personal USER -- select USER-responsible items
+;; -t, --todo -- select unfinished items (status "-")
+;; -d, --done -- select finished items (status "+")
+;; -r, --review -- select review items (marker "R")
+;;
+;; -w, --who -- also show who is associated w/ the item
+;; -n, --no-parent -- do not show parent chain
+;;
+;;
+;; Usage from a Scheme program:
+;; (summarize-guile-TODO . args) ; uses first arg only
+;;
+;;
+;; Bugs: (1) Markers are scanned in sequence: D R X N%. This means "XD"
+;; and the like are completely dropped. However, such strings
+;; are unlikely to be used if the markers are chosen to be
+;; somewhat exclusive, which is currently the case for D R X.
+;; N% used w/ these needs to be something like: "D25%" (this
+;; means discussion accounts for 1/4 of the task).
+;;
+;; TODO: Implement more various ways. (Patches welcome.)
+;; Add support for ORing criteria.
+
+;;; Code:
+(debug-enable 'debug 'backtrace)
+
+(define-module (scripts summarize-guile-TODO)
+ :use-module (scripts read-text-outline)
+ :use-module (ice-9 getopt-long)
+ :autoload (srfi srfi-13) (string-tokenize) ; string library
+ :autoload (srfi srfi-14) (char-set) ; string library
+ :autoload (ice-9 common-list) (remove-if-not)
+ :export (summarize-guile-TODO))
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (as-leaf x)
+ (cond ((get x 'who)
+ => (lambda (who)
+ (put x 'who
+ (map string->symbol
+ (string-tokenize who (char-set #\:)))))))
+ (cond ((get x 'pct-done)
+ => (lambda (pct-done)
+ (put x 'pct-done (string->number pct-done)))))
+ x)
+
+(define (hang-by-the-leaves trees)
+ (let ((leaves '()))
+ (letrec ((hang (lambda (tree parent)
+ (if (list? tree)
+ (begin
+ (put (car tree) 'parent parent)
+ (for-each (lambda (child)
+ (hang child (car tree)))
+ (cdr tree)))
+ (begin
+ (put tree 'parent parent)
+ (set! leaves (cons (as-leaf tree) leaves)))))))
+ (for-each (lambda (tree)
+ (hang tree #f))
+ trees))
+ leaves))
+
+(define (read-TODO file)
+ (hang-by-the-leaves
+ ((make-text-outline-reader
+ "(([ ][ ])*)([-+])(D*)(R*)(X*)(([0-9]+)%)* *([^[]*)(\\[(.*)\\])*"
+ '((level-substring-divisor . 2)
+ (body-submatch-number . 9)
+ (extra-fields . ((status . 3)
+ (design? . 4)
+ (review? . 5)
+ (extblock? . 6)
+ (pct-done . 8)
+ (who . 11)))))
+ (open-file file "r"))))
+
+(define (select-items p items)
+ (let ((sub '()))
+ (cond ((option-ref p 'involved #f)
+ => (lambda (u)
+ (let ((u (string->symbol u)))
+ (set! sub (cons
+ (lambda (x)
+ (and (get x 'who)
+ (memq u (get x 'who))))
+ sub))))))
+ (cond ((option-ref p 'personal #f)
+ => (lambda (u)
+ (let ((u (string->symbol u)))
+ (set! sub (cons
+ (lambda (x)
+ (cond ((get x 'who)
+ => (lambda (ls)
+ (eq? (car (reverse ls))
+ u)))
+ (else #f)))
+ sub))))))
+ (for-each (lambda (pair)
+ (cond ((option-ref p (car pair) #f)
+ (set! sub (cons (cdr pair) sub)))))
+ `((todo . ,(lambda (x) (string=? (get x 'status) "-")))
+ (done . ,(lambda (x) (string=? (get x 'status) "+")))
+ (review . ,(lambda (x) (get x 'review?)))))
+ (let loop ((sub (reverse sub)) (items items))
+ (if (null? sub)
+ (reverse items)
+ (loop (cdr sub) (remove-if-not (car sub) items))))))
+
+(define (make-display-item show-who? show-parent?)
+ (let ((show-who
+ (if show-who?
+ (lambda (item)
+ (cond ((get item 'who)
+ => (lambda (who) (format #f " ~A" who)))
+ (else "")))
+ (lambda (item) "")))
+ (show-parents
+ (if show-parent?
+ (lambda (item)
+ (let loop ((parent (get item 'parent)) (indent 2))
+ (and parent
+ (begin
+ (format #t "under : ~A~A\n"
+ (make-string indent #\space)
+ parent)
+ (loop (get parent 'parent) (+ 2 indent))))))
+ (lambda (item) #t))))
+ (lambda (item)
+ (format #t "status: ~A~A~A~A~A~A\nitem : ~A\n"
+ (get item 'status)
+ (if (get item 'design?) "D" "")
+ (if (get item 'review?) "R" "")
+ (if (get item 'extblock?) "X" "")
+ (cond ((get item 'pct-done)
+ => (lambda (pct-done)
+ (format #f " ~A%" pct-done)))
+ (else ""))
+ (show-who item)
+ item)
+ (show-parents item))))
+
+(define (display-items p items)
+ (let ((display-item (make-display-item (option-ref p 'who #f)
+ (not (option-ref p 'no-parent #f))
+ )))
+ (for-each display-item items)))
+
+(define (summarize-guile-TODO . args)
+ (let ((p (getopt-long (cons "summarize-guile-TODO" args)
+ '((who (single-char #\w))
+ (no-parent (single-char #\n))
+ (involved (single-char #\i)
+ (value #t))
+ (personal (single-char #\p)
+ (value #t))
+ (todo (single-char #\t))
+ (done (single-char #\d))
+ (review (single-char #\r))
+ ;; Add options here.
+ ))))
+ (display-items p (select-items p (read-TODO (car (option-ref p '() #f))))))
+ #t) ; exit val
+
+(define main summarize-guile-TODO)
+
+;;; summarize-guile-TODO ends here
diff --git a/module/scripts/use2dot.scm b/module/scripts/use2dot.scm
new file mode 100644
index 000000000..ab97afbc7
--- /dev/null
+++ b/module/scripts/use2dot.scm
@@ -0,0 +1,108 @@
+;;; use2dot --- Display module dependencies as a DOT specification
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: use2dot [OPTIONS] [FILE ...]
+;; Display to stdout a DOT specification that describes module dependencies
+;; in FILEs.
+;;
+;; A top-level `use-modules' form or a `:use-module' `define-module'-component
+;; results in a "solid" style edge.
+;;
+;; An `:autoload' `define-module'-component results in a "dotted" style edge
+;; with label "N" indicating that N names are responsible for triggering the
+;; autoload. [The "N" label is not implemented.]
+;;
+;; A top-level `load' or `primitive-load' form results in a a "bold" style
+;; edge to a node named with either the file name if the `load' argument is a
+;; string, or "[computed in FILE]" otherwise.
+;;
+;; Options:
+;; -m, --default-module MOD -- Set MOD as the default module (for top-level
+;; `use-modules' forms that do not follow some
+;; `define-module' form in a file). MOD should be
+;; be a list or `#f', in which case such top-level
+;; `use-modules' forms are effectively ignored.
+;; Default value: `(guile-user)'.
+
+;;; Code:
+
+(define-module (scripts use2dot)
+ :autoload (ice-9 getopt-long) (getopt-long)
+ :use-module ((srfi srfi-13) :select (string-join))
+ :use-module ((scripts frisk)
+ :select (make-frisker edge-type edge-up edge-down))
+ :export (use2dot))
+
+(define *default-module* '(guile-user))
+
+(define (q s) ; quote
+ (format #f "~S" s))
+
+(define (vv pairs) ; => ("var=val" ...)
+ (map (lambda (pair)
+ (format #f "~A=~A" (car pair) (cdr pair)))
+ pairs))
+
+(define (>>header)
+ (format #t "digraph use2dot {\n")
+ (for-each (lambda (s) (format #t " ~A;\n" s))
+ (vv `((label . ,(q "Guile Module Dependencies"))
+ ;;(rankdir . LR)
+ ;;(size . ,(q "7.5,10"))
+ (ratio . fill)
+ ;;(nodesep . ,(q "0.05"))
+ ))))
+
+(define (>>body edges)
+ (for-each
+ (lambda (edge)
+ (format #t " \"~A\" -> \"~A\"" (edge-down edge) (edge-up edge))
+ (cond ((case (edge-type edge)
+ ((autoload) '((style . dotted) (fontsize . 5)))
+ ((computed) '((style . bold)))
+ (else #f))
+ => (lambda (etc)
+ (format #t " [~A]" (string-join (vv etc) ",")))))
+ (format #t ";\n"))
+ edges))
+
+(define (>>footer)
+ (format #t "}"))
+
+(define (>> edges)
+ (>>header)
+ (>>body edges)
+ (>>footer))
+
+(define (use2dot . args)
+ (let* ((parsed-args (getopt-long (cons "use2dot" args) ;;; kludge
+ '((default-module
+ (single-char #\m) (value #t)))))
+ (=m (option-ref parsed-args 'default-module *default-module*))
+ (scan (make-frisker `(default-module . ,=m)))
+ (files (option-ref parsed-args '() '())))
+ (>> (reverse ((scan files) 'edges)))))
+
+(define main use2dot)
+
+;;; use2dot ends here
diff --git a/module/srfi/Makefile.am b/module/srfi/Makefile.am
index 0fc926e40..7cbac6630 100644
--- a/module/srfi/Makefile.am
+++ b/module/srfi/Makefile.am
@@ -4,20 +4,20 @@
##
## This file is part of GUILE.
##
-## GUILE is free software; you can redistribute it and/or modify
-## it under the terms of the GNU General Public License as
-## published by the Free Software Foundation; either version 2, or
+## GUILE is free software; you can redistribute it and/or modify it
+## under the terms of the GNU Lesser General Public License as
+## published by the Free Software Foundation; either version 3, or
## (at your option) any later version.
-##
+##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU General Public License for more details.
-##
-## You should have received a copy of the GNU General Public
-## License along with GUILE; see the file COPYING. If not, write
-## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-## Floor, Boston, MA 02110-1301 USA
+## GNU Lesser General Public License for more details.
+##
+## You should have received a copy of the GNU Lesser General Public
+## License along with GUILE; see the file COPYING.LESSER. If not,
+## write to the Free Software Foundation, Inc., 51 Franklin Street,
+## Fifth Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 7c55d9923..db21122b9 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-10.scm b/module/srfi/srfi-10.scm
index 8e7181a3b..533d9f769 100644
--- a/module/srfi/srfi-10.scm
+++ b/module/srfi/srfi-10.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm
index 9e17d6632..22bda21a2 100644
--- a/module/srfi/srfi-11.scm
+++ b/module/srfi/srfi-11.scm
@@ -1,11 +1,11 @@
;;; srfi-11.scm --- let-values and let*-values
-;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -37,7 +37,6 @@
;;; Code:
(define-module (srfi srfi-11)
- :use-module (ice-9 syncase)
:export-syntax (let-values let*-values))
(cond-expand-provide (current-module) '(srfi-11))
@@ -64,148 +63,58 @@
;; (q <tmp-q>))
;; (baz x y z p q))))))
-;; I originally wrote this as a define-macro, but then I found out
-;; that guile's gensym/gentemp was broken, so I tried rewriting it as
-;; a syntax-rules statement.
-;; [make-symbol now fixes gensym/gentemp problems.]
-;;
-;; Since syntax-rules didn't seem powerful enough to implement
-;; let-values in one definition without exposing illegal syntax (or
-;; perhaps my brain's just not powerful enough :>). I tried writing
-;; it using a private helper, but that didn't work because the
-;; let-values expands outside the scope of this module. I wonder why
-;; syntax-rules wasn't designed to allow "private" patterns or
-;; similar...
-;;
-;; So in the end, I dumped the syntax-rules implementation, reproduced
-;; here for posterity, and went with the define-macro one below --
-;; gensym/gentemp's got to be fixed anyhow...
-;
-; (define-syntax let-values-helper
-; (syntax-rules ()
-; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
-; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
-; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
-; ;; temps you create so you can use them later...
-; ;;
-; ;; I really don't fully understand why the (var-1 var-1) trick
-; ;; works below, but basically, when all those (x x) bindings show
-; ;; up in the final "let", syntax-rules forces a renaming.
-
-; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
-; body ...)
-; (lambda lambda-tmps
-; (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
-
-; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
-; body ...)
-; (let-values-helper "consumer"
-; (var-2 ...)
-; (lambda-tmp ... var-1)
-; ((var-1 var-1) . final-let-bindings)
-; lv-bindings
-; body ...))
-
-; ((_ "cwv" () final-let-bindings body ...)
-; (let final-let-bindings
-; body ...))
-
-; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
-; body ...)
-; (call-with-values (lambda () binding-1)
-; (let-values-helper "consumer"
-; vars-1
-; ()
-; final-let-bindings
-; (other-bindings ...)
-; body ...)))))
-;
-; (define-syntax let-values
-; (syntax-rules ()
-; ((let-values () body ...)
-; (begin body ...))
-; ((let-values (binding ...) body ...)
-; (let-values-helper "cwv" (binding ...) () body ...))))
-;
-;
-; (define-syntax let-values
-; (letrec-syntax ((build-consumer
-; ;; Take the vars from one let binding (i.e. the (x
-; ;; y z) from ((x y z) (values 1 2 3)) and turn it
-; ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
-; ;; <tmp-z>) ...) from above.
-; (syntax-rules ()
-; ((_ () new-tmps tmp-vars () body ...)
-; (lambda new-tmps
-; body ...))
-; ((_ () new-tmps tmp-vars vars body ...)
-; (lambda new-tmps
-; (lv-builder vars tmp-vars body ...)))
-; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
-; (build-consumer (var-2 ...)
-; (tmp-1 . new-tmps)
-; ((var-1 tmp-1) . tmp-vars)
-; bindings
-; body ...))))
-; (lv-builder
-; (syntax-rules ()
-; ((_ () tmp-vars body ...)
-; (let tmp-vars
-; body ...))
-; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
-; tmp-vars
-; body ...)
-; (call-with-values (lambda () binding-1)
-; (build-consumer vars-1
-; ()
-; tmp-vars
-; ((vars-2 binding-2) ...)
-; body ...))))))
-;
-; (syntax-rules ()
-; ((_ () body ...)
-; (begin body ...))
-; ((_ ((vars binding) ...) body ...)
-; (lv-builder ((vars binding) ...) () body ...)))))
-
-(define-macro (let-values vars . body)
-
- (define (map-1-dot proc elts)
- ;; map over one optionally dotted (a b c . d) list, producing an
- ;; optionally dotted result.
- (cond
- ((null? elts) '())
- ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
- (else (proc elts))))
-
- (define (undot-list lst)
- ;; produce a non-dotted list from a possibly dotted list.
- (cond
- ((null? lst) '())
- ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
- (else (list lst))))
-
- (define (let-values-helper vars body prev-let-vars)
- (let* ((var-binding (car vars))
- (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var"))
- (car var-binding)))
- (let-vars (map (lambda (sym tmp) (list sym tmp))
- (undot-list (car var-binding))
- (undot-list new-tmps))))
-
- (if (null? (cdr vars))
- `(call-with-values (lambda () ,(cadr var-binding))
- (lambda ,new-tmps
- (let ,(apply append let-vars prev-let-vars)
- ,@body)))
- `(call-with-values (lambda () ,(cadr var-binding))
- (lambda ,new-tmps
- ,(let-values-helper (cdr vars) body
- (cons let-vars prev-let-vars)))))))
-
- (if (null? vars)
- `(begin ,@body)
- (let-values-helper vars body '())))
+;; We could really use quasisyntax here...
+(define-syntax let-values
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((binds exp)) b0 b1 ...)
+ (syntax (call-with-values (lambda () exp)
+ (lambda binds b0 b1 ...))))
+ ((_ (clause ...) b0 b1 ...)
+ (let lp ((clauses (syntax (clause ...)))
+ (ids '())
+ (tmps '()))
+ (if (null? clauses)
+ (with-syntax (((id ...) ids)
+ ((tmp ...) tmps))
+ (syntax (let ((id tmp) ...)
+ b0 b1 ...)))
+ (syntax-case (car clauses) ()
+ (((var ...) exp)
+ (with-syntax (((new-tmp ...) (generate-temporaries
+ (syntax (var ...))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (var ... id ...))
+ (syntax (new-tmp ... tmp ...)))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda (new-tmp ...) inner))))))
+ ((vars exp)
+ (with-syntax ((((new-tmp . new-var) ...)
+ (let lp ((vars (syntax vars)))
+ (syntax-case vars ()
+ ((id . rest)
+ (acons (syntax id)
+ (car
+ (generate-temporaries (syntax (id))))
+ (lp (syntax rest))))
+ (id (acons (syntax id)
+ (car
+ (generate-temporaries (syntax (id))))
+ '())))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (new-var ... id ...))
+ (syntax (new-tmp ... tmp ...))))
+ (args (let lp ((tmps (syntax (new-tmp ...))))
+ (syntax-case tmps ()
+ ((id) (syntax id))
+ ((id . rest) (cons (syntax id)
+ (lp (syntax rest))))))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda args inner)))))))))))))
;;;;;;;;;;;;;;
;; let*-values
@@ -227,28 +136,11 @@
(define-syntax let*-values
(syntax-rules ()
((let*-values () body ...)
- (begin body ...))
+ (let () body ...))
((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
(call-with-values (lambda () binding-1)
(lambda vars-1
(let*-values ((vars-2 binding-2) ...)
body ...))))))
-; Alternate define-macro implementation...
-;
-; (define-macro (let*-values vars . body)
-; (define (let-values-helper vars body)
-; (let ((var-binding (car vars)))
-; (if (null? (cdr vars))
-; `(call-with-values (lambda () ,(cadr var-binding))
-; (lambda ,(car var-binding)
-; ,@body))
-; `(call-with-values (lambda () ,(cadr var-binding))
-; (lambda ,(car var-binding)
-; ,(let-values-helper (cdr vars) body))))))
-
-; (if (null? vars)
-; `(begin ,@body)
-; (let-values-helper vars body)))
-
;;; srfi-11.scm ends here
diff --git a/module/srfi/srfi-13.scm b/module/srfi/srfi-13.scm
index 1036a0f47..a2d64cba3 100644
--- a/module/srfi/srfi-13.scm
+++ b/module/srfi/srfi-13.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-14.scm b/module/srfi/srfi-14.scm
index 100b43b8e..ecc21e52e 100644
--- a/module/srfi/srfi-14.scm
+++ b/module/srfi/srfi-14.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-16.scm b/module/srfi/srfi-16.scm
index 0b213fde7..dc3c70920 100644
--- a/module/srfi/srfi-16.scm
+++ b/module/srfi/srfi-16.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-17.scm b/module/srfi/srfi-17.scm
index c9cb2abfe..a14c5c33b 100644
--- a/module/srfi/srfi-17.scm
+++ b/module/srfi/srfi-17.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 925ecb304..26acb6300 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -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/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index 29c604fcd..b91824976 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-2.scm b/module/srfi/srfi-2.scm
index 0dfe38305..c09323fbb 100644
--- a/module/srfi/srfi-2.scm
+++ b/module/srfi/srfi-2.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-26.scm b/module/srfi/srfi-26.scm
index 410d2e2f8..324a5dc37 100644
--- a/module/srfi/srfi-26.scm
+++ b/module/srfi/srfi-26.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm
index 54c2f9fd4..4238dc269 100644
--- a/module/srfi/srfi-31.scm
+++ b/module/srfi/srfi-31.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-34.scm b/module/srfi/srfi-34.scm
index 18a2fda1c..7fb9d1dd6 100644
--- a/module/srfi/srfi-34.scm
+++ b/module/srfi/srfi-34.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 203546625..873b08b13 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -1,11 +1,11 @@
;;; srfi-35.scm --- Conditions
-;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
-;; version 2.1 of the License, or (at your option) any later version.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -28,6 +28,7 @@
(define-module (srfi srfi-35)
#:use-module (srfi srfi-1)
+ #:use-module (ice-9 syncase)
#:export (make-condition-type condition-type?
make-condition condition? condition-has-type? condition-ref
make-compound-condition extract-condition
@@ -274,37 +275,39 @@ by C."
;;; Syntax.
;;;
-(define-macro (define-condition-type name parent pred . field-specs)
- `(begin
- (define ,name
- (make-condition-type ',name ,parent
- ',(map car field-specs)))
- (define (,pred c)
- (condition-has-type? c ,name))
- ,@(map (lambda (field-spec)
- (let ((field-name (car field-spec))
- (accessor (cadr field-spec)))
- `(define (,accessor c)
- (condition-ref c ',field-name))))
- field-specs)))
-
-(define-macro (condition . type-field-bindings)
- (cond ((null? type-field-bindings)
- (error "`condition' syntax error" type-field-bindings))
- (else
- ;; the poor man's hygienic macro
- (let ((mc (gensym "mc"))
- (mcct (gensym "mcct")))
- `(let ((,mc (@ (srfi srfi-35) make-condition))
- (,mcct (@@ (srfi srfi-35) make-compound-condition-type)))
- (,mc (,mcct 'compound (list ,@(map car type-field-bindings)))
- ,@(append-map (lambda (type-field-binding)
- (append-map (lambda (field+value)
- (let ((f (car field+value))
- (v (cadr field+value)))
- `(',f ,v)))
- (cdr type-field-binding)))
- type-field-bindings)))))))
+(define-syntax define-condition-type
+ (syntax-rules ()
+ ((_ name parent pred (field-name field-accessor) ...)
+ (begin
+ (define name
+ (make-condition-type 'name parent '(field-name ...)))
+ (define (pred c)
+ (condition-has-type? c name))
+ (define (field-accessor c)
+ (condition-ref c 'field-name))
+ ...))))
+
+(define-syntax compound-condition
+ ;; Create a compound condition using `make-compound-condition-type'.
+ (syntax-rules ()
+ ((_ (type ...) (field ...))
+ (condition ((make-compound-condition-type '%compound `(,type ...))
+ field ...)))))
+
+(define-syntax condition-instantiation
+ ;; Build the `(make-condition type ...)' call.
+ (syntax-rules ()
+ ((_ type (out ...))
+ (make-condition type out ...))
+ ((_ type (out ...) (field-name field-value) rest ...)
+ (condition-instantiation type (out ... 'field-name field-value) rest ...))))
+
+(define-syntax condition
+ (syntax-rules ()
+ ((_ (type field ...))
+ (condition-instantiation type () field ...))
+ ((_ (type field ...) ...)
+ (compound-condition (type ...) (field ... ...)))))
;;;
diff --git a/module/srfi/srfi-37.scm b/module/srfi/srfi-37.scm
index 5e6d512a2..565b44cb9 100644
--- a/module/srfi/srfi-37.scm
+++ b/module/srfi/srfi-37.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm
index 086751170..61e67b820 100644
--- a/module/srfi/srfi-39.scm
+++ b/module/srfi/srfi-39.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -35,7 +35,6 @@
;;; Code:
(define-module (srfi srfi-39)
- #:use-module (ice-9 syncase)
#:use-module (srfi srfi-16)
#:export (make-parameter)
diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm
index f30e83952..b133f2106 100644
--- a/module/srfi/srfi-4.scm
+++ b/module/srfi/srfi-4.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm
index 1e455bb5c..098b586cc 100644
--- a/module/srfi/srfi-6.scm
+++ b/module/srfi/srfi-6.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-60.scm b/module/srfi/srfi-60.scm
index 177f97681..c9eb60f8b 100644
--- a/module/srfi/srfi-60.scm
+++ b/module/srfi/srfi-60.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm
index d26393576..0d835d09b 100644
--- a/module/srfi/srfi-69.scm
+++ b/module/srfi/srfi-69.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-8.scm b/module/srfi/srfi-8.scm
index c15cbe9c0..ced123894 100644
--- a/module/srfi/srfi-8.scm
+++ b/module/srfi/srfi-8.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-88.scm b/module/srfi/srfi-88.scm
index ebde81d0b..0fec19ee1 100644
--- a/module/srfi/srfi-88.scm
+++ b/module/srfi/srfi-88.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 59d23bf53..c64be5e51 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -5,7 +5,7 @@
;; 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.
+;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
diff --git a/module/srfi/srfi-98.scm b/module/srfi/srfi-98.scm
new file mode 100644
index 000000000..944f40261
--- /dev/null
+++ b/module/srfi/srfi-98.scm
@@ -0,0 +1,44 @@
+;;; srfi-98.scm --- An interface to access environment variables
+
+;; 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 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Julian Graham <julian.graham@aya.yale.edu>
+;;; Date: 2009-05-26
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-98 (An interface to access environment
+;; variables).
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-98)
+ :use-module (srfi srfi-1)
+ :export (get-environment-variable
+ get-environment-variables))
+
+(cond-expand-provide (current-module) '(srfi-98))
+
+(define get-environment-variable getenv)
+(define (get-environment-variables)
+ (define (string->alist-entry str)
+ (let ((pvt (string-index str #\=))
+ (len (string-length str)))
+ (and pvt (cons (substring str 0 pvt) (substring str (+ pvt 1) len)))))
+ (filter-map string->alist-entry (environ)))
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 891902367..8470f39e2 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -2,26 +2,26 @@
;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (system base compile)
#:use-module (system base syntax)
#:use-module (system base language)
+ #:use-module (system base message)
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
#:use-module (ice-9 regex)
#:use-module (ice-9 optargs)
@@ -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))
@@ -73,7 +73,7 @@
thunk
(lambda () #t))))
-(define (call-with-output-file/atomic filename proc)
+(define* (call-with-output-file/atomic filename proc #:optional reference)
(let* ((template (string-append filename ".XXXXXX"))
(tmp (mkstemp! template)))
(call-once
@@ -83,6 +83,9 @@
(proc tmp)
(chmod tmp (logand #o0666 (lognot (umask))))
(close-port tmp)
+ (if reference
+ (let ((st (stat reference)))
+ (utime template (stat:atime st) (stat:mtime st))))
(rename-file template filename))
(lambda args
(delete-file template)))))))
@@ -92,90 +95,138 @@
x
(lookup-language x)))
-(define* (compile-file file #:optional output-file
- #:key (to 'objcode) (opts '()))
- (let ((comp (or output-file (compiled-file-name file)))
- (lang (ensure-language (current-language)))
- (to (ensure-language to)))
- (catch 'nothing-at-all
- (lambda ()
- (call-with-compile-error-catch
- (lambda ()
- (call-with-output-file/atomic comp
- (lambda (port)
- (let ((print (language-printer to)))
- (print (compile (read-file-in file lang)
- #:from lang #:to to #:opts opts)
- port))))
- (format #t "wrote `~A'\n" comp))))
- (lambda (key . args)
- (format #t "ERROR: during compilation of ~A:\n" file)
- (display "ERROR: ")
- (apply format #t (cadr args) (caddr args))
- (newline)
- (format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
- (delete-file comp)))))
-
-(define* (compile-and-load file #:key (to 'value) (opts '()))
- (let ((lang (ensure-language (current-language))))
- (compile (read-file-in file lang) #:to 'value #:opts opts)))
+;; Throws an exception if `dir' is not writable. The double-stat is OK,
+;; as this is only used during compilation.
+(define (ensure-writable-dir dir)
+ (if (file-exists? dir)
+ (if (access? dir W_OK)
+ #t
+ (error "directory not writable" dir))
+ (begin
+ (ensure-writable-dir (dirname dir))
+ (mkdir dir))))
+
+(define (dsu-sort list key less)
+ (map cdr
+ (stable-sort (map (lambda (x) (cons (key x) x)) list)
+ (lambda (x y) (less (car x) (car y))))))
+;;; This function is among the trickiest I've ever written. I tried many
+;;; variants. In the end, simple is best, of course.
+;;;
+;;; After turning this around a number of times, it seems that the the
+;;; desired behavior is that .go files should exist in a path, for
+;;; searching. That is orthogonal to this function. For writing .go
+;;; files, either you know where they should go, in which case you tell
+;;; compile-file explicitly, as in the srcdir != builddir case; or you
+;;; don't know, in which case this function is called, and we just put
+;;; them in your own ccache dir in ~/.guile-ccache.
(define (compiled-file-name file)
- (let ((base (basename file))
- (cext (cond ((or (null? %load-compiled-extensions)
- (string-null? (car %load-compiled-extensions)))
- (warn "invalid %load-compiled-extensions"
- %load-compiled-extensions)
- ".go")
- (else (car %load-compiled-extensions)))))
- (let lp ((exts %load-extensions))
- (cond ((null? exts) (string-append file cext))
- ((string-null? (car exts)) (lp (cdr exts)))
- ((string-suffix? (car exts) base)
- (string-append
- (dirname file) "/"
- (substring base 0
- (- (string-length base) (string-length (car exts))))
- cext))
- (else (lp (cdr exts)))))))
+ (define (compiled-extension)
+ (cond ((or (null? %load-compiled-extensions)
+ (string-null? (car %load-compiled-extensions)))
+ (warn "invalid %load-compiled-extensions"
+ %load-compiled-extensions)
+ ".go")
+ (else (car %load-compiled-extensions))))
+ (and %compile-fallback-path
+ (let ((f (string-append
+ %compile-fallback-path
+ ;; no need for '/' separator here, canonicalize-path
+ ;; will give us an absolute path
+ (canonicalize-path file)
+ (compiled-extension))))
+ (and (false-if-exception (ensure-writable-dir (dirname f)))
+ f))))
+
+(define* (compile-file file #:key
+ (output-file #f)
+ (env #f)
+ (from (current-language))
+ (to 'objcode)
+ (opts '()))
+ (let ((comp (or output-file (compiled-file-name file)))
+ (in (open-input-file file)))
+ (ensure-writable-dir (dirname comp))
+ (call-with-output-file/atomic comp
+ (lambda (port)
+ ((language-printer (ensure-language to))
+ (read-and-compile in #:env env #:from from #:to to #:opts opts)
+ port))
+ file)
+ comp))
+
+(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
+ (read-and-compile (open-input-file file)
+ #:from from #:to to #:opts opts))
;;;
;;; Compiler interface
;;;
-(define (read-file-in file lang)
- (call-with-input-file file
- (or (language-read-file lang)
- (error "language has no #:read-file" lang))))
-
(define (compile-passes from to opts)
(map cdr
(or (lookup-compilation-order from to)
(error "no way to compile" from "to" to))))
(define (compile-fold passes exp env opts)
- (if (null? passes)
- exp
- (receive (exp env) ((car passes) exp env opts)
- (compile-fold (cdr passes) exp env opts))))
-
-(define (compile-time-environment)
- "A special function known to the compiler that, when compiled, will
-return a representation of the lexical environment in place at compile
-time. Useful for supporting some forms of dynamic compilation. Returns
-#f if called from the interpreter."
- #f)
+ (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
+ (if (null? passes)
+ (values x e cenv)
+ (receive (x e new-cenv) ((car passes) x e opts)
+ (lp (cdr passes) x e (if first? new-cenv cenv) #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))))
+ (lang to))
+ (cond ((null? in)
+ (error "don't know how to join expressions" from to))
+ ((language-joiner lang) lang)
+ (else
+ (lp (cdr in) (caar in))))))
+
+(define* (read-and-compile port #:key
+ (env #f)
+ (from (current-language))
+ (to 'objcode)
+ (opts '()))
+ (let ((from (ensure-language from))
+ (to (ensure-language to)))
+ (let ((joint (find-language-joint from to)))
+ (with-fluids ((*current-language* from))
+ (let lp ((exps '()) (env #f) (cenv env))
+ (let ((x ((language-reader (current-language)) port)))
+ (cond
+ ((eof-object? x)
+ (compile ((language-joiner joint) (reverse exps) env)
+ #:from joint #:to to #:env env #:opts opts))
+ (else
+ ;; compile-fold instead of compile so we get the env too
+ (receive (jexp jenv jcenv)
+ (compile-fold (compile-passes (current-language) joint opts)
+ x cenv opts)
+ (lp (cons jexp exps) jenv jcenv))))))))))
(define* (compile x #:key
(env #f)
(from (current-language))
(to 'value)
(opts '()))
- (compile-fold (compile-passes from to opts)
- x
- env
- opts))
+
+ (let ((warnings (memq #:warnings opts)))
+ (if (pair? warnings)
+ (let ((warnings (cadr warnings)))
+ ;; Sanity-check the requested warnings.
+ (for-each (lambda (w)
+ (or (lookup-warning-type w)
+ (warning 'unsupported-warning #f w)))
+ warnings))))
+
+ (receive (exp env cenv)
+ (compile-fold (compile-passes from to opts) x env opts)
+ exp))
;;;
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 70000c551..3670c53d9 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -1,21 +1,21 @@
;;; Multi-language support
-;; 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
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
;;
-;; This 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.
+;; 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 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.
+;; 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
;;; Code:
@@ -23,8 +23,9 @@
#: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
lookup-compilation-order lookup-decompilation-order
invalidate-compilation-cache!))
@@ -41,10 +42,10 @@
reader
printer
(parser #f)
- (read-file #f)
(compilers '())
(decompilers '())
- (evaluator #f))
+ (evaluator #f)
+ (joiner #f))
(define-macro (define-language name . spec)
`(begin
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
new file mode 100644
index 000000000..6b68c5639
--- /dev/null
+++ b/module/system/base/message.scm
@@ -0,0 +1,102 @@
+;;; User interface messages
+
+;; 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 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; This module provide a simple interface to send messages to the user.
+;;; TODO: Internationalize messages.
+;;;
+;;; Code:
+
+(define-module (system base message)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:export (*current-warning-port* warning
+
+ warning-type? warning-type-name warning-type-description
+ warning-type-printer lookup-warning-type
+
+ %warning-types))
+
+
+;;;
+;;; Source location
+;;;
+
+(define (location-string loc)
+ (if (pair? loc)
+ (format #f "~a:~a:~a"
+ (or (assoc-ref loc 'filename) "<stdin>")
+ (1+ (assoc-ref loc 'line))
+ (assoc-ref loc 'column))
+ "<unknown-location>"))
+
+
+;;;
+;;; Warnings
+;;;
+
+(define *current-warning-port*
+ ;; The port where warnings are sent.
+ (make-fluid))
+
+(fluid-set! *current-warning-port* (current-error-port))
+
+(define-record-type <warning-type>
+ (make-warning-type name description printer)
+ warning-type?
+ (name warning-type-name)
+ (description warning-type-description)
+ (printer warning-type-printer))
+
+(define %warning-types
+ ;; List of know warning types.
+ (map (lambda (args)
+ (apply make-warning-type args))
+
+ `((unsupported-warning ;; a "meta warning"
+ "warn about unknown warning types"
+ ,(lambda (port unused name)
+ (format port "warning: unknown warning type `~A'~%"
+ name)))
+
+ (unused-variable
+ "report unused variables"
+ ,(lambda (port loc name)
+ (format port "~A: warning: unused variable `~A'~%"
+ loc name))))))
+
+(define (lookup-warning-type name)
+ "Return the warning type NAME or `#f' if not found."
+ (find (lambda (wt)
+ (eq? name (warning-type-name wt)))
+ %warning-types))
+
+(define (warning type location . args)
+ "Emit a warning of type TYPE for source location LOCATION (a source
+property alist) using the data in ARGS."
+ (let ((wt (lookup-warning-type type))
+ (port (fluid-ref *current-warning-port*)))
+ (if (warning-type? wt)
+ (apply (warning-type-printer wt)
+ port (location-string location)
+ args)
+ (format port "~A: unknown warning type `~A': ~A~%"
+ (location-string location) type args))))
+
+;;; message.scm ends here
diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm
index ed61464f0..4777431e5 100644
--- a/module/system/base/pmatch.scm
+++ b/module/system/base/pmatch.scm
@@ -1,6 +1,5 @@
(define-module (system base pmatch)
- #:use-module (ice-9 syncase)
- #:export (pmatch ppat))
+ #:export (pmatch))
;; FIXME: shouldn't have to export ppat...
;; Originally written by Oleg Kiselyov. Taken from:
@@ -17,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/base/syntax.scm b/module/system/base/syntax.scm
index d968bdff8..249961d79 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -1,21 +1,20 @@
;;; Guile VM specific syntaxes and utilities
-;; 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
-;; 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
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -175,29 +174,70 @@
;; 5.88 0.01 0.01 list-index
-(define-macro (record-case record . clauses)
- (let ((r (gensym))
- (rtd (gensym)))
- (define (process-clause clause)
- (if (eq? (car clause) 'else)
- clause
- (let ((record-type (caar clause))
- (slots (cdar clause))
- (body (cdr clause)))
- (let ((stem (trim-brackets record-type)))
- `((eq? ,rtd ,record-type)
- (let ,(map (lambda (slot)
- (if (pair? slot)
- `(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
- `(,slot (,(symbol-append stem '- slot) ,r))))
- slots)
- ,@(if (pair? body) body '((if #f #f)))))))))
- `(let* ((,r ,record)
- (,rtd (struct-vtable ,r)))
- (cond ,@(let ((clauses (map process-clause clauses)))
- (if (assq 'else clauses)
- clauses
- (append clauses `((else (error "unhandled record" ,r))))))))))
+;;; So ugly... but I am too ignorant to know how to make it better.
+(define-syntax record-case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ record clause ...)
+ (let ((r (syntax r))
+ (rtd (syntax rtd)))
+ (define (process-clause tag fields exprs)
+ (let ((infix (trim-brackets (syntax->datum tag))))
+ (with-syntax ((tag tag)
+ (((f . accessor) ...)
+ (let lp ((fields fields))
+ (syntax-case fields ()
+ (() (syntax ()))
+ (((v0 f0) f1 ...)
+ (acons (syntax v0)
+ (datum->syntax x
+ (symbol-append infix '- (syntax->datum
+ (syntax f0))))
+ (lp (syntax (f1 ...)))))
+ ((f0 f1 ...)
+ (acons (syntax f0)
+ (datum->syntax x
+ (symbol-append infix '- (syntax->datum
+ (syntax f0))))
+ (lp (syntax (f1 ...))))))))
+ ((e0 e1 ...)
+ (syntax-case exprs ()
+ (() (syntax (#t)))
+ ((e0 e1 ...) (syntax (e0 e1 ...))))))
+ (syntax
+ ((eq? rtd tag)
+ (let ((f (accessor r))
+ ...)
+ e0 e1 ...))))))
+ (with-syntax
+ ((r r)
+ (rtd rtd)
+ ((processed ...)
+ (let lp ((clauses (syntax (clause ...)))
+ (out '()))
+ (syntax-case clauses (else)
+ (()
+ (reverse! (cons (syntax
+ (else (error "unhandled record" r)))
+ out)))
+ (((else e0 e1 ...))
+ (reverse! (cons (syntax (else e0 e1 ...)) out)))
+ (((else e0 e1 ...) . rest)
+ (syntax-violation 'record-case
+ "bad else clause placement"
+ (syntax x)
+ (syntax (else e0 e1 ...))))
+ ((((<foo> f0 ...) e0 ...) . rest)
+ (lp (syntax rest)
+ (cons (process-clause (syntax <foo>)
+ (syntax (f0 ...))
+ (syntax (e0 ...)))
+ out)))))))
+ (syntax
+ (let* ((r record)
+ (rtd (struct-vtable r)))
+ (cond processed ...)))))))))
+
;; Here we take the terrorism to another level. Nasty, but the client
;; code looks good.
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index cf09e01af..a99e1bae9 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -1,33 +1,33 @@
;;; Repl commands
-;; 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
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
;;
-;; This 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.
+;; 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 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.
+;; 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
;;; Code:
(define-module (system repl command)
- #:use-syntax (system base syntax)
+ #:use-module (system base syntax)
#:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (system repl common)
#:use-module (system vm objcode)
#:use-module (system vm program)
#:use-module (system vm vm)
- #:autoload (system base language) (lookup-language)
+ #:autoload (system base language) (lookup-language language-reader)
#:autoload (system vm debug) (vm-debugger vm-backtrace)
#:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
#:autoload (system vm profile) (vm-profile)
@@ -35,6 +35,7 @@
#:use-module (ice-9 session)
#:use-module (ice-9 documentation)
#:use-module (ice-9 and-let-star)
+ #:use-module (ice-9 rdelim)
#:export (meta-command))
@@ -109,33 +110,66 @@
(let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
(format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
-(define (meta-command repl line)
- (let ((input (call-with-input-string (string-append "(" line ")") read)))
- (if (not (null? input))
- (do ((key (car input))
- (args (cdr input) (cdr args))
- (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts)))
- ((or (null? args)
- (not (symbol? (car args)))
- (not (eq? (string-ref (symbol->string (car args)) 0) #\-)))
- (let ((c (lookup-command key)))
- (if c
- (cond ((memq #:h opts) (display-command c))
- (else (apply (command-procedure c)
- repl (append! args (reverse! opts)))))
- (user-error "Unknown meta command: ~A" key))))))))
+(define (read-datum repl)
+ (read))
+
+(define read-line
+ (let ((orig-read-line read-line))
+ (lambda (repl)
+ (orig-read-line))))
+
+(define (meta-command repl)
+ (let ((command (read-datum repl)))
+ (if (not (symbol? command))
+ (user-error "Meta-command not a symbol: ~s" command))
+ (let ((c (lookup-command command)))
+ (if c
+ ((command-procedure c) repl)
+ (user-error "Unknown meta command: ~A" command)))))
+
+(define-syntax define-meta-command
+ (syntax-rules ()
+ ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
+ (define (name repl)
+ docstring
+ (let* ((expression0
+ (with-fluid* current-reader
+ (language-reader (repl-language repl))
+ (lambda () (repl-reader ""))))
+ ...)
+ (apply (lambda datums b0 b1 ...)
+ (let ((port (open-input-string (read-line repl))))
+ (let lp ((out '()))
+ (let ((x (read port)))
+ (if (eof-object? x)
+ (reverse out)
+ (lp (cons x out))))))))))
+ ((_ (name repl . datums) docstring b0 b1 ...)
+ (define-meta-command (name repl () . datums)
+ docstring b0 b1 ...))))
+
;;;
;;; Help commands
;;;
-(define (help repl . args)
- "help [GROUP]
-List available meta commands.
-A command group name can be given as an optional argument.
+(define-meta-command (help repl . args)
+ "help
+help GROUP
+help [-c] COMMAND
+
+Gives help on the meta-commands available at the REPL.
+
+With one argument, tries to look up the argument as a group name, giving
+help on that group if successful. Otherwise tries to look up the
+argument as a command, giving help on the command.
+
+If there is a command whose name is also a group name, use the ,help
+-c COMMAND form to give help on the command instead of the group.
+
Without any argument, a list of help commands and command groups
-are displayed, as you have already seen ;)"
+are displayed."
(pmatch args
(()
(display-group (lookup-group 'help))
@@ -154,23 +188,30 @@ are displayed, as you have already seen ;)"
(for-each display-group *command-table*))
((,group) (guard (lookup-group group))
(display-group (lookup-group group)))
+ ((,command) (guard (lookup-command command))
+ (display-command (lookup-command command)))
+ ((-c ,command) (guard (lookup-command command))
+ (display-command (lookup-command command)))
+ ((,command)
+ (user-error "Unknown command or group: ~A" command))
+ ((-c ,command)
+ (user-error "Unknown command: ~A" command))
(else
- (user-error "Unknown command group: ~A" (car args)))))
+ (user-error "Bad arguments: ~A" args))))
(define guile:apropos apropos)
-(define (apropos repl regexp)
+(define-meta-command (apropos repl regexp)
"apropos REGEXP
Find bindings/modules/packages."
(guile:apropos (->string regexp)))
-(define (describe repl obj)
+(define-meta-command (describe repl (form))
"describe OBJ
Show description/documentation."
- (display (object-documentation
- (repl-eval repl (repl-parse repl obj))))
+ (display (object-documentation (repl-eval repl (repl-parse repl form))))
(newline))
-(define (option repl . args)
+(define-meta-command (option repl . args)
"option [KEY VALUE]
List/show/set options."
(pmatch args
@@ -190,7 +231,7 @@ List/show/set options."
(apply vm-trace-on vm val)
(vm-trace-off vm))))))))
-(define (quit repl)
+(define-meta-command (quit repl)
"quit
Quit this session."
(throw 'quit))
@@ -200,7 +241,7 @@ Quit this session."
;;; Module commands
;;;
-(define (module repl . args)
+(define-meta-command (module repl . args)
"module [MODULE]
Change modules / Show current module."
(pmatch args
@@ -209,7 +250,7 @@ Change modules / Show current module."
(set-current-module (resolve-module mod-name)))
(,mod-name (set-current-module (resolve-module mod-name)))))
-(define (import repl . args)
+(define-meta-command (import repl . args)
"import [MODULE ...]
Import modules / List those imported."
(let ()
@@ -222,7 +263,7 @@ Import modules / List those imported."
(for-each puts (map module-name (module-uses (current-module))))
(for-each use args))))
-(define (load repl file . opts)
+(define-meta-command (load repl file . opts)
"load FILE
Load a file in the current module.
@@ -233,7 +274,7 @@ Load a file in the current module.
(apply load-file file opts))))
(vm-load (repl-vm repl) objcode)))
-(define (binding repl . opts)
+(define-meta-command (binding repl)
"binding
List current bindings."
(module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
@@ -244,7 +285,7 @@ List current bindings."
;;; Language commands
;;;
-(define (language repl name)
+(define-meta-command (language repl name)
"language LANGUAGE
Change languages."
(set! (repl-language repl) (lookup-language name))
@@ -255,7 +296,7 @@ Change languages."
;;; Compile commands
;;;
-(define (compile repl form . opts)
+(define-meta-command (compile repl (form) . opts)
"compile FORM
Generate compiled code.
@@ -266,11 +307,11 @@ Generate compiled code.
-O Enable optimization
-D Add debug information"
(let ((x (apply repl-compile repl (repl-parse repl form) opts)))
- (cond ((objcode? x) (disassemble-objcode x))
+ (cond ((objcode? x) (guile:disassemble x))
(else (repl-print repl x)))))
(define guile:compile-file compile-file)
-(define (compile-file repl file . opts)
+(define-meta-command (compile-file repl file . opts)
"compile-file FILE
Compile a file."
(guile:compile-file (->string file) #:opts opts))
@@ -278,12 +319,12 @@ Compile a file."
(define (guile:disassemble x)
((@ (language assembly disassemble) disassemble) x))
-(define (disassemble repl prog)
+(define-meta-command (disassemble repl (form))
"disassemble PROGRAM
Disassemble a program."
- (guile:disassemble (repl-eval repl (repl-parse repl prog))))
+ (guile:disassemble (repl-eval repl (repl-parse repl form))))
-(define (disassemble-file repl file)
+(define-meta-command (disassemble-file repl file)
"disassemble-file FILE
Disassemble a file."
(guile:disassemble (load-objcode (->string file))))
@@ -293,7 +334,7 @@ Disassemble a file."
;;; Profile commands
;;;
-(define (time repl form)
+(define-meta-command (time repl (form))
"time FORM
Time execution."
(let* ((vms-start (vm-stats (repl-vm repl)))
@@ -316,7 +357,7 @@ Time execution."
(get identity gc-start gc-end))
result))
-(define (profile repl form . opts)
+(define-meta-command (profile repl form . opts)
"profile FORM
Profile execution."
(apply vm-profile
@@ -329,29 +370,28 @@ Profile execution."
;;; Debug commands
;;;
-(define (backtrace repl)
+(define-meta-command (backtrace repl)
"backtrace
Display backtrace."
(vm-backtrace (repl-vm repl)))
-(define (debugger repl)
+(define-meta-command (debugger repl)
"debugger
Start debugger."
(vm-debugger (repl-vm repl)))
-(define (trace repl form . opts)
+(define-meta-command (trace repl form . opts)
"trace FORM
Trace execution.
-s Display stack
-l Display local variables
- -e Display external variables
-b Bytecode level trace"
(apply vm-trace (repl-vm repl)
(repl-compile repl (repl-parse repl form))
opts))
-(define (step repl)
+(define-meta-command (step repl)
"step FORM
Step execution."
(display "Not implemented yet\n"))
@@ -362,12 +402,12 @@ Step execution."
;;;
(define guile:gc gc)
-(define (gc repl)
+(define-meta-command (gc repl)
"gc
Garbage collection."
(guile:gc))
-(define (statistics repl)
+(define-meta-command (statistics repl)
"statistics
Display statistics."
(let ((this-tms (times))
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index bc3242375..2db4518ad 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -2,25 +2,24 @@
;; 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.
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (system repl common)
- #:use-syntax (system base syntax)
+ #:use-module (system base syntax)
#:use-module (system base compile)
#:use-module (system base language)
#:use-module (system vm vm)
diff --git a/module/system/repl/describe.scm b/module/system/repl/describe.scm
index 0563def90..590d2235a 100644
--- a/module/system/repl/describe.scm
+++ b/module/system/repl/describe.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 76e7bfe3f..2f4a3783a 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -1,26 +1,26 @@
;;; Read-Eval-Print Loop
-;; 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
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
;;
-;; This 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.
+;; 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 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.
+;; 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
;;; Code:
(define-module (system repl repl)
- #:use-syntax (system base syntax)
+ #:use-module (system base syntax)
#:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (system base language)
@@ -28,7 +28,6 @@
#:use-module (system repl command)
#:use-module (system vm vm)
#:use-module (system vm debug)
- #:use-module (ice-9 rdelim)
#:export (start-repl call-with-backtrace))
(define meta-command-token (cons 'meta 'command))
@@ -89,7 +88,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)))
@@ -103,11 +102,14 @@
(cond
((eqv? exp (if #f #f))) ; read error, pass
((eq? exp meta-command-token)
- (with-backtrace (meta-command repl (read-line))))
+ (with-backtrace (meta-command repl)))
((eof-object? exp)
(newline)
(set! status '()))
(else
+ ;; since the input port is line-buffered, consume up to the
+ ;; newline
+ (flush-to-newline)
(with-backtrace
(catch 'quit
(lambda ()
@@ -135,3 +137,14 @@
((char-whitespace? ch) (read-char) (next-char wait))
(else ch)))
#f))
+
+(define (flush-to-newline)
+ (if (char-ready?)
+ (let ((ch (peek-char)))
+ (if (and (not (eof-object? ch)) (char-whitespace? ch))
+ (begin
+ (read-char)
+ (if (not (char=? ch #\newline))
+ (flush-to-newline)))))))
+
+ \ No newline at end of file
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 3c5cfa201..740111257 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -20,7 +20,7 @@
;;; Code:
(define-module (system vm debug)
- #:use-syntax (system base syntax)
+ #:use-module (system base syntax)
#:use-module (system vm vm)
#:use-module (system vm frame)
#:use-module (ice-9 format)
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index a74d903da..332cd6172 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
;;; Guile VM frame functions
-;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
;;;
;;; This program is free software; you can redistribute it and/or modify
@@ -27,23 +27,22 @@
vm-frame-program
vm-frame-local-ref vm-frame-local-set!
vm-frame-return-address vm-frame-mv-return-address
- vm-frame-dynamic-link vm-frame-external-link
+ vm-frame-dynamic-link
vm-frame-stack
vm-frame-number vm-frame-address
- make-frame-chain
- print-frame print-frame-chain-as-backtrace
- frame-arguments frame-local-variables frame-external-variables
- frame-environment
- frame-variable-exists? frame-variable-ref frame-variable-set!
- frame-object-name
- frame-local-ref frame-external-link frame-local-set!
- frame-return-address frame-program
- frame-dynamic-link heap-frame?))
-
-;; fixme: avoid the dynamic-call?
-(dynamic-call "scm_init_frames" (dynamic-link "libguile"))
+ make-frame-chain
+ print-frame print-frame-chain-as-backtrace
+ frame-arguments frame-local-variables
+ frame-environment
+ frame-variable-exists? frame-variable-ref frame-variable-set!
+ frame-object-name
+ frame-local-ref frame-local-set!
+ frame-return-address frame-program
+ frame-dynamic-link heap-frame?))
+
+(load-extension "libguile" "scm_init_frames")
;;;
;;; Frame chain
@@ -159,24 +158,19 @@
(l '() (cons (frame-local-ref frame n) l)))
((< n 0) l))))
-(define (frame-external-variables frame)
- (frame-external-link frame))
-
-(define (frame-external-ref frame index)
- (list-ref (frame-external-link frame) index))
-
-(define (frame-external-set! frame index val)
- (list-set! (frame-external-link frame) index val))
-
(define (frame-binding-ref frame binding)
- (if (binding:extp binding)
- (frame-external-ref frame (binding:index binding))
- (frame-local-ref frame (binding:index binding))))
+ (let ((x (frame-local-ref frame (binding:index binding))))
+ (if (and (binding:boxed? binding) (variable? x))
+ (variable-ref x)
+ x)))
(define (frame-binding-set! frame binding val)
- (if (binding:extp binding)
- (frame-external-set! frame (binding:index binding) val)
- (frame-local-set! frame (binding:index binding) val)))
+ (if (binding:boxed? binding)
+ (let ((v (frame-local-ref frame binding)))
+ (if (variable? v)
+ (variable-set! v val)
+ (frame-local-set! frame binding (make-variable val))))
+ (frame-local-set! frame binding val)))
;; FIXME handle #f program-bindings return
(define (frame-bindings frame addr)
diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm
index c820e9952..403e9cdc7 100644
--- a/module/system/vm/instruction.scm
+++ b/module/system/vm/instruction.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -25,4 +24,4 @@
instruction-pops instruction-pushes
instruction->opcode opcode->instruction))
-(dynamic-call "scm_init_instructions" (dynamic-link "libguile"))
+(load-extension "libguile" "scm_init_instructions")
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index df1ff26e4..7c0490da6 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
@@ -25,4 +24,4 @@
load-objcode write-objcode
word-size byte-order))
-(dynamic-call "scm_init_objcodes" (dynamic-link "libguile"))
+(load-extension "libguile" "scm_init_objcodes")
diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm
index 2c17fc7a6..6ab418ac3 100644
--- a/module/system/vm/profile.scm
+++ b/module/system/vm/profile.scm
@@ -2,20 +2,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 program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 7e4007b75..755c606e2 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -1,30 +1,29 @@
;;; Guile VM program functions
-;;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
;;;
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
;;;
-;;; This 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.
+;;; 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 General Public License
-;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+;;; 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
;;; Code:
(define-module (system vm program)
#:export (make-program
- arity:nargs arity:nrest arity:nlocs arity:nexts
+ arity:nargs arity:nrest arity:nlocs
- make-binding binding:name binding:extp binding:index
+ make-binding binding:name binding:boxed? binding:index
binding:start binding:end
source:addr source:line source:column source:file
@@ -32,21 +31,20 @@
program-properties program-property program-documentation
program-name program-arguments
- program-arity program-external-set! program-meta
+ program-arity program-meta
program-objcode program? program-objects
- program-module program-base program-external))
+ program-module program-base program-free-variables))
-(dynamic-call "scm_init_programs" (dynamic-link "libguile"))
+(load-extension "libguile" "scm_init_programs")
(define arity:nargs car)
(define arity:nrest cadr)
(define arity:nlocs caddr)
-(define arity:nexts cadddr)
-(define (make-binding name extp index start end)
- (list name extp index start end))
+(define (make-binding name boxed? index start end)
+ (list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
-(define (binding:extp b) (list-ref b 1))
+(define (binding:boxed? b) (list-ref b 1))
(define (binding:index b) (list-ref b 2))
(define (binding:start b) (list-ref b 3))
(define (binding:end b) (list-ref b 4))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 00f013c9d..d8165f202 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -1,26 +1,25 @@
;;; Guile VM tracer
-;; 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
-;; 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.
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (system vm trace)
- #:use-syntax (system base syntax)
+ #:use-module (system base syntax)
#:use-module (system vm vm)
#:use-module (system vm frame)
#:use-module (ice-9 format)
@@ -55,8 +54,7 @@
((null? opts) (newline))
(case (car opts)
((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
- ((:l) (puts (vm-fetch-locals vm)))
- ((:e) (puts (vm-fetch-externals vm))))))
+ ((:l) (puts (vm-fetch-locals vm))))))
(define (trace-apply vm)
(if (vm-option vm 'trace-first)
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index de5c3fa21..48dc4f2b8 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -32,7 +32,7 @@
vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
-(dynamic-call "scm_init_vm" (dynamic-link "libguile"))
+(load-extension "libguile" "scm_init_vm")
(define (vms:time stat) (vector-ref stat 0))
(define (vms:clock stat) (vector-ref stat 1))
diff --git a/module/system/xref.scm b/module/system/xref.scm
index ea419079f..906ec8e4a 100644
--- a/module/system/xref.scm
+++ b/module/system/xref.scm
@@ -1,30 +1,33 @@
;;;; 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 (system xref)
#:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (system vm program)
+ #:use-module (srfi srfi-1)
#:export (*xref-ignored-modules*
procedure-callees
procedure-callers))
(define (program-callee-rev-vars prog)
+ (define (cons-uniq x y)
+ (if (memq x y) y (cons x y)))
(cond
((program-objects prog)
=> (lambda (objects)
@@ -32,7 +35,7 @@
(progv (make-vector (vector-length objects) #f))
(asm (decompile (program-objcode prog) #:to 'assembly)))
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,next ,labels ,len . ,body)
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,len . ,body)
(for-each
(lambda (x)
(pmatch x
@@ -44,19 +47,19 @@
((= i n) out)
((program? (vector-ref objects i))
(lp (1+ i)
- (append (program-callee-rev-vars (vector-ref objects i))
- out)))
+ (fold cons-uniq out
+ (program-callee-rev-vars (vector-ref objects i)))))
((vector-ref progv i)
(let ((obj (vector-ref objects i)))
(if (variable? obj)
- (lp (1+ i) (cons obj out))
+ (lp (1+ i) (cons-uniq obj out))
;; otherwise it's an unmemoized binding
(pmatch obj
(,sym (guard (symbol? sym))
(let ((v (module-variable (or (program-module prog)
the-root-module)
sym)))
- (lp (1+ i) (if v (cons v out) out))))
+ (lp (1+ i) (if v (cons-uniq v out) out))))
((,mod ,sym ,public?)
;; hm, hacky.
(let* ((m (nested-ref the-root-module
@@ -68,7 +71,7 @@
m)
sym))))
(lp (1+ i)
- (if v (cons v out) out))))))))
+ (if v (cons-uniq v out) out))))))))
(else (lp (1+ i) out)))))))
(else '())))
@@ -78,51 +81,95 @@
(else '())))
(define (procedure-callees prog)
+ "Evaluates to a list of the given program callees."
(let lp ((in (procedure-callee-rev-vars prog)) (out '()))
(cond ((null? in) out)
((variable-bound? (car in))
(lp (cdr in) (cons (variable-ref (car in)) out)))
(else (lp (cdr in) out)))))
+;; var -> ((module-name caller ...) ...)
(define *callers-db* #f)
+;; module-name -> (callee ...)
+(define *module-callees-db* (make-hash-table))
+;; (module-name ...)
+(define *tainted-modules* '())
(define *xref-ignored-modules* '((value-history)))
(define (on-module-modified m)
- (if (not (member (module-name m) *xref-ignored-modules*))
- (set! *callers-db* #f)))
+ (let ((name (module-name m)))
+ (if (and (not (member name *xref-ignored-modules*))
+ (not (member name *tainted-modules*))
+ (pair? name))
+ (set! *tainted-modules* (cons name *tainted-modules*)))))
-(define (ensure-callers-db)
- (let ((visited '())
- (db #f))
- (define (visit-variable var)
+(define (add-caller callee caller mod-name)
+ (let ((all-callers (hashq-ref *callers-db* callee)))
+ (if (not all-callers)
+ (hashq-set! *callers-db* callee `((,mod-name ,caller)))
+ (let ((callers (assoc mod-name all-callers)))
+ (if callers
+ (if (not (member caller callers))
+ (set-cdr! callers (cons caller (cdr callers))))
+ (hashq-set! *callers-db* callee
+ (cons `(,mod-name ,caller) all-callers)))))))
+
+(define (forget-callers callee mod-name)
+ (hashq-set! *callers-db* callee
+ (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name)))
+
+(define (add-callees callees mod-name)
+ (hash-set! *module-callees-db* mod-name
+ (append callees (hash-ref *module-callees-db* mod-name '()))))
+
+(define (untaint-modules)
+ (define (untaint m)
+ (for-each (lambda (callee) (forget-callers callee m))
+ (hash-ref *module-callees-db* m '()))
+ (ensure-callers-db m))
+ (ensure-callers-db #f)
+ (for-each untaint *tainted-modules*)
+ (set! *tainted-modules* '()))
+
+(define (ensure-callers-db mod-name)
+ (let ((mod (and mod-name (resolve-module mod-name)))
+ (visited #f))
+ (define (visit-variable var recurse mod-name)
(if (variable-bound? var)
(let ((x (variable-ref var)))
(cond
+ ((and visited (hashq-ref visited x)))
((procedure? x)
- (for-each
- (lambda (callee)
- (if (variable-bound? callee)
- (let ((y (variable-ref callee)))
- (hashq-set! db callee (cons x (hashq-ref db callee '()))))))
- (procedure-callee-rev-vars x)))
- ((and (module? x) (not (memq x visited)))
- (visit-module x))))))
+ (if visited (hashq-set! visited x #t))
+ (let ((callees (filter variable-bound?
+ (procedure-callee-rev-vars x))))
+ (for-each (lambda (callee)
+ (add-caller callee x mod-name))
+ callees)
+ (add-callees callees mod-name)))
+ ((and recurse (module? x))
+ (visit-module x #t))))))
- (define (visit-module mod)
- (set! visited (cons mod visited))
+ (define (visit-module mod recurse)
+ (if visited (hashq-set! visited mod #t))
(if (not (memq on-module-modified (module-observers mod)))
(module-observe mod on-module-modified))
- (module-for-each (lambda (sym var)
- (visit-variable var))
- mod))
+ (let ((name (module-name mod)))
+ (module-for-each (lambda (sym var)
+ (visit-variable var recurse name))
+ mod)))
- (if (not *callers-db*)
- (begin
- (set! db (make-hash-table))
- (visit-module the-root-module)
- (set! *callers-db* db)))))
+ (cond ((and (not mod-name) (not *callers-db*))
+ (set! *callers-db* (make-hash-table 1000))
+ (set! visited (make-hash-table 1000))
+ (visit-module the-root-module #t))
+ (mod-name (visit-module mod #f)))))
(define (procedure-callers var)
+ "Returns an association list, keyed by module name, of known callers
+of the given procedure. The latter can specified directly as a
+variable, a symbol (which gets resolved in the current module) or a
+pair of the form (module-name . variable-name), "
(let ((v (cond ((variable? var) var)
((symbol? var) (module-variable (current-module) var))
(else
@@ -130,6 +177,6 @@
((,modname . ,sym)
(module-variable (resolve-module modname) sym))
(else
- (error "expected a variable, symbol, or (modname sym)" var)))))))
- (ensure-callers-db)
+ (error "expected a variable, symbol, or (modname . sym)" var)))))))
+ (untaint-modules)
(hashq-ref *callers-db* v '())))