summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--GUILE-VERSION10
-rw-r--r--NEWS190
-rw-r--r--README13
-rw-r--r--THANKS2
-rw-r--r--acinclude.m437
-rw-r--r--am/guilec4
-rwxr-xr-xautogen.sh6
-rw-r--r--benchmark-suite/benchmarks/0-reference.bm4
-rw-r--r--benchmark-suite/benchmarks/bytevectors.bm2
-rw-r--r--benchmark-suite/benchmarks/chars.bm2
-rw-r--r--benchmark-suite/benchmarks/continuations.bm4
-rw-r--r--benchmark-suite/benchmarks/if.bm4
-rw-r--r--benchmark-suite/benchmarks/logand.bm4
-rw-r--r--benchmark-suite/benchmarks/read.bm8
-rw-r--r--benchmark-suite/benchmarks/srfi-13.bm2
-rw-r--r--benchmark-suite/lib.scm2
-rw-r--r--benchmark-suite/results/neil-arudy93
-rwxr-xr-xbuild-aux/gitlog-to-changelog5
-rw-r--r--configure.ac17
-rw-r--r--doc/maint/guile.texi20
-rw-r--r--doc/ref/api-control.texi6
-rwxr-xr-xdoc/ref/api-data.texi281
-rw-r--r--doc/ref/api-evaluation.texi111
-rw-r--r--doc/ref/api-i18n.texi8
-rw-r--r--doc/ref/api-io.texi84
-rw-r--r--doc/ref/api-memory.texi108
-rw-r--r--doc/ref/api-options.texi10
-rw-r--r--doc/ref/api-procedures.texi558
-rw-r--r--doc/ref/api-scheduling.texi52
-rw-r--r--doc/ref/api-smobs.texi58
-rw-r--r--doc/ref/compiler.texi37
-rw-r--r--doc/ref/goops.texi2
-rw-r--r--doc/ref/libguile-linking.texi2
-rw-r--r--doc/ref/posix.texi8
-rw-r--r--doc/ref/scheme-scripts.texi6
-rw-r--r--doc/ref/srfi-modules.texi91
-rwxr-xr-xemacs/gds-scheme.el6
-rw-r--r--gc-benchmarks/larceny/dynamic-input-large.sch2
-rwxr-xr-xgc-benchmarks/run-benchmark.scm166
-rw-r--r--gdbinit3
-rw-r--r--guile-readline/ice-9/readline.scm22
-rw-r--r--guile-readline/readline.c11
-rw-r--r--libguile.h2
-rw-r--r--libguile/Makefile.am33
-rw-r--r--libguile/__scm.h46
-rw-r--r--libguile/_scm.h2
-rw-r--r--libguile/array-map.c18
-rw-r--r--libguile/arrays.c46
-rw-r--r--libguile/async.c27
-rw-r--r--libguile/async.h50
-rw-r--r--libguile/bdw-gc.h (renamed from libguile/boehm-gc.h)19
-rw-r--r--libguile/bitvectors.c14
-rw-r--r--libguile/boolean.c35
-rw-r--r--libguile/boolean.h89
-rw-r--r--libguile/bytevectors.c188
-rw-r--r--libguile/chars.c68
-rw-r--r--libguile/chars.h9
-rw-r--r--libguile/continuations.c2
-rw-r--r--libguile/deprecated.c25
-rw-r--r--libguile/deprecated.h271
-rw-r--r--libguile/dynl.c18
-rw-r--r--libguile/environments.c2226
-rw-r--r--libguile/environments.h187
-rw-r--r--libguile/eval.c42
-rw-r--r--libguile/eval.h6
-rw-r--r--libguile/eval.i.c24
-rw-r--r--libguile/frames.c152
-rw-r--r--libguile/frames.h25
-rw-r--r--libguile/futures.c375
-rw-r--r--libguile/futures.h91
-rw-r--r--libguile/gc-malloc.c7
-rw-r--r--libguile/gc.c16
-rw-r--r--libguile/gc.h34
-rw-r--r--libguile/gen-scmconfig.c7
-rw-r--r--libguile/gen-scmconfig.h.in1
-rw-r--r--libguile/generalized-arrays.c16
-rw-r--r--libguile/generalized-arrays.h3
-rw-r--r--libguile/goops.c42
-rw-r--r--libguile/guardians.c2
-rw-r--r--libguile/hashtab.c129
-rw-r--r--libguile/hashtab.h60
-rw-r--r--libguile/i18n.c534
-rw-r--r--libguile/i18n.h9
-rw-r--r--libguile/inet_aton.c8
-rw-r--r--libguile/init.c8
-rw-r--r--libguile/inline.h6
-rw-r--r--libguile/lang.h4
-rw-r--r--libguile/load.c43
-rw-r--r--libguile/load.h4
-rw-r--r--libguile/macros.c2
-rw-r--r--libguile/macros.h4
-rw-r--r--libguile/modules.c12
-rw-r--r--libguile/objcodes.h7
-rw-r--r--libguile/pairs.c16
-rw-r--r--libguile/pairs.h29
-rw-r--r--libguile/ports.c51
-rw-r--r--libguile/ports.h2
-rw-r--r--libguile/print.c32
-rw-r--r--libguile/procprop.c131
-rw-r--r--libguile/procprop.h8
-rw-r--r--libguile/procs.c14
-rw-r--r--libguile/programs.c75
-rw-r--r--libguile/programs.h5
-rw-r--r--libguile/pthread-threads.h2
-rw-r--r--libguile/read.c89
-rw-r--r--libguile/root.h15
-rw-r--r--libguile/scmsigs.c5
-rw-r--r--libguile/smob.c20
-rw-r--r--libguile/smob.h3
-rw-r--r--libguile/socket.c9
-rw-r--r--libguile/srcprop.h11
-rw-r--r--libguile/srfi-14.c364
-rw-r--r--libguile/srfi-14.h4
-rw-r--r--libguile/srfi-14.i.c11
-rw-r--r--libguile/srfi-4.c2
-rw-r--r--libguile/srfi-4.h2
-rw-r--r--libguile/stackchk.h6
-rw-r--r--libguile/stacks.c10
-rw-r--r--libguile/strings.c9
-rw-r--r--libguile/strings.h10
-rw-r--r--libguile/strports.c108
-rw-r--r--libguile/strports.h4
-rw-r--r--libguile/struct.c6
-rw-r--r--libguile/struct.h4
-rw-r--r--libguile/tags.h113
-rw-r--r--libguile/threads.c292
-rw-r--r--libguile/threads.h35
-rw-r--r--libguile/throw.c2
-rwxr-xr-xlibguile/unidata_to_charset.pl14
-rw-r--r--libguile/uniform.c56
-rw-r--r--libguile/uniform.h4
-rw-r--r--libguile/vectors.c2
-rw-r--r--libguile/vm-engine.c22
-rw-r--r--libguile/vm-engine.h41
-rw-r--r--libguile/vm-i-scheme.c26
-rw-r--r--libguile/vm-i-system.c419
-rw-r--r--libguile/vm.c16
-rw-r--r--libguile/vports.c26
-rw-r--r--libguile/weaks.c2
-rw-r--r--libguile/weaks.h16
-rw-r--r--libguile/win32-socket.c2
-rw-r--r--meta/Makefile.am16
-rw-r--r--meta/gdb-uninstalled-guile.in5
-rw-r--r--meta/guile-2.0.pc.in1
-rwxr-xr-xmeta/guile-config.in (renamed from meta/guile-config)12
-rw-r--r--meta/uninstalled-env.in4
-rw-r--r--module/Makefile.am8
-rw-r--r--module/ice-9/boot-9.scm99
-rw-r--r--module/ice-9/deprecated.scm17
-rw-r--r--module/ice-9/i18n.scm10
-rw-r--r--module/ice-9/optargs.scm450
-rw-r--r--module/ice-9/psyntax-pp.scm13195
-rw-r--r--module/ice-9/psyntax.scm448
-rw-r--r--module/ice-9/session.scm5
-rw-r--r--module/language/assembly.scm8
-rw-r--r--module/language/assembly/compile-bytecode.scm31
-rw-r--r--module/language/assembly/decompile-bytecode.scm36
-rw-r--r--module/language/assembly/disassemble.scm13
-rw-r--r--module/language/assembly/spec.scm4
-rw-r--r--module/language/brainfuck/compile-tree-il.scm19
-rw-r--r--module/language/brainfuck/parse.scm13
-rw-r--r--module/language/brainfuck/spec.scm2
-rw-r--r--module/language/bytecode/spec.scm4
-rw-r--r--module/language/ecmascript/base.scm20
-rw-r--r--module/language/ecmascript/compile-tree-il.scm124
-rw-r--r--module/language/ecmascript/spec.scm2
-rw-r--r--module/language/ecmascript/tokenize.scm5
-rw-r--r--module/language/elisp/spec.scm62
-rw-r--r--module/language/ghil.scm478
-rw-r--r--module/language/ghil/compile-glil.scm592
-rw-r--r--module/language/ghil/spec.scm62
-rw-r--r--module/language/glil.scm40
-rw-r--r--module/language/glil/compile-assembly.scm188
-rw-r--r--module/language/glil/decompile-assembly.scm13
-rw-r--r--module/language/glil/spec.scm4
-rw-r--r--module/language/objcode/spec.scm25
-rw-r--r--module/language/r5rs/core.il324
-rw-r--r--module/language/r5rs/expand.scm80
-rw-r--r--module/language/r5rs/psyntax.pp14552
-rw-r--r--module/language/r5rs/psyntax.ss3202
-rw-r--r--module/language/r5rs/spec.scm63
-rw-r--r--module/language/scheme/compile-ghil.scm494
-rw-r--r--module/language/scheme/compile-tree-il.scm35
-rw-r--r--module/language/scheme/inline.scm205
-rw-r--r--module/language/scheme/spec.scm22
-rw-r--r--module/language/tree-il.scm130
-rw-r--r--module/language/tree-il/analyze.scm359
-rw-r--r--module/language/tree-il/compile-glil.scm365
-rw-r--r--module/language/tree-il/inline.scm72
-rw-r--r--module/language/tree-il/optimize.scm5
-rw-r--r--module/language/tree-il/primitives.scm18
-rw-r--r--module/language/tree-il/spec.scm8
-rw-r--r--module/oop/goops.scm13
-rw-r--r--module/oop/goops/active-slot.scm4
-rw-r--r--module/oop/goops/dispatch.scm5
-rw-r--r--module/oop/goops/save.scm5
-rw-r--r--module/scripts/autofrisk.scm3
-rw-r--r--module/srfi/srfi-16.scm81
-rw-r--r--module/srfi/srfi-18.scm4
-rw-r--r--module/srfi/srfi-19.scm37
-rw-r--r--module/srfi/srfi-35.scm31
-rw-r--r--module/srfi/srfi-4/gnu.scm2
-rw-r--r--module/srfi/srfi-88.scm7
-rw-r--r--module/system/base/compile.scm24
-rw-r--r--module/system/base/language.scm12
-rw-r--r--module/system/base/message.scm6
-rw-r--r--module/system/repl/command.scm26
-rw-r--r--module/system/repl/common.scm10
-rw-r--r--module/system/repl/repl.scm33
-rw-r--r--module/system/vm/frame.scm67
-rw-r--r--module/system/vm/program.scm180
-rw-r--r--module/system/xref.scm2
-rw-r--r--srfi/Makefile.am3
-rw-r--r--test-suite/Makefile.am2
-rw-r--r--test-suite/standalone/.gitignore1
-rw-r--r--test-suite/standalone/Makefile.am7
-rw-r--r--test-suite/standalone/test-scm-take-u8vector.c65
-rw-r--r--test-suite/tests/asm-to-bytecode.test14
-rw-r--r--test-suite/tests/brainfuck.test51
-rw-r--r--test-suite/tests/bytevectors.test30
-rw-r--r--test-suite/tests/chars.test265
-rw-r--r--test-suite/tests/compiler.test72
-rw-r--r--test-suite/tests/encoding-escapes.test27
-rw-r--r--test-suite/tests/encoding-iso88591.test111
-rw-r--r--test-suite/tests/encoding-iso88597.test109
-rw-r--r--test-suite/tests/encoding-utf8.test111
-rw-r--r--test-suite/tests/environments.nottest1051
-rw-r--r--test-suite/tests/eval.test25
-rw-r--r--test-suite/tests/gc.test4
-rw-r--r--test-suite/tests/goops.test7
-rw-r--r--test-suite/tests/i18n.test146
-rw-r--r--test-suite/tests/optargs.test50
-rw-r--r--test-suite/tests/r5rs_pitfall.test1
-rw-r--r--test-suite/tests/reader.test32
-rw-r--r--test-suite/tests/records.test74
-rw-r--r--test-suite/tests/regexp.test94
-rw-r--r--test-suite/tests/signals.test (renamed from module/language/r5rs/null.il)24
-rw-r--r--test-suite/tests/socket.test89
-rw-r--r--test-suite/tests/srfi-13.test12
-rw-r--r--test-suite/tests/srfi-14.test406
-rw-r--r--test-suite/tests/srfi-35.test8
-rw-r--r--test-suite/tests/strings.test41
-rw-r--r--test-suite/tests/syncase.test5
-rw-r--r--test-suite/tests/syntax.test10
-rw-r--r--test-suite/tests/threads.test18
-rw-r--r--test-suite/tests/tree-il.test322
-rw-r--r--test-suite/tests/unif.test7
-rw-r--r--test-suite/tests/vectors.test22
-rw-r--r--test-suite/tests/weaks.test12
250 files changed, 15875 insertions, 33209 deletions
diff --git a/.gitignore b/.gitignore
index 8754b488a..ffaebb456 100644
--- a/.gitignore
+++ b/.gitignore
@@ -113,3 +113,4 @@ INSTALL
/GSYMS
/GTAGS
/meta/guile-tools
+/meta/guile-config
diff --git a/GUILE-VERSION b/GUILE-VERSION
index 580a1f506..7ec8d742b 100644
--- a/GUILE-VERSION
+++ b/GUILE-VERSION
@@ -2,10 +2,10 @@
GUILE_MAJOR_VERSION=1
GUILE_MINOR_VERSION=9
-GUILE_MICRO_VERSION=2
+GUILE_MICRO_VERSION=4
GUILE_EFFECTIVE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION}
-GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION}-bdwgc
+GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION}
# For automake.
VERSION=${GUILE_VERSION}
@@ -54,9 +54,3 @@ LIBGUILE_SRFI_SRFI_60_INTERFACE_CURRENT=3
LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION=0
LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE=0
LIBGUILE_SRFI_SRFI_60_INTERFACE="${LIBGUILE_SRFI_SRFI_60_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE}"
-
-LIBGUILE_I18N_MAJOR=0
-LIBGUILE_I18N_INTERFACE_CURRENT=0
-LIBGUILE_I18N_INTERFACE_REVISION=0
-LIBGUILE_I18N_INTERFACE_AGE=0
-LIBGUILE_I18N_INTERFACE="${LIBGUILE_I18N_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_I18N_INTERFACE_AGE}"
diff --git a/NEWS b/NEWS
index 0f2d6930d..a9a7adf24 100644
--- a/NEWS
+++ b/NEWS
@@ -8,31 +8,70 @@ Please send Guile bug reports to bug-guile@gnu.org.
(During the 1.9 series, we will keep an incremental NEWS for the latest
prerelease, and a full NEWS corresponding to 1.8 -> 2.0.)
-Changes in 1.9.3 (since the 1.9.2 prerelease):
+Changes in 1.9.4 (since the 1.9.3 prerelease):
-** Removed deprecated uniform array procedures: scm_make_uve,
- scm_array_prototype, scm_list_to_uniform_array,
- scm_dimensions_to_uniform_array, scm_make_ra, scm_shap2ra, scm_cvref,
- scm_ra_set_contp, scm_aind, scm_raprin1
+** Guile now adds its install prefix to the LTDL_LIBRARY_PATH
-These functions have been deprecated since early 2005.
+Users may now install Guile to nonstandard prefixes and just run
+`/path/to/bin/guile', instead of also having to set LTDL_LIBRARY_PATH to
+include `/path/to/lib'.
-** scm_array_p has one argument, not two
+** Dynamically loadable extensions may be placed in a Guile-specific path
-Use of the second argument produced a deprecation warning, so it is
-unlikely that any code out there actually used this functionality.
+Before, Guile only searched the system library paths for extensions
+(e.g. /usr/lib), which meant that the names of Guile extensions had to
+be globally unique. Installing them to a Guile-specific extensions
+directory is cleaner. Use `pkg-config --variable=extensionsdir
+guile-2.0' to get the location of the extensions directory.
-** Removed deprecated uniform array procedures:
- dimensions->uniform-array, list->uniform-array, array-prototype
+** The programmatic `compile' procedure compiles its expression in a
+ fresh module, by default
-Instead, use make-typed-array, list->typed-array, or array-type,
-respectively.
+This should make the results of `compile' more predictable. Users may
+specify a specific module in which to compile via the `#:env' keyword
+argument to `compile' (and `compile-file').
+
+** `compile-file' preserves expansion-time side-effects to `current-reader'
+
+User modules may now modify the `current-reader' fluid at expansion
+time, usually within an eval-when, and those modifications will remain
+in place when compiling subsequent forms in the file.
+
+See "The Scheme Compiler" in the Guile manual for more details.
+
+** Guile's Emacs integration is now more keyboard-friendly
+
+Backtraces may now be disclosed with the keyboard in addition to the
+mouse.
+
+** Compile-time warnings: -Wunbound-variable
+
+Guile can warn about potentially unbound free variables. Pass the
+-Wunbound-variable on the `guile-tools compile' command line, or add
+`#:warnings '(unbound-variable)' to your `compile' or `compile-file'
+invocation.
+
+** Wide character/string support in locale-specific character/string
+ functions
+
+The `(ice-9 i18n)' functions (`string-locale<?', etc.) now work
+correctly on wide strings as well. This should finish off the remaining
+Unicode support patches. Please send any Unicode bug reports to
+`bug-guile@gnu.org'.
+
+** ABI harmonization
+
+`scm_primitive_load_path' now has the signature it did in 1.8.
+`scm_array_p' does as well, reverting an incompatible change made in
+1.9.3. Finally, Guile now has the same ABI when built with or without
+threads, something that should make Debian users happy.
** And of course, the usual collection of bugfixes
Interested users should see the ChangeLog for more information.
+
Changes in 1.9.x (since the 1.8.x series):
* New modules (see the manual for details)
@@ -75,6 +114,17 @@ documented in the manual. This will be fixed before 2.0.
Pass the `--help' command-line option to these commands for more
information.
+** Guile now adds its install prefix to the LTDL_LIBRARY_PATH
+
+Users may now install Guile to nonstandard prefixes and just run
+`/path/to/bin/guile', instead of also having to set LTDL_LIBRARY_PATH to
+include `/path/to/lib'.
+
+** Guile's Emacs integration is now more keyboard-friendly
+
+Backtraces may now be disclosed with the keyboard in addition to the
+mouse.
+
* Changes to Scheme functions and syntax
** Procedure removed: `the-environment'
@@ -108,6 +158,20 @@ For example, the old (lang elisp) modules are meant to be interpreted,
not compiled. This bug will be fixed before 2.0. FIXME 2.0: Should say
something here about module-transformer called for compile.
+** Files loaded with `load' will now be compiled automatically.
+
+As with files loaded via `primitive-load-path', `load' will also compile
+its target if autocompilation is enabled, and a fresh compiled file is
+not found.
+
+There are two points of difference to note, however. First, `load' does
+not search `GUILE_LOAD_COMPILED_PATH' for the file; it only looks in the
+autocompilation directory, normally a subdirectory of ~/.cache/guile.
+
+Secondly, autocompilation also applies to files loaded via the -l
+command-line argument -- so the user may experience a slight slowdown
+the first time they run a Guile script, as the script is autocompiled.
+
** New POSIX procedures: `getrlimit' and `setrlimit'
Note however that the interface of these functions is likely to change
@@ -492,9 +556,52 @@ Internally, strings are now represented either in the `latin-1'
encoding, one byte per character, or in UTF-32, with four bytes per
character. Strings manage their own allocation, switching if needed.
-Currently no locale conversion is performed. Extended characters may be
-written in a string using the hexadecimal escapes `\xXX', `\uXXXX', or
-`\UXXXXXX', for 8-bit, 16-bit, or 24-bit codepoints, respectively.
+Extended characters may be written in a literal string using the
+hexadecimal escapes `\xXX', `\uXXXX', or `\UXXXXXX', for 8-bit, 16-bit,
+or 24-bit codepoints, respectively, or entered directly in the native
+encoding of the port on which the string is read.
+
+** Unicode symbols
+
+One may now use U+03BB (GREEK SMALL LETTER LAMBDA) as an identifier.
+
+** Support for non-ASCII source code files
+
+The default reader now handles source code files for some of the
+non-ASCII character encodings, such as UTF-8. A non-ASCII source file
+should have an encoding declaration near the top of the file. Also,
+there is a new function, `file-encoding', that scans a port for a coding
+declaration. See the section of the manual entitled, "Character Encoding
+of Source Files".
+
+The pre-1.9.3 reader handled 8-bit clean but otherwise unspecified source
+code. This use is now discouraged.
+
+** Support for locale transcoding when reading from and writing to ports
+
+Ports now have an associated character encoding, and port read and write
+operations do conversion to and from locales automatically. Ports also
+have an associated strategy for how to deal with locale conversion
+failures.
+
+See the documentation in the manual for the four new support functions,
+`set-port-encoding!', `port-encoding', `set-port-conversion-strategy!',
+and `port-conversion-strategy'.
+
+** String and SRFI-13 functions can operate on Unicode strings
+
+** Unicode support for SRFI-14 character sets
+
+The default character sets are no longer locale dependent and contain
+characters from the whole Unicode range. There is a new predefined
+character set, `char-set:designated', which contains all assigned
+Unicode characters. There is a new debugging function, `%char-set-dump'.
+
+** Character functions operate on Unicode characters
+
+`char-upcase' and `char-downcase' use default Unicode casing rules.
+Character comparisons such as `char<?' and `char-ci<?' now sort based on
+Unicode code points.
** Global variables `scm_charnames' and `scm_charnums' are removed
@@ -509,6 +616,13 @@ There was an EBCDIC compile flag that altered some of the character
processing. It appeared that full EBCDIC support was never completed
and was unmaintained.
+** Compile-time warnings: -Wunbound-variable
+
+Guile can warn about potentially unbound free variables. Pass the
+-Wunbound-variable on the `guile-tools compile' command line, or add
+`#:warnings '(unbound-variable)' to your `compile' or `compile-file'
+invocation.
+
** New macro type: syncase-macro
XXX Need to decide whether to document this for 2.0, probably should:
@@ -559,14 +673,31 @@ the variable. This was an error, and was fixed.
As syntax-case is available by default, importing `(ice-9 syncase)' has
no effect, and will trigger a deprecation warning.
+** New readline history functions
+
+The (ice-9 readline) module now provides add-history, read-history,
+write-history and clear-history, which wrap the corresponding GNU
+History library functions.
+
** Removed deprecated uniform array procedures:
dimensions->uniform-array, list->uniform-array, array-prototype
Instead, use make-typed-array, list->typed-array, or array-type,
respectively.
+** Last but not least, the `λ' macro can be used in lieu of `lambda'
+
* Changes to the C interface
+** Guile now uses libgc, the Boehm-Demers-Weiser garbage collector
+
+The semantics of `scm_gc_malloc ()' have been changed, in a
+backward-compatible way. A new allocation routine,
+`scm_gc_malloc_pointerless ()', was added.
+
+Libgc is a conservative GC, which we hope will make interaction with C
+code easier and less error-prone.
+
** The GH interface (deprecated in version 1.6, 2001) was removed.
** Internal `scm_i_' functions now have "hidden" linkage with GCC/ELF
@@ -600,11 +731,6 @@ definition depends on the application's value for `_FILE_OFFSET_BITS'.
These functions have been deprecated since early 2005.
-** scm_array_p has one argument, not two
-
-Use of the second argument produced a deprecation warning, so it is
-unlikely that any code out there actually used this functionality.
-
* Changes to the distribution
** Guile's license is now LGPLv3+
@@ -613,6 +739,11 @@ In other words the GNU Lesser General Public License, version 3 or
later (at the discretion of each person that chooses to redistribute
part of Guile).
+** GOOPS documentation folded into Guile reference manual
+
+GOOPS, Guile's object system, used to be documented in separate manuals.
+This content is now included in Guile's manual directly.
+
** `guile-config' will be deprecated in favor of `pkg-config'
`guile-config' has been rewritten to get its information from
@@ -630,10 +761,22 @@ macros should now require `guile-2.0' instead of `guile-1.8'.
If $(libdir) is /usr/lib, for example, Guile will install its .go files
to /usr/lib/guile/1.9/ccache. These files are architecture-specific.
-** New dependency: GNU libunistring.
+** Dynamically loadable extensions may be placed in a Guile-specific path
+
+Before, Guile only searched the system library paths for extensions
+(e.g. /usr/lib), which meant that the names of Guile extensions had to
+be globally unique. Installing them to a Guile-specific extensions
+directory is cleaner. Use `pkg-config --variable=extensionsdir
+guile-2.0' to get the location of the extensions directory.
+
+** New dependency: libgc
+
+See http://www.hpl.hp.com/personal/Hans_Boehm/gc/, for more information.
+
+** New dependency: GNU libunistring
See http://www.gnu.org/software/libunistring/, for more information. Our
-unicode support uses routines from libunistring.
+Unicode support uses routines from libunistring.
@@ -643,6 +786,7 @@ Changes in 1.8.8 (since 1.8.7)
** Fix possible buffer overruns when parsing numbers
** Avoid clash with system setjmp/longjmp on IA64
+** Fix `wrong type arg' exceptions with IPv6 addresses
Changes in 1.8.7 (since 1.8.6)
diff --git a/README b/README
index bea40debc..c4f24f88e 100644
--- a/README
+++ b/README
@@ -33,6 +33,7 @@ Guile depends on the following external libraries.
- libintl
- libltdl
- libunistring
+- libgc
It will also use the libreadline library if it is available. For each
of these there is a corresponding --with-XXX-prefix option that you
can use when invoking ./configure, if you have these libraries
@@ -68,12 +69,12 @@ Guile requires the following external packages:
- GNU MP, at least version 4.1
GNU MP is used for bignum arithmetic. It is available from
- http://swox.com/gmp
+ http://gmplib.org/ .
- - libltdl from libtool, at least from libtool version 1.5.6
+ - libltdl from GNU Libtool, at least version 1.5.6
libltdl is used for loading extensions at run-time. It is
- available from http://www.gnu.org/software/libtool/
+ available from http://www.gnu.org/software/libtool/ .
- GNU libunistring
@@ -81,6 +82,12 @@ Guile requires the following external packages:
`utf*->string' procedures. It is available from
http://www.gnu.org/software/libunistring/ .
+ - libgc, at least version 7.0
+
+ libgc (aka. the Boehm-Demers-Weiser garbage collector) is the
+ conservative garbage collector used by Guile. It is available
+ from http://www.hpl.hp.com/personal/Hans_Boehm/gc/ .
+
Special Instructions For Some Systems =====================================
diff --git a/THANKS b/THANKS
index 90121094b..e507d73ec 100644
--- a/THANKS
+++ b/THANKS
@@ -76,6 +76,7 @@ For fixes or providing information which led to a fix:
Antoine Mathys
Dan McMahill
Roger Mc Murtrie
+ Scott McPeak
Tim Mooney
Han-Wen Nienhuys
Jan Nieuwenhuizen
@@ -85,6 +86,7 @@ For fixes or providing information which led to a fix:
Peter O'Gorman
Pieter Pareit
Jack Pavlovsky
+ Derek Peschel
Arno Peters
Ron Peterson
David Pirotte
diff --git a/acinclude.m4 b/acinclude.m4
index 680003309..43a227bc9 100644
--- a/acinclude.m4
+++ b/acinclude.m4
@@ -311,20 +311,51 @@ fi
AC_LANG_RESTORE
])dnl ACX_PTHREAD
+dnl GUILE_GNU_LD_RELRO
+dnl
dnl Check whether GNU ld's read-only relocations (the `PT_GNU_RELRO'
dnl ELF segment header) are supported. This allows things like
dnl statically allocated cells (1) to eventually be remapped read-only
dnl by the loader, and (2) to be identified as pointerless by the
-dnl garbage collector.
+dnl garbage collector. Substitute `GNU_LD_FLAGS' with the relevant
+dnl flags.
AC_DEFUN([GUILE_GNU_LD_RELRO], [
AC_MSG_CHECKING([whether the linker understands `-z relro'])
+ GNU_LD_FLAGS="-Wl,-z -Wl,relro"
+
save_LDFLAGS="$LDFLAGS"
- LDFLAGS="$LDFLAGS -Wl,-z -Wl,relro"
+ LDFLAGS="$LDFLAGS $GNU_LD_FLAGS"
AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])],
[AC_MSG_RESULT([yes])],
[AC_MSG_RESULT([no])
- LDFLAGS="$save_LDFLAGS"])
+ GNU_LD_FLAGS=""])
+ LDFLAGS="$save_LDFLAGS"
+
+ AC_SUBST([GNU_LD_FLAGS])
+])
+
+dnl GUILE_THREAD_LOCAL_STORAGE
+dnl
+dnl Check for compiler thread-local storage (TLS) support.
+AC_DEFUN([GUILE_THREAD_LOCAL_STORAGE], [
+ AC_CACHE_CHECK([whether the `__thread' storage class is available],
+ [ac_cv_have_thread_storage_class],
+ [dnl On some systems, e.g., NetBSD 5.0 with GCC 4.1, `__thread' is
+ dnl properly compiled but fails to link due to the lack of TLS
+ dnl support in the C library. Thus we try to link, not just compile.
+ AC_LINK_IFELSE([AC_LANG_PROGRAM([__thread int tls_integer;],
+ [tls_integer = 123;])],
+ [ac_cv_have_thread_storage_class="yes"],
+ [ac_cv_have_thread_storage_class="no"])])
+
+ if test "x$ac_cv_have_thread_storage_class" = "xyes"; then
+ SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS=1
+ else
+ SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS=0
+ fi
+
+ AC_SUBST([SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS])
])
dnl GUILE_READLINE
diff --git a/am/guilec b/am/guilec
index ce0711b74..00366d85e 100644
--- a/am/guilec
+++ b/am/guilec
@@ -30,4 +30,6 @@ install-data-hook:
SUFFIXES = .scm .go
.scm.go:
- GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guile-tools compile -o "$@" "$<"
+ GUILE_AUTO_COMPILE=0 \
+ $(top_builddir)/meta/uninstalled-env \
+ guile-tools compile -Wunbound-variable -o "$@" "$<"
diff --git a/autogen.sh b/autogen.sh
index 8062d7e84..78b680276 100755
--- a/autogen.sh
+++ b/autogen.sh
@@ -15,7 +15,11 @@ autoconf --version
echo ""
automake --version
echo ""
-libtool --version
+if test "`uname -s`" = Darwin; then
+ glibtool --version
+else
+ libtool --version
+fi
echo ""
${M4:-/usr/bin/m4} --version
echo ""
diff --git a/benchmark-suite/benchmarks/0-reference.bm b/benchmark-suite/benchmarks/0-reference.bm
index 65085a8d7..3d02ee7b1 100644
--- a/benchmark-suite/benchmarks/0-reference.bm
+++ b/benchmark-suite/benchmarks/0-reference.bm
@@ -1,2 +1,6 @@
+
+(define-module (benchmarks 0-reference)
+ :use-module (benchmark-suite lib))
+
(benchmark "reference benchmark for iteration counts" 330000
#t)
diff --git a/benchmark-suite/benchmarks/bytevectors.bm b/benchmark-suite/benchmarks/bytevectors.bm
index a686a08c9..06f23ef3b 100644
--- a/benchmark-suite/benchmarks/bytevectors.bm
+++ b/benchmark-suite/benchmarks/bytevectors.bm
@@ -1,4 +1,4 @@
-;;; -*- mode: scheme; coding: latin-1; -*-
+;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*-
;;; R6RS Byte Vectors.
;;;
;;; Copyright 2009 Ludovic Courtès <ludo@gnu.org>
diff --git a/benchmark-suite/benchmarks/chars.bm b/benchmark-suite/benchmarks/chars.bm
index dc6ad94aa..6ae0e60bd 100644
--- a/benchmark-suite/benchmarks/chars.bm
+++ b/benchmark-suite/benchmarks/chars.bm
@@ -1,4 +1,4 @@
-;;; -*- mode: scheme; coding: latin-1; -*-
+;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*-
;;; chars.bm
;;;
;;; Copyright (C) 2009 Free Software Foundation, Inc.
diff --git a/benchmark-suite/benchmarks/continuations.bm b/benchmark-suite/benchmarks/continuations.bm
index 7c44300f7..59d3d0842 100644
--- a/benchmark-suite/benchmarks/continuations.bm
+++ b/benchmark-suite/benchmarks/continuations.bm
@@ -1,3 +1,7 @@
+
+(define-module (benchmarks continuations)
+ :use-module (benchmark-suite lib))
+
(define (callee continuation)
(continuation #t))
diff --git a/benchmark-suite/benchmarks/if.bm b/benchmark-suite/benchmarks/if.bm
index 30c22c9c3..70aa8debf 100644
--- a/benchmark-suite/benchmarks/if.bm
+++ b/benchmark-suite/benchmarks/if.bm
@@ -1,3 +1,7 @@
+
+(define-module (benchmarks if)
+ :use-module (benchmark-suite lib))
+
(with-benchmark-prefix "if-<expr>-then-else"
(benchmark "executing then" 330000
diff --git a/benchmark-suite/benchmarks/logand.bm b/benchmark-suite/benchmarks/logand.bm
index cdb05e88d..c94ad3167 100644
--- a/benchmark-suite/benchmarks/logand.bm
+++ b/benchmark-suite/benchmarks/logand.bm
@@ -1,3 +1,7 @@
+
+(define-module (benchmarks logand)
+ :use-module (benchmark-suite lib))
+
(define bignum (1- (expt 2 128)))
(let* ((i 0))
diff --git a/benchmark-suite/benchmarks/read.bm b/benchmark-suite/benchmarks/read.bm
index f11ca687a..7bc81509e 100644
--- a/benchmark-suite/benchmarks/read.bm
+++ b/benchmark-suite/benchmarks/read.bm
@@ -49,14 +49,14 @@
(benchmark "_IONBF" 5 ;; this one is very slow
(exercise-read (list _IONBF)))
- (benchmark "_IOLBF" 100
+ (benchmark "_IOLBF" 10
(exercise-read (list _IOLBF)))
- (benchmark "_IOFBF 4096" 100
+ (benchmark "_IOFBF 4096" 10
(exercise-read (list _IOFBF 4096)))
- (benchmark "_IOFBF 8192" 100
+ (benchmark "_IOFBF 8192" 10
(exercise-read (list _IOFBF 8192)))
- (benchmark "_IOFBF 16384" 100
+ (benchmark "_IOFBF 16384" 10
(exercise-read (list _IOFBF 16384))))
diff --git a/benchmark-suite/benchmarks/srfi-13.bm b/benchmark-suite/benchmarks/srfi-13.bm
index e648e2af9..c6afd7ee4 100644
--- a/benchmark-suite/benchmarks/srfi-13.bm
+++ b/benchmark-suite/benchmarks/srfi-13.bm
@@ -1,4 +1,4 @@
-;;; -*- mode: scheme; coding: latin-1; -*-
+;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*-
;;; srfi-13.bm
;;;
;;; Copyright (C) 2009 Free Software Foundation, Inc.
diff --git a/benchmark-suite/lib.scm b/benchmark-suite/lib.scm
index 65253c5ff..4a2bf385b 100644
--- a/benchmark-suite/lib.scm
+++ b/benchmark-suite/lib.scm
@@ -325,7 +325,7 @@
;;; A short form for benchmarks.
(defmacro benchmark (name iterations body . rest)
- `(,run-benchmark ,name ,iterations (lambda () ,body ,@rest)))
+ `(run-benchmark ,name ,iterations (lambda () ,body ,@rest)))
;;;; BENCHMARK NAMES
diff --git a/benchmark-suite/results/neil-arudy b/benchmark-suite/results/neil-arudy
new file mode 100644
index 000000000..7b61d399c
--- /dev/null
+++ b/benchmark-suite/results/neil-arudy
@@ -0,0 +1,93 @@
+Benchmarking /home/neil/SW/Guile/git/meta/guile ...
+with GUILE_LOAD_PATH=/home/neil/SW/Guile/git/benchmark-suite
+;; running guile version 1.9.3
+;; calibrating the benchmarking framework...
+;; framework time per iteration: 5.7220458984375e-7
+("0-reference.bm: reference benchmark for iteration counts" 330000 user 0.2 benchmark 0.0111724853515625 bench/interp 0.0111724853515625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u8-ref" 1000000 user 0.73 benchmark 0.15779541015625 bench/interp 0.15779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u16-ref (foreign)" 1000000 user 0.82 benchmark 0.24779541015625 bench/interp 0.24779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u16-ref (native)" 1000000 user 0.78 benchmark 0.20779541015625 bench/interp 0.20779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u16-native-ref" 1000000 user 0.72 benchmark 0.14779541015625 bench/interp 0.14779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u32-ref (foreign)" 1000000 user 1.61 benchmark 1.03779541015625 bench/interp 1.03779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u32-ref (native)" 1000000 user 0.8 benchmark 0.22779541015625 bench/interp 0.22779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u32-native-ref" 1000000 user 0.74 benchmark 0.16779541015625 bench/interp 0.16779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u64-ref (foreign)" 1000000 user 1.86 benchmark 1.28779541015625 bench/interp 1.28779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u64-ref (native)" 1000000 user 0.81 benchmark 0.23779541015625 bench/interp 0.23779541015625 gc 0.0)
+("bytevectors.bm: ref/set!: bytevector-u64-native-ref" 1000000 user 0.73 benchmark 0.15779541015625 bench/interp 0.15779541015625 gc 0.0)
+("bytevectors.bm: lists: bytevector->u8-list" 2000 user 9.87 benchmark 9.86885559082031 bench/interp 9.86885559082031 gc 0.0)
+("bytevectors.bm: lists: bytevector->uint-list 16-bit" 2000 user 4.48 benchmark 4.47885559082031 bench/interp 4.47885559082031 gc 0.0)
+("bytevectors.bm: lists: bytevector->uint-list 64-bit" 2000 user 3.75 benchmark 3.74885559082031 bench/interp 3.74885559082031 gc 0.0)
+("bytevectors.bm: SRFI-4: u8vector-ref" 1000000 user 1.88 benchmark 1.30779541015625 bench/interp 1.30779541015625 gc 0.0)
+("bytevectors.bm: SRFI-4: u16vector-ref" 1000000 user 1.9 benchmark 1.32779541015625 bench/interp 1.32779541015625 gc 0.0)
+("bytevectors.bm: SRFI-4: u32vector-ref" 1000000 user 1.88 benchmark 1.30779541015625 bench/interp 1.30779541015625 gc 0.0)
+("bytevectors.bm: SRFI-4: u64vector-ref" 1000000 user 1.98 benchmark 1.40779541015625 bench/interp 1.40779541015625 gc 0.0)
+("chars.bm: chars: char" 1000000 user 0.63 benchmark 0.05779541015625 bench/interp 0.05779541015625 gc 0.0)
+("chars.bm: chars: octal" 1000000 user 0.64 benchmark 0.06779541015625 bench/interp 0.06779541015625 gc 0.0)
+("chars.bm: chars: char? eq" 1000000 user 1.19 benchmark 0.61779541015625 bench/interp 0.61779541015625 gc 0.0)
+("chars.bm: chars: char=?" 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0)
+("chars.bm: chars: char<?" 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0)
+("chars.bm: chars: char-ci=?" 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0)
+("chars.bm: chars: char-ci<? " 1000000 user 1.45 benchmark 0.87779541015625 bench/interp 0.87779541015625 gc 0.0)
+("chars.bm: chars: char->integer" 1000000 user 1.2 benchmark 0.62779541015625 bench/interp 0.62779541015625 gc 0.0)
+("chars.bm: chars: char-alphabetic?" 1000000 user 1.36 benchmark 0.78779541015625 bench/interp 0.78779541015625 gc 0.0)
+("chars.bm: chars: char-numeric?" 1000000 user 1.36 benchmark 0.78779541015625 bench/interp 0.78779541015625 gc 0.0)
+("continuations.bm: call/cc" 300 user 0.03 benchmark 0.0298283386230469 bench/interp 0.0298283386230469 gc 0.0)
+("if.bm: if-<expr>-then-else: executing then" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("if.bm: if-<expr>-then-else: executing else" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("if.bm: if-<expr>-then: executing then" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("if.bm: if-<expr>-then: executing else" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0)
+("if.bm: if-<iloc>-then-else: executing then" 330000 user 0.25 benchmark 0.0611724853515625 bench/interp 0.0611724853515625 gc 0.0)
+("if.bm: if-<iloc>-then-else: executing else" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0)
+("if.bm: if-<iloc>-then: executing then" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0)
+("if.bm: if-<iloc>-then: executing else" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0)
+("if.bm: if-<bool>-then-else: executing then" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("if.bm: if-<bool>-then-else: executing else" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("if.bm: if-<bool>-then: executing then" 330000 user 0.24 benchmark 0.0511724853515625 bench/interp 0.0511724853515625 gc 0.0)
+("if.bm: if-<bool>-then: executing else" 330000 user 0.23 benchmark 0.0411724853515625 bench/interp 0.0411724853515625 gc 0.0)
+("logand.bm: bignum" 130000 user 0.48 benchmark 0.405613403320312 bench/interp 0.405613403320312 gc 0.0)
+("read.bm: read: _IONBF" 5 user 12.71 benchmark 12.7099971389771 bench/interp 12.7099971389771 gc 0.0)
+("read.bm: read: _IOLBF" 10 user 20.32 benchmark 20.3199942779541 bench/interp 20.3199942779541 gc 0.0)
+("read.bm: read: _IOFBF 4096" 10 user 20.34 benchmark 20.3399942779541 bench/interp 20.3399942779541 gc 0.0)
+("read.bm: read: _IOFBF 8192" 10 user 20.36 benchmark 20.3599942779541 bench/interp 20.3599942779541 gc 0.0)
+("read.bm: read: _IOFBF 16384" 10 user 20.34 benchmark 20.3399942779541 bench/interp 20.3399942779541 gc 0.0)
+("srfi-13.bm: strings: predicates: string?" 1190000 user 2.98 benchmark 2.29907653808594 bench/interp 2.29907653808594 gc 0.0)
+("srfi-13.bm: strings: predicates: null?" 969000 user 2.56 benchmark 2.00553375244141 bench/interp 2.00553375244141 gc 0.0)
+("srfi-13.bm: strings: predicates: any" 94000 user 1.89 benchmark 1.83621276855469 bench/interp 1.83621276855469 gc 0.0)
+("srfi-13.bm: strings: predicates: every" 94000 user 1.53 benchmark 1.47621276855469 bench/interp 1.47621276855469 gc 0.0)
+("srfi-13.bm: strings: constructors: string" 5000 user 2.02 benchmark 2.01713897705078 bench/interp 2.01713897705078 gc 0.0)
+("srfi-13.bm: strings: constructors: list->" 4500 user 0.3 benchmark 0.297425079345703 bench/interp 0.297425079345703 gc 0.0)
+("srfi-13.bm: strings: constructors: reverse-list->" 5000 user 0.58 benchmark 0.577138977050781 bench/interp 0.577138977050781 gc 0.0)
+("srfi-13.bm: strings: constructors: make" 22000 user 0.52 benchmark 0.507411499023438 bench/interp 0.507411499023438 gc 0.0)
+("srfi-13.bm: strings: constructors: tabulate" 17000 user 0.57 benchmark 0.560272521972656 bench/interp 0.560272521972656 gc 0.0)
+("srfi-13.bm: strings: constructors: join" 5500 user 0.46 benchmark 0.456852874755859 bench/interp 0.456852874755859 gc 0.0)
+("srfi-13.bm: strings: list/string: ->list" 7300 user 2.36 benchmark 2.35582290649414 bench/interp 2.35582290649414 gc 0.0)
+("srfi-13.bm: strings: list/string: split" 60000 user 1.87 benchmark 1.83566772460938 bench/interp 1.83566772460938 gc 0.0)
+("srfi-13.bm: strings: selection: ref" 660 user 1.5 benchmark 1.4996223449707 bench/interp 1.4996223449707 gc 0.0)
+("srfi-13.bm: strings: selection: copy" 1100 user 0.04 benchmark 0.0393705749511719 bench/interp 0.0393705749511719 gc 0.0)
+("srfi-13.bm: strings: selection: pad" 6800 user 0.17 benchmark 0.166109008789063 bench/interp 0.166109008789063 gc 0.0)
+("srfi-13.bm: strings: selection: trim trim-right trim-both" 60000 user 2.67 benchmark 2.63566772460937 bench/interp 2.63566772460937 gc 0.0)
+("srfi-13.bm: strings: modification: set!" 3000 user 1.42 benchmark 1.41828338623047 bench/interp 1.41828338623047 gc 0.0)
+("srfi-13.bm: strings: modification: sub-move!" 230000 user 1.88 benchmark 1.74839294433594 bench/interp 1.74839294433594 gc 0.0)
+("srfi-13.bm: strings: modification: fill!" 230000 user 2.31 benchmark 2.17839294433594 bench/interp 2.17839294433594 gc 0.0)
+("srfi-13.bm: strings: modification: comparison: compare compare-ci" 140000 user 1.93 benchmark 1.84989135742187 bench/interp 1.84989135742187 gc 0.0)
+("srfi-13.bm: strings: modification: comparison: hash hash-ci" 1000 user 0.27 benchmark 0.269427795410156 bench/interp 0.269427795410156 gc 0.0)
+("srfi-13.bm: strings: searching: prefix-length suffix-length" 270 user 0.2 benchmark 0.199845504760742 bench/interp 0.199845504760742 gc 0.0)
+("srfi-13.bm: strings: searching: prefix? suffix?" 270 user 0.2 benchmark 0.199845504760742 bench/interp 0.199845504760742 gc 0.0)
+("srfi-13.bm: strings: searching: index index-right rindex" 100000 user 3.48 benchmark 3.42277954101562 bench/interp 3.42277954101562 gc 0.0)
+("srfi-13.bm: strings: searching: skip skip-right?" 100000 user 2.14 benchmark 2.08277954101563 bench/interp 2.08277954101563 gc 0.0)
+("srfi-13.bm: strings: searching: count" 10000 user 9.35 benchmark 9.34427795410156 bench/interp 9.34427795410156 gc 0.0)
+("srfi-13.bm: strings: searching: contains contains-ci" 34000 user 2.29 benchmark 2.27054504394531 bench/interp 2.27054504394531 gc 0.0)
+("srfi-13.bm: strings: searching: upcase downcase upcase! downcase!" 600 user 0.2 benchmark 0.199656677246094 bench/interp 0.199656677246094 gc 0.0)
+("srfi-13.bm: strings: readers: read token, method 1" 1200 user 1.26 benchmark 1.25931335449219 bench/interp 1.25931335449219 gc 0.0)
+("srfi-13.bm: strings: readers: read token, method 2" 1200 user 2.03 benchmark 2.02931335449219 bench/interp 2.02931335449219 gc 0.0)
+("subr.bm: subr invocation: simple subr" 700000 user 0.47 benchmark 0.069456787109375 bench/interp 0.069456787109375 gc 0.0)
+("subr.bm: subr invocation: generic subr" 700000 user 1.75 benchmark 1.34945678710938 bench/interp 1.34945678710938 gc 0.0)
+("subr.bm: subr invocation: generic subr with rest arg" 700000 user 1.39 benchmark 0.989456787109375 bench/interp 0.989456787109375 gc 0.0)
+("subr.bm: subr invocation: generic subr with rest arg and 3+ parameters" 700000 user 1.86 benchmark 1.45945678710938 bench/interp 1.45945678710938 gc 0.0)
+("subr.bm: subr application: simple subr" 700000 user 0.91 benchmark 0.509456787109375 bench/interp 0.509456787109375 gc 0.0)
+("subr.bm: subr application: generic subr" 700000 user 1.8 benchmark 1.39945678710938 bench/interp 1.39945678710938 gc 0.0)
+("subr.bm: subr application: generic subr with rest arg" 700000 user 1.44 benchmark 1.03945678710937 bench/interp 1.03945678710937 gc 0.0)
+("subr.bm: subr application: generic subr with rest arg and 3+ parameters" 700000 user 1.89 benchmark 1.48945678710937 bench/interp 1.48945678710937 gc 0.0)
+("uniform-vector-read.bm: uniform-vector-read!: uniform-vector-write" 500 user 0.12 benchmark 0.119713897705078 bench/interp 0.119713897705078 gc 0.0)
+("uniform-vector-read.bm: uniform-vector-read!: uniform-vector-read!" 500 user 0.02 benchmark 0.0197138977050781 bench/interp 0.0197138977050781 gc 0.0)
+("uniform-vector-read.bm: uniform-vector-read!: string port" 5000 user 2.49 benchmark 2.48713897705078 bench/interp 2.48713897705078 gc 0.0)
diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog
index 1cc53eb7c..270b8cf56 100755
--- a/build-aux/gitlog-to-changelog
+++ b/build-aux/gitlog-to-changelog
@@ -1,4 +1,7 @@
-#!/usr/bin/perl
+#!/bin/sh
+# Accommodate systems where /usr/bin/perl is not the right path.
+exec perl -x "$0" "$@"
+#!perl
# Convert git log output to ChangeLog format.
my $VERSION = '2009-06-04 08:53'; # UTC
diff --git a/configure.ac b/configure.ac
index f10df101d..87710777a 100644
--- a/configure.ac
+++ b/configure.ac
@@ -86,6 +86,9 @@ AM_CONDITIONAL(HAVE_MAKEINFO, test "$have_makeinfo" = yes)
AM_PATH_LISPDIR
+AC_DEFINE_UNQUOTED([HOST_TYPE], ["$host"],
+ [Define to the host's GNU triplet.])
+
#--------------------------------------------------------------------
#
# User options (after above tests that may set default CFLAGS etc.)
@@ -826,6 +829,11 @@ AC_LIB_HAVE_LINKFLAGS(gmp,
AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README]))
dnl GNU libunistring is checked for by Gnulib's `libunistring' module.
+if test "x$LTLIBUNISTRING" != "x"; then
+ LIBS="$LTLIBUNISTRING $LIBS"
+else
+ AC_MSG_ERROR([GNU libunistring is required, please install it.])
+fi
dnl i18n tests
#AC_CHECK_HEADERS([libintl.h])
@@ -1185,6 +1193,13 @@ AC_CHECK_DECL([GC_do_blocking],
[],
[#include <gc/gc.h>])
+# `GC_fn_type' is not available in GC 7.1 and earlier.
+AC_CHECK_TYPE([GC_fn_type],
+ [AC_DEFINE([HAVE_GC_FN_TYPE], [1],
+ [Define this if the `GC_fn_type' type is available.])],
+ [],
+ [#include <gc/gc.h>])
+
AC_CHECK_SIZEOF(float)
if test "$ac_cv_sizeof_float" -le "$ac_cv_sizeof_long"; then
@@ -1372,6 +1387,8 @@ AC_DEFINE(PTHREAD_ATTR_GETSTACK_WORKS, [1], [Define when pthread_att_get_stack w
CFLAGS="$old_CFLAGS"
AC_MSG_RESULT($works)
+GUILE_THREAD_LOCAL_STORAGE
+
fi # with_threads=pthreads
diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi
index 4ef4aab18..127f0bbc9 100644
--- a/doc/maint/guile.texi
+++ b/doc/maint/guile.texi
@@ -1750,22 +1750,6 @@ current interfaces. If a file cannot be opened with the access
requested, @code{open-file} throws an exception.
@end deffn
- make-future
-@c snarfed from futures.c:89
-@deffn {Scheme Procedure} make-future thunk
-@deffnx {C Function} scm_make_future (thunk)
-Make a future evaluating THUNK.
-@end deffn
-
- future-ref
-@c snarfed from futures.c:221
-@deffn {Scheme Procedure} future-ref future
-@deffnx {C Function} scm_future_ref (future)
-If the future @var{x} has not been computed yet, compute and
-return @var{x}, otherwise just return the previously computed
-value.
-@end deffn
-
gc-live-object-stats
@c snarfed from gc.c:276
@deffn {Scheme Procedure} gc-live-object-stats
@@ -10708,8 +10692,8 @@ the input is an integer with normal host byte ordering.
@lisp
(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1"
-(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}
-ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff
+(inet-ntop AF_INET6 (- (expt 2 128) 1))
+ @result{} "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff"
@end lisp
@end deffn
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index e7614d136..66fb99ef2 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -1506,8 +1506,8 @@ which is the name of the procedure incorrectly invoked.
@subsection Continuation Barriers
The non-local flow of control caused by continuations might sometimes
-not be wanted. You can use @code{with-continuation-barrier} etc to
-errect fences that continuations can not pass.
+not be wanted. You can use @code{with-continuation-barrier} to erect
+fences that continuations can not pass.
@deffn {Scheme Procedure} with-continuation-barrier proc
@deffnx {C Function} scm_with_continuation_barrier (proc)
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 0fd4ee1cf..cf0d32113 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -539,7 +539,7 @@ error. Instead, the result of the division is either plus or minus
infinity, depending on the sign of the divided number.
The infinities are written @samp{+inf.0} and @samp{-inf.0},
-respectivly. This syntax is also recognized by @code{read} as an
+respectively. This syntax is also recognized by @code{read} as an
extension to the usual Scheme syntax.
Dividing zero by zero yields something that is not a number at all:
@@ -637,7 +637,7 @@ magnitude. The argument @var{val} must be a real number.
@end deftypefn
@deftypefn {C Function} SCM scm_from_double (double val)
-Return the @code{SCM} value that representats @var{val}. The returned
+Return the @code{SCM} value that represents @var{val}. The returned
value is inexact according to the predicate @code{inexact?}, but it
will be exactly equal to @var{val}.
@end deftypefn
@@ -1779,16 +1779,66 @@ another manual.
@subsection Characters
@tpindex Characters
+In Scheme, there is a data type to describe a single character.
+
+Defining what exactly a character @emph{is} can be more complicated
+than it seems. Guile follows the advice of R6RS and uses The Unicode
+Standard to help define what a character is. So, for Guile, a
+character is anything in the Unicode Character Database.
+
+@cindex code point
+@cindex Unicode code point
+
+The Unicode Character Database is basically a table of characters
+indexed using integers called 'code points'. Valid code points are in
+the ranges 0 to @code{#xD7FF} inclusive or @code{#xE000} to
+@code{#x10FFFF} inclusive, which is about 1.1 million code points.
+
+@cindex designated code point
+@cindex code point, designated
+
+Any code point that has been assigned to a character or that has
+otherwise been given a meaning by Unicode is called a 'designated code
+point'. Most of the designated code points, about 200,000 of them,
+indicate characters, accents or other combining marks that modify
+other characters, symbols, whitespace, and control characters. Some
+are not characters but indicators that suggest how to format or
+display neighboring characters.
+
+@cindex reserved code point
+@cindex code point, reserved
+
+If a code point is not a designated code point -- if it has not been
+assigned to a character by The Unicode Standard -- it is a 'reserved
+code point', meaning that they are reserved for future use. Most of
+the code points, about 800,000, are 'reserved code points'.
+
+By convention, a Unicode code point is written as
+``U+XXXX'' where ``XXXX'' is a hexadecimal number. Please note that
+this convenient notation is not valid code. Guile does not interpret
+``U+XXXX'' as a character.
+
In Scheme, a character literal is written as @code{#\@var{name}} where
@var{name} is the name of the character that you want. Printable
characters have their usual single character name; for example,
-@code{#\a} is a lower case @code{a}.
+@code{#\a} is a lower case @code{a}.
+
+Some of the code points are 'combining characters' that are not meant
+to be printed by themselves but are instead meant to modify the
+appearance of the previous character. For combining characters, an
+alternate form of the character literal is @code{#\} followed by
+U+25CC (a small, dotted circle), followed by the combining character.
+This allows the combining character to be drawn on the circle, not on
+the backslash of @code{#\}.
+
+Many of the non-printing characters, such as whitespace characters and
+control characters, also have names.
-Most of the ``control characters'' (those below codepoint 32) in the
-@acronym{ASCII} character set, as well as the space, may be referred
-to by longer names: for example, @code{#\tab}, @code{#\esc},
-@code{#\stx}, and so on. The following table describes the
-@acronym{ASCII} names for each character.
+The most commonly used non-printing characters are space and
+newline. Their character names are @code{#\space} and
+@code{#\newline}. There are also names for all of the ``C0 control
+characters'' (those with code points below 32). The following table
+describes the names for each character.
@multitable @columnfractions .25 .25 .25 .25
@item 0 = @code{#\nul}
@@ -1801,9 +1851,9 @@ to by longer names: for example, @code{#\tab}, @code{#\esc},
@tab 7 = @code{#\bel}
@item 8 = @code{#\bs}
@tab 9 = @code{#\ht}
- @tab 10 = @code{#\nl}
+ @tab 10 = @code{#\lf}
@tab 11 = @code{#\vt}
-@item 12 = @code{#\np}
+@item 12 = @code{#\ff}
@tab 13 = @code{#\cr}
@tab 14 = @code{#\so}
@tab 15 = @code{#\si}
@@ -1826,85 +1876,112 @@ to by longer names: for example, @code{#\tab}, @code{#\esc},
@item 32 = @code{#\sp}
@end multitable
-The ``delete'' character (octal 177) may be referred to with the name
-@code{#\del}.
+The ``delete'' character (code point U+007F) may be referred to with the
+name @code{#\del}.
-Several characters have more than one name:
+One might note that the space character has two names --
+@code{#\space} and @code{#\sp} -- as does the newline character.
+Several other non-printing characters have more than one name, for the
+sake of compatibility with previous versions.
-@multitable {@code{#\backspace}} {Original}
-@item Alias @tab Original
-@item @code{#\space} @tab @code{#\sp}
-@item @code{#\newline} @tab @code{#\nl}
+@multitable {@code{#\backspace}} {Preferred}
+@item Alternate @tab Standard
+@item @code{#\sp} @tab @code{#\space}
+@item @code{#\nl} @tab @code{#\newline}
+@item @code{#\lf} @tab @code{#\newline}
@item @code{#\tab} @tab @code{#\ht}
@item @code{#\backspace} @tab @code{#\bs}
@item @code{#\return} @tab @code{#\cr}
-@item @code{#\page} @tab @code{#\np}
+@item @code{#\page} @tab @code{#\ff}
+@item @code{#\np} @tab @code{#\ff}
@item @code{#\null} @tab @code{#\nul}
@end multitable
+Characters may also be written using their code point values. They can
+be written with as an octal number, such as @code{#\10} for
+@code{#\bs} or @code{#\177} for @code{#\del}.
+
@rnindex char?
@deffn {Scheme Procedure} char? x
@deffnx {C Function} scm_char_p (x)
Return @code{#t} iff @var{x} is a character, else @code{#f}.
@end deffn
+Fundamentally, the character comparison operations below are
+numeric comparisons of the character's code points.
+
@rnindex char=?
@deffn {Scheme Procedure} char=? x y
-Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}.
+Return @code{#t} iff code point of @var{x} is equal to the code point
+of @var{y}, else @code{#f}.
@end deffn
@rnindex char<?
@deffn {Scheme Procedure} char<? x y
-Return @code{#t} iff @var{x} is less than @var{y} in the @acronym{ASCII} sequence,
-else @code{#f}.
+Return @code{#t} iff the code point of @var{x} is less than the code
+point of @var{y}, else @code{#f}.
@end deffn
@rnindex char<=?
@deffn {Scheme Procedure} char<=? x y
-Return @code{#t} iff @var{x} is less than or equal to @var{y} in the
-@acronym{ASCII} sequence, else @code{#f}.
+Return @code{#t} iff the code point of @var{x} is less than or equal
+to the code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char>?
@deffn {Scheme Procedure} char>? x y
-Return @code{#t} iff @var{x} is greater than @var{y} in the @acronym{ASCII}
-sequence, else @code{#f}.
+Return @code{#t} iff the code point of @var{x} is greater than the
+code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char>=?
@deffn {Scheme Procedure} char>=? x y
-Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the
-@acronym{ASCII} sequence, else @code{#f}.
+Return @code{#t} iff the code point of @var{x} is greater than or
+equal to the code point of @var{y}, else @code{#f}.
@end deffn
+@cindex case folding
+
+Case-insensitive character comparisons use @emph{Unicode case
+folding}. In case folding comparisons, if a character is lowercase
+and has an uppercase form that can be expressed as a single character,
+it is converted to uppercase before comparison. All other characters
+undergo no conversion before the comparison occurs. This includes the
+German sharp S (Eszett) which is not uppercased before conversion
+because its uppercase form has two characters. Unicode case folding
+is language independent: it uses rules that are generally true, but,
+it cannot cover all cases for all languages.
+
@rnindex char-ci=?
@deffn {Scheme Procedure} char-ci=? x y
-Return @code{#t} iff @var{x} is the same character as @var{y} ignoring
-case, else @code{#f}.
+Return @code{#t} iff the case-folded code point of @var{x} is the same
+as the case-folded code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char-ci<?
@deffn {Scheme Procedure} char-ci<? x y
-Return @code{#t} iff @var{x} is less than @var{y} in the @acronym{ASCII} sequence
-ignoring case, else @code{#f}.
+Return @code{#t} iff the case-folded code point of @var{x} is less
+than the case-folded code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char-ci<=?
@deffn {Scheme Procedure} char-ci<=? x y
-Return @code{#t} iff @var{x} is less than or equal to @var{y} in the
-@acronym{ASCII} sequence ignoring case, else @code{#f}.
+Return @code{#t} iff the case-folded code point of @var{x} is less
+than or equal to the case-folded code point of @var{y}, else
+@code{#f}.
@end deffn
@rnindex char-ci>?
@deffn {Scheme Procedure} char-ci>? x y
-Return @code{#t} iff @var{x} is greater than @var{y} in the @acronym{ASCII}
-sequence ignoring case, else @code{#f}.
+Return @code{#t} iff the case-folded code point of @var{x} is greater
+than the case-folded code point of @var{y}, else @code{#f}.
@end deffn
@rnindex char-ci>=?
@deffn {Scheme Procedure} char-ci>=? x y
-Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the
-@acronym{ASCII} sequence ignoring case, else @code{#f}.
+Return @code{#t} iff the case-folded code point of @var{x} is greater
+than or equal to the case-folded code point of @var{y}, else
+@code{#f}.
@end deffn
@rnindex char-alphabetic?
@@ -1946,14 +2023,15 @@ Return @code{#t} iff @var{chr} is either uppercase or lowercase, else
@rnindex char->integer
@deffn {Scheme Procedure} char->integer chr
@deffnx {C Function} scm_char_to_integer (chr)
-Return the number corresponding to ordinal position of @var{chr} in the
-@acronym{ASCII} sequence.
+Return the code point of @var{chr}.
@end deffn
@rnindex integer->char
@deffn {Scheme Procedure} integer->char n
@deffnx {C Function} scm_integer_to_char (n)
-Return the character at position @var{n} in the @acronym{ASCII} sequence.
+Return the character that has code point @var{n}. The integer @var{n}
+must be a valid code point. Valid code points are in the ranges 0 to
+@code{#xD7FF} inclusive or @code{#xE000} to @code{#x10FFFF} inclusive.
@end deffn
@rnindex char-upcase
@@ -1981,12 +2059,6 @@ handling them are provided.
Character sets can be created, extended, tested for the membership of a
characters and be compared to other character sets.
-The Guile implementation of character sets currently deals only with
-8-bit characters. In the future, when Guile gets support for
-international character sets, this will change, but the functions
-provided here will always then be able to efficiently cope with very
-large character sets.
-
@menu
* Character Set Predicates/Comparison::
* Iterating Over Character Sets:: Enumerate charset elements.
@@ -2185,7 +2257,7 @@ character codes lie in the half-open range
If @var{error} is a true value, an error is signalled if the
specified range contains characters which are not contained in
the implemented character range. If @var{error} is @code{#f},
-these characters are silently left out of the resultung
+these characters are silently left out of the resulting
character set.
The characters in @var{base_cs} are added to the result, if
@@ -2201,7 +2273,7 @@ character codes lie in the half-open range
If @var{error} is a true value, an error is signalled if the
specified range contains characters which are not contained in
the implemented character range. If @var{error} is @code{#f},
-these characters are silently left out of the resultung
+these characters are silently left out of the resulting
character set.
The characters are added to @var{base_cs} and @var{base_cs} is
@@ -2210,7 +2282,10 @@ returned.
@deffn {Scheme Procedure} ->char-set x
@deffnx {C Function} scm_to_char_set (x)
-Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is.
+Coerces x into a char-set. @var{x} may be a string, character or
+char-set. A string is converted to the set of its constituent
+characters; a character is converted to a singleton set; a char-set is
+returned as-is.
@end deffn
@c ===================================================================
@@ -2221,6 +2296,23 @@ Coerces x into a char-set. @var{x} may be a string, character or char-set. A str
Access the elements and other information of a character set with these
procedures.
+@deffn {Scheme Procedure} %char-set-dump cs
+Returns an association list containing debugging information
+for @var{cs}. The association list has the following entries.
+@table @code
+@item char-set
+The char-set itself
+@item len
+The number of groups of contiguous code points the char-set
+contains
+@item ranges
+A list of lists where each sublist is a range of code points
+and their associated characters
+@end table
+The return value of this function cannot be relied upon to be
+consistent between versions of Guile and should not be used in code.
+@end deffn
+
@deffn {Scheme Procedure} char-set-size cs
@deffnx {C Function} scm_char_set_size (cs)
Return the number of elements in character set @var{cs}.
@@ -2302,6 +2394,12 @@ must be a character set.
Return the complement of the character set @var{cs}.
@end deffn
+Note that the complement of a character set is likely to contain many
+reserved code points (code points that are not associated with
+characters). It may be helpful to modify the output of
+@code{char-set-complement} by computing its intersection with the set
+of designated code points, @code{char-set:designated}.
+
@deffn {Scheme Procedure} char-set-union . rest
@deffnx {C Function} scm_char_set_union (rest)
Return the union of all argument character sets.
@@ -2371,12 +2469,10 @@ useful, several predefined character set variables exist.
@cindex charset
@cindex locale
-Currently, the contents of these character sets are recomputed upon a
-successful @code{setlocale} call (@pxref{Locales}) in order to reflect
-the characters available in the current locale's codeset. For
-instance, @code{char-set:letter} contains 52 characters under an ASCII
-locale (e.g., the default @code{C} locale) and 117 characters under an
-ISO-8859-1 (``Latin-1'') locale.
+These character sets are locale independent and are not recomputed
+upon a @code{setlocale} call. They contain characters from the whole
+range of Unicode code points. For instance, @code{char-set:letter}
+contains about 94,000 characters.
@defvr {Scheme Variable} char-set:lower-case
@defvrx {C Variable} scm_char_set_lower_case
@@ -2390,13 +2486,16 @@ All upper-case characters.
@defvr {Scheme Variable} char-set:title-case
@defvrx {C Variable} scm_char_set_title_case
-This is empty, because ASCII has no titlecase characters.
+All single characters that function as if they were an upper-case
+letter followed by a lower-case letter.
@end defvr
@defvr {Scheme Variable} char-set:letter
@defvrx {C Variable} scm_char_set_letter
-All letters, e.g. the union of @code{char-set:lower-case} and
-@code{char-set:upper-case}.
+All letters. This includes @code{char-set:lower-case},
+@code{char-set:upper-case}, @code{char-set:title-case}, and many
+letters that have no case at all. For example, Chinese and Japanese
+characters typically have no concept of case.
@end defvr
@defvr {Scheme Variable} char-set:digit
@@ -2426,23 +2525,26 @@ All whitespace characters.
@defvr {Scheme Variable} char-set:blank
@defvrx {C Variable} scm_char_set_blank
-All horizontal whitespace characters, that is @code{#\space} and
-@code{#\tab}.
+All horizontal whitespace characters, which notably includes
+@code{#\space} and @code{#\tab}.
@end defvr
@defvr {Scheme Variable} char-set:iso-control
@defvrx {C Variable} scm_char_set_iso_control
-The ISO control characters with the codes 0--31 and 127.
+The ISO control characters are the C0 control characters (U+0000 to
+U+001F), delete (U+007F), and the C1 control characters (U+0080 to
+U+009F).
@end defvr
@defvr {Scheme Variable} char-set:punctuation
@defvrx {C Variable} scm_char_set_punctuation
-The characters @code{!"#%&'()*,-./:;?@@[\\]_@{@}}
+All punctuation characters, such as the characters
+@code{!"#%&'()*,-./:;?@@[\\]_@{@}}
@end defvr
@defvr {Scheme Variable} char-set:symbol
@defvrx {C Variable} scm_char_set_symbol
-The characters @code{$+<=>^`|~}.
+All symbol characters, such as the characters @code{$+<=>^`|~}.
@end defvr
@defvr {Scheme Variable} char-set:hex-digit
@@ -2460,9 +2562,17 @@ All ASCII characters.
The empty character set.
@end defvr
+@defvr {Scheme Variable} char-set:designated
+@defvrx {C Variable} scm_char_set_designated
+This character set contains all designated code points. This includes
+all the code points to which Unicode has assigned a character or other
+meaning.
+@end defvr
+
@defvr {Scheme Variable} char-set:full
@defvrx {C Variable} scm_char_set_full
-This character set contains all possible characters.
+This character set contains all possible code points. This includes
+both designated and reserved code points.
@end defvr
@node Strings
@@ -2490,7 +2600,7 @@ memory.
When one of these two strings is modified, as with @code{string-set!},
their common memory does get copied so that each string has its own
-memory and modifying one does not accidently modify the other as well.
+memory and modifying one does not accidentally modify the other as well.
Thus, Guile's strings are `copy on write'; the actual copying of their
memory is delayed until one string is written to.
@@ -2580,6 +2690,14 @@ Vertical tab character (ASCII 11).
@item @nicode{\xHH}
Character code given by two hexadecimal digits. For example
@nicode{\x7f} for an ASCII DEL (127).
+
+@item @nicode{\uHHHH}
+Character code given by four hexadecimal digits. For example
+@nicode{\u0100} for a capital A with macron (U+0100).
+
+@item @nicode{\UHHHHHH}
+Character code given by six hexadecimal digits. For example
+@nicode{\U010402}.
@end table
@noindent
@@ -2910,7 +3028,7 @@ characters.
@deffnx {C Function} scm_string_trim (s, char_pred, start, end)
@deffnx {C Function} scm_string_trim_right (s, char_pred, start, end)
@deffnx {C Function} scm_string_trim_both (s, char_pred, start, end)
-Trim occurrances of @var{char_pred} from the ends of @var{s}.
+Trim occurrences of @var{char_pred} from the ends of @var{s}.
@code{string-trim} trims @var{char_pred} characters from the left
(start) of the string, @code{string-trim-right} trims them from the
@@ -3000,9 +3118,14 @@ The procedures in this section are similar to the character ordering
predicates (@pxref{Characters}), but are defined on character sequences.
The first set is specified in R5RS and has names that end in @code{?}.
-The second set is specified in SRFI-13 and the names have no ending
-@code{?}. The predicates ending in @code{-ci} ignore the character case
-when comparing strings. @xref{Text Collation, the @code{(ice-9
+The second set is specified in SRFI-13 and the names have not ending
+@code{?}.
+
+The predicates ending in @code{-ci} ignore the character case
+when comparing strings. For now, case-insensitive comparison is done
+using the R5RS rules, where every lower-case character that has a
+single character upper-case form is converted to uppercase before
+comparison. See @xref{Text Collation, the @code{(ice-9
i18n)} module}, for locale-dependent string comparison.
@rnindex string=?
@@ -3192,14 +3315,14 @@ Compute a hash value for @var{S}. the optional argument @var{bound} is a non-ne
@deffn {Scheme Procedure} string-index s char_pred [start [end]]
@deffnx {C Function} scm_string_index (s, char_pred, start, end)
Search through the string @var{s} from left to right, returning
-the index of the first occurence of a character which
+the index of the first occurrence of a character which
@itemize @bullet
@item
equals @var{char_pred}, if it is character,
@item
-satisifies the predicate @var{char_pred}, if it is a procedure,
+satisfies the predicate @var{char_pred}, if it is a procedure,
@item
is in the set @var{char_pred}, if it is a character set.
@@ -3209,14 +3332,14 @@ is in the set @var{char_pred}, if it is a character set.
@deffn {Scheme Procedure} string-rindex s char_pred [start [end]]
@deffnx {C Function} scm_string_rindex (s, char_pred, start, end)
Search through the string @var{s} from right to left, returning
-the index of the last occurence of a character which
+the index of the last occurrence of a character which
@itemize @bullet
@item
equals @var{char_pred}, if it is character,
@item
-satisifies the predicate @var{char_pred}, if it is a procedure,
+satisfies the predicate @var{char_pred}, if it is a procedure,
@item
is in the set if @var{char_pred} is a character set.
@@ -3270,14 +3393,14 @@ Is @var{s1} a suffix of @var{s2}, ignoring character case?
@deffn {Scheme Procedure} string-index-right s char_pred [start [end]]
@deffnx {C Function} scm_string_index_right (s, char_pred, start, end)
Search through the string @var{s} from right to left, returning
-the index of the last occurence of a character which
+the index of the last occurrence of a character which
@itemize @bullet
@item
equals @var{char_pred}, if it is character,
@item
-satisifies the predicate @var{char_pred}, if it is a procedure,
+satisfies the predicate @var{char_pred}, if it is a procedure,
@item
is in the set if @var{char_pred} is a character set.
@@ -3287,14 +3410,14 @@ is in the set if @var{char_pred} is a character set.
@deffn {Scheme Procedure} string-skip s char_pred [start [end]]
@deffnx {C Function} scm_string_skip (s, char_pred, start, end)
Search through the string @var{s} from left to right, returning
-the index of the first occurence of a character which
+the index of the first occurrence of a character which
@itemize @bullet
@item
does not equal @var{char_pred}, if it is character,
@item
-does not satisify the predicate @var{char_pred}, if it is a
+does not satisfy the predicate @var{char_pred}, if it is a
procedure,
@item
@@ -3305,7 +3428,7 @@ is not in the set if @var{char_pred} is a character set.
@deffn {Scheme Procedure} string-skip-right s char_pred [start [end]]
@deffnx {C Function} scm_string_skip_right (s, char_pred, start, end)
Search through the string @var{s} from right to left, returning
-the index of the last occurence of a character which
+the index of the last occurrence of a character which
@itemize @bullet
@item
@@ -3330,7 +3453,7 @@ Return the count of the number of characters in the string
equals @var{char_pred}, if it is character,
@item
-satisifies the predicate @var{char_pred}, if it is a procedure.
+satisfies the predicate @var{char_pred}, if it is a procedure.
@item
is in the set @var{char_pred}, if it is a character set.
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index d8412154c..e50a51546 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -17,6 +17,7 @@ loading, evaluating, and compiling Scheme code at run time.
* Fly Evaluation:: Procedures for on the fly evaluation.
* Compilation:: How to compile Scheme files and procedures.
* Loading:: Loading Scheme code from file.
+* Character Encoding of Source Files:: Loading non-ASCII Scheme code from file.
* Delayed Evaluation:: Postponing evaluation until it is needed.
* Local Evaluation:: Evaluation in a local environment.
* Evaluator Behaviour:: Modifying Guile's evaluator.
@@ -229,6 +230,27 @@ Thus a Guile script often starts like this.
More details on Guile scripting can be found in the scripting section
(@pxref{Guile Scripting}).
+@cindex R6RS block comments
+@cindex SRFI-30 block comments
+Similarly, Guile (starting from version 2.0) supports nested block
+comments as specified by R6RS and
+@url{http://srfi.schemers.org/srfi-30/srfi-30.html, SRFI-30}:
+
+@lisp
+(+ #| this is a #| nested |# block comment |# 2)
+@result{} 3
+@end lisp
+
+For backward compatibility, this syntax can be overridden with
+@code{read-hash-extend} (@pxref{Reader Extensions,
+@code{read-hash-extend}}).
+
+There is one special case where the contents of a comment can actually
+affect the interpretation of code. When a character encoding
+declaration, such as @code{coding: utf-8} appears in one of the first
+few lines of a source file, it indicates to Guile's default reader
+that this source code file is not ASCII. For details see @ref{Character
+Encoding of Source Files}.
@node Case Sensitivity
@subsubsection Case Sensitivity
@@ -531,13 +553,20 @@ documentation for @code{%load-hook} later in this section.
@code{SCM}.
@end deftypefn
-@deffn {Scheme Procedure} primitive-load-path filename
+@deffn {Scheme Procedure} primitive-load-path filename [exception-on-not-found]
@deffnx {C Function} scm_primitive_load_path (filename)
Search @code{%load-path} for the file named @var{filename} and
load it into the top-level environment. If @var{filename} is a
relative pathname and is not found in the list of search paths,
an error is signalled. Preferentially loads a compiled version of the
file, if it is available and up-to-date.
+
+By default or if @var{exception-on-not-found} is true, an exception is
+raised if @var{filename} is not found. If @var{exception-on-not-found}
+is @code{#f} and @var{filename} is not found, no exception is raised and
+@code{#f} is returned. For compatibility with Guile 1.8 and earlier,
+the C function takes only one argument, which can be either a string
+(the file name) or an argument list.
@end deffn
@deffn {Scheme Procedure} %search-load-path filename
@@ -558,6 +587,21 @@ that they are loading). @code{current-reader} is a fluid, so it has an
independent value in each dynamic root and should be read and set using
@code{fluid-ref} and @code{fluid-set!} (@pxref{Fluids and Dynamic
States}).
+
+Changing @code{current-reader} is typically useful to introduce local
+syntactic changes, such that code following the @code{fluid-set!} call
+is read using the newly installed reader. The @code{current-reader}
+change should take place at evaluation time when the code is evaluated,
+or at compilation time when the code is compiled:
+
+@findex eval-when
+@example
+(eval-when (compile eval)
+ (fluid-set! current-reader my-own-reader))
+@end example
+
+The @code{eval-when} form above ensures that the @code{current-reader}
+change occurs at the right time.
@end defvar
@defvar %load-hook
@@ -590,6 +634,69 @@ a file to load. By default, @code{%load-extensions} is bound to the
list @code{("" ".scm")}.
@end defvar
+@node Character Encoding of Source Files
+@subsection Character Encoding of Source Files
+
+@cindex primitive-load
+@cindex load
+Scheme source code files are usually encoded in ASCII, but, the
+built-in reader can interpret other character encodings. The
+procedure @code{primitive-load}, and by extension the functions that
+call it, such as @code{load}, first scan the top 500 characters of the
+file for a coding declaration.
+
+A coding declaration has the form @code{coding: XXXXXX}, where
+@code{XXXXXX} is the name of a character encoding in which the source
+code file has been encoded. The coding declaration must appear in a
+scheme comment. It can either be a semicolon-initiated comment or a block
+@code{#!} comment.
+
+The name of the character encoding in the coding declaration is
+typically lower case and containing only letters, numbers, and
+hyphens. The most common examples of character encodings are
+@code{utf-8} and @code{iso-8859-1}. This allows the coding
+declaration to be compatible with EMACS.
+
+For source code, only a subset of all possible character encodings can
+be interpreted by the built-in source code reader. Only those
+character encodings in which ASCII text appears unmodified can be
+used. This includes @code{UTF-8} and @code{ISO-8859-1} through
+@code{ISO-8859-15}. The multi-byte character encodings @code{UTF-16}
+and @code{UTF-32} may not be used because they are not compatible with
+ASCII.
+
+@cindex read
+@cindex set-port-encoding!
+There might be a scenario in which one would want to read non-ASCII
+code from a port, such as with the function @code{read}, instead of
+with @code{load}. If the port's character encoding is the same as the
+encoding of the code to be read by the port, not other special
+handling is necessary. The port will automatically do the character
+encoding conversion. The functions @code{setlocale} or by
+@code{set-port-encoding!} are used to set port encodings.
+
+If a port is used to read code of unknown character encoding, it can
+accomplish this in three steps. First, the character encoding of the
+port should be set to ISO-8859-1 using @code{set-port-encoding!}.
+Then, the procedure @code{file-encoding}, described below, is used to
+scan for a coding declaration when reading from the port. As a side
+effect, it rewinds the port after its scan is complete. After that,
+the port's character encoding should be set to the encoding returned
+by @code{file-encoding}, if any, again by using
+@code{set-port-encoding!}. Then the code can be read as normal.
+
+@deffn {Scheme Procedure} file-encoding port
+@deffnx {C Function} scm_file_encoding port
+Scans the port for an EMACS-like character coding declaration near the
+top of the contents of a port with random-accessible contents. The
+coding declaration is of the form @code{coding: XXXXX} and must appear
+in a scheme comment.
+
+Returns a string containing the character encoding of the file
+if a declaration was found, or @code{#f} otherwise. The port is
+rewound.
+@end deffn
+
@node Delayed Evaluation
@subsection Delayed Evaluation
diff --git a/doc/ref/api-i18n.texi b/doc/ref/api-i18n.texi
index be5afe4f9..8bc9896e5 100644
--- a/doc/ref/api-i18n.texi
+++ b/doc/ref/api-i18n.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -39,12 +39,6 @@ In order to make use of the functions described thereafter, the
(use-modules (ice-9 i18n))
@end example
-@cindex libguile-i18n-v-@value{LIBGUILE_I18N_MAJOR}
-
-C programs can use the C functions corresponding to the procedures of
-this module by including @code{<libguile/i18n.h>} and by linking
-against @code{libguile-i18n-v-@value{LIBGUILE_I18N_MAJOR}}.
-
@cindex cultural conventions
The @code{(ice-9 i18n)} module provides procedures to manipulate text
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 96cd147f3..83a2fd79c 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -47,7 +47,7 @@ are two interesting and powerful examples of this technique.
Ports are garbage collected in the usual way (@pxref{Memory
Management}), and will be closed at that time if not already closed.
-In this case any errors occuring in the close will not be reported.
+In this case any errors occurring in the close will not be reported.
Usually a program will want to explicitly close so as to be sure all
its operations have been successful. Of course if a program has
abandoned something due to an error or other condition then closing
@@ -70,6 +70,18 @@ All file access uses the ``LFS'' large file support functions when
available, so files bigger than 2 Gbytes (@math{2^31} bytes) can be
read and written on a 32-bit system.
+Each port has an associated character encoding that controls how bytes
+read from the port are converted to characters and string and controls
+how characters and strings written to the port are converted to bytes.
+When ports are created, they inherit their character encoding from the
+current locale, but, that can be modified after the port is created.
+
+Each port also has an associated conversion strategy: what to do when
+a Guile character can't be converted to the port's encoded character
+representation for output. There are three possible strategies: to
+raise an error, to replace the character with a hex escape, or to
+replace the character with a substitute character.
+
@rnindex input-port?
@deffn {Scheme Procedure} input-port? x
@deffnx {C Function} scm_input_port_p (x)
@@ -93,6 +105,55 @@ Equivalent to @code{(or (input-port? @var{x}) (output-port?
@var{x}))}.
@end deffn
+@deffn {Scheme Procedure} set-port-encoding! port enc
+@deffnx {C Function} scm_set_port_encoding_x (port, enc)
+Sets the character encoding that will be used to interpret all port
+I/O. @var{enc} is a string containing the name of an encoding.
+@end deffn
+
+New ports are created with the encoding appropriate for the current
+locale if @code{setlocale} has been called or ISO-8859-1 otherwise,
+and this procedure can be used to modify that encoding.
+
+@deffn {Scheme Procedure} port-encoding port
+@deffnx {C Function} scm_port_encoding
+Returns, as a string, the character encoding that @var{port} uses to
+interpret its input and output.
+@end deffn
+
+@deffn {Scheme Procedure} set-port-conversion-strategy! port sym
+@deffnx {C Function} scm_set_port_conversion_strategy_x (port, sym)
+Sets the behavior of the interpreter when outputting a character that
+is not representable in the port's current encoding. @var{sym} can be
+either @code{'error}, @code{'substitute}, or @code{'escape}. If it is
+@code{'error}, an error will be thrown when an nonconvertible character
+is encountered. If it is @code{'substitute}, then nonconvertible
+characters will be replaced with approximate characters, or with
+question marks if no approximately correct character is available. If
+it is @code{'escape}, it will appear as a hex escape when output.
+
+If @var{port} is an open port, the conversion error behavior
+is set for that port. If it is @code{#f}, it is set as the
+default behavior for any future ports that get created in
+this thread.
+@end deffn
+
+@deffn {Scheme Procedure} port-conversion-strategy port
+@deffnx {C Function} scm_port_conversion_strategy (port)
+Returns the behavior of the port when outputting a character that is
+not representable in the port's current encoding. It returns the
+symbol @code{error} if unrepresentable characters should cause
+exceptions, @code{substitute} if the port should try to replace
+unrepresentable characters with question marks or approximate
+characters, or @code{escape} if unrepresentable characters should be
+converted to string escapes.
+
+If @var{port} is @code{#f}, then the current default behavior will be
+returned. New ports will have this default behavior when they are
+created.
+@end deffn
+
+
@node Reading
@subsection Reading
@@ -238,7 +299,7 @@ output port if not given.
The output is designed to be machine readable, and can be read back
with @code{read} (@pxref{Reading}). Strings are printed in
-doublequotes, with escapes if necessary, and characters are printed in
+double quotes, with escapes if necessary, and characters are printed in
@samp{#\} notation.
@end deffn
@@ -248,7 +309,7 @@ Send a representation of @var{obj} to @var{port} or to the current
output port if not given.
The output is designed for human readability, it differs from
-@code{write} in that strings are printed without doublequotes and
+@code{write} in that strings are printed without double quotes and
escapes, and characters are printed as per @code{write-char}, not in
@samp{#\} form.
@end deffn
@@ -496,7 +557,7 @@ used. This function is equivalent to:
@end lisp
@end deffn
-Some of the abovementioned I/O functions rely on the following C
+Some of the aforementioned I/O functions rely on the following C
primitives. These will mainly be of interest to people hacking Guile
internals.
@@ -815,11 +876,11 @@ Open @var{filename} for output. Equivalent to
Open @var{filename} for input or output, and call @code{(@var{proc}
port)} with the resulting port. Return the value returned by
@var{proc}. @var{filename} is opened as per @code{open-input-file} or
-@code{open-output-file} respectively, and an error is signalled if it
+@code{open-output-file} respectively, and an error is signaled if it
cannot be opened.
When @var{proc} returns, the port is closed. If @var{proc} does not
-return (eg.@: if it throws an error), then the port might not be
+return (e.g.@: if it throws an error), then the port might not be
closed automatically, though it will be garbage collected in the usual
way if not otherwise referenced.
@end deffn
@@ -834,7 +895,7 @@ setup as respectively the @code{current-input-port},
@code{current-output-port}, or @code{current-error-port}. Return the
value returned by @var{thunk}. @var{filename} is opened as per
@code{open-input-file} or @code{open-output-file} respectively, and an
-error is signalled if it cannot be opened.
+error is signaled if it cannot be opened.
When @var{thunk} returns, the port is closed and the previous setting
of the respective current port is restored.
@@ -891,6 +952,13 @@ Determine whether @var{obj} is a port that is related to a file.
The following allow string ports to be opened by analogy to R4R*
file port facilities:
+With string ports, the port-encoding is treated differently than other
+types of ports. When string ports are created, they do not inherit a
+character encoding from the current locale. They are given a
+default locale that allows them to handle all valid string characters.
+Typically one should not modify a string port's character encoding
+away from its default.
+
@deffn {Scheme Procedure} call-with-output-string proc
@deffnx {C Function} scm_call_with_output_string (proc)
Calls the one-argument procedure @var{proc} with a newly created output
@@ -1409,7 +1477,7 @@ is set.
@node Port Implementation
@subsubsection Port Implementation
-@cindex Port implemenation
+@cindex Port implementation
This section describes how to implement a new port type in C.
diff --git a/doc/ref/api-memory.texi b/doc/ref/api-memory.texi
index f492203f7..15cef6438 100644
--- a/doc/ref/api-memory.texi
+++ b/doc/ref/api-memory.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -41,6 +41,11 @@ otherwise might be. When you are done with the object, call
the object remains protected until it has been unprotected as many times
as it was protected. It is an error to unprotect an object more times
than it has been protected. Returns the SCM object it was passed.
+
+Note that storing @var{obj} in a C global variable has the same
+effect@footnote{In Guile up to version 1.8, C global variables were not
+scanned by the garbage collector; hence, @code{scm_gc_protect_object}
+was the only way in C to prevent a Scheme object from being freed.}.
@end deftypefn
@deftypefn {C Function} SCM scm_gc_unprotect_object (SCM @var{obj})
@@ -98,38 +103,52 @@ typically from a smob @emph{mark} function.
@node Memory Blocks
@subsection Memory Blocks
+@cindex automatically-managed memory
+@cindex GC-managed memory
+@cindex conservative garbage collection
+
In C programs, dynamic management of memory blocks is normally done
with the functions malloc, realloc, and free. Guile has additional
functions for dynamic memory allocation that are integrated into the
garbage collector and the error reporting system.
Memory blocks that are associated with Scheme objects (for example a
-smob) should be allocated and freed with @code{scm_gc_malloc} and
-@code{scm_gc_free}. The function @code{scm_gc_malloc} will either
-return a valid pointer or signal an error. It will also assume that
-the new memory can be freed by a garbage collection. The garbage
-collector uses this information to decide when to try to actually
-collect some garbage. Memory blocks allocated with
-@code{scm_gc_malloc} must be freed with @code{scm_gc_free}.
+smob) should be allocated with @code{scm_gc_malloc} or
+@code{scm_gc_malloc_pointerless}. These two functions will either
+return a valid pointer or signal an error. Memory blocks allocated this
+way can be freed with @code{scm_gc_free}; however, this is not strictly
+needed: memory allocated with @code{scm_gc_malloc} or
+@code{scm_gc_malloc_pointerless} is automatically reclaimed when the
+garbage collector no longer sees any live reference to it@footnote{In
+Guile up to version 1.8, memory allocated with @code{scm_gc_malloc}
+@emph{had} to be freed with @code{scm_gc_free}.}.
+
+Memory allocated with @code{scm_gc_malloc} is scanned for live pointers.
+This means that if @code{scm_gc_malloc}-allocated memory contains a
+pointer to some other part of the memory, the garbage collector notices
+it and prevents it from being reclaimed@footnote{In Guile up to 1.8,
+memory allocated with @code{scm_gc_malloc} was @emph{not} scanned.
+Consequently, the GC had to be told explicitly about pointers to live
+objects contained in the memory block, e.g., @i{via} SMOB mark functions
+(@pxref{Smobs, @code{scm_set_smob_mark}})}. Conversely, memory
+allocated with @code{scm_gc_malloc_pointerless} is assumed to be
+``pointer-less'' and is not scanned.
For memory that is not associated with a Scheme object, you can use
@code{scm_malloc} instead of @code{malloc}. Like
@code{scm_gc_malloc}, it will either return a valid pointer or signal
an error. However, it will not assume that the new memory block can
-be freed by a garbage collection. The memory can be freed with
-@code{free}.
+be freed by a garbage collection. The memory must be explicitly freed
+with @code{free}.
There is also @code{scm_gc_realloc} and @code{scm_realloc}, to be used
in place of @code{realloc} when appropriate, and @code{scm_gc_calloc}
and @code{scm_calloc}, to be used in place of @code{calloc} when
appropriate.
-The function @code{scm_dynwind_free} can be useful when memory should
-be freed when a dynwind context, @xref{Dynamic Wind}.
-
-For really specialized needs, take at look at
-@code{scm_gc_register_collectable_memory} and
-@code{scm_gc_unregister_collectable_memory}.
+The function @code{scm_dynwind_free} can be useful when memory should be
+freed with libc's @code{free} when leaving a dynwind context,
+@xref{Dynamic Wind}.
@deftypefn {C Function} {void *} scm_malloc (size_t @var{size})
@deftypefnx {C Function} {void *} scm_calloc (size_t @var{size})
@@ -161,6 +180,36 @@ runs the GC to free up some memory when it deems it appropriate.
+@deftypefn {C Function} {void *} scm_gc_malloc (size_t @var{size}, const char *@var{what})
+@deftypefnx {C Function} {void *} scm_gc_malloc_pointerless (size_t @var{size}, const char *@var{what})
+@deftypefnx {C Function} {void *} scm_gc_realloc (void *@var{mem}, size_t @var{old_size}, size_t @var{new_size}, const char *@var{what});
+@deftypefnx {C Function} {void *} scm_gc_calloc (size_t @var{size}, const char *@var{what})
+Allocate @var{size} bytes of automatically-managed memory. The memory
+is automatically freed when no longer referenced from any live memory
+block.
+
+Memory allocated with @code{scm_gc_malloc} or @code{scm_gc_calloc} is
+scanned for pointers. Memory allocated by
+@code{scm_gc_malloc_pointerless} is not scanned.
+
+The @code{scm_gc_realloc} call preserves the ``pointerlessness'' of the
+memory area pointed to by @var{mem}. Note that you need to pass the old
+size of a reallocated memory block as well. See below for a motivation.
+@end deftypefn
+
+
+@deftypefn {C Function} void scm_gc_free (void *@var{mem}, size_t @var{size}, const char *@var{what})
+Explicitly free the memory block pointed to by @var{mem}, which was
+previously allocated by one of the above @code{scm_gc} functions.
+
+Note that you need to explicitly pass the @var{size} parameter. This
+is done since it should normally be easy to provide this parameter
+(for memory that is associated with GC controlled objects) and help keep
+the memory management overhead very low. However, in Guile 2.x,
+@var{size} is always ignored.
+@end deftypefn
+
+
@deftypefn {C Function} void scm_gc_register_collectable_memory (void *@var{mem}, size_t @var{size}, const char *@var{what})
Informs the GC that the memory at @var{mem} of size @var{size} can
potentially be freed during a GC. That is, announce that @var{mem} is
@@ -170,13 +219,12 @@ object, @var{size} bytes will be freed along with it. The GC will
much bytes of memory are associated with GC controlled objects and the
memory system figures this into its decisions when to run a GC.
-@var{mem} does not need to come from @code{scm_malloc}. You can only
-call this function once for every memory block.
-
The @var{what} argument is used for statistical purposes. It should
describe the type of object that the memory will be used for so that
users can identify just what strange objects are eating up their
memory.
+
+In Guile 2.x, this function has no effect.
@end deftypefn
@deftypefn {C Function} void scm_gc_unregister_collectable_memory (void *@var{mem}, size_t @var{size})
@@ -186,28 +234,11 @@ match up every call to @code{scm_gc_register_collectable_memory} with
a call to @code{scm_gc_unregister_collectable_memory}. If you don't do
this, the GC might have a wrong impression of what is going on and run
much less efficiently than it could.
-@end deftypefn
-@deftypefn {C Function} {void *} scm_gc_malloc (size_t @var{size}, const char *@var{what})
-@deftypefnx {C Function} {void *} scm_gc_realloc (void *@var{mem}, size_t @var{old_size}, size_t @var{new_size}, const char *@var{what});
-@deftypefnx {C Function} {void *} scm_gc_calloc (size_t @var{size}, const char *@var{what})
-Like @code{scm_malloc}, @code{scm_realloc} or @code{scm_calloc}, but
-also call @code{scm_gc_register_collectable_memory}. Note that you
-need to pass the old size of a reallocated memory block as well. See
-below for a motivation.
+In Guile 2.x, this function has no effect.
@end deftypefn
-@deftypefn {C Function} void scm_gc_free (void *@var{mem}, size_t @var{size}, const char *@var{what})
-Like @code{free}, but also call @code{scm_gc_unregister_collectable_memory}.
-
-Note that you need to explicitly pass the @var{size} parameter. This
-is done since it should normally be easy to provide this parameter
-(for memory that is associated with GC controlled objects) and this
-frees us from tracking this value in the GC itself, which will keep
-the memory management overhead very low.
-@end deftypefn
-
@deftypefn {C Function} void scm_frame_free (void *mem)
Equivalent to @code{scm_frame_unwind_handler (free, @var{mem},
SCM_F_WIND_EXPLICITLY)}. That is, the memory block at @var{mem} will
@@ -220,6 +251,9 @@ of malloced objects.
@var{what} is the second argument to @code{scm_gc_malloc},
@var{n} is the number of objects of that type currently
allocated.
+
+This function is only available if the @code{GUILE_DEBUG_MALLOC}
+preprocessor macro was defined when Guile was compiled.
@end deffn
diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi
index f7d0962df..f4caa8ac9 100644
--- a/doc/ref/api-options.texi
+++ b/doc/ref/api-options.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -178,6 +178,14 @@ libguile/libpath.h, which is completely generated, so deleting this file
before a build guarantees up-to-date values for that build.
@end defvar
+@cindex GNU triplet
+@cindex canonical host type
+
+@defvar %host-type
+The canonical host type (GNU triplet) of the host Guile was configured
+for, e.g., @code{"x86_64-unknown-linux-gnu"} (@pxref{Canonicalizing,,,
+autoconf, The GNU Autoconf Manual}).
+@end defvar
@node Feature Tracking
@subsection Feature Tracking
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index 8098b4ffb..972ce2e72 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -13,6 +13,7 @@
* Primitive Procedures:: Procedures defined in C.
* Compiled Procedures:: Scheme procedures can be compiled.
* Optional Arguments:: Handling keyword, optional and rest arguments.
+* Case-lambda:: One function, multiple arities.
* Procedure Properties:: Procedure properties and meta-information.
* Procedures with Setters:: Procedures with setters.
* Macros:: Lisp style macro definitions.
@@ -26,8 +27,6 @@
@subsection Lambda: Basic Procedure Creation
@cindex lambda
-@c FIXME::martin: Review me!
-
A @code{lambda} expression evaluates to a procedure. The environment
which is in effect when a @code{lambda} expression is evaluated is
enclosed in the newly created procedure, this is referred to as a
@@ -135,15 +134,21 @@ slightly higher-level abstraction of the Guile implementation.
@node Compiled Procedures
@subsection Compiled Procedures
-Procedures that were created when loading a compiled file are
-themselves compiled. (In contrast, procedures that are defined by
-loading a Scheme source file are interpreted, and often not as fast as
-compiled procedures.)
+In Guile, procedures can be executed by directly interpreting their
+source code. Scheme source code is a set of nested lists, after all,
+with each list representing a procedure call.
+
+Most procedures are compiled, however. This means that Guile has done
+some pre-computation on the procedure, to determine what it will need
+to do each time the procedure runs. Compiled procedures run faster
+than interpreted procedures.
-Loading compiled files is the normal way that compiled procedures come
-to being, though procedures can be compiled at runtime as well.
-@xref{Read/Load/Eval/Compile}, for more information on runtime
-compilation.
+Loading files is the normal way that compiled procedures come to
+being. If Guile sees that a file is uncompiled, or that its compiled
+file is out of date, it will attempt to compile the file when it is
+loaded, and save the result to disk. Procedures can be compiled at
+runtime as well. @xref{Read/Load/Eval/Compile}, for more information
+on runtime compilation.
Compiled procedures, also known as @dfn{programs}, respond all
procedures that operate on procedures. In addition, there are a few
@@ -181,56 +186,34 @@ return @code{#f} if the compiler could determine that this information
was unnecessary.
@end deffn
-@deffn {Scheme Procedure} program-external program
-@deffnx {C Function} scm_program_external (program)
-Returns the set of heap-allocated variables that this program captures
-in its closure, as a list. If a closure is code with data, you can get
-the code from @code{program-bytecode}, and the data via
-@code{program-external}.
+@deffn {Scheme Procedure} program-free-variables program
+@deffnx {C Function} scm_program_free_variables (program)
+Returns the set of free variables that this program captures in its
+closure, as a vector. If a closure is code with data, you can get the
+code from @code{program-objcode}, and the data via
+@code{program-free-variables}.
+
+Some of the values captured are actually in variable ``boxes''.
+@xref{Variables and the VM}, for more information.
Users must not modify the returned value unless they think they're
really clever.
@end deffn
-@deffn {Scheme Procedure} program-external-set! program external
-@deffnx {C Function} scm_program_external_set_x (program, external)
-Set @var{external} as the set of closure variables on @var{program}.
-
-The Guile maintainers will not be held responsible for side effects of
-calling this function, including but not limited to replacement of
-shampoo with hair dye, and a slight salty taste in tomorrow's dinner.
-@end deffn
-
-@deffn {Scheme Procedure} program-arity program
-@deffnx {C Function} scm_program_arity (program)
-@deffnx {Scheme Procedure} arity:nargs arity
-@deffnx {Scheme Procedure} arity:nrest arity
-@deffnx {Scheme Procedure} arity:nlocs arity
-@deffnx {Scheme Procedure} arity:nexts arity
-Accessors for a representation of the ``arity'' of a program.
-
-@code{nargs} is the number of arguments to the procedure, and
-@code{nrest} will be non-zero if the last argument is a rest argument.
-
-The other two accessors determine the number of local and external
-(heap-allocated) variables that this procedure will need to have
-allocated.
-@end deffn
-
@deffn {Scheme Procedure} program-meta program
-@deffnx scm_program_meta (program)
+@deffnx {C Function} scm_program_meta (program)
Return the metadata thunk of @var{program}, or @code{#f} if it has no
metadata.
When called, a metadata thunk returns a list of the following form:
-@code{(@var{bindings} @var{sources} . @var{properties})}. The format
+@code{(@var{bindings} @var{sources} @var{arities} . @var{properties})}. The format
of each of these elements is discussed below.
@end deffn
@deffn {Scheme Procedure} program-bindings program
-@deffnx {Scheme Procedure} make-binding name extp index start end
+@deffnx {Scheme Procedure} make-binding name boxed? index start end
@deffnx {Scheme Procedure} binding:name binding
-@deffnx {Scheme Procedure} binding:extp binding
+@deffnx {Scheme Procedure} binding:boxed? binding
@deffnx {Scheme Procedure} binding:index binding
@deffnx {Scheme Procedure} binding:start binding
@deffnx {Scheme Procedure} binding:end binding
@@ -238,9 +221,7 @@ Bindings annotations for programs, along with their accessors.
Bindings declare names and liveness extents for block-local variables.
The best way to see what these are is to play around with them at a
-REPL. The only tricky bit is that @var{extp} is a boolean, declaring
-whether the binding is heap-allocated or not. @xref{VM Concepts}, for
-more information.
+REPL. @xref{VM Concepts}, for more information.
Note that bindings information is stored in a program as part of its
metadata thunk, so including it in the generated object code does not
@@ -262,6 +243,40 @@ following} an instruction, so that backtraces can find the source
location of a call that is in progress.
@end deffn
+@deffn {Scheme Procedure} program-arities program
+@deffnx {C Function} scm_program_arities (program)
+@deffnx {Scheme Procedure} program-arity program ip
+@deffnx {Scheme Procedure} arity:start arity
+@deffnx {Scheme Procedure} arity:end arity
+@deffnx {Scheme Procedure} arity:nreq arity
+@deffnx {Scheme Procedure} arity:nopt arity
+@deffnx {Scheme Procedure} arity:rest? arity
+@deffnx {Scheme Procedure} arity:kw arity
+@deffnx {Scheme Procedure} arity:allow-other-keys? arity
+Accessors for a representation of the ``arity'' of a program.
+
+The normal case is that a procedure has one arity. For example,
+@code{(lambda (x) x)}, takes one required argument, and that's it. One
+could access that number of required arguments via @code{(arity:nreq
+(program-arities (lambda (x) x)))}. Similarly, @code{arity:nopt} gets
+the number of optional arguments, and @code{arity:rest?} returns a true
+value if the procedure has a rest arg.
+
+@code{arity:kw} returns a list of @code{(@var{kw} . @var{idx})} pairs,
+if the procedure has keyword arguments. The @var{idx} refers to the
+@var{idx}th local variable; @xref{Variables and the VM}, for more
+information. Finally @code{arity:allow-other-keys?} returns a true
+value if other keys are allowed. @xref{Optional Arguments}, for more
+information.
+
+So what about @code{arity:start} and @code{arity:end}, then? They
+return the range of bytes in the program's bytecode for which a given
+arity is valid. You see, a procedure can actually have more than one
+arity. The question, ``what is a procedure's arity'' only really makes
+sense at certain points in the program, delimited by these
+@code{arity:start} and @code{arity:end} values.
+@end deffn
+
@deffn {Scheme Procedure} program-properties program
Return the properties of a @code{program} as an association list,
keyed by property name (a symbol).
@@ -285,146 +300,33 @@ Accessors for specific properties.
@node Optional Arguments
@subsection Optional Arguments
-@c FIXME::martin: Review me!
-
Scheme procedures, as defined in R5RS, can either handle a fixed number
of actual arguments, or a fixed number of actual arguments followed by
arbitrarily many additional arguments. Writing procedures of variable
arity can be useful, but unfortunately, the syntactic means for handling
argument lists of varying length is a bit inconvenient. It is possible
-to give names to the fixed number of argument, but the remaining
+to give names to the fixed number of arguments, but the remaining
(optional) arguments can be only referenced as a list of values
(@pxref{Lambda}).
-Guile comes with the module @code{(ice-9 optargs)}, which makes using
-optional arguments much more convenient. In addition, this module
-provides syntax for handling keywords in argument lists
-(@pxref{Keywords}).
-
-Before using any of the procedures or macros defined in this section,
-you have to load the module @code{(ice-9 optargs)} with the statement:
-
-@cindex @code{optargs}
-@lisp
-(use-modules (ice-9 optargs))
-@end lisp
+For this reason, Guile provides an extension to @code{lambda},
+@code{lambda*}, which allows the user to define procedures with
+optional and keyword arguments. In addition, Guile's virtual machine
+has low-level support for optional and keyword argument dispatch.
+Calls to procedures with optional and keyword arguments can be made
+cheaply, without allocating a rest list.
@menu
-* let-optional Reference:: Locally binding optional arguments.
-* let-keywords Reference:: Locally binding keywords arguments.
-* lambda* Reference:: Creating advanced argument handling procedures.
-* define* Reference:: Defining procedures and macros.
+* lambda* and define*:: Creating advanced argument handling procedures.
+* ice-9 optargs:: (ice-9 optargs) provides some utilities.
@end menu
-@node let-optional Reference
-@subsubsection let-optional Reference
-
-@c FIXME::martin: Review me!
-
-The syntax @code{let-optional} and @code{let-optional*} are for
-destructuring rest argument lists and giving names to the various list
-elements. @code{let-optional} binds all variables simultaneously, while
-@code{let-optional*} binds them sequentially, consistent with @code{let}
-and @code{let*} (@pxref{Local Bindings}).
-
-@deffn {library syntax} let-optional rest-arg (binding @dots{}) expr @dots{}
-@deffnx {library syntax} let-optional* rest-arg (binding @dots{}) expr @dots{}
-These two macros give you an optional argument interface that is very
-@dfn{Schemey} and introduces no fancy syntax. They are compatible with
-the scsh macros of the same name, but are slightly extended. Each of
-@var{binding} may be of one of the forms @var{var} or @code{(@var{var}
-@var{default-value})}. @var{rest-arg} should be the rest-argument of the
-procedures these are used from. The items in @var{rest-arg} are
-sequentially bound to the variable names are given. When @var{rest-arg}
-runs out, the remaining vars are bound either to the default values or
-@code{#f} if no default value was specified. @var{rest-arg} remains
-bound to whatever may have been left of @var{rest-arg}.
-
-After binding the variables, the expressions @var{expr} @dots{} are
-evaluated in order.
-@end deffn
-
-
-@node let-keywords Reference
-@subsubsection let-keywords Reference
-
-@code{let-keywords} and @code{let-keywords*} extract values from
-keyword style argument lists, binding local variables to those values
-or to defaults.
-
-@deffn {library syntax} let-keywords args allow-other-keys? (binding @dots{}) body @dots{}
-@deffnx {library syntax} let-keywords* args allow-other-keys? (binding @dots{}) body @dots{}
-@var{args} is evaluated and should give a list of the form
-@code{(#:keyword1 value1 #:keyword2 value2 @dots{})}. The
-@var{binding}s are variables and default expressions, with the
-variables to be set (by name) from the keyword values. The @var{body}
-forms are then evaluated and the last is the result. An example will
-make the syntax clearest,
-
-@example
-(define args '(#:xyzzy "hello" #:foo "world"))
-
-(let-keywords args #t
- ((foo "default for foo")
- (bar (string-append "default" "for" "bar")))
- (display foo)
- (display ", ")
- (display bar))
-@print{} world, defaultforbar
-@end example
-
-The binding for @code{foo} comes from the @code{#:foo} keyword in
-@code{args}. But the binding for @code{bar} is the default in the
-@code{let-keywords}, since there's no @code{#:bar} in the args.
-
-@var{allow-other-keys?} is evaluated and controls whether unknown
-keywords are allowed in the @var{args} list. When true other keys are
-ignored (such as @code{#:xyzzy} in the example), when @code{#f} an
-error is thrown for anything unknown.
-
-@code{let-keywords} is like @code{let} (@pxref{Local Bindings}) in
-that all bindings are made at once, the defaults expressions are
-evaluated (if needed) outside the scope of the @code{let-keywords}.
-
-@code{let-keywords*} is like @code{let*}, each binding is made
-successively, and the default expressions see the bindings previously
-made. This is the style used by @code{lambda*} keywords
-(@pxref{lambda* Reference}). For example,
-
-@example
-(define args '(#:foo 3))
-
-(let-keywords* args #f
- ((foo 99)
- (bar (+ foo 6)))
- (display bar))
-@print{} 9
-@end example
-
-The expression for each default is only evaluated if it's needed,
-ie. if the keyword doesn't appear in @var{args}. So one way to make a
-keyword mandatory is to throw an error of some sort as the default.
-
-@example
-(define args '(#:start 7 #:finish 13))
-
-(let-keywords* args #t
- ((start 0)
- (stop (error "missing #:stop argument")))
- ...)
-@result{} ERROR: missing #:stop argument
-@end example
-@end deffn
-
-
-@node lambda* Reference
-@subsubsection lambda* Reference
+@node lambda* and define*
+@subsubsection lambda* and define*.
-When using optional and keyword argument lists, @code{lambda} for
-creating a procedure then @code{let-optional} or @code{let-keywords}
-is a bit lengthy. @code{lambda*} combines the features of those
-macros into a single convenient syntax.
+@code{lambda*} is like @code{lambda}, except with some extensions to
+allow optional and keyword arguments.
@deffn {library syntax} lambda* ([var@dots{}] @* [#:optional vardef@dots{}] @* [#:key vardef@dots{} [#:allow-other-keys]] @* [#:rest var | . var]) @* body
@sp 1
@@ -440,25 +342,31 @@ arguments @var{c} and @var{d}, and rest argument @var{e}. If the
optional arguments are omitted in a call, the variables for them are
bound to @code{#f}.
-@code{lambda*} can also take keyword arguments. For example, a procedure
-defined like this:
+@fnindex define*
+Likewise, @code{define*} is syntactic sugar for defining procedures
+using @code{lambda*}.
+
+@code{lambda*} can also make procedures with keyword arguments. For
+example, a procedure defined like this:
@lisp
-(lambda* (#:key xyzzy larch) '())
+(define* (sir-yes-sir #:key action how-high)
+ (list action how-high))
@end lisp
-can be called with any of the argument lists @code{(#:xyzzy 11)},
-@code{(#:larch 13)}, @code{(#:larch 42 #:xyzzy 19)}, @code{()}.
-Whichever arguments are given as keywords are bound to values (and
-those not given are @code{#f}).
+can be called as @code{(sir-yes-sir #:action 'jump)},
+@code{(sir-yes-sir #:how-high 13)}, @code{(sir-yes-sir #:action
+'lay-down #:how-high 0)}, or just @code{(sir-yes-sir)}. Whichever
+arguments are given as keywords are bound to values (and those not
+given are @code{#f}).
Optional and keyword arguments can also have default values to take
when not present in a call, by giving a two-element list of variable
name and expression. For example in
@lisp
-(lambda* (foo #:optional (bar 42) #:key (baz 73))
- (list foo bar baz))
+(define* (frob foo #:optional (bar 42) #:key (baz 73))
+ (list foo bar baz))
@end lisp
@var{foo} is a fixed argument, @var{bar} is an optional argument with
@@ -475,9 +383,10 @@ If a call has a keyword given twice, the last value is used. For
example,
@lisp
-((lambda* (#:key (heads 0) (tails 0))
- (display (list heads tails)))
- #:heads 37 #:tails 42 #:heads 99)
+(define* (flips #:key (heads 0) (tails 0))
+ (display (list heads tails)))
+
+(flips #:heads 37 #:tails 42 #:heads 99)
@print{} (99 42)
@end lisp
@@ -499,9 +408,8 @@ Common Lisp. For example,
@end lisp
@code{#:optional} and @code{#:key} establish their bindings
-successively, from left to right, as per @code{let-optional*} and
-@code{let-keywords*}. This means default expressions can refer back
-to prior parameters, for example
+successively, from left to right. This means default expressions can
+refer back to prior parameters, for example
@lisp
(lambda* (start #:optional (end (+ 10 start)))
@@ -509,48 +417,95 @@ to prior parameters, for example
((> i end))
(display i)))
@end lisp
+
+The exception to this left-to-right scoping rule is the rest argument.
+If there is a rest argument, it is bound after the optional arguments,
+but before the keyword arguments.
@end deffn
-@node define* Reference
-@subsubsection define* Reference
+@node ice-9 optargs
+@subsubsection (ice-9 optargs)
-@c FIXME::martin: Review me!
+Before Guile 2.0, @code{lambda*} and @code{define*} were implemented
+using macros that processed rest list arguments. This was not optimal,
+as calling procedures with optional arguments had to allocate rest
+lists at every procedure invocation. Guile 2.0 improved this
+situation by bringing optional and keyword arguments into Guile's
+core.
-Just like @code{define} has a shorthand notation for defining procedures
-(@pxref{Lambda Alternatives}), @code{define*} is provided as an
-abbreviation of the combination of @code{define} and @code{lambda*}.
+However there are occasions in which you have a list and want to parse
+it for optional or keyword arguments. Guile's @code{(ice-9 optargs)}
+provides some macros to help with that task.
-@code{define*-public} is the @code{lambda*} version of
-@code{define-public}; @code{defmacro*} and @code{defmacro*-public} exist
-for defining macros with the improved argument list handling
-possibilities. The @code{-public} versions not only define the
-procedures/macros, but also export them from the current module.
+The syntax @code{let-optional} and @code{let-optional*} are for
+destructuring rest argument lists and giving names to the various list
+elements. @code{let-optional} binds all variables simultaneously, while
+@code{let-optional*} binds them sequentially, consistent with @code{let}
+and @code{let*} (@pxref{Local Bindings}).
+
+@deffn {library syntax} let-optional rest-arg (binding @dots{}) expr @dots{}
+@deffnx {library syntax} let-optional* rest-arg (binding @dots{}) expr @dots{}
+These two macros give you an optional argument interface that is very
+@dfn{Schemey} and introduces no fancy syntax. They are compatible with
+the scsh macros of the same name, but are slightly extended. Each of
+@var{binding} may be of one of the forms @var{var} or @code{(@var{var}
+@var{default-value})}. @var{rest-arg} should be the rest-argument of the
+procedures these are used from. The items in @var{rest-arg} are
+sequentially bound to the variable names are given. When @var{rest-arg}
+runs out, the remaining vars are bound either to the default values or
+@code{#f} if no default value was specified. @var{rest-arg} remains
+bound to whatever may have been left of @var{rest-arg}.
-@deffn {library syntax} define* formals body
-@deffnx {library syntax} define*-public formals body
-@code{define*} and @code{define*-public} support optional arguments with
-a similar syntax to @code{lambda*}. They also support arbitrary-depth
-currying, just like Guile's define. Some examples:
+After binding the variables, the expressions @var{expr} @dots{} are
+evaluated in order.
+@end deffn
-@lisp
-(define* (x y #:optional a (z 3) #:key w . u)
- (display (list y z u)))
-@end lisp
-defines a procedure @code{x} with a fixed argument @var{y}, an optional
-argument @var{a}, another optional argument @var{z} with default value 3,
-a keyword argument @var{w}, and a rest argument @var{u}.
+Similarly, @code{let-keywords} and @code{let-keywords*} extract values
+from keyword style argument lists, binding local variables to those
+values or to defaults.
-@lisp
-(define-public* ((foo #:optional bar) #:optional baz) '())
-@end lisp
+@deffn {library syntax} let-keywords args allow-other-keys? (binding @dots{}) body @dots{}
+@deffnx {library syntax} let-keywords* args allow-other-keys? (binding @dots{}) body @dots{}
+@var{args} is evaluated and should give a list of the form
+@code{(#:keyword1 value1 #:keyword2 value2 @dots{})}. The
+@var{binding}s are variables and default expressions, with the
+variables to be set (by name) from the keyword values. The @var{body}
+forms are then evaluated and the last is the result. An example will
+make the syntax clearest,
-This illustrates currying. A procedure @code{foo} is defined, which,
-when called with an optional argument @var{bar}, returns a procedure
-that takes an optional argument @var{baz}.
+@example
+(define args '(#:xyzzy "hello" #:foo "world"))
-Of course, @code{define*[-public]} also supports @code{#:rest} and
-@code{#:allow-other-keys} in the same way as @code{lambda*}.
+(let-keywords args #t
+ ((foo "default for foo")
+ (bar (string-append "default" "for" "bar")))
+ (display foo)
+ (display ", ")
+ (display bar))
+@print{} world, defaultforbar
+@end example
+
+The binding for @code{foo} comes from the @code{#:foo} keyword in
+@code{args}. But the binding for @code{bar} is the default in the
+@code{let-keywords}, since there's no @code{#:bar} in the args.
+
+@var{allow-other-keys?} is evaluated and controls whether unknown
+keywords are allowed in the @var{args} list. When true other keys are
+ignored (such as @code{#:xyzzy} in the example), when @code{#f} an
+error is thrown for anything unknown.
+@end deffn
+
+@code{(ice-9 optargs)} also provides some more @code{define*} sugar,
+which is not so useful with modern Guile coding, but still supported:
+@code{define*-public} is the @code{lambda*} version of
+@code{define-public}; @code{defmacro*} and @code{defmacro*-public}
+exist for defining macros with the improved argument list handling
+possibilities. The @code{-public} versions not only define the
+procedures/macros, but also export them from the current module.
+
+@deffn {library syntax} define*-public formals body
+Like a mix of @code{define*} and @code{define-public}.
@end deffn
@deffn {library syntax} defmacro* name formals body
@@ -562,29 +517,124 @@ semantics. Here is an example of a macro with an optional argument:
@lisp
(defmacro* transmorgify (a #:optional b)
- (a 1))
+ (a 1))
@end lisp
@end deffn
+@node Case-lambda
+@subsection Case-lambda
+@cindex SRFI-16
+@cindex variable arity
+@cindex arity, variable
+
+R5RS's rest arguments are indeed useful and very general, but they
+often aren't the most appropriate or efficient means to get the job
+done. For example, @code{lambda*} is a much better solution to the
+optional argument problem than @code{lambda} with rest arguments.
+
+@fnindex case-lambda
+Likewise, @code{case-lambda} works well for when you want one
+procedure to do double duty (or triple, or ...), without the penalty
+of consing a rest list.
+
+For example:
+
+@lisp
+(define (make-accum n)
+ (case-lambda
+ (() n)
+ ((m) (set! n (+ n m)) n)))
+
+(define a (make-accum 20))
+(a) @result{} 20
+(a 10) @result{} 30
+(a) @result{} 30
+@end lisp
+
+The value returned by a @code{case-lambda} form is a procedure which
+matches the number of actual arguments against the formals in the
+various clauses, in order. The first matching clause is selected, the
+corresponding values from the actual parameter list are bound to the
+variable names in the clauses and the body of the clause is evaluated.
+If no clause matches, an error is signalled.
+
+The syntax of the @code{case-lambda} form is defined in the following
+EBNF grammar. @dfn{Formals} means a formal argument list just like
+with @code{lambda} (@pxref{Lambda}).
+
+@example
+@group
+<case-lambda>
+ --> (case-lambda <case-lambda-clause>)
+<case-lambda-clause>
+ --> (<formals> <definition-or-command>*)
+<formals>
+ --> (<identifier>*)
+ | (<identifier>* . <identifier>)
+ | <identifier>
+@end group
+@end example
+
+Rest lists can be useful with @code{case-lambda}:
+
+@lisp
+(define plus
+ (case-lambda
+ (() 0)
+ ((a) a)
+ ((a b) (+ a b))
+ ((a b . rest) (apply plus (+ a b) rest))))
+(plus 1 2 3) @result{} 6
+@end lisp
+
+@fnindex case-lambda*
+Also, for completeness. Guile defines @code{case-lambda*} as well,
+which is like @code{case-lambda}, except with @code{lambda*} clauses.
+A @code{case-lambda*} clause matches if the arguments fill the
+required arguments, but are not too many for the optional and/or rest
+arguments.
+
+@code{case-lambda*} is particularly useful in combination with an
+obscure @code{lambda*} feature, @code{#:predicate}. @code{lambda*}
+argument lists may contain a @code{#:predicate @var{expr}} clause at
+the end -- before the rest argument, if any. This expression is
+evaluated in the context of all of the arguments, and if false, causes
+the @code{case-lambda*} expression not to match. This can be used to
+make a simple form of type dispatch:
+
+@lisp
+(define type-of
+ (case-lambda*
+ ((a #:predicate (symbol? a)) 'symbol)
+ ((a #:predicate (string? a)) 'string)
+ ((a) 'unknown)))
+(type-of 'foo) @result{} symbol
+(type-of "foo") @result{} string
+(type-of '(foo)) @result{} unknown
+@end lisp
+
+Keyword arguments are possible with @code{case-lambda*}, but they do
+not contribute to the ``matching'' behavior. That is to say,
+@code{case-lambda*} matches only on required, optional, and rest
+arguments, and on the predicate; keyword arguments may be present but
+do not contribute to the ``success'' of a match. In fact a bad keyword
+argument list may cause an error to be raised.
@node Procedure Properties
@subsection Procedure Properties and Meta-information
-@c FIXME::martin: Review me!
+In addition to the information that is strictly necessary to run,
+procedures may have other associated information. For example, the
+name of a procedure is information not for the procedure, but about
+the procedure. This meta-information can be accessed via the procedure
+properties interface.
-Procedures always have attached the environment in which they were
-created and information about how to apply them to actual arguments. In
-addition to that, properties and meta-information can be stored with
-procedures. The procedures in this section can be used to test whether
-a given procedure satisfies a condition; and to access and set a
-procedure's property.
-
-The first group of procedures are predicates to test whether a Scheme
-object is a procedure, or a special procedure, respectively.
-@code{procedure?} is the most general predicates, it returns @code{#t}
-for any kind of procedure. @code{closure?} does not return @code{#t}
-for primitive procedures, and @code{thunk?} only returns @code{#t} for
-procedures which do not accept any arguments.
+The first group of procedures in this meta-interface are predicates to
+test whether a Scheme object is a procedure, or a special procedure,
+respectively. @code{procedure?} is the most general predicates, it
+returns @code{#t} for any kind of procedure. @code{closure?} does not
+return @code{#t} for primitive procedures, and @code{thunk?} only
+returns @code{#t} for procedures which do not accept any arguments.
@rnindex procedure?
@deffn {Scheme Procedure} procedure? obj
@@ -594,7 +644,11 @@ Return @code{#t} if @var{obj} is a procedure.
@deffn {Scheme Procedure} closure? obj
@deffnx {C Function} scm_closure_p (obj)
-Return @code{#t} if @var{obj} is a closure.
+Return @code{#t} if @var{obj} is a closure. This category somewhat
+misnamed, actually, as it applies only to interpreted procedures, not
+compiled procedures. But since it has historically been used more to
+select on implementation details than on essence (closure or not), we
+keep it here for compatibility. Don't use it in new code, though.
@end deffn
@deffn {Scheme Procedure} thunk? obj
@@ -602,10 +656,9 @@ Return @code{#t} if @var{obj} is a closure.
Return @code{#t} if @var{obj} is a thunk.
@end deffn
-@c FIXME::martin: Is that true?
@cindex procedure properties
-Procedure properties are general properties to be attached to
-procedures. These can be the name of a procedure or other relevant
+Procedure properties are general properties associated with
+procedures. These can be the name of a procedure or other relevant
information, such as debug hints.
@deffn {Scheme Procedure} procedure-name proc
@@ -615,32 +668,34 @@ Return the name of the procedure @var{proc}
@deffn {Scheme Procedure} procedure-source proc
@deffnx {C Function} scm_procedure_source (proc)
-Return the source of the procedure @var{proc}.
+Return the source of the procedure @var{proc}. Returns @code{#f} if
+the source code is not available.
@end deffn
@deffn {Scheme Procedure} procedure-environment proc
@deffnx {C Function} scm_procedure_environment (proc)
-Return the environment of the procedure @var{proc}.
+Return the environment of the procedure @var{proc}. Very deprecated.
@end deffn
@deffn {Scheme Procedure} procedure-properties proc
@deffnx {C Function} scm_procedure_properties (proc)
-Return @var{obj}'s property list.
+Return the properties associated with @var{proc}, as an association
+list.
@end deffn
-@deffn {Scheme Procedure} procedure-property obj key
-@deffnx {C Function} scm_procedure_property (obj, key)
-Return the property of @var{obj} with name @var{key}.
+@deffn {Scheme Procedure} procedure-property proc key
+@deffnx {C Function} scm_procedure_property (proc, key)
+Return the property of @var{proc} with name @var{key}.
@end deffn
@deffn {Scheme Procedure} set-procedure-properties! proc alist
@deffnx {C Function} scm_set_procedure_properties_x (proc, alist)
-Set @var{obj}'s property list to @var{alist}.
+Set @var{proc}'s property list to @var{alist}.
@end deffn
-@deffn {Scheme Procedure} set-procedure-property! obj key value
-@deffnx {C Function} scm_set_procedure_property_x (obj, key, value)
-In @var{obj}'s property list, set the property named @var{key} to
+@deffn {Scheme Procedure} set-procedure-property! proc key value
+@deffnx {C Function} scm_set_procedure_property_x (proc, key, value)
+In @var{proc}'s property list, set the property named @var{key} to
@var{value}.
@end deffn
@@ -899,6 +954,9 @@ given by the <transformer-spec>.
@node Internal Macros
@subsection Internal Representation of Macros and Syntax
+[FIXME: used to be true. Isn't any more. Use syntax-rules or
+syntax-case please :)]
+
Internally, Guile uses three different flavors of macros. The three
flavors are called @dfn{acro} (or @dfn{syntax}), @dfn{macro} and
@dfn{mmacro}.
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index 521369619..8382ba3f1 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -542,10 +542,19 @@ which only ever executes on behalf of one process at any one time.
@node Blocking
@subsection Blocking in Guile Mode
-A thread must not block outside of a libguile function while it is in
-guile mode. The following functions can be used to temporily leave
-guile mode or to perform some common blocking operations in a supported
-way.
+Up to Guile version 1.8, a thread blocked in guile mode would prevent
+the garbage collector from running. Thus threads had to explicitly
+leave guile mode with @code{scm_without_guile ()} before making a
+potentially blocking call such as a mutex lock, a @code{select ()}
+system call, etc. The following functions could be used to temporarily
+leave guile mode or to perform some common blocking operations in a
+supported way.
+
+Starting from Guile 2.0, blocked threads no longer hinder garbage
+collection. Thus, the functions below are not needed anymore. They can
+still be used to inform the GC that a thread is about to block, giving
+it a (small) optimization opportunity for ``stop the world'' garbage
+collections, should they occur while the thread is blocked.
@deftypefn {C Function} {void *} scm_without_guile (void *(*func) (void *), void *data)
Leave guile mode, call @var{func} on @var{data}, enter guile mode and
@@ -783,39 +792,6 @@ Like @code{scm_with_dynamic_state}, but call @var{func} with
@var{data}.
@end deftypefn
-@c @node Futures
-@c @subsection Futures
-@c @cindex futures
-
-@c -- Futures are disabled for the time being, see futures.h for an
-@c -- explanation.
-
-@c Futures are a convenient way to run a calculation in a new thread, and
-@c only wait for the result when it's actually needed.
-
-@c Futures are similar to promises (@pxref{Delayed Evaluation}), in that
-@c they allow mainline code to continue immediately. But @code{delay}
-@c doesn't evaluate at all until forced, whereas @code{future} starts
-@c immediately in a new thread.
-
-@c @deffn {syntax} future expr
-@c Begin evaluating @var{expr} in a new thread, and return a ``future''
-@c object representing the calculation.
-@c @end deffn
-
-@c @deffn {Scheme Procedure} make-future thunk
-@c @deffnx {C Function} scm_make_future (thunk)
-@c Begin evaluating the call @code{(@var{thunk})} in a new thread, and
-@c return a ``future'' object representing the calculation.
-@c @end deffn
-
-@c @deffn {Scheme Procedure} future-ref f
-@c @deffnx {C Function} scm_future_ref (f)
-@c Return the value computed by the future @var{f}. If @var{f} has not
-@c yet finished executing then wait for it to do so.
-@c @end deffn
-
-
@node Parallel Forms
@subsection Parallel forms
@cindex parallel forms
diff --git a/doc/ref/api-smobs.texi b/doc/ref/api-smobs.texi
index df000d838..82ca4b203 100644
--- a/doc/ref/api-smobs.texi
+++ b/doc/ref/api-smobs.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -8,6 +8,8 @@
@node Smobs
@section Smobs
+@cindex smob
+
This chapter contains reference information related to defining and
working with smobs. See @ref{Defining New Types (Smobs)} for a
tutorial-like introduction to smobs.
@@ -33,10 +35,48 @@ immediately followed by calls to one or several of
@code{scm_set_smob_print}, and/or @code{scm_set_smob_equalp}.
@end deftypefun
+@cindex finalizer
+@cindex finalization
+
+@deftypefn {C Function} void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM obj))
+This function sets the smob freeing procedure (sometimes referred to as
+a @dfn{finalizer}) for the smob type specified by the tag
+@var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}.
+
+The @var{free} procedure must deallocate all resources that are
+directly associated with the smob instance @var{OBJ}. It must assume
+that all @code{SCM} values that it references have already been freed
+and are thus invalid.
+
+It must also not call any libguile function or macro except
+@code{scm_gc_free}, @code{SCM_SMOB_FLAGS}, @code{SCM_SMOB_DATA},
+@code{SCM_SMOB_DATA_2}, and @code{SCM_SMOB_DATA_3}.
+
+The @var{free} procedure must return 0.
+
+Note that defining a freeing procedure is not necessary if the resources
+associated with @var{obj} consists only of memory allocated with
+@code{scm_gc_malloc} or @code{scm_gc_malloc_pointerless} because this
+memory is automatically reclaimed by the garbage collector when it is no
+longer needed (@pxref{Memory Blocks, @code{scm_gc_malloc}}).
+@end deftypefn
+
+@cindex precise marking
+
@deftypefn {C Function} void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM obj))
This function sets the smob marking procedure for the smob type specified by
the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}.
+Defining a marking procedure may sometimes be unnecessary because large
+parts of the process' memory (with the exception of
+@code{scm_gc_malloc_pointerless} regions, and @code{malloc}- or
+@code{scm_malloc}-allocated memory) are scanned for live
+pointers@footnote{Conversely, in Guile up to the 1.8 series, the marking
+procedure was always required. The reason is that Guile's GC would only
+look for pointers in the memory area used for built-in types (the
+@dfn{cell heap}), not in user-allocated or statically allocated memory.
+This approach is often referred to as @dfn{precise marking}.}.
+
The @var{mark} procedure must cause @code{scm_gc_mark} to be called
for every @code{SCM} value that is directly referenced by the smob
instance @var{obj}. One of these @code{SCM} values can be returned
@@ -49,22 +89,6 @@ It must not call any libguile function or macro except
@code{SCM_SMOB_DATA_2}, and @code{SCM_SMOB_DATA_3}.
@end deftypefn
-@deftypefn {C Function} void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM obj))
-This function sets the smob freeing procedure for the smob type
-specified by the tag @var{tc}. @var{tc} is the tag returned by
-@code{scm_make_smob_type}.
-
-The @var{free} procedure must deallocate all resources that are
-directly associated with the smob instance @var{OBJ}. It must assume
-that all @code{SCM} values that it references have already been freed
-and are thus invalid.
-
-It must also not call any libguile function or macro except
-@code{scm_gc_free}, @code{SCM_SMOB_FLAGS}, @code{SCM_SMOB_DATA},
-@code{SCM_SMOB_DATA_2}, and @code{SCM_SMOB_DATA_3}.
-
-The @var{free} procedure must return 0.
-@end deftypefn
@deftypefn {C Function} void scm_set_smob_print (scm_t_bits tc, int (*print) (SCM obj, SCM port, scm_print_state* pstate))
This function sets the smob printing procedure for the smob type
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index d749fc1f3..67a8ab481 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -236,12 +236,49 @@ which puts the user in the @code{(foo)} module. That is purpose of the
when compiling the subsequent expression.
For Scheme, an environment may be one of two things:
+
@itemize
@item @code{#f}, in which case compilation is performed in the context
of the current module; or
@item a module, which specifies the context of the compilation.
@end itemize
+By default, the @code{compile} and @code{compile-file} procedures
+compile in a fresh module, such that bindings and macros introduced by
+the expression being compiled are isolated:
+
+@example
+(eq? (current-module) (compile '(current-module)))
+@result{} #f
+
+(compile '(define hello 'world))
+(defined? 'hello)
+@result{} #f
+
+(define / *)
+(eq? (compile '/) /)
+@result{} #f
+@end example
+
+Similarly, changes to the @code{current-reader} fluid (@pxref{Loading,
+@code{current-reader}}) are isolated:
+
+@example
+(compile '(fluid-set! current-reader (lambda args 'fail)))
+(fluid-ref current-reader)
+@result{} #f
+@end example
+
+Nevertheless, having the compiler and @dfn{compilee} share the same name
+space can be achieved by explicitly passing @code{(current-module)} as
+the compilation environment:
+
+@example
+(define hello 'world)
+(compile 'hello #:env (current-module))
+@result{} world
+@end example
+
@node Tree-IL
@subsection Tree-IL
diff --git a/doc/ref/goops.texi b/doc/ref/goops.texi
index c0a828f71..9b0d05714 100644
--- a/doc/ref/goops.texi
+++ b/doc/ref/goops.texi
@@ -17,7 +17,7 @@ Guile
@goops{} is the object oriented extension to @guile{}. Its
implementation is derived from @w{STk-3.99.3} by Erick Gallesio and
-version 1.3 of Gregor Kiczales @cite{Tiny-Clos}. It is very close in
+version 1.3 of Gregor Kiczales' @cite{Tiny-Clos}. It is very close in
spirit to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is
adapted for the Scheme language. While GOOPS is not compatible with any
of these systems, GOOPS contains a compatibility module which allows for
diff --git a/doc/ref/libguile-linking.texi b/doc/ref/libguile-linking.texi
index 72b59bbba..78a93e64d 100644
--- a/doc/ref/libguile-linking.texi
+++ b/doc/ref/libguile-linking.texi
@@ -61,6 +61,8 @@ command-line arguments in the same manner as the stock Guile
interpreter. To make that straightforward, Guile provides the
@code{scm_boot_guile} and @code{scm_shell} function.
+For more about these functions, see @ref{Initialization}.
+
@node A Sample Guile Main Program
@subsection A Sample Guile Main Program
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index d568af23d..21bac6139 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -2288,8 +2288,8 @@ Convert a network address from an integer to a printable string.
@lisp
(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1"
-(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}
-ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff
+(inet-ntop AF_INET6 (- (expt 2 128) 1))
+ @result{} "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff"
@end lisp
@end deffn
@@ -2860,8 +2860,8 @@ same as @code{make-socket-address} would take to make such an object
(@pxref{Network Socket Address}). The return value is unspecified.
@example
-(connect sock AF_INET INADDR_LOCALHOST 23)
-(connect sock (make-socket-address AF_INET INADDR_LOCALHOST 23))
+(connect sock AF_INET INADDR_LOOPBACK 23)
+(connect sock (make-socket-address AF_INET INADDR_LOOPBACK 23))
@end example
@end deffn
diff --git a/doc/ref/scheme-scripts.texi b/doc/ref/scheme-scripts.texi
index e12eee60f..249bc3414 100644
--- a/doc/ref/scheme-scripts.texi
+++ b/doc/ref/scheme-scripts.texi
@@ -64,6 +64,12 @@ operating system never reads this far, but Guile treats this as the end
of the comment begun on the first line by the @samp{#!} characters.
@item
+If this source code file is not ASCII or ISO-8859-1 encoded, a coding
+declaration such as @code{coding: utf-8} should appear in a comment
+somewhere in the first five lines of the file: see @ref{Character
+Encoding of Source Files}.
+
+@item
The rest of the file should be a Scheme program.
@end itemize
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 7c107e710..5e8d762b6 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -37,6 +37,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-18:: Multithreading support
* SRFI-19:: Time/Date library.
* SRFI-26:: Specializing parameters
+* SRFI-30:: Nested multi-line block comments
* SRFI-31:: A special form `rec' for recursive evaluation
* SRFI-34:: Exception handling.
* SRFI-35:: Conditions.
@@ -134,6 +135,7 @@ The Guile core has the following features,
@example
guile
+guile-2 ;; starting from Guile 2.x
r5rs
srfi-0
srfi-4
@@ -161,6 +163,23 @@ how to load it with the Guile mechanism.
(use-modules (srfi srfi-8))))
@end example
+@cindex @code{guile-2} SRFI-0 feature
+@cindex portability between 2.0 and older versions
+Likewise, testing the @code{guile-2} feature allows code to be portable
+between Guile 2.0 and previous versions of Guile. For instance, it
+makes it possible to write code that accounts for Guile 2.0's compiler,
+yet be correctly interpreted on 1.8 and earlier versions:
+
+@example
+(cond-expand (guile-2 (eval-when (compile)
+ ;; This must be evaluated at compile time.
+ (fluid-set! current-reader my-reader)))
+ (guile
+ ;; Earlier versions of Guile do not have a
+ ;; separate compilation phase.
+ (fluid-set! current-reader my-reader)))
+@end example
+
It should be noted that @code{cond-expand} is separate from the
@code{*features*} mechanism (@pxref{Feature Tracking}), feature
symbols in one are unrelated to those in the other.
@@ -1558,66 +1577,9 @@ The SRFI-14 data type and procedures are always available,
@cindex variable arity
@cindex arity, variable
-@c FIXME::martin: Review me!
-
-@findex case-lambda
-The syntactic form @code{case-lambda} creates procedures, just like
-@code{lambda}, but has syntactic extensions for writing procedures of
-varying arity easier.
-
-The syntax of the @code{case-lambda} form is defined in the following
-EBNF grammar.
-
-@example
-@group
-<case-lambda>
- --> (case-lambda <case-lambda-clause>)
-<case-lambda-clause>
- --> (<formals> <definition-or-command>*)
-<formals>
- --> (<identifier>*)
- | (<identifier>* . <identifier>)
- | <identifier>
-@end group
-@end example
-
-The value returned by a @code{case-lambda} form is a procedure which
-matches the number of actual arguments against the formals in the
-various clauses, in order. @dfn{Formals} means a formal argument list
-just like with @code{lambda} (@pxref{Lambda}). The first matching clause
-is selected, the corresponding values from the actual parameter list are
-bound to the variable names in the clauses and the body of the clause is
-evaluated. If no clause matches, an error is signalled.
-
-The following (silly) definition creates a procedure @var{foo} which
-acts differently, depending on the number of actual arguments. If one
-argument is given, the constant @code{#t} is returned, two arguments are
-added and if more arguments are passed, their product is calculated.
-
-@lisp
-(define foo (case-lambda
- ((x) #t)
- ((x y) (+ x y))
- (z
- (apply * z))))
-(foo 'bar)
-@result{}
-#t
-(foo 2 4)
-@result{}
-6
-(foo 3 3 3)
-@result{}
-27
-(foo)
-@result{}
-1
-@end lisp
-
-The last expression evaluates to 1 because the last clause is matched,
-@var{z} is bound to the empty list and the following multiplication,
-applied to zero arguments, yields 1.
-
+SRFI-16 defines a variable-arity @code{lambda} form,
+@code{case-lambda}. This form is available in the default Guile
+environment. @xref{Case-lambda}, for more information.
@node SRFI-17
@subsection SRFI-17 - Generalized set!
@@ -2712,6 +2674,13 @@ or similar is typical.
@end example
@end deffn
+@node SRFI-30
+@subsection SRFI-30 - Nested Multi-line Comments
+@cindex SRFI-30
+
+Starting from version 2.0, Guile's @code{read} supports SRFI-30/R6RS
+nested multi-line comments by default, @ref{Block Comments}.
+
@node SRFI-31
@subsection SRFI-31 - A special form `rec' for recursive evaluation
@cindex SRFI-31
diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el
index bb605c364..326d15265 100755
--- a/emacs/gds-scheme.el
+++ b/emacs/gds-scheme.el
@@ -424,11 +424,13 @@ through the code."
(map (make-sparse-keymap)))
(define-key map [mouse-1] 'gds-show-last-stack)
(define-key map "\C-m" 'gds-show-last-stack)
- (insert "[click here to show error stack]")
+ (insert "[click here (or RET) to show error stack]")
(add-text-properties beg (point)
(list 'keymap map
'mouse-face 'highlight))
- (insert "\n")))
+ (insert "\n")
+ (add-text-properties (1- (point)) (point)
+ (list 'keymap map))))
(goto-char (point-min))
(gds-associate-buffer client))
(pop-to-buffer buf)
diff --git a/gc-benchmarks/larceny/dynamic-input-large.sch b/gc-benchmarks/larceny/dynamic-input-large.sch
index 068ea3e5f..7bc52ef1e 100644
--- a/gc-benchmarks/larceny/dynamic-input-large.sch
+++ b/gc-benchmarks/larceny/dynamic-input-large.sch
@@ -1190,7 +1190,7 @@
(let () (begin (set! make-fasl (lambda (.infilename|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let ((.outfilename|6 (if (not (null? .rest|1)) (let ((.x|8|11 .rest|1)) (begin (.check! (pair? .x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (rewrite-file-type .infilename|1 *lop-file-type* *fasl-file-type*)))) (begin (process-file .infilename|1 .outfilename|6 dump-fasl-segment-to-port (lambda (.x|7) .x|7)) (unspecified))))) (if (eq? (nbuild-parameter 'target-machine) 'standard-c) (error "Make-fasl not supported on this target architecture.") (.doit|2)))))) 'make-fasl))
(let () (begin (set! disassemble (lambda (.item|1 . .rest|1) (let ((.output-port|4 (if (null? .rest|1) (current-output-port) (let ((.x|5|8 .rest|1)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8)))))) (begin (disassemble-item .item|1 #f .output-port|4) (unspecified))))) 'disassemble))
(let () (begin (set! disassemble-item (lambda (.item|1 .segment-no|1 .port|1) (let ((.disassemble-item|2 0)) (begin (set! .disassemble-item|2 (lambda (.item|3 .segment-no|3 .port|3) (let ((.print-segment|5 (unspecified)) (.print-constvector|5 (unspecified)) (.print|5 (unspecified))) (begin (set! .print-segment|5 (lambda (.segment|6) (begin (.print|5 "Segment # " .segment-no|3) (print-instructions (disassemble-codevector (let ((.x|7|10 .segment|6)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) .port|3) (.print-constvector|5 (let ((.x|11|14 .segment|6)) (begin (.check! (pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) (.print|5 "========================================")))) (set! .print-constvector|5 (lambda (.cv|15) (let () (let ((.loop|17|19|22 (unspecified))) (begin (set! .loop|17|19|22 (lambda (.i|23) (if (= .i|23 (let ((.v|25|28 .cv|15)) (begin (.check! (vector? .v|25|28) 42 .v|25|28) (vector-length:vec .v|25|28)))) (if #f #f (unspecified)) (begin (begin #t (.print|5 "------------------------------------------") (.print|5 "Constant vector element # " .i|23) (let ((.temp|30|33 (let ((.x|90|93 (let ((.v|94|97 .cv|15) (.i|94|97 .i|23)) (begin (.check! (fixnum? .i|94|97) 40 .v|94|97 .i|94|97) (.check! (vector? .v|94|97) 40 .v|94|97 .i|94|97) (.check! (<:fix:fix .i|94|97 (vector-length:vec .v|94|97)) 40 .v|94|97 .i|94|97) (.check! (>=:fix:fix .i|94|97 0) 40 .v|94|97 .i|94|97) (vector-ref:trusted .v|94|97 .i|94|97))))) (begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93))))) (if (memv .temp|30|33 '(codevector)) (begin (.print|5 "Code vector") (print-instructions (disassemble-codevector (let ((.x|36|39 (let ((.x|40|43 (let ((.v|44|47 .cv|15) (.i|44|47 .i|23)) (begin (.check! (fixnum? .i|44|47) 40 .v|44|47 .i|44|47) (.check! (vector? .v|44|47) 40 .v|44|47 .i|44|47) (.check! (<:fix:fix .i|44|47 (vector-length:vec .v|44|47)) 40 .v|44|47 .i|44|47) (.check! (>=:fix:fix .i|44|47 0) 40 .v|44|47 .i|44|47) (vector-ref:trusted .v|44|47 .i|44|47))))) (begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43))))) (begin (.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39)))) .port|3)) (if (memv .temp|30|33 '(constantvector)) (begin (.print|5 "Constant vector") (.print-constvector|5 (let ((.x|50|53 (let ((.x|54|57 (let ((.v|58|61 .cv|15) (.i|58|61 .i|23)) (begin (.check! (fixnum? .i|58|61) 40 .v|58|61 .i|58|61) (.check! (vector? .v|58|61) 40 .v|58|61 .i|58|61) (.check! (<:fix:fix .i|58|61 (vector-length:vec .v|58|61)) 40 .v|58|61 .i|58|61) (.check! (>=:fix:fix .i|58|61 0) 40 .v|58|61 .i|58|61) (vector-ref:trusted .v|58|61 .i|58|61))))) (begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57))))) (begin (.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memv .temp|30|33 '(global)) (.print|5 "Global: " (let ((.x|64|67 (let ((.x|68|71 (let ((.v|72|75 .cv|15) (.i|72|75 .i|23)) (begin (.check! (fixnum? .i|72|75) 40 .v|72|75 .i|72|75) (.check! (vector? .v|72|75) 40 .v|72|75 .i|72|75) (.check! (<:fix:fix .i|72|75 (vector-length:vec .v|72|75)) 40 .v|72|75 .i|72|75) (.check! (>=:fix:fix .i|72|75 0) 40 .v|72|75 .i|72|75) (vector-ref:trusted .v|72|75 .i|72|75))))) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair .x|68|71))))) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair .x|64|67)))) (if (memv .temp|30|33 '(data)) (.print|5 "Data: " (let ((.x|78|81 (let ((.x|82|85 (let ((.v|86|89 .cv|15) (.i|86|89 .i|23)) (begin (.check! (fixnum? .i|86|89) 40 .v|86|89 .i|86|89) (.check! (vector? .v|86|89) 40 .v|86|89 .i|86|89) (.check! (<:fix:fix .i|86|89 (vector-length:vec .v|86|89)) 40 .v|86|89 .i|86|89) (.check! (>=:fix:fix .i|86|89 0) 40 .v|86|89 .i|86|89) (vector-ref:trusted .v|86|89 .i|86|89))))) (begin (.check! (pair? .x|82|85) 1 .x|82|85) (cdr:pair .x|82|85))))) (begin (.check! (pair? .x|78|81) 0 .x|78|81) (car:pair .x|78|81)))) (unspecified))))))) (.loop|17|19|22 (+ .i|23 1)))))) (.loop|17|19|22 0)))))) (set! .print|5 (lambda .rest|98 (begin (let () (let ((.loop|104|106|109 (unspecified))) (begin (set! .loop|104|106|109 (lambda (.y1|99|100|110) (if (null? .y1|99|100|110) (if #f #f (unspecified)) (begin (begin #t (let ((.x|114 (let ((.x|115|118 .y1|99|100|110)) (begin (.check! (pair? .x|115|118) 0 .x|115|118) (car:pair .x|115|118))))) (display .x|114 .port|3))) (.loop|104|106|109 (let ((.x|119|122 .y1|99|100|110)) (begin (.check! (pair? .x|119|122) 1 .x|119|122) (cdr:pair .x|119|122)))))))) (.loop|104|106|109 .rest|98)))) (newline .port|3)))) (if (procedure? .item|3) (print-instructions (disassemble-codevector (procedure-ref .item|3 0)) .port|3) (if (if (pair? .item|3) (if (bytevector? (let ((.x|126|129 .item|3)) (begin (.check! (pair? .x|126|129) 0 .x|126|129) (car:pair .x|126|129)))) (vector? (let ((.x|131|134 .item|3)) (begin (.check! (pair? .x|131|134) 1 .x|131|134) (cdr:pair .x|131|134)))) #f) #f) (.print-segment|5 .item|3) (error "disassemble-item: " .item|3 " is not disassemblable."))))))) (.disassemble-item|2 .item|1 .segment-no|1 .port|1))))) 'disassemble-item))
-(let () (begin (set! disassemble-file (lambda (.file|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda (.input-port|3 .output-port|3) (begin (display "\; From " .output-port|3) (display .file|1 .output-port|3) (newline .output-port|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.segment-no|12 .segment|12) (if (eof-object? .segment|12) (if #f #f (unspecified)) (begin (begin #t (disassemble-item .segment|12 .segment-no|12 .output-port|3)) (.loop|5|8|11 (+ .segment-no|12 1) (read .input-port|3)))))) (.loop|5|8|11 0 (read .input-port|3)))))))) (call-with-input-file .file|1 (lambda (.input-port|15) (if (null? .rest|1) (.doit|2 .input-port|15 (current-output-port)) (begin (delete-file (let ((.x|16|19 .rest|1)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19)))) (call-with-output-file (let ((.x|20|23 .rest|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) (lambda (.output-port|24) (.doit|2 .input-port|15 .output-port|24))))))) (unspecified))))) 'disassemble-file))
+(let () (begin (set! disassemble-file (lambda (.file|1 . .rest|1) (let ((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda (.input-port|3 .output-port|3) (begin (display "; From " .output-port|3) (display .file|1 .output-port|3) (newline .output-port|3) (let () (let ((.loop|5|8|11 (unspecified))) (begin (set! .loop|5|8|11 (lambda (.segment-no|12 .segment|12) (if (eof-object? .segment|12) (if #f #f (unspecified)) (begin (begin #t (disassemble-item .segment|12 .segment-no|12 .output-port|3)) (.loop|5|8|11 (+ .segment-no|12 1) (read .input-port|3)))))) (.loop|5|8|11 0 (read .input-port|3)))))))) (call-with-input-file .file|1 (lambda (.input-port|15) (if (null? .rest|1) (.doit|2 .input-port|15 (current-output-port)) (begin (delete-file (let ((.x|16|19 .rest|1)) (begin (.check! (pair? .x|16|19) 0 .x|16|19) (car:pair .x|16|19)))) (call-with-output-file (let ((.x|20|23 .rest|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) (lambda (.output-port|24) (.doit|2 .input-port|15 .output-port|24))))))) (unspecified))))) 'disassemble-file))
(let () (begin (set! compiler-switches (lambda .rest|1 (let ((.fast-unsafe-code|3 (unspecified)) (.fast-safe-code|3 (unspecified)) (.standard-code|3 (unspecified)) (.slow-code|3 (unspecified))) (begin (set! .fast-unsafe-code|3 (lambda () (begin (set-compiler-flags! 'fast-unsafe) (set-assembler-flags! 'fast-unsafe)))) (set! .fast-safe-code|3 (lambda () (begin (set-compiler-flags! 'fast-safe) (set-assembler-flags! 'fast-safe)))) (set! .standard-code|3 (lambda () (begin (set-compiler-flags! 'standard) (set-assembler-flags! 'standard)))) (set! .slow-code|3 (lambda () (begin (set-compiler-flags! 'no-optimization) (set-assembler-flags! 'no-optimization)))) (if (null? .rest|1) (begin (display "Debugging:") (newline) (display-twobit-flags 'debugging) (display-assembler-flags 'debugging) (newline) (display "Safety:") (newline) (display-twobit-flags 'safety) (display-assembler-flags 'safety) (newline) (display "Speed:") (newline) (display-twobit-flags 'optimization) (display-assembler-flags 'optimization) (if #f #f (unspecified))) (if (null? (let ((.x|9|12 .rest|1)) (begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12)))) (begin (let ((.temp|13|16 (let ((.x|27|30 .rest|1)) (begin (.check! (pair? .x|27|30) 0 .x|27|30) (car:pair .x|27|30))))) (if (memv .temp|13|16 '(0 slow)) (.slow-code|3) (if (memv .temp|13|16 '(1 standard)) (.standard-code|3) (if (memv .temp|13|16 '(2 fast-safe)) (.fast-safe-code|3) (if (memv .temp|13|16 '(3 fast-unsafe)) (.fast-unsafe-code|3) (if (memv .temp|13|16 '(default factory-settings)) (begin (.fast-safe-code|3) (include-source-code #t) (benchmark-mode #f) (benchmark-block-mode #f) (common-subexpression-elimination #f) (representation-inference #f)) (error "Unrecognized flag " (let ((.x|23|26 .rest|1)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))) " to compiler-switches."))))))) (unspecified)) (error "Too many arguments to compiler-switches."))))))) 'compiler-switches))
(let () (begin (set! process-file (lambda (.infilename|1 .outfilename|1 .writer|1 .processer|1) (let ((.process-file|2 0)) (begin (set! .process-file|2 (lambda (.infilename|3 .outfilename|3 .writer|3 .processer|3) (let ((.doit|6 (unspecified))) (begin (set! .doit|6 (lambda () (begin (delete-file .outfilename|3) (call-with-output-file .outfilename|3 (lambda (.outport|8) (call-with-input-file .infilename|3 (lambda (.inport|9) (let ((.x|12 (read .inport|9))) (let () (let ((.loop|15 (unspecified))) (begin (set! .loop|15 (lambda (.x|16) (if (eof-object? .x|16) #t (begin (.writer|3 (.processer|3 .x|16) .outport|8) (.loop|15 (read .inport|9)))))) (.loop|15 .x|12)))))))))))) (let ((.current-syntactic-environment|17 (syntactic-copy global-syntactic-environment))) (dynamic-wind (lambda () #t) (lambda () (.doit|6)) (lambda () (set! global-syntactic-environment .current-syntactic-environment|17)))))))) (.process-file|2 .infilename|1 .outfilename|1 .writer|1 .processer|1))))) 'process-file))
(let () (begin (set! process-file-block (lambda (.infilename|1 .outfilename|1 .writer|1 .processer|1) (let ((.process-file-block|2 0)) (begin (set! .process-file-block|2 (lambda (.infilename|3 .outfilename|3 .writer|3 .processer|3) (let ((.doit|6 (unspecified))) (begin (set! .doit|6 (lambda () (begin (delete-file .outfilename|3) (call-with-output-file .outfilename|3 (lambda (.outport|8) (call-with-input-file .infilename|3 (lambda (.inport|9) (let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 (lambda (.x|17 .forms|17) (if (eof-object? .x|17) (.writer|3 (.processer|3 (reverse .forms|17)) .outport|8) (begin #t (.loop|10|13|16 (read .inport|9) (cons .x|17 .forms|17)))))) (.loop|10|13|16 (read .inport|9) '()))))))))))) (let ((.current-syntactic-environment|20 (syntactic-copy global-syntactic-environment))) (dynamic-wind (lambda () #t) (lambda () (.doit|6)) (lambda () (set! global-syntactic-environment .current-syntactic-environment|20)))))))) (.process-file-block|2 .infilename|1 .outfilename|1 .writer|1 .processer|1))))) 'process-file-block))
diff --git a/gc-benchmarks/run-benchmark.scm b/gc-benchmarks/run-benchmark.scm
index 915143f1d..7a9e67b2f 100755
--- a/gc-benchmarks/run-benchmark.scm
+++ b/gc-benchmarks/run-benchmark.scm
@@ -4,7 +4,7 @@ exec ${GUILE-guile} -q -l "$0" \
-c '(apply main (cdr (command-line)))' \
--benchmark-dir="$(dirname $0)" "$@"
!#
-;;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;; Copyright (C) 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
@@ -25,6 +25,7 @@ exec ${GUILE-guile} -q -l "$0" \
(ice-9 popen)
(ice-9 regex)
(ice-9 format)
+ (ice-9 pretty-print)
(srfi srfi-1)
(srfi srfi-37))
@@ -103,23 +104,64 @@ exec ${GUILE-guile} -q -l "$0" \
result)))
(define (pretty-print-result benchmark reference bdwgc)
+ (define ref-heap (assoc-ref reference 'heap-size))
+ (define ref-time (assoc-ref reference 'execution-time))
+
+ (define (distance x1 y1 x2 y2)
+ ;; Return the distance between (X1,Y1) and (X2,Y2). Y is the heap size,
+ ;; in MiB and X is the execution time in seconds.
+ (let ((y1 (/ y1 (expt 2 20)))
+ (y2 (/ y2 (expt 2 20))))
+ (sqrt (+ (expt (- y1 y2) 2)
+ (expt (- x1 x2) 2)))))
+
+ (define (score time heap)
+ ;; Return a score lower than +1.0. The score is positive if the
+ ;; distance to the origin of (TIME,HEAP) is smaller than that of
+ ;; (REF-TIME,REF-HEAP), negative otherwise.
+
+ ;; heap ^ .
+ ;; size | . worse
+ ;; | . [-]
+ ;; | .
+ ;; | . . . .ref. . . .
+ ;; | .
+ ;; | [+] .
+ ;; | better .
+ ;; 0 +-------------------->
+ ;; exec. time
+
+ (let ((ref-dist (distance ref-time ref-heap 0 0))
+ (dist (distance time heap 0 0)))
+ (/ (- ref-dist dist) ref-dist)))
+
+ (define (score-string time heap)
+ ;; Return a string denoting a bar to illustrate the score of (TIME,HEAP)
+ ;; relative to (REF-TIME,REF-HEAP).
+ (define %max-width 15)
+
+ (let ((s (score time heap)))
+ (make-string (inexact->exact (round (* (if (< s 0.0) (- s) s)
+ %max-width)))
+ (if (< s 0.0)
+ #\-
+ #\+))))
+
(define (print-line name result ref?)
- (let ((name (string-pad-right name 23))
- (time (assoc-ref result 'execution-time))
- (heap (assoc-ref result 'heap-size))
- (ref-heap (assoc-ref reference 'heap-size))
- (ref-time (assoc-ref reference 'execution-time)))
- (format #t "~a ~1,2f (~,2fx) ~6,3f (~,2fx)~A~%"
+ (let ((name (string-pad-right name 23))
+ (time (assoc-ref result 'execution-time))
+ (heap (assoc-ref result 'heap-size)))
+ (format #t "~a ~6,2f (~,2fx) ~7,3f (~,2fx)~A~%"
name
- (/ heap 1000000.0) (/ heap ref-heap 1.0)
+ (/ heap (expt 2.0 20)) (/ heap ref-heap 1.0)
time (/ time ref-time 1.0)
- (if (and (not ref?)
- (<= heap ref-heap) (<= time ref-time))
- " !"
+ (if (not ref?)
+ (string-append " "
+ (score-string time heap))
""))))
(format #t "benchmark: `~a'~%" benchmark)
- (format #t " heap size (MiB) execution time (s.)~%")
+ (format #t " heap size (MiB) execution time (s.)~%")
(print-line "Guile" reference #t)
(for-each (lambda (bdwgc)
(let ((name (format #f "BDW-GC, FSD=~a~a"
@@ -134,6 +176,12 @@ exec ${GUILE-guile} -q -l "$0" \
(print-line name bdwgc #f)))
bdwgc))
+(define (print-raw-result benchmark reference bdwgc)
+ (pretty-print `(,benchmark
+ (reference . ,reference)
+ (bdw-gc . ,bdwgc))))
+
+
;;;
;;; Option processing.
@@ -170,14 +218,22 @@ exec ${GUILE-guile} -q -l "$0" \
(lambda (opt name arg result)
(alist-cons 'log-port (open-output-file arg)
(alist-delete 'log-port result
- eq?))))))
+ eq?))))
+ (option '("raw") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'printer print-raw-result
+ (alist-delete 'printer result eq?))))
+ (option '("load-results") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'load-results? #t result)))))
(define %default-options
`((reference-environment . "GUILE=guile")
(benchmark-directory . "./gc-benchmarks")
(log-port . ,(current-output-port))
(profile-options . "")
- (input . ())))
+ (input . ())
+ (printer . ,pretty-print-result)))
(define (show-help)
(format #t "Usage: run-benchmark [OPTIONS] BENCHMARKS...
@@ -199,6 +255,12 @@ comparison of standard Guile (1.9) and the BDW-GC-based Guile.
Pass OPTS as additional options for `gc-profile.scm'.
-l, --log-file=FILE
Save output to FILE instead of the standard output.
+
+ --raw Write benchmark results in raw (s-exp) format.
+ --load-results
+ Load raw (s-exp) results instead of actually running
+ the benchmarks.
+
-d, --benchmark-dir=DIR
Use DIR as the GC benchmark directory where `gc-profile.scm'
lives (it is automatically determined by default).
@@ -234,36 +296,54 @@ Report bugs to <bug-guile@gnu.org>.~%"))
(bdwgc-env (or (assoc-ref args 'bdwgc-environment)
(string-append "GUILE=" bench-dir
"/../meta/guile")))
- (prof-opts (assoc-ref args 'profile-options)))
- (for-each (lambda (benchmark)
- (let ((ref (parse-result (run-reference-guile ref-env
- bench-dir
- prof-opts
- benchmark)))
- (bdwgc (map (lambda (fsd incremental?
- generational? parallel?)
- (let ((opts
- (list
- (cons 'free-space-divisor fsd)
- (cons 'incremental? incremental?)
- (cons 'generational? generational?)
- (cons 'parallel? parallel?))))
- (append opts
- (parse-result
- (run-bdwgc-guile bdwgc-env
- bench-dir
- prof-opts
- opts
- benchmark)))))
- '( 3 6 9 3 3)
- '(#f #f #f #t #f) ;; incremental
- '(#f #f #f #f #t) ;; generational
- '(#f #f #f #f #f)))) ;; parallel
- ;;(format #t "ref=~A~%" ref)
- ;;(format #t "bdw-gc=~A~%" bdwgc)
+ (prof-opts (assoc-ref args 'profile-options))
+ (print (assoc-ref args 'printer)))
+ (define (run benchmark)
+ (let ((ref (parse-result (run-reference-guile ref-env
+ bench-dir
+ prof-opts
+ benchmark)))
+ (bdwgc (map (lambda (fsd incremental?
+ generational? parallel?)
+ (let ((opts
+ (list
+ (cons 'free-space-divisor fsd)
+ (cons 'incremental? incremental?)
+ (cons 'generational? generational?)
+ (cons 'parallel? parallel?))))
+ (append opts
+ (parse-result
+ (run-bdwgc-guile bdwgc-env
+ bench-dir
+ prof-opts
+ opts
+ benchmark)))))
+ '( 3 6 9 3 3)
+ '(#f #f #f #t #f) ;; incremental
+ '(#f #f #f #f #t) ;; generational
+ '(#f #f #f #f #f)))) ;; parallel
+ `(,benchmark
+ (reference . ,ref)
+ (bdw-gc . ,bdwgc))))
+
+ (define (load-results file)
+ (with-input-from-file file
+ (lambda ()
+ (let loop ((results '()) (o (read)))
+ (if (eof-object? o)
+ (reverse results)
+ (loop (cons o results)
+ (read)))))))
+
+ (for-each (lambda (result)
+ (let ((benchmark (car result))
+ (ref (assoc-ref (cdr result) 'reference))
+ (bdwgc (assoc-ref (cdr result) 'bdw-gc)))
(with-output-to-port log
(lambda ()
- (pretty-print-result benchmark ref bdwgc)
+ (print benchmark ref bdwgc)
(newline)
(force-output)))))
- benchmark-files))))
+ (if (assoc-ref args 'load-results?)
+ (append-map load-results benchmark-files)
+ (map run benchmark-files))))))
diff --git a/gdbinit b/gdbinit
index b66e3e249..812f04b59 100644
--- a/gdbinit
+++ b/gdbinit
@@ -1,5 +1,8 @@
# -*- GDB-Script -*-
+handle SIGPWR noprint nostop
+handle SIGXCPU noprint nostop
+
define newline
call (void)scm_newline (scm_current_error_port ())
end
diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm
index 96af69e2f..4766e619e 100644
--- a/guile-readline/ice-9/readline.scm
+++ b/guile-readline/ice-9/readline.scm
@@ -1,6 +1,6 @@
;;;; readline.scm --- support functions for command-line editing
;;;;
-;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 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
@@ -24,11 +24,15 @@
(define-module (ice-9 readline)
- :use-module (ice-9 session)
- :use-module (ice-9 regex)
- :use-module (ice-9 buffered-input)
- :no-backtrace
- :export (filename-completion-function))
+ #:use-module (ice-9 session)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 buffered-input)
+ #:no-backtrace
+ #:export (filename-completion-function
+ add-history
+ read-history
+ write-history
+ clear-history))
@@ -204,7 +208,7 @@
(let ((repl-read-hook (lambda () (run-hook before-read-hook))))
(set-current-input-port (readline-port))
(set! repl-reader
- (lambda (repl-prompt)
+ (lambda (repl-prompt . reader)
(let ((outer-new-input-prompt new-input-prompt)
(outer-continuation-prompt continuation-prompt)
(outer-read-hook read-hook))
@@ -213,7 +217,9 @@
(set-buffered-input-continuation?! (readline-port) #f)
(set-readline-prompt! repl-prompt "... ")
(set-readline-read-hook! repl-read-hook))
- (lambda () ((or (fluid-ref current-reader) read)))
+ (lambda () ((or (and (pair? reader) (car reader))
+ (fluid-ref current-reader)
+ read)))
(lambda ()
(set-readline-prompt! outer-new-input-prompt outer-continuation-prompt)
(set-readline-read-hook! outer-read-hook))))))
diff --git a/guile-readline/readline.c b/guile-readline/readline.c
index cbf4051cc..5f6719dd7 100644
--- a/guile-readline/readline.c
+++ b/guile-readline/readline.c
@@ -128,6 +128,7 @@ rl_free_line_state ()
static int promptp;
static SCM input_port;
+static SCM output_port;
static SCM before_read;
static int
@@ -138,7 +139,7 @@ current_input_getc (FILE *in SCM_UNUSED)
scm_apply (before_read, SCM_EOL, SCM_EOL);
promptp = 0;
}
- return scm_getc (input_port);
+ return scm_get_byte_or_eof (input_port);
}
static int in_readline = 0;
@@ -255,7 +256,12 @@ internal_readline (SCM text)
promptp = 1;
s = readline (prompt);
if (s)
- ret = scm_from_locale_string (s);
+ {
+ scm_t_port *pt = SCM_PTAB_ENTRY (output_port);
+
+ ret = scm_from_stringn (s, strlen (s), pt->encoding,
+ SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
+ }
else
ret = SCM_EOF_VAL;
@@ -311,6 +317,7 @@ scm_readline_init_ports (SCM inp, SCM outp)
}
input_port = inp;
+ output_port = outp;
#ifndef __MINGW32__
rl_instream = stream_from_fport (inp, "r", s_scm_readline);
rl_outstream = stream_from_fport (outp, "w", s_scm_readline);
diff --git a/libguile.h b/libguile.h
index 74674d5b9..73b3de76b 100644
--- a/libguile.h
+++ b/libguile.h
@@ -51,7 +51,6 @@ extern "C" {
#include "libguile/filesys.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
-#include "libguile/futures.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
#include "libguile/generalized-arrays.h"
@@ -61,6 +60,7 @@ extern "C" {
#include "libguile/guardians.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
+#include "libguile/i18n.h"
#include "libguile/init.h"
#include "libguile/ioext.h"
#include "libguile/rdelim.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 046ce21cc..96c66a79e 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -43,8 +43,7 @@ gnulib_library = $(top_builddir)/lib/libgnu.la
ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/' \
--regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/'
-lib_LTLIBRARIES = libguile.la \
- libguile-i18n-v-@LIBGUILE_I18N_MAJOR@.la
+lib_LTLIBRARIES = libguile.la
bin_PROGRAMS = guile
noinst_PROGRAMS = guile_filter_doc_snarfage gen-scmconfig
@@ -132,7 +131,6 @@ libguile_la_SOURCES = \
fluids.c \
fports.c \
frames.c \
- futures.c \
gc-malloc.c \
gc.c \
gdbint.c \
@@ -145,6 +143,7 @@ libguile_la_SOURCES = \
hash.c \
hashtab.c \
hooks.c \
+ i18n.c \
init.c \
inline.c \
instructions.c \
@@ -203,15 +202,6 @@ libguile_la_SOURCES = \
vports.c \
weaks.c
-libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
-libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
- $(libguile_la_CFLAGS)
-libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LIBADD = \
- libguile.la $(gnulib_library)
-libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
- -module -L$(builddir) -lguile \
- -version-info @LIBGUILE_I18N_INTERFACE@
-
DOT_X_FILES = \
alist.x \
arbiters.x \
@@ -239,7 +229,6 @@ DOT_X_FILES = \
feature.x \
fluids.x \
fports.x \
- futures.x \
gc-malloc.x \
gc.x \
gettext.x \
@@ -336,7 +325,6 @@ DOT_DOC_FILES = \
feature.doc \
fluids.doc \
fports.doc \
- futures.doc \
gc-malloc.doc \
gc.doc \
gettext.doc \
@@ -442,7 +430,11 @@ noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) $(LTLIBUNISTRING)
-libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
+libguile_la_LDFLAGS = \
+ @LTLIBINTL@ \
+ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ \
+ -export-dynamic -no-undefined \
+ $(GNU_LD_FLAGS)
if HAVE_LD_VERSION_SCRIPT
@@ -465,6 +457,7 @@ modinclude_HEADERS = \
arrays.h \
async.h \
backtrace.h \
+ bdw-gc.h \
boolean.h \
bitvectors.h \
bytevectors.h \
@@ -487,7 +480,6 @@ modinclude_HEADERS = \
fluids.h \
fports.h \
frames.h \
- futures.h \
gc.h \
gdb_interface.h \
gdbint.h \
@@ -605,6 +597,8 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status
@echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.tmp
@echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)"'>>libpath.tmp
@echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.tmp
+ @echo '#define SCM_LIB_DIR "$(libdir)"' >> libpath.tmp
+ @echo '#define SCM_EXTENSIONS_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions"' >> libpath.tmp
@echo '#define SCM_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache"' >> libpath.tmp
@echo '#define SCM_EFFECTIVE_VERSION "$(GUILE_EFFECTIVE_VERSION)"' >> libpath.tmp
@echo '#define SCM_BUILD_INFO { \' >> libpath.tmp
@@ -624,10 +618,11 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status
@echo ' { "infodir", "@infodir@" }, \' >> libpath.tmp
@echo ' { "mandir", "@mandir@" }, \' >> libpath.tmp
@echo ' { "includedir", "@includedir@" }, \' >> libpath.tmp
- @echo ' { "pkgdatadir", "@pkgdatadir@" }, \' >> libpath.tmp
- @echo ' { "pkglibdir", "@pkglibdir@" }, \' >> libpath.tmp
- @echo ' { "pkgincludedir", "@pkgincludedir@" }, \' \
+ @echo ' { "pkgdatadir", "$(pkgdatadir)" }, \' >> libpath.tmp
+ @echo ' { "pkglibdir", "$(pkglibdir)" }, \' >> libpath.tmp
+ @echo ' { "pkgincludedir", "$(pkgincludedir)" }, \' \
>> libpath.tmp
+ @echo ' { "extensionsdir", "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions" }, \' >> libpath.tmp
@echo ' { "guileversion", "@GUILE_VERSION@" }, \' >> libpath.tmp
@echo ' { "libguileinterface", "@LIBGUILE_INTERFACE@" }, \' \
>> libpath.tmp
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 32b52df51..8bb1b1a0e 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -104,11 +104,22 @@
* and then SCM_API marks them for export. */
#define SCM_INTERNAL extern
+/* The SCM_DEPRECATED macro is used in declarations of deprecated functions
+ * or variables. Defining `SCM_BUILDING_DEPRECATED_CODE' allows deprecated
+ * functions to be implemented in terms of deprecated functions, and allows
+ * deprecated functions to be referred to by `scm_c_define_gsubr ()'. */
+#if !defined (SCM_BUILDING_DEPRECATED_CODE) \
+ && defined (__GNUC__) && (__GNUC__ >= 3)
+# define SCM_DEPRECATED SCM_API __attribute__ ((__deprecated__))
+#else
+# define SCM_DEPRECATED SCM_API
+#endif
+
/* The SCM_ALIGNED macro, when defined, can be used to instruct the compiler
* to honor the given alignment constraint. */
-#if (defined __GNUC__)
+#if defined __GNUC__
# define SCM_ALIGNED(x) __attribute__ ((aligned (x)))
-#elif (defined __INTEL_COMPILER)
+#elif defined __INTEL_COMPILER
# define SCM_ALIGNED(x) __declspec (align (x))
#else
/* Don't know how to align things. */
@@ -491,11 +502,24 @@ typedef long SCM_STACKITEM;
#define SCM_STACK_PTR(ptr) ((SCM_STACKITEM *) (void *) (ptr))
-#define SCM_ASYNC_TICK /*fixme* should change names */ \
-do { \
- if (SCM_I_CURRENT_THREAD->pending_asyncs) \
- scm_async_click (); \
-} while (0)
+SCM_API void scm_async_tick (void);
+
+#ifdef BUILDING_LIBGUILE
+
+/* FIXME: should change names */
+# define SCM_ASYNC_TICK \
+ do \
+ { \
+ if (SCM_I_CURRENT_THREAD->pending_asyncs) \
+ scm_async_click (); \
+ } \
+ while (0)
+
+#else /* !BUILDING_LIBGUILE */
+
+# define SCM_ASYNC_TICK (scm_async_tick ())
+
+#endif /* !BUILDING_LIBGUILE */
/* Anthony Green writes:
@@ -665,6 +689,14 @@ SCM_API SCM scm_apply_generic (SCM gf, SCM args);
#define SCM_C_INLINE_KEYWORD
#endif
+/* Handling thread-local storage (TLS). */
+
+#ifdef SCM_HAVE_THREAD_STORAGE_CLASS
+# define SCM_THREAD_LOCAL __thread
+#else
+# define SCM_THREAD_LOCAL
+#endif
+
#endif /* SCM___SCM_H */
/*
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 9907adf24..6cb7ce8a4 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -173,7 +173,7 @@
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
-#define SCM_OBJCODE_MINOR_VERSION D
+#define SCM_OBJCODE_MINOR_VERSION L
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
diff --git a/libguile/array-map.c b/libguile/array-map.c
index fb9ceea37..eaac54a1f 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -37,7 +37,6 @@
#include "libguile/vectors.h"
#include "libguile/bitvectors.h"
#include "libguile/srfi-4.h"
-#include "libguile/dynwind.h"
#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"
@@ -78,6 +77,9 @@ static ra_iproc ra_asubrs[] =
{0, 0, 0}
};
+/* The WHAT argument for `scm_gc_malloc ()' et al. */
+static const char indices_gc_hint[] = "array-indices";
+
#define GVREF scm_c_generalized_vector_ref
#define GVSET scm_c_generalized_vector_set_x
@@ -311,10 +313,8 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
plvra = SCM_CDRLOC (*plvra);
}
- scm_dynwind_begin (0);
-
- vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra0));
- scm_dynwind_free (vinds);
+ vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra0),
+ indices_gc_hint);
for (k = 0; k <= kmax; k++)
vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
@@ -343,7 +343,6 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
}
while (k >= 0);
- scm_dynwind_end ();
return 1;
}
}
@@ -1015,10 +1014,8 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
if (kmax < 0)
return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
- scm_dynwind_begin (0);
-
- vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra));
- scm_dynwind_free (vinds);
+ vinds = scm_gc_malloc_pointerless (sizeof(long) * SCM_I_ARRAY_NDIM (ra),
+ indices_gc_hint);
for (k = 0; k <= kmax; k++)
vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
@@ -1050,7 +1047,6 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
}
while (k >= 0);
- scm_dynwind_end ();
return SCM_UNSPECIFIED;
}
else if (scm_is_generalized_vector (ra))
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 2be9ec3f0..8dc1d7888 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -211,7 +211,7 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
scm_t_array_dim *s;
SCM ra;
scm_t_array_handle h;
- void *base;
+ void *elts;
size_t sz;
ra = scm_i_shap2ra (bounds);
@@ -230,16 +230,28 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
scm_array_get_handle (ra, &h);
- base = scm_array_handle_uniform_writable_elements (&h);
- sz = scm_array_handle_uniform_element_size (&h);
+ elts = h.writable_elements;
+ sz = scm_array_handle_uniform_element_bit_size (&h);
scm_array_handle_release (&h);
- if (byte_len % sz)
- SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
- if (byte_len / sz != rlen)
- SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+ if (sz >= 8 && ((sz % 8) == 0))
+ {
+ if (byte_len % (sz / 8))
+ SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
+ if (byte_len / (sz / 8) != rlen)
+ SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+ }
+ else if (sz < 8)
+ {
+ /* byte_len ?= ceil (rlen * sz / 8) */
+ if (byte_len != (rlen * sz + 7) / 8)
+ SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+ }
+ else
+ /* an internal guile error, really */
+ SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
- memcpy (base, bytes, byte_len);
+ memcpy (elts, bytes, byte_len);
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
@@ -1087,22 +1099,6 @@ scm_i_read_array (SCM port, int c)
static SCM
-array_mark (SCM ptr)
-{
- return SCM_I_ARRAY_V (ptr);
-}
-
-static size_t
-array_free (SCM ptr)
-{
- scm_gc_free (SCM_I_ARRAY_MEM (ptr),
- (sizeof (scm_i_t_array)
- + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
- "array");
- return 0;
-}
-
-static SCM
array_handle_ref (scm_t_array_handle *h, size_t pos)
{
return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
@@ -1138,8 +1134,6 @@ void
scm_init_arrays ()
{
scm_i_tc16_array = scm_make_smob_type ("array", 0);
- scm_set_smob_mark (scm_i_tc16_array, array_mark);
- scm_set_smob_free (scm_i_tc16_array, array_free);
scm_set_smob_print (scm_i_tc16_array, scm_i_print_array);
scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p);
diff --git a/libguile/async.c b/libguile/async.c
index 3e5a581c6..664264f3c 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -22,6 +22,8 @@
# include <config.h>
#endif
+#define SCM_BUILDING_DEPRECATED_CODE
+
#include <signal.h>
#include "libguile/_scm.h"
#include "libguile/eval.h"
@@ -470,6 +472,29 @@ scm_dynwind_unblock_asyncs ()
scm_dynwind_unwind_handler (increase_block, t, SCM_F_WIND_EXPLICITLY);
}
+
+/* These are function variants of the same-named macros (uppercase) for use
+ outside of libguile. This is so that `SCM_I_CURRENT_THREAD', which may
+ reside in TLS, is not accessed from outside of libguile. It thus allows
+ libguile to be built with the "local-dynamic" TLS model. */
+
+void
+scm_critical_section_start (void)
+{
+ SCM_CRITICAL_SECTION_START;
+}
+
+void
+scm_critical_section_end (void)
+{
+ SCM_CRITICAL_SECTION_END;
+}
+
+void
+scm_async_tick (void)
+{
+ SCM_ASYNC_TICK;
+}
diff --git a/libguile/async.h b/libguile/async.h
index 427d9b4c8..ceb2b960b 100644
--- a/libguile/async.h
+++ b/libguile/async.h
@@ -3,7 +3,7 @@
#ifndef SCM_ASYNC_H
#define SCM_ASYNC_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -29,10 +29,6 @@
-#define scm_mask_ints (SCM_I_CURRENT_THREAD->block_asyncs != 0)
-
-
-
SCM_API void scm_async_click (void);
SCM_API void scm_switch (void);
SCM_API SCM scm_async (SCM thunk);
@@ -60,32 +56,42 @@ void scm_dynwind_unblock_asyncs (void);
the manual.
*/
-/* Defined in threads.c. scm_i_critical_section_level is only used
- for error checking and will go away eventually. */
-extern scm_i_pthread_mutex_t scm_i_critical_section_mutex;
-extern int scm_i_critical_section_level;
+/* Defined in threads.c. */
+SCM_INTERNAL scm_i_pthread_mutex_t scm_i_critical_section_mutex;
+
+SCM_API void scm_critical_section_start (void);
+SCM_API void scm_critical_section_end (void);
-#define SCM_CRITICAL_SECTION_START \
- do { \
- scm_i_pthread_mutex_lock (&scm_i_critical_section_mutex);\
- SCM_I_CURRENT_THREAD->block_asyncs++; \
- scm_i_critical_section_level++; \
+#ifdef BUILDING_LIBGUILE
+
+# define SCM_CRITICAL_SECTION_START \
+ do { \
+ scm_i_pthread_mutex_lock (&scm_i_critical_section_mutex); \
+ SCM_I_CURRENT_THREAD->block_asyncs++; \
+ SCM_I_CURRENT_THREAD->critical_section_level++; \
} while (0)
-#define SCM_CRITICAL_SECTION_END \
- do { \
- scm_i_critical_section_level--; \
- SCM_I_CURRENT_THREAD->block_asyncs--; \
+# define SCM_CRITICAL_SECTION_END \
+ do { \
+ SCM_I_CURRENT_THREAD->critical_section_level--; \
+ SCM_I_CURRENT_THREAD->block_asyncs--; \
scm_i_pthread_mutex_unlock (&scm_i_critical_section_mutex); \
- scm_async_click (); \
+ scm_async_click (); \
} while (0)
+#else /* !BUILDING_LIBGUILE */
+
+# define SCM_CRITICAL_SECTION_START scm_critical_section_start ()
+# define SCM_CRITICAL_SECTION_END scm_critical_section_end ()
+
+#endif /* !BUILDING_LIBGUILE */
+
SCM_INTERNAL void scm_init_async (void);
#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_API SCM scm_system_async (SCM thunk);
-SCM_API SCM scm_unmask_signals (void);
-SCM_API SCM scm_mask_signals (void);
+SCM_DEPRECATED SCM scm_system_async (SCM thunk);
+SCM_DEPRECATED SCM scm_unmask_signals (void);
+SCM_DEPRECATED SCM scm_mask_signals (void);
#endif
diff --git a/libguile/boehm-gc.h b/libguile/bdw-gc.h
index 9a92d08b2..3adf99e66 100644
--- a/libguile/boehm-gc.h
+++ b/libguile/bdw-gc.h
@@ -1,21 +1,22 @@
-#ifndef SCM_BOEHM_GC_H
-#define SCM_BOEHM_GC_H
+#ifndef SCM_BDW_GC_H
+#define SCM_BDW_GC_H
/* Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * 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
+ * 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
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
/* Correct header inclusion. */
@@ -61,4 +62,4 @@ typedef void *GC_PTR;
: 0)
-#endif /* SCM_BOEHM_GC_H */
+#endif /* SCM_BDW_GC_H */
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
index f1d8473d9..c3b6f3e4e 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -45,15 +45,6 @@ static scm_t_bits scm_tc16_bitvector;
#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
-static size_t
-bitvector_free (SCM vec)
-{
- scm_gc_free (BITVECTOR_BITS (vec),
- sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32),
- "bitvector");
- return 0;
-}
-
static int
bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
{
@@ -120,8 +111,8 @@ scm_c_make_bitvector (size_t len, SCM fill)
scm_t_uint32 *bits;
SCM res;
- bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len,
- "bitvector");
+ bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len,
+ "bitvector");
SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
if (!SCM_UNBNDP (fill))
@@ -896,7 +887,6 @@ void
scm_init_bitvectors ()
{
scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);
- scm_set_smob_free (scm_tc16_bitvector, bitvector_free);
scm_set_smob_print (scm_tc16_bitvector, bitvector_print);
scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp);
diff --git a/libguile/boolean.c b/libguile/boolean.c
index d79bf7979..d7091bbef 100644
--- a/libguile/boolean.c
+++ b/libguile/boolean.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -29,15 +29,37 @@
#include "libguile/lang.h"
#include "libguile/tags.h"
+#include "verify.h"
+
+/*
+ * These compile-time tests verify the properties needed for the
+ * efficient test macros defined in boolean.h, which are defined in
+ * terms of the SCM_MATCHES_BITS_IN_COMMON macro.
+ *
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
+ */
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_BOOL_F, SCM_BOOL_T));
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_ELISP_NIL, SCM_BOOL_F));
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_ELISP_NIL, SCM_EOL));
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
+ (SCM_ELISP_NIL, SCM_BOOL_F, SCM_BOOL_T, \
+ SCM_XXX_ANOTHER_BOOLEAN_DONT_USE));
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS \
+ (SCM_ELISP_NIL, SCM_BOOL_F, SCM_EOL, \
+ SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE));
SCM_DEFINE (scm_not, "not", 1, 0, 0,
(SCM x),
"Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}.")
#define FUNC_NAME s_scm_not
{
- return scm_from_bool (scm_is_false (x) || SCM_NILP (x));
+ return scm_from_bool (scm_is_false_or_nil (x));
}
#undef FUNC_NAME
@@ -47,19 +69,14 @@ SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0,
"Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}.")
#define FUNC_NAME s_scm_boolean_p
{
- return scm_from_bool (scm_is_bool (obj) || SCM_NILP (obj));
+ return scm_from_bool (scm_is_bool_or_nil (obj));
}
#undef FUNC_NAME
int
-scm_is_bool (SCM x)
-{
- return scm_is_eq (x, SCM_BOOL_F) || scm_is_eq (x, SCM_BOOL_T);
-}
-
-int
scm_to_bool (SCM x)
{
+ /* XXX Should this first test use scm_is_false_or_nil instead? */
if (scm_is_eq (x, SCM_BOOL_F))
return 0;
else if (scm_is_eq (x, SCM_BOOL_T))
diff --git a/libguile/boolean.h b/libguile/boolean.h
index 5a8379713..4c97a4933 100644
--- a/libguile/boolean.h
+++ b/libguile/boolean.h
@@ -3,7 +3,7 @@
#ifndef SCM_BOOLEAN_H
#define SCM_BOOLEAN_H
-/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -31,16 +31,97 @@
*
*/
+/*
+ * Use these macros if it's important (for correctness)
+ * that %nil MUST be considered true
+ */
+#define scm_is_false_and_not_nil(x) (scm_is_eq ((x), SCM_BOOL_F))
+#define scm_is_true_or_nil(x) (!scm_is_eq ((x), SCM_BOOL_F))
+
+/*
+ * Use these macros if %nil will never be tested,
+ * for increased efficiency.
+ */
+#define scm_is_false_assume_not_nil(x) (scm_is_eq ((x), SCM_BOOL_F))
+#define scm_is_true_assume_not_nil(x) (!scm_is_eq ((x), SCM_BOOL_F))
+
+/*
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information on
+ * how the following macro works.
+ */
+#if SCM_ENABLE_ELISP
+# define scm_is_false_or_nil(x) \
+ (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_ELISP_NIL, SCM_BOOL_F))
+#else
+# define scm_is_false_or_nil(x) (scm_is_false_assume_not_nil (x))
+#endif
+#define scm_is_true_and_not_nil(x) (!scm_is_false_or_nil (x))
-#define scm_is_false(x) scm_is_eq ((x), SCM_BOOL_F)
-#define scm_is_true(x) !scm_is_false (x)
+/* XXX Should these macros treat %nil as false by default? */
+#define scm_is_false(x) (scm_is_false_and_not_nil (x))
+#define scm_is_true(x) (!scm_is_false (x))
+
+/*
+ * Since we know SCM_BOOL_F and SCM_BOOL_T differ by exactly one bit,
+ * and that SCM_BOOL_F and SCM_ELISP_NIL differ by exactly one bit,
+ * and that they of course can't be the same bit (or else SCM_BOOL_T
+ * and SCM_ELISP_NIL be would equal), it follows that SCM_BOOL_T and
+ * SCM_ELISP_NIL differ by exactly two bits, and these are the bits
+ * which will be ignored by SCM_MATCHES_BITS_IN_COMMON below.
+ *
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
+ *
+ * If SCM_ENABLE_ELISP is true, then scm_is_bool_or_nil(x)
+ * returns 1 if and only if x is one of the following: SCM_BOOL_F,
+ * SCM_BOOL_T, SCM_ELISP_NIL, or SCM_XXX_ANOTHER_BOOLEAN_DONT_USE.
+ * Otherwise, it returns 0.
+ */
+#if SCM_ENABLE_ELISP
+# define scm_is_bool_or_nil(x) \
+ (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_BOOL_T, SCM_ELISP_NIL))
+#else
+# define scm_is_bool_or_nil(x) (scm_is_bool_and_not_nil (x))
+#endif
+
+#define scm_is_bool_and_not_nil(x) \
+ (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_BOOL_F, SCM_BOOL_T))
+
+/* XXX Should scm_is_bool treat %nil as a boolean? */
+#define scm_is_bool(x) (scm_is_bool_and_not_nil (x))
-SCM_API int scm_is_bool (SCM x);
#define scm_from_bool(x) ((x) ? SCM_BOOL_T : SCM_BOOL_F)
SCM_API int scm_to_bool (SCM x);
+/*
+ * The following macros efficiently implement boolean truth testing as
+ * expected by most lisps, which treat '() aka SCM_EOL as false.
+ *
+ * Since we know SCM_ELISP_NIL and SCM_BOOL_F differ by exactly one
+ * bit, and that SCM_ELISP_NIL and SCM_EOL differ by exactly one bit,
+ * and that they of course can't be the same bit (or else SCM_BOOL_F
+ * and SCM_EOL be would equal), it follows that SCM_BOOL_F and SCM_EOL
+ * differ by exactly two bits, and these are the bits which will be
+ * ignored by SCM_MATCHES_BITS_IN_COMMON below.
+ *
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
+ *
+ * scm_is_lisp_false(x) returns 1 if and only if x is one of the
+ * following: SCM_BOOL_F, SCM_ELISP_NIL, SCM_EOL or
+ * SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE. Otherwise, it returns 0.
+ */
+#if SCM_ENABLE_ELISP
+# define scm_is_lisp_false(x) \
+ (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_BOOL_F, SCM_EOL))
+# define scm_is_lisp_true(x) (!scm_is_lisp_false(x))
+#endif
+
+
+
SCM_API SCM scm_not (SCM x);
SCM_API SCM scm_boolean_p (SCM obj);
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 4246f0111..ce5fa962f 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -22,6 +22,7 @@
#endif
#include <alloca.h>
+#include <assert.h>
#include <gmp.h>
@@ -39,6 +40,7 @@
#include <byteswap.h>
#include <striconveh.h>
#include <uniconv.h>
+#include <unistr.h>
#ifdef HAVE_LIMITS_H
# include <limits.h>
@@ -587,23 +589,31 @@ SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
#define FUNC_NAME s_scm_uniform_array_to_bytevector
{
SCM contents, ret;
- size_t len;
+ size_t len, sz, byte_len;
scm_t_array_handle h;
- const void *base;
- size_t sz;
+ const void *elts;
contents = scm_array_contents (array, SCM_BOOL_T);
if (scm_is_false (contents))
scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
scm_array_get_handle (contents, &h);
+ assert (h.base == 0);
- base = scm_array_handle_uniform_elements (&h);
+ elts = h.elements;
len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
- sz = scm_array_handle_uniform_element_size (&h);
+ sz = scm_array_handle_uniform_element_bit_size (&h);
+ if (sz >= 8 && ((sz % 8) == 0))
+ byte_len = len * (sz / 8);
+ else if (sz < 8)
+ /* byte_len = ceil (len * sz / 8) */
+ byte_len = (len * sz + 7) / 8;
+ else
+ /* an internal guile error, really */
+ SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
- ret = make_bytevector (len * sz, SCM_ARRAY_ELEMENT_TYPE_VU8);
- memcpy (SCM_BYTEVECTOR_CONTENTS (ret), base, len * sz);
+ ret = make_bytevector (byte_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (ret), elts, byte_len);
scm_array_handle_release (&h);
@@ -1862,58 +1872,50 @@ utf_encoding_name (char *name, size_t utf_width, SCM endianness)
#define MAX_UTF_ENCODING_NAME_LEN 16
/* Produce the body of a `string->utf' function. */
-#define STRING_TO_UTF(_utf_width) \
- SCM utf; \
- int err; \
- char *c_str; \
- char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
- char *c_utf = NULL, *c_locale; \
- size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
- \
- SCM_VALIDATE_STRING (1, str); \
- if (endianness == SCM_UNDEFINED) \
- endianness = scm_sym_big; \
- else \
- SCM_VALIDATE_SYMBOL (2, endianness); \
- \
- c_strlen = scm_c_string_length (str); \
- c_raw_strlen = c_strlen * ((_utf_width) / 8); \
- do \
- { \
- c_str = (char *) alloca (c_raw_strlen + 1); \
- c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
- } \
- while (c_raw_strlen > c_strlen); \
- c_str[c_raw_strlen] = '\0'; \
- \
- utf_encoding_name (c_utf_name, (_utf_width), endianness); \
- \
- c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
- strcpy (c_locale, locale_charset ()); \
- \
- err = mem_iconveh (c_str, c_raw_strlen, \
- c_locale, c_utf_name, \
- iconveh_question_mark, NULL, \
- &c_utf, &c_utf_len); \
- if (SCM_UNLIKELY (err)) \
- scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
- scm_list_1 (str), err); \
- else \
- { \
- /* C_UTF is null-terminated. It is malloc(3)-allocated, so we cannot \
- use `scm_c_take_bytevector ()'. */ \
- scm_dynwind_begin (0); \
- scm_dynwind_free (c_utf); \
- \
- utf = make_bytevector (c_utf_len, \
- SCM_ARRAY_ELEMENT_TYPE_VU8); \
- memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, \
- c_utf_len); \
- \
- scm_dynwind_end (); \
- } \
- \
- return (utf);
+#define STRING_TO_UTF(_utf_width) \
+ SCM utf; \
+ int err; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ char *c_utf = NULL; \
+ size_t c_strlen, c_utf_len = 0; \
+ \
+ SCM_VALIDATE_STRING (1, str); \
+ if (endianness == SCM_UNDEFINED) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_strlen = scm_i_string_length (str); \
+ if (scm_i_is_narrow_string (str)) \
+ { \
+ err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
+ "ISO-8859-1", c_utf_name, \
+ iconveh_question_mark, NULL, \
+ &c_utf, &c_utf_len); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
+ scm_list_1 (str), err); \
+ } \
+ else \
+ { \
+ const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
+ c_utf = u32_conv_to_encoding (c_utf_name, \
+ iconveh_question_mark, \
+ (scm_t_uint32 *) wbuf, \
+ c_strlen, NULL, NULL, &c_utf_len); \
+ if (SCM_UNLIKELY (c_utf == NULL)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
+ scm_list_1 (str), errno); \
+ } \
+ scm_dynwind_begin (0); \
+ scm_dynwind_free (c_utf); \
+ utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8); \
+ memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len); \
+ scm_dynwind_end (); \
+ \
+ return (utf);
@@ -1925,36 +1927,30 @@ SCM_DEFINE (scm_string_to_utf8, "string->utf8",
#define FUNC_NAME s_scm_string_to_utf8
{
SCM utf;
- char *c_str;
uint8_t *c_utf;
- size_t c_strlen, c_raw_strlen;
+ size_t c_strlen, c_utf_len = 0;
SCM_VALIDATE_STRING (1, str);
- c_strlen = scm_c_string_length (str);
- c_raw_strlen = c_strlen;
- do
+ c_strlen = scm_i_string_length (str);
+ if (scm_i_is_narrow_string (str))
+ c_utf = u8_conv_from_encoding ("ISO-8859-1", iconveh_question_mark,
+ scm_i_string_chars (str), c_strlen,
+ NULL, NULL, &c_utf_len);
+ else
{
- c_str = (char *) alloca (c_raw_strlen + 1);
- c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen);
+ const scm_t_wchar *wbuf = scm_i_string_wide_chars (str);
+ c_utf = u32_to_u8 ((const uint32_t *) wbuf, c_strlen, NULL, &c_utf_len);
}
- while (c_raw_strlen > c_strlen);
- c_str[c_raw_strlen] = '\0';
-
- c_utf = u8_strconv_from_locale (c_str);
if (SCM_UNLIKELY (c_utf == NULL))
scm_syserror (FUNC_NAME);
else
{
- /* C_UTF is null-terminated. It is malloc(3)-allocated, so we cannot
- use `scm_c_take_bytevector ()'. */
scm_dynwind_begin (0);
scm_dynwind_free (c_utf);
- utf = make_bytevector (UTF_STRLEN (8, c_utf),
- SCM_ARRAY_ELEMENT_TYPE_VU8);
- memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf,
- UTF_STRLEN (8, c_utf));
+ utf = make_bytevector (c_utf_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, c_utf_len);
scm_dynwind_end ();
}
@@ -1991,10 +1987,10 @@ SCM_DEFINE (scm_string_to_utf32, "string->utf32",
#define UTF_TO_STRING(_utf_width) \
SCM str = SCM_BOOL_F; \
int err; \
- char *c_str = NULL, *c_locale; \
+ char *c_str = NULL; \
char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
- const char *c_utf; \
- size_t c_strlen = 0, c_utf_len; \
+ char *c_utf; \
+ size_t c_strlen = 0, c_utf_len = 0; \
\
SCM_VALIDATE_BYTEVECTOR (1, utf); \
if (endianness == SCM_UNDEFINED) \
@@ -2006,20 +2002,19 @@ SCM_DEFINE (scm_string_to_utf32, "string->utf32",
c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
utf_encoding_name (c_utf_name, (_utf_width), endianness); \
\
- c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
- strcpy (c_locale, locale_charset ()); \
- \
err = mem_iconveh (c_utf, c_utf_len, \
- c_utf_name, c_locale, \
+ c_utf_name, "UTF-8", \
iconveh_question_mark, NULL, \
&c_str, &c_strlen); \
if (SCM_UNLIKELY (err)) \
scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
scm_list_1 (utf), err); \
else \
- /* C_STR is null-terminated. */ \
- str = scm_take_locale_stringn (c_str, c_strlen); \
- \
+ { \
+ str = scm_from_stringn (c_str, c_strlen, "UTF-8", \
+ SCM_FAILED_CONVERSION_ERROR); \
+ free (c_str); \
+ } \
return (str);
@@ -2031,29 +2026,15 @@ SCM_DEFINE (scm_utf8_to_string, "utf8->string",
#define FUNC_NAME s_scm_utf8_to_string
{
SCM str;
- int err;
- char *c_str = NULL, *c_locale;
const char *c_utf;
- size_t c_utf_len, c_strlen = 0;
+ size_t c_utf_len = 0;
SCM_VALIDATE_BYTEVECTOR (1, utf);
c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
-
- c_locale = (char *) alloca (strlen (locale_charset ()) + 1);
- strcpy (c_locale, locale_charset ());
-
c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
- err = mem_iconveh (c_utf, c_utf_len,
- "UTF-8", c_locale,
- iconveh_question_mark, NULL,
- &c_str, &c_strlen);
- if (SCM_UNLIKELY (err))
- scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A",
- scm_list_1 (utf), err);
- else
- /* C_STR is null-terminated. */
- str = scm_take_locale_stringn (c_str, c_strlen);
+ str = scm_from_stringn (c_utf, c_utf_len, "UTF-8",
+ SCM_FAILED_CONVERSION_ERROR);
return (str);
}
@@ -2081,7 +2062,6 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
}
#undef FUNC_NAME
-
/* Bytevectors as generalized vectors & arrays. */
diff --git a/libguile/chars.c b/libguile/chars.c
index c7cb09c47..59ac6f412 100644
--- a/libguile/chars.c
+++ b/libguile/chars.c
@@ -45,7 +45,8 @@ SCM_DEFINE (scm_char_p, "char?", 1, 0, 0,
SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}.")
+ "Return @code{#t} if the Unicode code point of @var{x} is equal to the\n"
+ "code point of @var{y}, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_eq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -57,8 +58,8 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is less than @var{y} in the Unicode sequence,\n"
- "else @code{#f}.")
+ "Return @code{#t} iff the code point of @var{x} is less than the code\n"
+ "point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_less_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -69,8 +70,8 @@ SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
- "Unicode sequence, else @code{#f}.")
+ "Return @code{#t} if the Unicode code point of @var{x} is less than or\n"
+ "equal to the code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_leq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -81,8 +82,8 @@ SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is greater than @var{y} in the Unicode\n"
- "sequence, else @code{#f}.")
+ "Return @code{#t} if the Unicode code point of @var{x} is greater than\n"
+ "the code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_gr_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -93,8 +94,8 @@ SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
- "Unicode sequence, else @code{#f}.")
+ "Return @code{#t} if the Unicode code point of @var{x} is greater than\n"
+ "or equal to the code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_geq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -103,10 +104,17 @@ SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
}
#undef FUNC_NAME
+/* FIXME?: R6RS specifies that these comparisons are case-folded.
+ This is the same thing as comparing the uppercase characters in
+ practice, but, not in theory. Unicode has table containing their
+ definition of case-folded character mappings. A more correct
+ implementation would be to use that table and make a char-foldcase
+ function. */
+
SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n"
- "case, else @code{#f}. Case is locale free and not context sensitive.")
+ "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n"
+ "the same as the case-folded code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_ci_eq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -117,9 +125,8 @@ SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff the Unicode uppercase form of @var{x} is less\n"
- "than the Unicode uppercase form @var{y} in the Unicode sequence,\n"
- "else @code{#f}.")
+ "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n"
+ "less than the case-folded code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_ci_less_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -130,9 +137,9 @@ SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff the Unicode uppercase form of @var{x} is less\n"
- "than or equal to the Unicode uppercase form of @var{y} in the\n"
- "Unicode sequence, else @code{#f}.")
+ "Return @code{#t} iff the case-folded Unicodd code point of @var{x} is\n"
+ "less than or equal to the case-folded code point of @var{y}, else\n"
+ "@code{#f}")
#define FUNC_NAME s_scm_char_ci_leq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -143,9 +150,8 @@ SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n"
- "than the Unicode uppercase form of @var{y} in the Unicode\n"
- "sequence, else @code{#f}.")
+ "Return @code{#t} iff the case-folded code point of @var{x} is greater\n"
+ "than the case-folded code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_char_ci_gr_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -156,9 +162,9 @@ SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n"
- "than or equal to the Unicode uppercase form of @var{y} in the\n"
- "Unicode sequence, else @code{#f}.")
+ "Return @code{#t} iff the case-folded Unicode code point of @var{x} is\n"
+ "greater than or equal to the case-folded code point of @var{y}, else\n"
+ "@code{#f}.")
#define FUNC_NAME s_scm_char_ci_geq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -196,7 +202,6 @@ SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0,
#undef FUNC_NAME
-
SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0,
(SCM chr),
"Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.\n")
@@ -217,10 +222,10 @@ SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0,
#undef FUNC_NAME
-
SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0,
(SCM chr),
- "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}.\n")
+ "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else\n"
+ "@code{#f}.\n")
#define FUNC_NAME s_scm_char_is_both_p
{
if (scm_is_true (scm_char_set_contains_p (scm_char_set_lower_case, chr)))
@@ -230,12 +235,9 @@ SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0,
#undef FUNC_NAME
-
-
SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
(SCM chr),
- "Return the number corresponding to ordinal position of @var{chr} in the\n"
- "ASCII sequence.")
+ "Return the Unicode code point of @var{chr}.")
#define FUNC_NAME s_scm_char_to_integer
{
SCM_VALIDATE_CHAR (1, chr);
@@ -244,10 +246,12 @@ SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
#undef FUNC_NAME
-
SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
(SCM n),
- "Return the character at position @var{n} in the ASCII sequence.")
+ "Return the character that has Unicode code point @var{n}. The integer\n"
+ "@var{n} must be a valid code point. Valid code points are in the\n"
+ "ranges 0 to @code{#xD7FF} inclusive or @code{#xE000} to\n"
+ "@code{#x10FFFF} inclusive.")
#define FUNC_NAME s_scm_integer_to_char
{
scm_t_wchar cn;
diff --git a/libguile/chars.h b/libguile/chars.h
index 85b16739a..04eb9f09f 100644
--- a/libguile/chars.h
+++ b/libguile/chars.h
@@ -47,10 +47,15 @@ typedef scm_t_int32 scm_t_wchar;
? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char) \
: SCM_MAKE_ITAG8 ((scm_t_bits) (x), scm_tc8_char))
+#define SCM_CODEPOINT_DOTTED_CIRCLE (0x25cc)
+#define SCM_CODEPOINT_SURROGATE_START (0xd800)
+#define SCM_CODEPOINT_SURROGATE_END (0xdfff)
#define SCM_CODEPOINT_MAX (0x10ffff)
#define SCM_IS_UNICODE_CHAR(c) \
- ((scm_t_wchar) (c) <= 0xd7ff \
- || ((scm_t_wchar) (c) >= 0xe000 && (scm_t_wchar) (c) <= SCM_CODEPOINT_MAX))
+ (((scm_t_wchar) (c) >= 0 \
+ && (scm_t_wchar) (c) < SCM_CODEPOINT_SURROGATE_START) \
+ || ((scm_t_wchar) (c) > SCM_CODEPOINT_SURROGATE_END \
+ && (scm_t_wchar) (c) <= SCM_CODEPOINT_MAX))
diff --git a/libguile/continuations.c b/libguile/continuations.c
index aa1fb334e..a0e2f6d4f 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -225,7 +225,7 @@ scm_dynthrow (SCM cont, SCM val)
SCM_STACKITEM *dst = thread->continuation_base;
SCM_STACKITEM stack_top_element;
- if (scm_i_critical_section_level)
+ if (thread->critical_section_level)
{
fprintf (stderr, "continuation invoked from within critical section.\n");
abort ();
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index d0669969c..df7ba4dc6 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -24,6 +24,8 @@
# include <config.h>
#endif
+#define SCM_BUILDING_DEPRECATED_CODE
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/deprecated.h"
@@ -633,6 +635,21 @@ scm_set_smob_mfpe (long tc,
if (equalp) scm_set_smob_equalp (tc, equalp);
}
+size_t
+scm_smob_free (SCM obj)
+{
+ long n = SCM_SMOBNUM (obj);
+
+ scm_c_issue_deprecation_warning
+ ("`scm_smob_free' is deprecated. "
+ "It is no longer needed.");
+
+ if (scm_smobs[n].size > 0)
+ scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
+ scm_smobs[n].size, SCM_SMOBNAME (n));
+ return 0;
+}
+
SCM
scm_read_0str (char *expr)
{
@@ -1450,6 +1467,14 @@ scm_i_defer_ints_etc ()
"Use a mutex instead if appropriate.");
}
+int
+scm_i_mask_ints (void)
+{
+ scm_c_issue_deprecation_warning ("`scm_mask_ints' is deprecated.");
+ return (SCM_I_CURRENT_THREAD->block_asyncs != 0);
+}
+
+
SCM
scm_guard (SCM guardian, SCM obj, int throw_p)
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index f428f7de8..5680d09e5 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -67,13 +67,13 @@ SCM_API char *scm_isymnames[];
/* From eval.h: Error messages of the evaluator. These were deprecated in
* guile 1.7.0 on 2003-06-02. */
-SCM_API const char scm_s_expression[];
-SCM_API const char scm_s_test[];
-SCM_API const char scm_s_body[];
-SCM_API const char scm_s_bindings[];
-SCM_API const char scm_s_variable[];
-SCM_API const char scm_s_clauses[];
-SCM_API const char scm_s_formals[];
+SCM_DEPRECATED const char scm_s_expression[];
+SCM_DEPRECATED const char scm_s_test[];
+SCM_DEPRECATED const char scm_s_body[];
+SCM_DEPRECATED const char scm_s_bindings[];
+SCM_DEPRECATED const char scm_s_variable[];
+SCM_DEPRECATED const char scm_s_clauses[];
+SCM_DEPRECATED const char scm_s_formals[];
/* From eval.h: Helper macros for evaluation and application. These were
@@ -97,18 +97,18 @@ SCM_API const char scm_s_formals[];
#define scm_sizet size_t
-SCM_API SCM scm_wta (SCM arg, const char *pos, const char *s_subr);
+SCM_DEPRECATED SCM scm_wta (SCM arg, const char *pos, const char *s_subr);
#define SCM_WNA 8
#define SCM_OUTOFRANGE 10
#define SCM_NALLOC 11
-SCM_API void scm_register_module_xxx (char *module_name, void *init_func);
-SCM_API SCM scm_registered_modules (void);
-SCM_API SCM scm_clear_registered_modules (void);
+SCM_DEPRECATED void scm_register_module_xxx (char *module_name, void *init_func);
+SCM_DEPRECATED SCM scm_registered_modules (void);
+SCM_DEPRECATED SCM scm_clear_registered_modules (void);
-SCM_API SCM scm_protect_object (SCM obj);
-SCM_API SCM scm_unprotect_object (SCM obj);
+SCM_DEPRECATED SCM scm_protect_object (SCM obj);
+SCM_DEPRECATED SCM scm_unprotect_object (SCM obj);
#define SCM_SETAND_CAR(x, y) \
(SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y))))
@@ -120,23 +120,20 @@ SCM_API SCM scm_unprotect_object (SCM obj);
(SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y))))
#define SCM_FREEP(x) (0)
#define SCM_NFREEP(x) (1)
-#define SCM_GC8MARKP(x) SCM_GC_MARK_P (x)
-#define SCM_SETGC8MARK(x) SCM_SET_GC_MARK (x)
-#define SCM_CLRGC8MARK(x) SCM_CLEAR_GC_MARK (x)
#define SCM_GCTYP16(x) SCM_TYP16 (x)
#define SCM_GCCDR(x) SCM_CDR (x)
-SCM_API void scm_remember (SCM * ptr);
+SCM_DEPRECATED void scm_remember (SCM * ptr);
-SCM_API SCM scm_the_root_module (void);
-SCM_API SCM scm_make_module (SCM name);
-SCM_API SCM scm_ensure_user_module (SCM name);
-SCM_API SCM scm_load_scheme_module (SCM name);
+SCM_DEPRECATED SCM scm_the_root_module (void);
+SCM_DEPRECATED SCM scm_make_module (SCM name);
+SCM_DEPRECATED SCM scm_ensure_user_module (SCM name);
+SCM_DEPRECATED SCM scm_load_scheme_module (SCM name);
#define scm_port scm_t_port
#define scm_ptob_descriptor scm_t_ptob_descriptor
#define scm_port_rw_active scm_t_port_rw_active
-SCM_API SCM scm_close_all_ports_except (SCM ports);
+SCM_DEPRECATED SCM scm_close_all_ports_except (SCM ports);
#define scm_rstate scm_t_rstate
#define scm_rng scm_t_rng
@@ -148,25 +145,27 @@ SCM_API SCM scm_close_all_ports_except (SCM ports);
#define scm_tc7_msymbol scm_tc7_symbol
#define scm_tcs_symbols scm_tc7_symbol
-SCM_API SCM scm_makstr (size_t len, int);
-SCM_API SCM scm_makfromstr (const char *src, size_t len, int);
+SCM_DEPRECATED SCM scm_makstr (size_t len, int);
+SCM_DEPRECATED SCM scm_makfromstr (const char *src, size_t len, int);
-SCM_API SCM scm_variable_set_name_hint (SCM var, SCM hint);
-SCM_API SCM scm_builtin_variable (SCM name);
+SCM_DEPRECATED SCM scm_variable_set_name_hint (SCM var, SCM hint);
+SCM_DEPRECATED SCM scm_builtin_variable (SCM name);
-SCM_API SCM scm_internal_with_fluids (SCM fluids, SCM vals,
- SCM (*cproc)(void *), void *cdata);
+SCM_DEPRECATED SCM scm_internal_with_fluids (SCM fluids, SCM vals,
+ SCM (*cproc)(void *),
+ void *cdata);
-SCM_API SCM scm_make_gsubr (const char *name, int req, int opt, int rst,
- SCM (*fcn)());
-SCM_API SCM scm_make_gsubr_with_generic (const char *name,
- int req,
- int opt,
- int rst,
- SCM (*fcn)(),
- SCM *gf);
+SCM_DEPRECATED SCM scm_make_gsubr (const char *name,
+ int req, int opt, int rst,
+ SCM (*fcn)());
+SCM_DEPRECATED SCM scm_make_gsubr_with_generic (const char *name,
+ int req,
+ int opt,
+ int rst,
+ SCM (*fcn)(),
+ SCM *gf);
-SCM_API SCM scm_create_hook (const char* name, int n_args);
+SCM_DEPRECATED SCM scm_create_hook (const char* name, int n_args);
#define SCM_LIST0 SCM_EOL
#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
@@ -188,76 +187,78 @@ SCM_API SCM scm_create_hook (const char* name, int n_args);
#define scm_listify scm_list_n
-SCM_API SCM scm_sloppy_memq (SCM x, SCM lst);
-SCM_API SCM scm_sloppy_memv (SCM x, SCM lst);
-SCM_API SCM scm_sloppy_member (SCM x, SCM lst);
+SCM_DEPRECATED SCM scm_sloppy_memq (SCM x, SCM lst);
+SCM_DEPRECATED SCM scm_sloppy_memv (SCM x, SCM lst);
+SCM_DEPRECATED SCM scm_sloppy_member (SCM x, SCM lst);
-SCM_API SCM scm_read_and_eval_x (SCM port);
+SCM_DEPRECATED SCM scm_read_and_eval_x (SCM port);
#define scm_subr_entry scm_t_subr_entry
#define SCM_SUBR_DOC(x) SCM_BOOL_F
-SCM_API SCM scm_make_subr (const char *name, int type, SCM (*fcn) ());
-SCM_API SCM scm_make_subr_with_generic (const char *name,
- int type,
- SCM (*fcn) (),
- SCM *gf);
-SCM_API SCM scm_make_subr_opt (const char *name,
- int type,
- SCM (*fcn) (),
- int set);
-
-SCM_API SCM scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(),
- void * closure);
-
-SCM_API long scm_make_smob_type_mfpe (char *name, size_t size,
- SCM (*mark) (SCM),
- size_t (*free) (SCM),
- int (*print) (SCM, SCM,
- scm_print_state*),
- SCM (*equalp) (SCM, SCM));
-
-SCM_API void scm_set_smob_mfpe (long tc,
- SCM (*mark) (SCM),
- size_t (*free) (SCM),
- int (*print) (SCM, SCM, scm_print_state*),
- SCM (*equalp) (SCM, SCM));
-
-SCM_API SCM scm_strprint_obj (SCM obj);
-SCM_API SCM scm_read_0str (char *expr);
-SCM_API SCM scm_eval_0str (const char *expr);
-
-SCM_API char *scm_i_object_chars (SCM);
+SCM_DEPRECATED SCM scm_make_subr (const char *name, int type, SCM (*fcn) ());
+SCM_DEPRECATED SCM scm_make_subr_with_generic (const char *name,
+ int type,
+ SCM (*fcn) (),
+ SCM *gf);
+SCM_DEPRECATED SCM scm_make_subr_opt (const char *name,
+ int type,
+ SCM (*fcn) (),
+ int set);
+
+SCM_DEPRECATED SCM scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(),
+ void * closure);
+
+SCM_DEPRECATED long scm_make_smob_type_mfpe (char *name, size_t size,
+ SCM (*mark) (SCM),
+ size_t (*free) (SCM),
+ int (*print) (SCM, SCM,
+ scm_print_state*),
+ SCM (*equalp) (SCM, SCM));
+
+SCM_DEPRECATED void scm_set_smob_mfpe (long tc,
+ SCM (*mark) (SCM),
+ size_t (*free) (SCM),
+ int (*print) (SCM, SCM, scm_print_state*),
+ SCM (*equalp) (SCM, SCM));
+
+SCM_DEPRECATED size_t scm_smob_free (SCM obj);
+
+SCM_DEPRECATED SCM scm_strprint_obj (SCM obj);
+SCM_DEPRECATED SCM scm_read_0str (char *expr);
+SCM_DEPRECATED SCM scm_eval_0str (const char *expr);
+
+SCM_DEPRECATED char *scm_i_object_chars (SCM);
#define SCM_CHARS(x) scm_i_object_chars(x)
#define SCM_UCHARS(x) ((unsigned char *)SCM_CHARS(x))
-SCM_API long scm_i_object_length (SCM);
+SCM_DEPRECATED long scm_i_object_length (SCM);
#define SCM_LENGTH(x) scm_i_object_length(x)
#define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n))
-SCM_API SCM scm_sym2ovcell_soft (SCM sym, SCM obarray);
-SCM_API SCM scm_sym2ovcell (SCM sym, SCM obarray);
-SCM_API SCM scm_intern_obarray_soft (const char *name, size_t len,
+SCM_DEPRECATED SCM scm_sym2ovcell_soft (SCM sym, SCM obarray);
+SCM_DEPRECATED SCM scm_sym2ovcell (SCM sym, SCM obarray);
+SCM_DEPRECATED SCM scm_intern_obarray_soft (const char *name, size_t len,
SCM obarray, unsigned int softness);
-SCM_API SCM scm_intern_obarray (const char *name, size_t len, SCM obarray);
-SCM_API SCM scm_symbol_value0 (const char *name);
+SCM_DEPRECATED SCM scm_intern_obarray (const char *name, size_t len, SCM obarray);
+SCM_DEPRECATED SCM scm_symbol_value0 (const char *name);
-SCM_API SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp);
-SCM_API SCM scm_intern_symbol (SCM o, SCM s);
-SCM_API SCM scm_unintern_symbol (SCM o, SCM s);
-SCM_API SCM scm_symbol_binding (SCM o, SCM s);
+SCM_DEPRECATED SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp);
+SCM_DEPRECATED SCM scm_intern_symbol (SCM o, SCM s);
+SCM_DEPRECATED SCM scm_unintern_symbol (SCM o, SCM s);
+SCM_DEPRECATED SCM scm_symbol_binding (SCM o, SCM s);
#if 0
/* This name has been reused for real uninterned symbols. */
-SCM_API SCM scm_symbol_interned_p (SCM o, SCM s);
+SCM_DEPRECATED SCM scm_symbol_interned_p (SCM o, SCM s);
#endif
-SCM_API SCM scm_symbol_bound_p (SCM o, SCM s);
-SCM_API SCM scm_symbol_set_x (SCM o, SCM s, SCM v);
+SCM_DEPRECATED SCM scm_symbol_bound_p (SCM o, SCM s);
+SCM_DEPRECATED SCM scm_symbol_set_x (SCM o, SCM s, SCM v);
-SCM_API SCM scm_gentemp (SCM prefix, SCM obarray);
+SCM_DEPRECATED SCM scm_gentemp (SCM prefix, SCM obarray);
#define SCM_OPDIRP(x) (SCM_DIRP (x) && (SCM_DIR_OPEN_P (x)))
#define scm_fport scm_t_fport
@@ -310,9 +311,9 @@ SCM_API SCM scm_gentemp (SCM prefix, SCM obarray);
/* Users shouldn't know about INUMs.
*/
-SCM_API SCM scm_i_makinum (scm_t_signed_bits val);
-SCM_API int scm_i_inump (SCM obj);
-SCM_API scm_t_signed_bits scm_i_inum (SCM obj);
+SCM_DEPRECATED SCM scm_i_makinum (scm_t_signed_bits val);
+SCM_DEPRECATED int scm_i_inump (SCM obj);
+SCM_DEPRECATED scm_t_signed_bits scm_i_inum (SCM obj);
#define SCM_MAKINUM(x) scm_i_makinum(x)
#define SCM_INUM(x) scm_i_inum(x)
@@ -405,7 +406,7 @@ SCM_API scm_t_signed_bits scm_i_inum (SCM obj);
copies the complete contents of OBJ, and sets *LENP to the length of the
scheme string (if LENP is non-null).
*/
-SCM_API char *scm_c_string2str (SCM obj, char *str, size_t *lenp);
+SCM_DEPRECATED char *scm_c_string2str (SCM obj, char *str, size_t *lenp);
/* XXX - buggy interface, you don't know how many bytes have been copied.
@@ -417,15 +418,15 @@ SCM_API char *scm_c_string2str (SCM obj, char *str, size_t *lenp);
region to fit the string. If truncation occurs, the corresponding
area of STR is left unchanged.
*/
-SCM_API char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len);
+SCM_DEPRECATED char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len);
-SCM_API char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp);
+SCM_DEPRECATED char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp);
/* Deprecated because the names belong to what is now
scm_truncate_number and scm_round_number.
*/
-SCM_API double scm_truncate (double x);
-SCM_API double scm_round (double x);
+SCM_DEPRECATED double scm_truncate (double x);
+SCM_DEPRECATED double scm_round (double x);
/* Deprecated because we don't want people to access the internal
representation of strings directly.
@@ -459,8 +460,8 @@ SCM_API double scm_round (double x);
symbols directly.
*/
-SCM_API char *scm_i_deprecated_symbol_chars (SCM sym);
-SCM_API size_t scm_i_deprecated_symbol_length (SCM sym);
+SCM_DEPRECATED char *scm_i_deprecated_symbol_chars (SCM sym);
+SCM_DEPRECATED size_t scm_i_deprecated_symbol_length (SCM sym);
#define SCM_SYMBOL_CHARS(x) scm_i_deprecated_symbol_chars(x)
#define SCM_SYMBOL_LENGTH(x) scm_i_deprecated_symbol_length(x)
@@ -469,8 +470,8 @@ SCM_API size_t scm_i_deprecated_symbol_length (SCM sym);
than once and because the symbol of a keyword now has no dash.
*/
-SCM_API int scm_i_keywordp (SCM obj);
-SCM_API SCM scm_i_keywordsym (SCM keyword);
+SCM_DEPRECATED int scm_i_keywordp (SCM obj);
+SCM_DEPRECATED SCM scm_i_keywordsym (SCM keyword);
#define SCM_KEYWORDP(x) scm_i_keywordp(x)
#define SCM_KEYWORDSYM(x) scm_i_keywordsym(x)
@@ -480,13 +481,13 @@ SCM_API SCM scm_i_keywordsym (SCM keyword);
#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1)
-SCM_API int scm_i_vectorp (SCM x);
-SCM_API unsigned long scm_i_vector_length (SCM x);
-SCM_API const SCM *scm_i_velts (SCM x);
-SCM_API SCM *scm_i_writable_velts (SCM x);
-SCM_API SCM scm_i_vector_ref (SCM x, size_t idx);
-SCM_API void scm_i_vector_set (SCM x, size_t idx, SCM val);
-SCM_API SCM scm_vector_equal_p (SCM x, SCM y);
+SCM_DEPRECATED int scm_i_vectorp (SCM x);
+SCM_DEPRECATED unsigned long scm_i_vector_length (SCM x);
+SCM_DEPRECATED const SCM *scm_i_velts (SCM x);
+SCM_DEPRECATED SCM *scm_i_writable_velts (SCM x);
+SCM_DEPRECATED SCM scm_i_vector_ref (SCM x, size_t idx);
+SCM_DEPRECATED void scm_i_vector_set (SCM x, size_t idx, SCM val);
+SCM_DEPRECATED SCM scm_vector_equal_p (SCM x, SCM y);
#define SCM_VECTORP(x) scm_i_vectorp(x)
#define SCM_VECTOR_LENGTH(x) scm_i_vector_length(x)
@@ -497,13 +498,13 @@ SCM_API SCM scm_vector_equal_p (SCM x, SCM y);
typedef scm_i_t_array scm_t_array;
-SCM_API int scm_i_arrayp (SCM a);
-SCM_API size_t scm_i_array_ndim (SCM a);
-SCM_API int scm_i_array_contp (SCM a);
-SCM_API scm_t_array *scm_i_array_mem (SCM a);
-SCM_API SCM scm_i_array_v (SCM a);
-SCM_API size_t scm_i_array_base (SCM a);
-SCM_API scm_t_array_dim *scm_i_array_dims (SCM a);
+SCM_DEPRECATED int scm_i_arrayp (SCM a);
+SCM_DEPRECATED size_t scm_i_array_ndim (SCM a);
+SCM_DEPRECATED int scm_i_array_contp (SCM a);
+SCM_DEPRECATED scm_t_array *scm_i_array_mem (SCM a);
+SCM_DEPRECATED SCM scm_i_array_v (SCM a);
+SCM_DEPRECATED size_t scm_i_array_base (SCM a);
+SCM_DEPRECATED scm_t_array_dim *scm_i_array_dims (SCM a);
#define SCM_ARRAYP(a) scm_i_arrayp(a)
#define SCM_ARRAY_NDIM(a) scm_i_array_ndim(a)
@@ -526,19 +527,19 @@ SCM_API scm_t_array_dim *scm_i_array_dims (SCM a);
#define scm_last_debug_frame scm_i_deprecated_last_debug_frame ()
#define scm_stack_base scm_i_stack_base ()
-SCM_API SCM scm_i_cur_inp (void);
-SCM_API SCM scm_i_cur_outp (void);
-SCM_API SCM scm_i_cur_errp (void);
-SCM_API SCM scm_i_cur_loadp (void);
-SCM_API SCM scm_i_progargs (void);
-SCM_API SCM scm_i_deprecated_dynwinds (void);
-SCM_API scm_t_debug_frame *scm_i_deprecated_last_debug_frame (void);
-SCM_API SCM_STACKITEM *scm_i_stack_base (void);
+SCM_DEPRECATED SCM scm_i_cur_inp (void);
+SCM_DEPRECATED SCM scm_i_cur_outp (void);
+SCM_DEPRECATED SCM scm_i_cur_errp (void);
+SCM_DEPRECATED SCM scm_i_cur_loadp (void);
+SCM_DEPRECATED SCM scm_i_progargs (void);
+SCM_DEPRECATED SCM scm_i_deprecated_dynwinds (void);
+SCM_DEPRECATED scm_t_debug_frame *scm_i_deprecated_last_debug_frame (void);
+SCM_DEPRECATED SCM_STACKITEM *scm_i_stack_base (void);
/* Deprecated because it evaluates its argument twice.
*/
#define SCM_FLUIDP(x) scm_i_fluidp (x)
-SCM_API int scm_i_fluidp (SCM x);
+SCM_DEPRECATED int scm_i_fluidp (SCM x);
/* In the old days, SCM_CRITICAL_SECTION_START stopped signal handlers
from running, since in those days the handler directly ran scheme
@@ -566,38 +567,44 @@ SCM_API int scm_i_fluidp (SCM x);
similar DEFER/ALLOW region.
*/
-SCM_API void scm_i_defer_ints_etc (void);
+SCM_DEPRECATED void scm_i_defer_ints_etc (void);
#define SCM_DEFER_INTS scm_i_defer_ints_etc ()
#define SCM_ALLOW_INTS scm_i_defer_ints_etc ()
#define SCM_REDEFER_INTS scm_i_defer_ints_etc ()
#define SCM_REALLOW_INTS scm_i_defer_ints_etc ()
+/* In the old days (pre-1.8), this macro was sometimes used as an lvalue as
+ in "scm_mask_ints = 1" to block async execution. It no longer works. */
+#define scm_mask_ints (scm_i_mask_ints ())
+
+SCM_DEPRECATED int scm_i_mask_ints (void);
+
/* Deprecated since they are unnecessary and had not been documented.
*/
-SCM_API SCM scm_guard (SCM guardian, SCM obj, int throw_p);
-SCM_API SCM scm_get_one_zombie (SCM guardian);
+SCM_DEPRECATED SCM scm_guard (SCM guardian, SCM obj, int throw_p);
+SCM_DEPRECATED SCM scm_get_one_zombie (SCM guardian);
/* Deprecated since guardians no longer have these special features.
*/
-SCM_API SCM scm_destroy_guardian_x (SCM guardian);
-SCM_API SCM scm_guardian_greedy_p (SCM guardian);
-SCM_API SCM scm_guardian_destroyed_p (SCM guardian);
+SCM_DEPRECATED SCM scm_destroy_guardian_x (SCM guardian);
+SCM_DEPRECATED SCM scm_guardian_greedy_p (SCM guardian);
+SCM_DEPRECATED SCM scm_guardian_destroyed_p (SCM guardian);
/* GC-related things deprecated with the move to BDW-GC starting from 1.9.3
(2009-09-15). */
-SCM_API unsigned long scm_mallocated;
-SCM_API unsigned long scm_mtrigger;
+SCM_DEPRECATED unsigned long scm_mallocated;
+SCM_DEPRECATED unsigned long scm_mtrigger;
-SCM_API size_t scm_max_segment_size;
+SCM_DEPRECATED size_t scm_max_segment_size;
#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
-SCM_API SCM scm_map_free_list (void);
+SCM_DEPRECATED SCM scm_map_free_list (void);
#endif
#if defined (GUILE_DEBUG_FREELIST)
-SCM_API SCM scm_gc_set_debug_check_freelist_x (SCM flag);
+SCM_DEPRECATED SCM scm_gc_set_debug_check_freelist_x (SCM flag);
#endif
diff --git a/libguile/dynl.c b/libguile/dynl.c
index dc98e7d17..52c43e542 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -48,6 +48,7 @@ maybe_drag_in_eprintf ()
#include <string.h>
#include "libguile/_scm.h"
+#include "libguile/libpath.h"
#include "libguile/dynl.h"
#include "libguile/smob.h"
#include "libguile/keywords.h"
@@ -113,7 +114,24 @@ sysdep_dynl_func (const char *symb, void *handle, const char *subr)
static void
sysdep_dynl_init ()
{
+ char *env;
+
lt_dlinit ();
+
+ env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH");
+ if (env && strcmp (env, "") == 0)
+ /* special-case interpret system-ltdl-path=="" as meaning no system path,
+ which is the case during the build */
+ ;
+ else if (env)
+ /* FIXME: should this be a colon-separated path? Or is the only point to
+ allow the build system to turn off the installed extensions path? */
+ lt_dladdsearchdir (env);
+ else
+ {
+ lt_dladdsearchdir (SCM_LIB_DIR);
+ lt_dladdsearchdir (SCM_EXTENSIONS_DIR);
+ }
}
scm_t_bits scm_tc16_dynamic_obj;
diff --git a/libguile/environments.c b/libguile/environments.c
deleted file mode 100644
index fd4b88300..000000000
--- a/libguile/environments.c
+++ /dev/null
@@ -1,2226 +0,0 @@
-/* Copyright (C) 1999,2000,2001, 2003, 2006, 2008 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
- */
-
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/_scm.h"
-#include "libguile/alist.h"
-#include "libguile/eval.h"
-#include "libguile/hash.h"
-#include "libguile/list.h"
-#include "libguile/ports.h"
-#include "libguile/smob.h"
-#include "libguile/symbols.h"
-#include "libguile/vectors.h"
-#include "libguile/weaks.h"
-
-#include "libguile/environments.h"
-
-
-
-scm_t_bits scm_tc16_environment;
-scm_t_bits scm_tc16_observer;
-#define DEFAULT_OBARRAY_SIZE 31
-
-SCM scm_system_environment;
-
-
-
-/* error conditions */
-
-/*
- * Throw an error if symbol is not bound in environment func
- */
-void
-scm_error_environment_unbound (const char *func, SCM env, SCM symbol)
-{
- /* Dirk:FIXME:: Should throw an environment:unbound type error */
- char error[] = "Symbol `~A' not bound in environment `~A'.";
- SCM arguments = scm_cons2 (symbol, env, SCM_EOL);
- scm_misc_error (func, error, arguments);
-}
-
-
-/*
- * Throw an error if func tried to create (define) or remove
- * (undefine) a new binding for symbol in env
- */
-void
-scm_error_environment_immutable_binding (const char *func, SCM env, SCM symbol)
-{
- /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
- char error[] = "Immutable binding in environment ~A (symbol: `~A').";
- SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
- scm_misc_error (func, error, arguments);
-}
-
-
-/*
- * Throw an error if func tried to change an immutable location.
- */
-void
-scm_error_environment_immutable_location (const char *func, SCM env, SCM symbol)
-{
- /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
- char error[] = "Immutable location in environment `~A' (symbol: `~A').";
- SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
- scm_misc_error (func, error, arguments);
-}
-
-
-
-/* generic environments */
-
-
-/* Create an environment for the given type. Dereferencing type twice must
- * deliver the initialized set of environment functions. Thus, type will
- * also determine the signature of the underlying environment implementation.
- * Dereferencing type once will typically deliver the data fields used by the
- * underlying environment implementation.
- */
-SCM
-scm_make_environment (void *type)
-{
- SCM_RETURN_NEWSMOB (scm_tc16_environment, type);
-}
-
-
-SCM_DEFINE (scm_environment_p, "environment?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_environment_p
-{
- return scm_from_bool (SCM_ENVIRONMENT_P (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0,
- (SCM env, SCM sym),
- "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
- "@code{#f} otherwise.")
-#define FUNC_NAME s_scm_environment_bound_p
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
-
- return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env, sym));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_ref, "environment-ref", 2, 0, 0,
- (SCM env, SCM sym),
- "Return the value of the location bound to @var{sym} in\n"
- "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
- "@code{environment:unbound} error.")
-#define FUNC_NAME s_scm_environment_ref
-{
- SCM val;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
-
- val = SCM_ENVIRONMENT_REF (env, sym);
-
- if (!SCM_UNBNDP (val))
- return val;
- else
- scm_error_environment_unbound (FUNC_NAME, env, sym);
-}
-#undef FUNC_NAME
-
-
-/* This C function is identical to environment-ref, except that if symbol is
- * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
- * an error.
- */
-SCM
-scm_c_environment_ref (SCM env, SCM sym)
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_ref");
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_ref");
- return SCM_ENVIRONMENT_REF (env, sym);
-}
-
-
-static SCM
-environment_default_folder (SCM proc, SCM symbol, SCM value, SCM tail)
-{
- return scm_call_3 (proc, symbol, value, tail);
-}
-
-
-SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0,
- (SCM env, SCM proc, SCM init),
- "Iterate over all the bindings in @var{env}, accumulating some\n"
- "value.\n"
- "For each binding in @var{env}, apply @var{proc} to the symbol\n"
- "bound, its value, and the result from the previous application\n"
- "of @var{proc}.\n"
- "Use @var{init} as @var{proc}'s third argument the first time\n"
- "@var{proc} is applied.\n"
- "If @var{env} contains no bindings, this function simply returns\n"
- "@var{init}.\n"
- "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
- "val2, and so on, then this procedure computes:\n"
- "@lisp\n"
- " (proc sym1 val1\n"
- " (proc sym2 val2\n"
- " ...\n"
- " (proc symn valn\n"
- " init)))\n"
- "@end lisp\n"
- "Each binding in @var{env} will be processed exactly once.\n"
- "@code{environment-fold} makes no guarantees about the order in\n"
- "which the bindings are processed.\n"
- "Here is a function which, given an environment, constructs an\n"
- "association list representing that environment's bindings,\n"
- "using environment-fold:\n"
- "@lisp\n"
- " (define (environment->alist env)\n"
- " (environment-fold env\n"
- " (lambda (sym val tail)\n"
- " (cons (cons sym val) tail))\n"
- " '()))\n"
- "@end lisp")
-#define FUNC_NAME s_scm_environment_fold
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
- proc, SCM_ARG2, FUNC_NAME);
-
- return SCM_ENVIRONMENT_FOLD (env, environment_default_folder, proc, init);
-}
-#undef FUNC_NAME
-
-
-/* This is the C-level analog of environment-fold. For each binding in ENV,
- * make the call:
- * (*proc) (data, symbol, value, previous)
- * where previous is the value returned from the last call to *PROC, or INIT
- * for the first call. If ENV contains no bindings, return INIT.
- */
-SCM
-scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_fold");
-
- return SCM_ENVIRONMENT_FOLD (env, proc, data, init);
-}
-
-
-SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0,
- (SCM env, SCM sym, SCM val),
- "Bind @var{sym} to a new location containing @var{val} in\n"
- "@var{env}. If @var{sym} is already bound to another location\n"
- "in @var{env} and the binding is mutable, that binding is\n"
- "replaced. The new binding and location are both mutable. The\n"
- "return value is unspecified.\n"
- "If @var{sym} is already bound in @var{env}, and the binding is\n"
- "immutable, signal an @code{environment:immutable-binding} error.")
-#define FUNC_NAME s_scm_environment_define
-{
- SCM status;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
-
- status = SCM_ENVIRONMENT_DEFINE (env, sym, val);
-
- if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
- return SCM_UNSPECIFIED;
- else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
- scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
- else
- abort();
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0,
- (SCM env, SCM sym),
- "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
- "is unbound in @var{env}, do nothing. The return value is\n"
- "unspecified.\n"
- "If @var{sym} is already bound in @var{env}, and the binding is\n"
- "immutable, signal an @code{environment:immutable-binding} error.")
-#define FUNC_NAME s_scm_environment_undefine
-{
- SCM status;
-
- SCM_ASSERT(SCM_ENVIRONMENT_P(env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT(scm_is_symbol(sym), sym, SCM_ARG2, FUNC_NAME);
-
- status = SCM_ENVIRONMENT_UNDEFINE (env, sym);
-
- if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
- return SCM_UNSPECIFIED;
- else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
- scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
- else
- abort();
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0,
- (SCM env, SCM sym, SCM val),
- "If @var{env} binds @var{sym} to some location, change that\n"
- "location's value to @var{val}. The return value is\n"
- "unspecified.\n"
- "If @var{sym} is not bound in @var{env}, signal an\n"
- "@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
- "to an immutable location, signal an\n"
- "@code{environment:immutable-location} error.")
-#define FUNC_NAME s_scm_environment_set_x
-{
- SCM status;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
-
- status = SCM_ENVIRONMENT_SET (env, sym, val);
-
- if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
- return SCM_UNSPECIFIED;
- else if (SCM_UNBNDP (status))
- scm_error_environment_unbound (FUNC_NAME, env, sym);
- else if (scm_is_eq (status, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
- scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
- else
- abort();
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0,
- (SCM env, SCM sym, SCM for_write),
- "Return the value cell which @var{env} binds to @var{sym}, or\n"
- "@code{#f} if the binding does not live in a value cell.\n"
- "The argument @var{for-write} indicates whether the caller\n"
- "intends to modify the variable's value by mutating the value\n"
- "cell. If the variable is immutable, then\n"
- "@code{environment-cell} signals an\n"
- "@code{environment:immutable-location} error.\n"
- "If @var{sym} is unbound in @var{env}, signal an\n"
- "@code{environment:unbound} error.\n"
- "If you use this function, you should consider using\n"
- "@code{environment-observe}, to be notified when @var{sym} gets\n"
- "re-bound to a new value cell, or becomes undefined.")
-#define FUNC_NAME s_scm_environment_cell
-{
- SCM location;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
- SCM_ASSERT (scm_is_bool (for_write), for_write, SCM_ARG3, FUNC_NAME);
-
- location = SCM_ENVIRONMENT_CELL (env, sym, scm_is_true (for_write));
- if (!SCM_IMP (location))
- return location;
- else if (SCM_UNBNDP (location))
- scm_error_environment_unbound (FUNC_NAME, env, sym);
- else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
- scm_error_environment_immutable_location (FUNC_NAME, env, sym);
- else /* no cell */
- return location;
-}
-#undef FUNC_NAME
-
-
-/* This C function is identical to environment-cell, with the following
- * exceptions: If symbol is unbound in env, it returns the value
- * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
- * immutable location but the cell is requested for write, the value
- * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
- */
-SCM
-scm_c_environment_cell(SCM env, SCM sym, int for_write)
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_cell");
- SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_cell");
-
- return SCM_ENVIRONMENT_CELL (env, sym, for_write);
-}
-
-
-static void
-environment_default_observer (SCM env, SCM proc)
-{
- scm_call_1 (proc, env);
-}
-
-
-SCM_DEFINE (scm_environment_observe, "environment-observe", 2, 0, 0,
- (SCM env, SCM proc),
- "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
- "@var{env}.\n"
- "This function returns an object, token, which you can pass to\n"
- "@code{environment-unobserve} to remove @var{proc} from the set\n"
- "of procedures observing @var{env}. The type and value of\n"
- "token is unspecified.")
-#define FUNC_NAME s_scm_environment_observe
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 0);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_observe_weak, "environment-observe-weak", 2, 0, 0,
- (SCM env, SCM proc),
- "This function is the same as environment-observe, except that\n"
- "the reference @var{env} retains to @var{proc} is a weak\n"
- "reference. This means that, if there are no other live,\n"
- "non-weak references to @var{proc}, it will be\n"
- "garbage-collected, and dropped from @var{env}'s\n"
- "list of observing procedures.")
-#define FUNC_NAME s_scm_environment_observe_weak
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 1);
-}
-#undef FUNC_NAME
-
-
-/* This is the C-level analog of the Scheme functions environment-observe and
- * environment-observe-weak. Whenever env's bindings change, call the
- * function proc, passing it env and data. If weak_p is non-zero, env will
- * retain only a weak reference to data, and if data is garbage collected, the
- * entire observation will be dropped. This function returns a token, with
- * the same meaning as those returned by environment-observe and
- * environment-observe-weak.
- */
-SCM
-scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
-#define FUNC_NAME "scm_c_environment_observe"
-{
- SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return SCM_ENVIRONMENT_OBSERVE (env, proc, data, weak_p);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_environment_unobserve, "environment-unobserve", 1, 0, 0,
- (SCM token),
- "Cancel the observation request which returned the value\n"
- "@var{token}. The return value is unspecified.\n"
- "If a call @code{(environment-observe env proc)} returns\n"
- "@var{token}, then the call @code{(environment-unobserve token)}\n"
- "will cause @var{proc} to no longer be called when @var{env}'s\n"
- "bindings change.")
-#define FUNC_NAME s_scm_environment_unobserve
-{
- SCM env;
-
- SCM_ASSERT (SCM_OBSERVER_P (token), token, SCM_ARG1, FUNC_NAME);
-
- env = SCM_OBSERVER_ENVIRONMENT (token);
- SCM_ENVIRONMENT_UNOBSERVE (env, token);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-
-static int
-environment_print (SCM env, SCM port, scm_print_state *pstate)
-{
- return (*(SCM_ENVIRONMENT_FUNCS (env)->print)) (env, port, pstate);
-}
-
-
-
-/* observers */
-
-
-static int
-observer_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- SCM address = scm_from_size_t (SCM_UNPACK (type));
- SCM base16 = scm_number_to_string (address, scm_from_int (16));
-
- scm_puts ("#<observer ", port);
- scm_display (base16, port);
- scm_puts (">", port);
-
- return 1;
-}
-
-
-
-/* obarrays
- *
- * Obarrays form the basic lookup tables used to implement most of guile's
- * built-in environment types. An obarray is implemented as a hash table with
- * symbols as keys. The content of the data depends on the environment type.
- */
-
-
-/*
- * Enter symbol into obarray. The symbol must not already exist in obarray.
- * The freshly generated (symbol . data) cell is returned.
- */
-static SCM
-obarray_enter (SCM obarray, SCM symbol, SCM data)
-{
- size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
- SCM entry = scm_cons (symbol, data);
- SCM slot = scm_cons (entry, SCM_HASHTABLE_BUCKET (obarray, hash));
- SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
- SCM_HASHTABLE_INCREMENT (obarray);
- if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
- scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_enter");
-
- return entry;
-}
-
-
-/*
- * Enter symbol into obarray. An existing entry for symbol is replaced. If
- * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
- */
-static SCM
-obarray_replace (SCM obarray, SCM symbol, SCM data)
-{
- size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
- SCM new_entry = scm_cons (symbol, data);
- SCM lsym;
- SCM slot;
-
- for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
- !scm_is_null (lsym);
- lsym = SCM_CDR (lsym))
- {
- SCM old_entry = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (old_entry), symbol))
- {
- SCM_SETCAR (lsym, new_entry);
- return old_entry;
- }
- }
-
- slot = scm_cons (new_entry, SCM_HASHTABLE_BUCKET (obarray, hash));
- SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
- SCM_HASHTABLE_INCREMENT (obarray);
- if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
- scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_replace");
-
- return SCM_BOOL_F;
-}
-
-
-/*
- * Look up symbol in obarray
- */
-static SCM
-obarray_retrieve (SCM obarray, SCM sym)
-{
- size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
- SCM lsym;
-
- for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
- !scm_is_null (lsym);
- lsym = SCM_CDR (lsym))
- {
- SCM entry = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (entry), sym))
- return entry;
- }
-
- return SCM_UNDEFINED;
-}
-
-
-/*
- * Remove entry from obarray. If the symbol was found and removed, the old
- * (symbol . data) cell is returned, #f otherwise.
- */
-static SCM
-obarray_remove (SCM obarray, SCM sym)
-{
- size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
- SCM table_entry = SCM_HASHTABLE_BUCKET (obarray, hash);
- SCM handle = scm_sloppy_assq (sym, table_entry);
-
- if (scm_is_pair (handle))
- {
- SCM new_table_entry = scm_delq1_x (handle, table_entry);
- SCM_SET_HASHTABLE_BUCKET (obarray, hash, new_table_entry);
- SCM_HASHTABLE_DECREMENT (obarray);
- }
-
- return handle;
-}
-
-
-static void
-obarray_remove_all (SCM obarray)
-{
- size_t size = SCM_HASHTABLE_N_BUCKETS (obarray);
- size_t i;
-
- for (i = 0; i < size; i++)
- {
- SCM_SET_HASHTABLE_BUCKET (obarray, i, SCM_EOL);
- }
- SCM_SET_HASHTABLE_N_ITEMS (obarray, 0);
-}
-
-
-
-/* core environments base
- *
- * This struct and the corresponding functions form a base class for guile's
- * built-in environment types.
- */
-
-
-struct core_environments_base {
- struct scm_environment_funcs *funcs;
-
- SCM observers;
- SCM weak_observers;
-};
-
-
-#define CORE_ENVIRONMENTS_BASE(env) \
- ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
-#define CORE_ENVIRONMENT_OBSERVERS(env) \
- (CORE_ENVIRONMENTS_BASE (env)->observers)
-#define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
- (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
-#define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
- (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
-#define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
- (scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
-#define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
- (scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
-
-
-
-static SCM
-core_environments_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
-{
- SCM observer;
-
- SCM_NEWSMOB3 (observer, scm_tc16_observer,
- SCM_UNPACK (env),
- SCM_UNPACK (data),
- (scm_t_bits) proc);
-
- if (!weak_p)
- {
- SCM observers = CORE_ENVIRONMENT_OBSERVERS (env);
- SCM new_observers = scm_cons (observer, observers);
- SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, new_observers);
- }
- else
- {
- SCM observers = CORE_ENVIRONMENT_WEAK_OBSERVERS (env);
- SCM new_observers = scm_acons (SCM_BOOL_F, observer, observers);
- SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, new_observers);
- }
-
- return observer;
-}
-
-
-static void
-core_environments_unobserve (SCM env, SCM observer)
-{
- unsigned int handling_weaks;
- for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
- {
- SCM l = handling_weaks
- ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
- : CORE_ENVIRONMENT_OBSERVERS (env);
-
- if (!scm_is_null (l))
- {
- SCM rest = SCM_CDR (l);
- SCM first = handling_weaks
- ? SCM_CDAR (l)
- : SCM_CAR (l);
-
- if (scm_is_eq (first, observer))
- {
- /* Remove the first observer */
- if (handling_weaks)
- SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest);
- else
- SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest);
- return;
- }
-
- do {
- SCM rest = SCM_CDR (l);
-
- if (!scm_is_null (rest))
- {
- SCM next = handling_weaks
- ? SCM_CDAR (l)
- : SCM_CAR (l);
-
- if (scm_is_eq (next, observer))
- {
- SCM_SETCDR (l, SCM_CDR (rest));
- return;
- }
- }
-
- l = rest;
- } while (!scm_is_null (l));
- }
- }
-
- /* Dirk:FIXME:: What to do now, since the observer is not found? */
-}
-
-
-static void
-core_environments_preinit (struct core_environments_base *body)
-{
- body->funcs = NULL;
- body->observers = SCM_BOOL_F;
- body->weak_observers = SCM_BOOL_F;
-}
-
-
-static void
-core_environments_init (struct core_environments_base *body,
- struct scm_environment_funcs *funcs)
-{
- body->funcs = funcs;
- body->observers = SCM_EOL;
- body->weak_observers = scm_make_weak_value_alist_vector (scm_from_int (1));
-}
-
-
-/* Tell all observers to clear their caches.
- *
- * Environments have to be informed about changes in the following cases:
- * - The observed env has a new binding. This must be always reported.
- * - The observed env has dropped a binding. This must be always reported.
- * - A binding in the observed environment has changed. This must only be
- * reported, if there is a chance that the binding is being cached outside.
- * However, this potential optimization is not performed currently.
- *
- * Errors that occur while the observers are called are accumulated and
- * signalled as one single error message to the caller.
- */
-
-struct update_data
-{
- SCM observer;
- SCM environment;
-};
-
-
-static SCM
-update_catch_body (void *ptr)
-{
- struct update_data *data = (struct update_data *) ptr;
- SCM observer = data->observer;
-
- (*SCM_OBSERVER_PROC (observer))
- (data->environment, SCM_OBSERVER_DATA (observer));
-
- return SCM_UNDEFINED;
-}
-
-
-static SCM
-update_catch_handler (void *ptr, SCM tag, SCM args)
-{
- struct update_data *data = (struct update_data *) ptr;
- SCM observer = data->observer;
- SCM message =
- scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");
-
- return scm_cons (message, scm_list_3 (observer, tag, args));
-}
-
-
-static void
-core_environments_broadcast (SCM env)
-#define FUNC_NAME "core_environments_broadcast"
-{
- unsigned int handling_weaks;
- SCM errors = SCM_EOL;
-
- for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
- {
- SCM observers = handling_weaks
- ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
- : CORE_ENVIRONMENT_OBSERVERS (env);
-
- for (; !scm_is_null (observers); observers = SCM_CDR (observers))
- {
- struct update_data data;
- SCM observer = handling_weaks
- ? SCM_CDAR (observers)
- : SCM_CAR (observers);
- SCM error;
-
- data.observer = observer;
- data.environment = env;
-
- error = scm_internal_catch (SCM_BOOL_T,
- update_catch_body, &data,
- update_catch_handler, &data);
-
- if (!SCM_UNBNDP (error))
- errors = scm_cons (error, errors);
- }
- }
-
- if (!scm_is_null (errors))
- {
- /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
- * parameter correctly it should not be necessary any more to also pass
- * namestr in order to get the desired information from the error
- * message.
- */
- SCM ordered_errors = scm_reverse (errors);
- scm_misc_error
- (FUNC_NAME,
- "Observers of `~A' have signalled the following errors: ~S",
- scm_cons2 (env, ordered_errors, SCM_EOL));
- }
-}
-#undef FUNC_NAME
-
-
-
-/* leaf environments
- *
- * A leaf environment is simply a mutable set of definitions. A leaf
- * environment supports no operations beyond the common set.
- *
- * Implementation: The obarray of the leaf environment holds (symbol . value)
- * pairs. No further information is necessary, since all bindings and
- * locations in a leaf environment are mutable.
- */
-
-
-struct leaf_environment {
- struct core_environments_base base;
-
- SCM obarray;
-};
-
-
-#define LEAF_ENVIRONMENT(env) \
- ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
-
-
-
-static SCM
-leaf_environment_ref (SCM env, SCM sym)
-{
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
- SCM binding = obarray_retrieve (obarray, sym);
- return SCM_UNBNDP (binding) ? binding : SCM_CDR (binding);
-}
-
-
-static SCM
-leaf_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
-{
- size_t i;
- SCM result = init;
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
-
- for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (obarray); i++)
- {
- SCM l;
- for (l = SCM_HASHTABLE_BUCKET (obarray, i);
- !scm_is_null (l);
- l = SCM_CDR (l))
- {
- SCM binding = SCM_CAR (l);
- SCM symbol = SCM_CAR (binding);
- SCM value = SCM_CDR (binding);
- result = (*proc) (data, symbol, value, result);
- }
- }
- return result;
-}
-
-
-static SCM
-leaf_environment_define (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "leaf_environment_define"
-{
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
-
- obarray_replace (obarray, sym, val);
- core_environments_broadcast (env);
-
- return SCM_ENVIRONMENT_SUCCESS;
-}
-#undef FUNC_NAME
-
-
-static SCM
-leaf_environment_undefine (SCM env, SCM sym)
-#define FUNC_NAME "leaf_environment_undefine"
-{
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
- SCM removed = obarray_remove (obarray, sym);
-
- if (scm_is_true (removed))
- core_environments_broadcast (env);
-
- return SCM_ENVIRONMENT_SUCCESS;
-}
-#undef FUNC_NAME
-
-
-static SCM
-leaf_environment_set_x (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "leaf_environment_set_x"
-{
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
- SCM binding = obarray_retrieve (obarray, sym);
-
- if (!SCM_UNBNDP (binding))
- {
- SCM_SETCDR (binding, val);
- return SCM_ENVIRONMENT_SUCCESS;
- }
- else
- {
- return SCM_UNDEFINED;
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-leaf_environment_cell (SCM env, SCM sym, int for_write SCM_UNUSED)
-{
- SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
- SCM binding = obarray_retrieve (obarray, sym);
- return binding;
-}
-
-
-
-static int
-leaf_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- SCM address = scm_from_size_t (SCM_UNPACK (type));
- SCM base16 = scm_number_to_string (address, scm_from_int (16));
-
- scm_puts ("#<leaf environment ", port);
- scm_display (base16, port);
- scm_puts (">", port);
-
- return 1;
-}
-
-
-static struct scm_environment_funcs leaf_environment_funcs = {
- leaf_environment_ref,
- leaf_environment_fold,
- leaf_environment_define,
- leaf_environment_undefine,
- leaf_environment_set_x,
- leaf_environment_cell,
- core_environments_observe,
- core_environments_unobserve,
- leaf_environment_print
-};
-
-
-void *scm_type_leaf_environment = &leaf_environment_funcs;
-
-
-SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0,
- (),
- "Create a new leaf environment, containing no bindings.\n"
- "All bindings and locations created in the new environment\n"
- "will be mutable.")
-#define FUNC_NAME s_scm_make_leaf_environment
-{
- size_t size = sizeof (struct leaf_environment);
- struct leaf_environment *body = scm_gc_malloc (size, "leaf environment");
- SCM env;
-
- core_environments_preinit (&body->base);
- body->obarray = SCM_BOOL_F;
-
- env = scm_make_environment (body);
-
- core_environments_init (&body->base, &leaf_environment_funcs);
- body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
-
- return env;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_leaf_environment_p, "leaf-environment?", 1, 0, 0,
- (SCM object),
- "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_leaf_environment_p
-{
- return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object));
-}
-#undef FUNC_NAME
-
-
-
-/* eval environments
- *
- * A module's source code refers to definitions imported from other modules,
- * and definitions made within itself. An eval environment combines two
- * environments -- a local environment and an imported environment -- to
- * produce a new environment in which both sorts of references can be
- * resolved.
- *
- * Implementation: The obarray of the eval environment is used to cache
- * entries from the local and imported environments such that in most of the
- * cases only a single lookup is necessary. Since for neither the local nor
- * the imported environment it is known, what kind of environment they form,
- * the most general case is assumed. Therefore, entries in the obarray take
- * one of the following forms:
- *
- * 1) (<symbol> location mutability . source-env), where mutability indicates
- * one of the following states: IMMUTABLE if the location is known to be
- * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
- * the location has only been requested for non modifying accesses.
- *
- * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
- * if the source-env can't provide a cell for the binding. Thus, for every
- * access, the source-env has to be contacted directly.
- */
-
-
-struct eval_environment {
- struct core_environments_base base;
-
- SCM obarray;
-
- SCM imported;
- SCM imported_observer;
- SCM local;
- SCM local_observer;
-};
-
-
-#define EVAL_ENVIRONMENT(env) \
- ((struct eval_environment *) SCM_CELL_WORD_1 (env))
-
-#define IMMUTABLE SCM_I_MAKINUM (0)
-#define MUTABLE SCM_I_MAKINUM (1)
-#define UNKNOWN SCM_I_MAKINUM (2)
-
-#define CACHED_LOCATION(x) SCM_CAR (x)
-#define CACHED_MUTABILITY(x) SCM_CADR (x)
-#define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
-#define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
-
-
-
-/* eval_environment_lookup will report one of the following distinct results:
- * a) (<object> . value) if a cell could be obtained.
- * b) <environment> if the environment has to be contacted directly.
- * c) IMMUTABLE if an immutable cell was requested for write.
- * d) SCM_UNDEFINED if there is no binding for the symbol.
- */
-static SCM
-eval_environment_lookup (SCM env, SCM sym, int for_write)
-{
- SCM obarray = EVAL_ENVIRONMENT (env)->obarray;
- SCM binding = obarray_retrieve (obarray, sym);
-
- if (!SCM_UNBNDP (binding))
- {
- /* The obarray holds an entry for the symbol. */
-
- SCM entry = SCM_CDR (binding);
-
- if (scm_is_pair (entry))
- {
- /* The entry in the obarray is a cached location. */
-
- SCM location = CACHED_LOCATION (entry);
- SCM mutability;
-
- if (!for_write)
- return location;
-
- mutability = CACHED_MUTABILITY (entry);
- if (scm_is_eq (mutability, MUTABLE))
- return location;
-
- if (scm_is_eq (mutability, UNKNOWN))
- {
- SCM source_env = CACHED_SOURCE_ENVIRONMENT (entry);
- SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, 1);
-
- if (scm_is_pair (location))
- {
- SET_CACHED_MUTABILITY (entry, MUTABLE);
- return location;
- }
- else /* IMMUTABLE */
- {
- SET_CACHED_MUTABILITY (entry, IMMUTABLE);
- return IMMUTABLE;
- }
- }
-
- return IMMUTABLE;
- }
- else
- {
- /* The obarray entry is an environment */
-
- return entry;
- }
- }
- else
- {
- /* There is no entry for the symbol in the obarray. This can either
- * mean that there has not been a request for the symbol yet, or that
- * the symbol is really undefined. We are looking for the symbol in
- * both the local and the imported environment. If we find a binding, a
- * cached entry is created.
- */
-
- struct eval_environment *body = EVAL_ENVIRONMENT (env);
- unsigned int handling_import;
-
- for (handling_import = 0; handling_import <= 1; ++handling_import)
- {
- SCM source_env = handling_import ? body->imported : body->local;
- SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, for_write);
-
- if (!SCM_UNBNDP (location))
- {
- if (scm_is_pair (location))
- {
- SCM mutability = for_write ? MUTABLE : UNKNOWN;
- SCM entry = scm_cons2 (location, mutability, source_env);
- obarray_enter (obarray, sym, entry);
- return location;
- }
- else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_NO_CELL))
- {
- obarray_enter (obarray, sym, source_env);
- return source_env;
- }
- else
- {
- return IMMUTABLE;
- }
- }
- }
-
- return SCM_UNDEFINED;
- }
-}
-
-
-static SCM
-eval_environment_ref (SCM env, SCM sym)
-#define FUNC_NAME "eval_environment_ref"
-{
- SCM location = eval_environment_lookup (env, sym, 0);
-
- if (scm_is_pair (location))
- return SCM_CDR (location);
- else if (!SCM_UNBNDP (location))
- return SCM_ENVIRONMENT_REF (location, sym);
- else
- return SCM_UNDEFINED;
-}
-#undef FUNC_NAME
-
-
-static SCM
-eval_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
-{
- SCM local = SCM_CAR (extended_data);
-
- if (!SCM_ENVIRONMENT_BOUND_P (local, symbol))
- {
- SCM proc_as_nr = SCM_CADR (extended_data);
- unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
- scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
- SCM data = SCM_CDDR (extended_data);
-
- return (*proc) (data, symbol, value, tail);
- }
- else
- {
- return tail;
- }
-}
-
-
-static SCM
-eval_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
-{
- SCM local = EVAL_ENVIRONMENT (env)->local;
- SCM imported = EVAL_ENVIRONMENT (env)->imported;
- SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
- SCM extended_data = scm_cons2 (local, proc_as_nr, data);
- SCM tmp_result = scm_c_environment_fold (imported, eval_environment_folder, extended_data, init);
-
- return scm_c_environment_fold (local, proc, data, tmp_result);
-}
-
-
-static SCM
-eval_environment_define (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "eval_environment_define"
-{
- SCM local = EVAL_ENVIRONMENT (env)->local;
- return SCM_ENVIRONMENT_DEFINE (local, sym, val);
-}
-#undef FUNC_NAME
-
-
-static SCM
-eval_environment_undefine (SCM env, SCM sym)
-#define FUNC_NAME "eval_environment_undefine"
-{
- SCM local = EVAL_ENVIRONMENT (env)->local;
- return SCM_ENVIRONMENT_UNDEFINE (local, sym);
-}
-#undef FUNC_NAME
-
-
-static SCM
-eval_environment_set_x (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "eval_environment_set_x"
-{
- SCM location = eval_environment_lookup (env, sym, 1);
-
- if (scm_is_pair (location))
- {
- SCM_SETCDR (location, val);
- return SCM_ENVIRONMENT_SUCCESS;
- }
- else if (SCM_ENVIRONMENT_P (location))
- {
- return SCM_ENVIRONMENT_SET (location, sym, val);
- }
- else if (scm_is_eq (location, IMMUTABLE))
- {
- return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
- }
- else
- {
- return SCM_UNDEFINED;
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-eval_environment_cell (SCM env, SCM sym, int for_write)
-#define FUNC_NAME "eval_environment_cell"
-{
- SCM location = eval_environment_lookup (env, sym, for_write);
-
- if (scm_is_pair (location))
- return location;
- else if (SCM_ENVIRONMENT_P (location))
- return SCM_ENVIRONMENT_LOCATION_NO_CELL;
- else if (scm_is_eq (location, IMMUTABLE))
- return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
- else
- return SCM_UNDEFINED;
-}
-#undef FUNC_NAME
-
-
-
-static int
-eval_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- SCM address = scm_from_size_t (SCM_UNPACK (type));
- SCM base16 = scm_number_to_string (address, scm_from_int (16));
-
- scm_puts ("#<eval environment ", port);
- scm_display (base16, port);
- scm_puts (">", port);
-
- return 1;
-}
-
-
-static struct scm_environment_funcs eval_environment_funcs = {
- eval_environment_ref,
- eval_environment_fold,
- eval_environment_define,
- eval_environment_undefine,
- eval_environment_set_x,
- eval_environment_cell,
- core_environments_observe,
- core_environments_unobserve,
- eval_environment_print
-};
-
-
-void *scm_type_eval_environment = &eval_environment_funcs;
-
-
-static void
-eval_environment_observer (SCM caller SCM_UNUSED, SCM eval_env)
-{
- SCM obarray = EVAL_ENVIRONMENT (eval_env)->obarray;
-
- obarray_remove_all (obarray);
- core_environments_broadcast (eval_env);
-}
-
-
-SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0,
- (SCM local, SCM imported),
- "Return a new environment object eval whose bindings are the\n"
- "union of the bindings in the environments @var{local} and\n"
- "@var{imported}, with bindings from @var{local} taking\n"
- "precedence. Definitions made in eval are placed in @var{local}.\n"
- "Applying @code{environment-define} or\n"
- "@code{environment-undefine} to eval has the same effect as\n"
- "applying the procedure to @var{local}.\n"
- "Note that eval incorporates @var{local} and @var{imported} by\n"
- "reference:\n"
- "If, after creating eval, the program changes the bindings of\n"
- "@var{local} or @var{imported}, those changes will be visible\n"
- "in eval.\n"
- "Since most Scheme evaluation takes place in eval environments,\n"
- "they transparently cache the bindings received from @var{local}\n"
- "and @var{imported}. Thus, the first time the program looks up\n"
- "a symbol in eval, eval may make calls to @var{local} or\n"
- "@var{imported} to find their bindings, but subsequent\n"
- "references to that symbol will be as fast as references to\n"
- "bindings in finite environments.\n"
- "In typical use, @var{local} will be a finite environment, and\n"
- "@var{imported} will be an import environment")
-#define FUNC_NAME s_scm_make_eval_environment
-{
- SCM env;
- struct eval_environment *body;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
-
- body = scm_gc_malloc (sizeof (struct eval_environment), "eval environment");
-
- core_environments_preinit (&body->base);
- body->obarray = SCM_BOOL_F;
- body->imported = SCM_BOOL_F;
- body->imported_observer = SCM_BOOL_F;
- body->local = SCM_BOOL_F;
- body->local_observer = SCM_BOOL_F;
-
- env = scm_make_environment (body);
-
- core_environments_init (&body->base, &eval_environment_funcs);
- body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
- body->imported = imported;
- body->imported_observer
- = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
- body->local = local;
- body->local_observer
- = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
-
- return env;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_eval_environment_p, "eval-environment?", 1, 0, 0,
- (SCM object),
- "Return @code{#t} if object is an eval environment, or @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_eval_environment_p
-{
- return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_eval_environment_local, "eval-environment-local", 1, 0, 0,
- (SCM env),
- "Return the local environment of eval environment @var{env}.")
-#define FUNC_NAME s_scm_eval_environment_local
-{
- SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return EVAL_ENVIRONMENT (env)->local;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_eval_environment_set_local_x, "eval-environment-set-local!", 2, 0, 0,
- (SCM env, SCM local),
- "Change @var{env}'s local environment to @var{local}.")
-#define FUNC_NAME s_scm_eval_environment_set_local_x
-{
- struct eval_environment *body;
-
- SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG2, FUNC_NAME);
-
- body = EVAL_ENVIRONMENT (env);
-
- obarray_remove_all (body->obarray);
- SCM_ENVIRONMENT_UNOBSERVE (body->local, body->local_observer);
-
- body->local = local;
- body->local_observer
- = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
-
- core_environments_broadcast (env);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_eval_environment_imported, "eval-environment-imported", 1, 0, 0,
- (SCM env),
- "Return the imported environment of eval environment @var{env}.")
-#define FUNC_NAME s_scm_eval_environment_imported
-{
- SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return EVAL_ENVIRONMENT (env)->imported;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_eval_environment_set_imported_x, "eval-environment-set-imported!", 2, 0, 0,
- (SCM env, SCM imported),
- "Change @var{env}'s imported environment to @var{imported}.")
-#define FUNC_NAME s_scm_eval_environment_set_imported_x
-{
- struct eval_environment *body;
-
- SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
-
- body = EVAL_ENVIRONMENT (env);
-
- obarray_remove_all (body->obarray);
- SCM_ENVIRONMENT_UNOBSERVE (body->imported, body->imported_observer);
-
- body->imported = imported;
- body->imported_observer
- = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
-
- core_environments_broadcast (env);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-
-/* import environments
- *
- * An import environment combines the bindings of a set of argument
- * environments, and checks for naming clashes.
- *
- * Implementation: The import environment does no caching at all. For every
- * access, the list of imported environments is scanned.
- */
-
-
-struct import_environment {
- struct core_environments_base base;
-
- SCM imports;
- SCM import_observers;
-
- SCM conflict_proc;
-};
-
-
-#define IMPORT_ENVIRONMENT(env) \
- ((struct import_environment *) SCM_CELL_WORD_1 (env))
-
-
-
-/* Lookup will report one of the following distinct results:
- * a) <environment> if only environment binds the symbol.
- * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
- * c) SCM_UNDEFINED if there is no binding for the symbol.
- */
-static SCM
-import_environment_lookup (SCM env, SCM sym)
-{
- SCM imports = IMPORT_ENVIRONMENT (env)->imports;
- SCM result = SCM_UNDEFINED;
- SCM l;
-
- for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM imported = SCM_CAR (l);
-
- if (SCM_ENVIRONMENT_BOUND_P (imported, sym))
- {
- if (SCM_UNBNDP (result))
- result = imported;
- else if (scm_is_pair (result))
- result = scm_cons (imported, result);
- else
- result = scm_cons2 (imported, result, SCM_EOL);
- }
- }
-
- if (scm_is_pair (result))
- return scm_reverse (result);
- else
- return result;
-}
-
-
-static SCM
-import_environment_conflict (SCM env, SCM sym, SCM imports)
-{
- SCM conflict_proc = IMPORT_ENVIRONMENT (env)->conflict_proc;
- SCM args = scm_cons2 (env, sym, scm_cons (imports, SCM_EOL));
-
- return scm_apply_0 (conflict_proc, args);
-}
-
-
-static SCM
-import_environment_ref (SCM env, SCM sym)
-#define FUNC_NAME "import_environment_ref"
-{
- SCM owner = import_environment_lookup (env, sym);
-
- if (SCM_UNBNDP (owner))
- {
- return SCM_UNDEFINED;
- }
- else if (scm_is_pair (owner))
- {
- SCM resolve = import_environment_conflict (env, sym, owner);
-
- if (SCM_ENVIRONMENT_P (resolve))
- return SCM_ENVIRONMENT_REF (resolve, sym);
- else
- return SCM_UNSPECIFIED;
- }
- else
- {
- return SCM_ENVIRONMENT_REF (owner, sym);
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
-#define FUNC_NAME "import_environment_fold"
-{
- SCM import_env = SCM_CAR (extended_data);
- SCM imported_env = SCM_CADR (extended_data);
- SCM owner = import_environment_lookup (import_env, symbol);
- SCM proc_as_nr = SCM_CADDR (extended_data);
- unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
- scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
- SCM data = SCM_CDDDR (extended_data);
-
- if (scm_is_pair (owner) && scm_is_eq (SCM_CAR (owner), imported_env))
- owner = import_environment_conflict (import_env, symbol, owner);
-
- if (SCM_ENVIRONMENT_P (owner))
- return (*proc) (data, symbol, value, tail);
- else /* unresolved conflict */
- return (*proc) (data, symbol, SCM_UNSPECIFIED, tail);
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
-{
- SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
- SCM result = init;
- SCM l;
-
- for (l = IMPORT_ENVIRONMENT (env)->imports; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM imported_env = SCM_CAR (l);
- SCM extended_data = scm_cons (env, scm_cons2 (imported_env, proc_as_nr, data));
-
- result = scm_c_environment_fold (imported_env, import_environment_folder, extended_data, result);
- }
-
- return result;
-}
-
-
-static SCM
-import_environment_define (SCM env SCM_UNUSED,
- SCM sym SCM_UNUSED,
- SCM val SCM_UNUSED)
-#define FUNC_NAME "import_environment_define"
-{
- return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_undefine (SCM env SCM_UNUSED,
- SCM sym SCM_UNUSED)
-#define FUNC_NAME "import_environment_undefine"
-{
- return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_set_x (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "import_environment_set_x"
-{
- SCM owner = import_environment_lookup (env, sym);
-
- if (SCM_UNBNDP (owner))
- {
- return SCM_UNDEFINED;
- }
- else if (scm_is_pair (owner))
- {
- SCM resolve = import_environment_conflict (env, sym, owner);
-
- if (SCM_ENVIRONMENT_P (resolve))
- return SCM_ENVIRONMENT_SET (resolve, sym, val);
- else
- return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
- }
- else
- {
- return SCM_ENVIRONMENT_SET (owner, sym, val);
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-import_environment_cell (SCM env, SCM sym, int for_write)
-#define FUNC_NAME "import_environment_cell"
-{
- SCM owner = import_environment_lookup (env, sym);
-
- if (SCM_UNBNDP (owner))
- {
- return SCM_UNDEFINED;
- }
- else if (scm_is_pair (owner))
- {
- SCM resolve = import_environment_conflict (env, sym, owner);
-
- if (SCM_ENVIRONMENT_P (resolve))
- return SCM_ENVIRONMENT_CELL (resolve, sym, for_write);
- else
- return SCM_ENVIRONMENT_LOCATION_NO_CELL;
- }
- else
- {
- return SCM_ENVIRONMENT_CELL (owner, sym, for_write);
- }
-}
-#undef FUNC_NAME
-
-
-
-static int
-import_environment_print (SCM type, SCM port,
- scm_print_state *pstate SCM_UNUSED)
-{
- SCM address = scm_from_size_t (SCM_UNPACK (type));
- SCM base16 = scm_number_to_string (address, scm_from_int (16));
-
- scm_puts ("#<import environment ", port);
- scm_display (base16, port);
- scm_puts (">", port);
-
- return 1;
-}
-
-
-static struct scm_environment_funcs import_environment_funcs = {
- import_environment_ref,
- import_environment_fold,
- import_environment_define,
- import_environment_undefine,
- import_environment_set_x,
- import_environment_cell,
- core_environments_observe,
- core_environments_unobserve,
- import_environment_print
-};
-
-
-void *scm_type_import_environment = &import_environment_funcs;
-
-
-static void
-import_environment_observer (SCM caller SCM_UNUSED, SCM import_env)
-{
- core_environments_broadcast (import_env);
-}
-
-
-SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0,
- (SCM imports, SCM conflict_proc),
- "Return a new environment @var{imp} whose bindings are the union\n"
- "of the bindings from the environments in @var{imports};\n"
- "@var{imports} must be a list of environments. That is,\n"
- "@var{imp} binds a symbol to a location when some element of\n"
- "@var{imports} does.\n"
- "If two different elements of @var{imports} have a binding for\n"
- "the same symbol, the @var{conflict-proc} is called with the\n"
- "following parameters: the import environment, the symbol and\n"
- "the list of the imported environments that bind the symbol.\n"
- "If the @var{conflict-proc} returns an environment @var{env},\n"
- "the conflict is considered as resolved and the binding from\n"
- "@var{env} is used. If the @var{conflict-proc} returns some\n"
- "non-environment object, the conflict is considered unresolved\n"
- "and the symbol is treated as unspecified in the import\n"
- "environment.\n"
- "The checking for conflicts may be performed lazily, i. e. at\n"
- "the moment when a value or binding for a certain symbol is\n"
- "requested instead of the moment when the environment is\n"
- "created or the bindings of the imports change.\n"
- "All bindings in @var{imp} are immutable. If you apply\n"
- "@code{environment-define} or @code{environment-undefine} to\n"
- "@var{imp}, Guile will signal an\n"
- " @code{environment:immutable-binding} error. However,\n"
- "notice that the set of bindings in @var{imp} may still change,\n"
- "if one of its imported environments changes.")
-#define FUNC_NAME s_scm_make_import_environment
-{
- size_t size = sizeof (struct import_environment);
- struct import_environment *body = scm_gc_malloc (size, "import environment");
- SCM env;
-
- core_environments_preinit (&body->base);
- body->imports = SCM_BOOL_F;
- body->import_observers = SCM_BOOL_F;
- body->conflict_proc = SCM_BOOL_F;
-
- env = scm_make_environment (body);
-
- core_environments_init (&body->base, &import_environment_funcs);
- body->imports = SCM_EOL;
- body->import_observers = SCM_EOL;
- body->conflict_proc = conflict_proc;
-
- scm_import_environment_set_imports_x (env, imports);
-
- return env;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_import_environment_p, "import-environment?", 1, 0, 0,
- (SCM object),
- "Return @code{#t} if object is an import environment, or\n"
- "@code{#f} otherwise.")
-#define FUNC_NAME s_scm_import_environment_p
-{
- return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_import_environment_imports, "import-environment-imports", 1, 0, 0,
- (SCM env),
- "Return the list of environments imported by the import\n"
- "environment @var{env}.")
-#define FUNC_NAME s_scm_import_environment_imports
-{
- SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return IMPORT_ENVIRONMENT (env)->imports;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_import_environment_set_imports_x, "import-environment-set-imports!", 2, 0, 0,
- (SCM env, SCM imports),
- "Change @var{env}'s list of imported environments to\n"
- "@var{imports}, and check for conflicts.")
-#define FUNC_NAME s_scm_import_environment_set_imports_x
-{
- struct import_environment *body = IMPORT_ENVIRONMENT (env);
- SCM import_observers = SCM_EOL;
- SCM l;
-
- SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- for (l = imports; scm_is_pair (l); l = SCM_CDR (l))
- {
- SCM obj = SCM_CAR (l);
- SCM_ASSERT (SCM_ENVIRONMENT_P (obj), imports, SCM_ARG2, FUNC_NAME);
- }
- SCM_ASSERT (scm_is_null (l), imports, SCM_ARG2, FUNC_NAME);
-
- for (l = body->import_observers; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM obs = SCM_CAR (l);
- SCM_ENVIRONMENT_UNOBSERVE (env, obs);
- }
-
- for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM imp = SCM_CAR (l);
- SCM obs = SCM_ENVIRONMENT_OBSERVE (imp, import_environment_observer, env, 1);
- import_observers = scm_cons (obs, import_observers);
- }
-
- body->imports = imports;
- body->import_observers = import_observers;
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-
-/* export environments
- *
- * An export environment restricts an environment to a specified set of
- * bindings.
- *
- * Implementation: The export environment does no caching at all. For every
- * access, the signature is scanned. The signature that is stored internally
- * is an alist of pairs (symbol . (mutability)).
- */
-
-
-struct export_environment {
- struct core_environments_base base;
-
- SCM private;
- SCM private_observer;
-
- SCM signature;
-};
-
-
-#define EXPORT_ENVIRONMENT(env) \
- ((struct export_environment *) SCM_CELL_WORD_1 (env))
-
-
-SCM_SYMBOL (symbol_immutable_location, "immutable-location");
-SCM_SYMBOL (symbol_mutable_location, "mutable-location");
-
-
-
-static SCM
-export_environment_ref (SCM env, SCM sym)
-#define FUNC_NAME "export_environment_ref"
-{
- struct export_environment *body = EXPORT_ENVIRONMENT (env);
- SCM entry = scm_assq (sym, body->signature);
-
- if (scm_is_false (entry))
- return SCM_UNDEFINED;
- else
- return SCM_ENVIRONMENT_REF (body->private, sym);
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
-{
- struct export_environment *body = EXPORT_ENVIRONMENT (env);
- SCM result = init;
- SCM l;
-
- for (l = body->signature; !scm_is_null (l); l = SCM_CDR (l))
- {
- SCM symbol = SCM_CAR (l);
- SCM value = SCM_ENVIRONMENT_REF (body->private, symbol);
- if (!SCM_UNBNDP (value))
- result = (*proc) (data, symbol, value, result);
- }
- return result;
-}
-
-
-static SCM
-export_environment_define (SCM env SCM_UNUSED,
- SCM sym SCM_UNUSED,
- SCM val SCM_UNUSED)
-#define FUNC_NAME "export_environment_define"
-{
- return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_undefine (SCM env SCM_UNUSED, SCM sym SCM_UNUSED)
-#define FUNC_NAME "export_environment_undefine"
-{
- return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_set_x (SCM env, SCM sym, SCM val)
-#define FUNC_NAME "export_environment_set_x"
-{
- struct export_environment *body = EXPORT_ENVIRONMENT (env);
- SCM entry = scm_assq (sym, body->signature);
-
- if (scm_is_false (entry))
- {
- return SCM_UNDEFINED;
- }
- else
- {
- if (scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
- return SCM_ENVIRONMENT_SET (body->private, sym, val);
- else
- return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
- }
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_cell (SCM env, SCM sym, int for_write)
-#define FUNC_NAME "export_environment_cell"
-{
- struct export_environment *body = EXPORT_ENVIRONMENT (env);
- SCM entry = scm_assq (sym, body->signature);
-
- if (scm_is_false (entry))
- {
- return SCM_UNDEFINED;
- }
- else
- {
- if (!for_write || scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
- return SCM_ENVIRONMENT_CELL (body->private, sym, for_write);
- else
- return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
- }
-}
-#undef FUNC_NAME
-
-
-
-static int
-export_environment_print (SCM type, SCM port,
- scm_print_state *pstate SCM_UNUSED)
-{
- SCM address = scm_from_size_t (SCM_UNPACK (type));
- SCM base16 = scm_number_to_string (address, scm_from_int (16));
-
- scm_puts ("#<export environment ", port);
- scm_display (base16, port);
- scm_puts (">", port);
-
- return 1;
-}
-
-
-static struct scm_environment_funcs export_environment_funcs = {
- export_environment_ref,
- export_environment_fold,
- export_environment_define,
- export_environment_undefine,
- export_environment_set_x,
- export_environment_cell,
- core_environments_observe,
- core_environments_unobserve,
- export_environment_print
-};
-
-
-void *scm_type_export_environment = &export_environment_funcs;
-
-
-static void
-export_environment_observer (SCM caller SCM_UNUSED, SCM export_env)
-{
- core_environments_broadcast (export_env);
-}
-
-
-SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0,
- (SCM private, SCM signature),
- "Return a new environment @var{exp} containing only those\n"
- "bindings in private whose symbols are present in\n"
- "@var{signature}. The @var{private} argument must be an\n"
- "environment.\n\n"
- "The environment @var{exp} binds symbol to location when\n"
- "@var{env} does, and symbol is exported by @var{signature}.\n\n"
- "@var{signature} is a list specifying which of the bindings in\n"
- "@var{private} should be visible in @var{exp}. Each element of\n"
- "@var{signature} should be a list of the form:\n"
- " (symbol attribute ...)\n"
- "where each attribute is one of the following:\n"
- "@table @asis\n"
- "@item the symbol @code{mutable-location}\n"
- " @var{exp} should treat the\n"
- " location bound to symbol as mutable. That is, @var{exp}\n"
- " will pass calls to @code{environment-set!} or\n"
- " @code{environment-cell} directly through to private.\n"
- "@item the symbol @code{immutable-location}\n"
- " @var{exp} should treat\n"
- " the location bound to symbol as immutable. If the program\n"
- " applies @code{environment-set!} to @var{exp} and symbol, or\n"
- " calls @code{environment-cell} to obtain a writable value\n"
- " cell, @code{environment-set!} will signal an\n"
- " @code{environment:immutable-location} error. Note that, even\n"
- " if an export environment treats a location as immutable, the\n"
- " underlying environment may treat it as mutable, so its\n"
- " value may change.\n"
- "@end table\n"
- "It is an error for an element of signature to specify both\n"
- "@code{mutable-location} and @code{immutable-location}. If\n"
- "neither is specified, @code{immutable-location} is assumed.\n\n"
- "As a special case, if an element of signature is a lone\n"
- "symbol @var{sym}, it is equivalent to an element of the form\n"
- "@code{(sym)}.\n\n"
- "All bindings in @var{exp} are immutable. If you apply\n"
- "@code{environment-define} or @code{environment-undefine} to\n"
- "@var{exp}, Guile will signal an\n"
- "@code{environment:immutable-binding} error. However,\n"
- "notice that the set of bindings in @var{exp} may still change,\n"
- "if the bindings in private change.")
-#define FUNC_NAME s_scm_make_export_environment
-{
- size_t size;
- struct export_environment *body;
- SCM env;
-
- SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1, FUNC_NAME);
-
- size = sizeof (struct export_environment);
- body = scm_gc_malloc (size, "export environment");
-
- core_environments_preinit (&body->base);
- body->private = SCM_BOOL_F;
- body->private_observer = SCM_BOOL_F;
- body->signature = SCM_BOOL_F;
-
- env = scm_make_environment (body);
-
- core_environments_init (&body->base, &export_environment_funcs);
- body->private = private;
- body->private_observer
- = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
- body->signature = SCM_EOL;
-
- scm_export_environment_set_signature_x (env, signature);
-
- return env;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_export_environment_p, "export-environment?", 1, 0, 0,
- (SCM object),
- "Return @code{#t} if object is an export environment, or\n"
- "@code{#f} otherwise.")
-#define FUNC_NAME s_scm_export_environment_p
-{
- return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_export_environment_private, "export-environment-private", 1, 0, 0,
- (SCM env),
- "Return the private environment of export environment @var{env}.")
-#define FUNC_NAME s_scm_export_environment_private
-{
- SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return EXPORT_ENVIRONMENT (env)->private;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_export_environment_set_private_x, "export-environment-set-private!", 2, 0, 0,
- (SCM env, SCM private),
- "Change the private environment of export environment @var{env}.")
-#define FUNC_NAME s_scm_export_environment_set_private_x
-{
- struct export_environment *body;
-
- SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2, FUNC_NAME);
-
- body = EXPORT_ENVIRONMENT (env);
- SCM_ENVIRONMENT_UNOBSERVE (private, body->private_observer);
-
- body->private = private;
- body->private_observer
- = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_export_environment_signature, "export-environment-signature", 1, 0, 0,
- (SCM env),
- "Return the signature of export environment @var{env}.")
-#define FUNC_NAME s_scm_export_environment_signature
-{
- SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
-
- return EXPORT_ENVIRONMENT (env)->signature;
-}
-#undef FUNC_NAME
-
-
-static SCM
-export_environment_parse_signature (SCM signature, const char* caller)
-{
- SCM result = SCM_EOL;
- SCM l;
-
- for (l = signature; scm_is_pair (l); l = SCM_CDR (l))
- {
- SCM entry = SCM_CAR (l);
-
- if (scm_is_symbol (entry))
- {
- SCM new_entry = scm_cons2 (entry, symbol_immutable_location, SCM_EOL);
- result = scm_cons (new_entry, result);
- }
- else
- {
- SCM sym;
- SCM new_entry;
- int immutable = 0;
- int mutable = 0;
- SCM mutability;
- SCM l2;
-
- SCM_ASSERT (scm_is_pair (entry), entry, SCM_ARGn, caller);
- SCM_ASSERT (scm_is_symbol (SCM_CAR (entry)), entry, SCM_ARGn, caller);
-
- sym = SCM_CAR (entry);
-
- for (l2 = SCM_CDR (entry); scm_is_pair (l2); l2 = SCM_CDR (l2))
- {
- SCM attribute = SCM_CAR (l2);
- if (scm_is_eq (attribute, symbol_immutable_location))
- immutable = 1;
- else if (scm_is_eq (attribute, symbol_mutable_location))
- mutable = 1;
- else
- SCM_ASSERT (0, entry, SCM_ARGn, caller);
- }
- SCM_ASSERT (scm_is_null (l2), entry, SCM_ARGn, caller);
- SCM_ASSERT (!mutable || !immutable, entry, SCM_ARGn, caller);
-
- if (!mutable && !immutable)
- immutable = 1;
-
- mutability = mutable ? symbol_mutable_location : symbol_immutable_location;
- new_entry = scm_cons2 (sym, mutability, SCM_EOL);
- result = scm_cons (new_entry, result);
- }
- }
- SCM_ASSERT (scm_is_null (l), signature, SCM_ARGn, caller);
-
- /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
- * are, however, no checks for symbols entered twice with contradicting
- * mutabilities. It would be nice, to implement this test, to be able to
- * call the sort functions conveniently from C.
- */
-
- return scm_reverse (result);
-}
-
-
-SCM_DEFINE (scm_export_environment_set_signature_x, "export-environment-set-signature!", 2, 0, 0,
- (SCM env, SCM signature),
- "Change the signature of export environment @var{env}.")
-#define FUNC_NAME s_scm_export_environment_set_signature_x
-{
- SCM parsed_sig;
-
- SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
- parsed_sig = export_environment_parse_signature (signature, FUNC_NAME);
-
- EXPORT_ENVIRONMENT (env)->signature = parsed_sig;
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-
-void
-scm_environments_prehistory ()
-{
- /* create environment smob */
- scm_tc16_environment = scm_make_smob_type ("environment", 0);
- scm_set_smob_print (scm_tc16_environment, environment_print);
-
- /* create observer smob */
- scm_tc16_observer = scm_make_smob_type ("observer", 0);
- scm_set_smob_print (scm_tc16_observer, observer_print);
-
- /* create system environment */
- scm_system_environment = scm_make_leaf_environment ();
- scm_permanent_object (scm_system_environment);
-}
-
-
-void
-scm_init_environments ()
-{
-#include "libguile/environments.x"
-}
-
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/environments.h b/libguile/environments.h
deleted file mode 100644
index 143963254..000000000
--- a/libguile/environments.h
+++ /dev/null
@@ -1,187 +0,0 @@
-/* classes: h_files */
-
-#ifndef SCM_ENVIRONMENTS_H
-#define SCM_ENVIRONMENTS_H
-
-/* Copyright (C) 1999,2000, 2006, 2008 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
- */
-
-
-
-#include "libguile/__scm.h"
-
-
-
-/* The type for folding functions written in C. A function meant to be passed
- * to scm_c_environment_fold should have the type scm_environment_folder.
- */
-typedef SCM (*scm_environment_folder) (SCM data, SCM sym, SCM val, SCM tail);
-
-
-/* The type for observer functions written in C. A function meant to be
- * passed to scm_c_environment_observe should have the type
- * scm_environment_observer.
- */
-typedef void (*scm_environment_observer) (SCM env, SCM data);
-
-
-struct scm_environment_funcs {
- SCM (*ref) (SCM self, SCM symbol);
- SCM (*fold) (SCM self, scm_environment_folder proc, SCM data, SCM init);
-
- SCM (*define) (SCM self, SCM symbol, SCM value);
- SCM (*undefine) (SCM self, SCM symbol);
- SCM (*set) (SCM self, SCM symbol, SCM value);
-
- SCM (*cell) (SCM self, SCM symbol, int for_write);
- SCM (*observe) (SCM self, scm_environment_observer proc, SCM data, int weak_p);
- void (*unobserve) (SCM self, SCM token);
-
- int (*print) (SCM self, SCM port, scm_print_state *pstate);
-};
-
-
-
-#define SCM_ENVIRONMENT_SUCCESS SCM_BOOL_T
-#define SCM_ENVIRONMENT_BINDING_IMMUTABLE scm_from_int (0)
-#define SCM_ENVIRONMENT_LOCATION_IMMUTABLE scm_from_int (1)
-#define SCM_ENVIRONMENT_LOCATION_NO_CELL SCM_BOOL_F
-
-SCM_API scm_t_bits scm_tc16_environment;
-
-#define SCM_ENVIRONMENT_P(x) \
- (!SCM_IMP (x) && SCM_CELL_TYPE (x) == scm_tc16_environment)
-#define SCM_ENVIRONMENT_FUNCS(env) \
- (*((struct scm_environment_funcs **) SCM_CELL_WORD_1 (env)))
-#define SCM_ENVIRONMENT_BOUND_P(env, symbol) \
- (!SCM_UNBNDP (SCM_ENVIRONMENT_REF (env, symbol)))
-#define SCM_ENVIRONMENT_REF(env, symbol) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->ref)) (env, symbol))
-#define SCM_ENVIRONMENT_FOLD(env, proc, data, init) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->fold)) (env, proc, data, init))
-#define SCM_ENVIRONMENT_DEFINE(env, symbol, value) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->define)) (env, symbol, value))
-#define SCM_ENVIRONMENT_UNDEFINE(env, symbol) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->undefine)) (env, symbol))
-#define SCM_ENVIRONMENT_SET(env, symbol, value) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->set)) (env, symbol, value))
-#define SCM_ENVIRONMENT_CELL(env, symbol, for_write) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->cell)) (env, symbol, for_write))
-#define SCM_ENVIRONMENT_OBSERVE(env, proc, data, weak_p) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->observe)) (env, proc, data, weak_p))
-#define SCM_ENVIRONMENT_UNOBSERVE(env, token) \
- ((*(SCM_ENVIRONMENT_FUNCS (env)->unobserve)) (env, token))
-
-SCM_API scm_t_bits scm_tc16_observer;
-
-#define SCM_OBSERVER_P(x) \
- (!SCM_IMP (x) && (SCM_CELL_TYPE (x) == scm_tc16_observer))
-#define SCM_OBSERVER_ENVIRONMENT(x) \
- (SCM_CELL_OBJECT_1 (x))
-#define SCM_OBSERVER_DATA(x) \
- (SCM_CELL_OBJECT_2 (x))
-#define SCM_OBSERVER_PROC(x) \
- ((scm_environment_observer) SCM_CELL_WORD_3 (x))
-
-SCM_API SCM scm_system_environment;
-
-SCM_API void scm_error_environment_unbound (const char *, SCM, SCM) SCM_NORETURN;
-SCM_API void scm_error_environment_immutable_binding (const char *, SCM, SCM) SCM_NORETURN;
-SCM_API void scm_error_environment_immutable_location (const char *, SCM, SCM) SCM_NORETURN;
-
-SCM_API SCM scm_make_environment (void *type);
-SCM_API SCM scm_environment_p (SCM env);
-SCM_API SCM scm_environment_bound_p (SCM env, SCM sym);
-SCM_API SCM scm_environment_ref (SCM env, SCM sym);
-SCM_API SCM scm_c_environment_ref (SCM env, SCM sym);
-SCM_API SCM scm_environment_fold (SCM env, SCM proc, SCM init);
-SCM_API SCM scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init);
-SCM_API SCM scm_environment_define (SCM env, SCM sym, SCM val);
-SCM_API SCM scm_environment_undefine (SCM env, SCM sym);
-SCM_API SCM scm_environment_set_x (SCM env, SCM sym, SCM val);
-SCM_API SCM scm_environment_cell (SCM env, SCM sym, SCM for_write);
-SCM_API SCM scm_c_environment_cell (SCM env, SCM sym, int for_write);
-SCM_API SCM scm_environment_observe (SCM env, SCM proc);
-SCM_API SCM scm_environment_observe_weak (SCM env, SCM proc);
-SCM_API SCM scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p);
-SCM_API SCM scm_environment_unobserve (SCM token);
-
-SCM_INTERNAL void scm_environments_prehistory (void);
-SCM_INTERNAL void scm_init_environments (void);
-
-
-
-SCM_API void *scm_type_leaf_environment;
-
-#define SCM_LEAF_ENVIRONMENT_P(env) \
- (SCM_ENVIRONMENT_P (env) \
- && SCM_ENVIRONMENT_FUNCS (env) == scm_type_leaf_environment)
-
-SCM_API SCM scm_make_leaf_environment (void);
-SCM_API SCM scm_leaf_environment_p (SCM env);
-
-
-
-SCM_API void *scm_type_eval_environment;
-
-#define SCM_EVAL_ENVIRONMENT_P(env) \
- (SCM_ENVIRONMENT_P (env) \
- && SCM_ENVIRONMENT_FUNCS (env) == scm_type_eval_environment)
-
-SCM_API SCM scm_make_eval_environment (SCM local, SCM imported);
-SCM_API SCM scm_eval_environment_p (SCM env);
-SCM_API SCM scm_eval_environment_local (SCM env);
-SCM_API SCM scm_eval_environment_set_local_x (SCM env, SCM local);
-SCM_API SCM scm_eval_environment_imported (SCM env);
-SCM_API SCM scm_eval_environment_set_imported_x (SCM env, SCM imported);
-
-
-
-SCM_API void *scm_type_import_environment;
-
-#define SCM_IMPORT_ENVIRONMENT_P(env) \
- (SCM_ENVIRONMENT_P (env) \
- && SCM_ENVIRONMENT_FUNCS (env) == scm_type_import_environment)
-
-SCM_API SCM scm_make_import_environment (SCM imports, SCM conflict_proc);
-SCM_API SCM scm_import_environment_p (SCM env);
-SCM_API SCM scm_import_environment_imports (SCM env);
-SCM_API SCM scm_import_environment_set_imports_x (SCM env, SCM imports);
-
-
-
-SCM_API void *scm_type_export_environment;
-
-#define SCM_EXPORT_ENVIRONMENT_P(env) \
- (SCM_ENVIRONMENT_P (env) \
- && SCM_ENVIRONMENT_FUNCS (env) == scm_type_export_environment)
-
-SCM_API SCM scm_make_export_environment (SCM private, SCM signature);
-SCM_API SCM scm_export_environment_p (SCM env);
-SCM_API SCM scm_export_environment_private (SCM env);
-SCM_API SCM scm_export_environment_set_private_x (SCM env, SCM private);
-SCM_API SCM scm_export_environment_signature (SCM env);
-SCM_API SCM scm_export_environment_set_signature_x (SCM env, SCM signature);
-
-#endif /* SCM_ENVIRONMENTS_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/eval.c b/libguile/eval.c
index e58c05410..cdb90423a 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -41,7 +41,6 @@
#include "libguile/eq.h"
#include "libguile/feature.h"
#include "libguile/fluids.h"
-#include "libguile/futures.h"
#include "libguile/goops.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
@@ -409,7 +408,6 @@ static const char *const isymnames[] =
"#@slot-ref",
"#@slot-set!",
"#@delay",
- "#@future",
"#@call-with-values",
"#@else",
"#@arrow",
@@ -784,9 +782,6 @@ static SCM scm_m_do (SCM xorig, SCM env);
static SCM scm_m_quasiquote (SCM xorig, SCM env);
static SCM scm_m_delay (SCM xorig, SCM env);
static SCM scm_m_generalized_set_x (SCM xorig, SCM env);
-#if 0 /* Futures are disabled, see "futures.h". */
-static SCM scm_m_future (SCM xorig, SCM env);
-#endif
static SCM scm_m_define (SCM x, SCM env);
static SCM scm_m_letrec (SCM xorig, SCM env);
static SCM scm_m_let (SCM xorig, SCM env);
@@ -2195,36 +2190,6 @@ scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
return scm_list_1 (SCM_IM_BEGIN);
}
-#if 0
-
-/* See futures.h for a comment why futures are not enabled.
- */
-
-SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future);
-SCM_GLOBAL_SYMBOL (scm_sym_future, "future");
-
-/* Like promises, futures are implemented as closures with an empty
- * parameter list. Thus, (future <expression>) is transformed into
- * (#@future '() <expression>), where the empty list represents the
- * empty parameter list. This representation allows for easy creation
- * of the closure during evaluation. */
-static SCM
-scm_m_future (SCM expr, SCM env)
-{
- const SCM new_expr = memoize_as_thunk_prototype (expr, env);
- SCM_SETCAR (new_expr, SCM_IM_FUTURE);
- return new_expr;
-}
-
-static SCM
-unmemoize_future (const SCM expr, const SCM env)
-{
- const SCM thunk_expr = SCM_CADDR (expr);
- return scm_list_2 (scm_sym_future, unmemoize_expression (thunk_expr, env));
-}
-
-#endif /* futures disabled. */
-
SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
SCM_SYMBOL (scm_sym_setter, "setter");
@@ -2493,13 +2458,6 @@ unmemoize_builtin_macro (const SCM expr, const SCM env)
case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
return unmemoize_at_call_with_values (expr, env);
-#if 0
- /* See futures.h for a comment why futures are not enabled.
- */
- case (ISYMNUM (SCM_IM_FUTURE)):
- return unmemoize_future (expr, env);
-#endif
-
case (ISYMNUM (SCM_IM_SLOT_REF)):
return unmemoize_atslot_ref (expr, env);
diff --git a/libguile/eval.h b/libguile/eval.h
index 4467358f5..522f639d8 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -157,9 +157,9 @@ SCM_INTERNAL void scm_init_eval (void);
#if (SCM_ENABLE_DEPRECATED == 1)
/* Deprecated in guile 1.7.0 on 2004-03-29. */
-SCM_API SCM scm_ceval (SCM x, SCM env);
-SCM_API SCM scm_deval (SCM x, SCM env);
-SCM_API SCM (*scm_ceval_ptr) (SCM x, SCM env);
+SCM_DEPRECATED SCM scm_ceval (SCM x, SCM env);
+SCM_DEPRECATED SCM scm_deval (SCM x, SCM env);
+SCM_DEPRECATED SCM (*scm_ceval_ptr) (SCM x, SCM env);
#endif
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index 25abf6cb9..5b4604a7a 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -304,7 +304,7 @@ dispatch:
while (!scm_is_null (SCM_CDR (x)))
{
SCM test_result = EVALCAR (x, env);
- if (scm_is_false (test_result) || SCM_NILP (test_result))
+ if (scm_is_false_or_nil (test_result))
RETURN (SCM_BOOL_F);
else
x = SCM_CDR (x);
@@ -442,8 +442,7 @@ dispatch:
xx = SCM_CDR (clause);
proc = EVALCAR (xx, env);
guard_result = SCM_APPLY (proc, arg1, SCM_EOL);
- if (scm_is_true (guard_result)
- && !SCM_NILP (guard_result))
+ if (scm_is_true_and_not_nil (guard_result))
{
proc = SCM_CDDR (xx);
proc = EVALCAR (proc, env);
@@ -451,7 +450,7 @@ dispatch:
goto apply_proc;
}
}
- else if (scm_is_true (arg1) && !SCM_NILP (arg1))
+ else if (scm_is_true_and_not_nil (arg1))
{
x = SCM_CDR (clause);
if (scm_is_null (x))
@@ -498,7 +497,7 @@ dispatch:
SCM test_result = EVALCAR (test_form, env);
- while (scm_is_false (test_result) || SCM_NILP (test_result))
+ while (scm_is_false_or_nil (test_result))
{
{
/* Evaluate body forms. */
@@ -552,7 +551,7 @@ dispatch:
{
SCM test_result = EVALCAR (x, env);
x = SCM_CDR (x); /* then expression */
- if (scm_is_false (test_result) || SCM_NILP (test_result))
+ if (scm_is_false_or_nil (test_result))
{
x = SCM_CDR (x); /* else expression */
if (scm_is_null (x))
@@ -623,7 +622,7 @@ dispatch:
while (!scm_is_null (SCM_CDR (x)))
{
SCM val = EVALCAR (x, env);
- if (scm_is_true (val) && !SCM_NILP (val))
+ if (scm_is_true_and_not_nil (val))
RETURN (val);
else
x = SCM_CDR (x);
@@ -735,13 +734,6 @@ dispatch:
case (ISYMNUM (SCM_IM_DELAY)):
RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env)));
-#if 0
- /* See futures.h for a comment why futures are not enabled.
- */
- case (ISYMNUM (SCM_IM_FUTURE)):
- RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
-#endif
-
/* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
code (type_dispatch) is intended to be the tail of the case
clause for the internal macro SCM_IM_DISPATCH. Please don't
@@ -1259,7 +1251,7 @@ dispatch:
RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
case scm_tc7_gsubr:
#ifdef DEVAL
- debug.info->a.args = scm_cons (arg1, debug.info->a.args);
+ debug.info->a.args = debug.info->a.args;
debug.info->a.proc = proc;
#endif
RETURN (scm_i_gsubr_apply (proc, arg1, SCM_UNDEFINED));
@@ -1896,7 +1888,7 @@ tail:
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
debug.vect[0].a.proc = proc;
- debug.vect[0].a.args = scm_cons (arg1, args);
+ debug.vect[0].a.args = args;
#else
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
diff --git a/libguile/frames.c b/libguile/frames.c
index a6835fbb4..39f78e09a 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -80,32 +80,19 @@ SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_vm_frame_arguments
+SCM
+scm_vm_frame_arguments (SCM frame)
+#define FUNC_NAME "vm-frame-arguments"
{
- SCM *fp;
- int i;
- struct scm_objcode *bp;
- SCM ret;
+ static SCM var = SCM_BOOL_F;
SCM_VALIDATE_VM_FRAME (1, frame);
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ if (scm_is_false (var))
+ var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
+ "vm-frame-arguments");
- if (!bp->nargs)
- return SCM_EOL;
- else if (bp->nrest)
- ret = SCM_FRAME_VARIABLE (fp, bp->nargs - 1);
- else
- ret = scm_cons (SCM_FRAME_VARIABLE (fp, bp->nargs - 1), SCM_EOL);
-
- for (i = bp->nargs - 2; i >= 0; i--)
- ret = scm_cons (SCM_FRAME_VARIABLE (fp, i), ret);
-
- return ret;
+ return scm_call_1 (SCM_VARIABLE_REF (var), frame);
}
#undef FUNC_NAME
@@ -127,47 +114,114 @@ SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
}
#undef FUNC_NAME
+/* The number of locals would be a simple thing to compute, if it weren't for
+ the presence of not-yet-active frames on the stack. So we have a cheap
+ heuristic to detect not-yet-active frames, and skip over them. Perhaps we
+ should represent them more usefully.
+ */
+SCM_DEFINE (scm_vm_frame_num_locals, "vm-frame-num-locals", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_num_locals
+{
+ SCM *sp, *p;
+ unsigned int n = 0;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ return scm_from_uint (n);
+}
+#undef FUNC_NAME
+
+/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
(SCM frame, SCM index),
"")
#define FUNC_NAME s_scm_vm_frame_local_ref
{
- SCM *fp;
+ SCM *sp, *p;
+ unsigned int n = 0;
unsigned int i;
- struct scm_objcode *bp;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
- SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
- return SCM_FRAME_VARIABLE (fp, i);
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else if (n == i)
+ return *p;
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ SCM_OUT_OF_RANGE (SCM_ARG2, index);
}
#undef FUNC_NAME
+/* Need same not-yet-active frame logic here as in vm-frame-num-locals */
SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
(SCM frame, SCM index, SCM val),
"")
#define FUNC_NAME s_scm_vm_frame_local_set_x
{
- SCM *fp;
+ SCM *sp, *p;
+ unsigned int n = 0;
unsigned int i;
- struct scm_objcode *bp;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- fp = SCM_VM_FRAME_FP (frame);
- bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+ SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
- SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
- SCM_FRAME_VARIABLE (fp, i) = val;
+ sp = SCM_VM_FRAME_SP (frame);
+ p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+ while (p <= sp)
+ {
+ if (p + 1 < sp && p[1] == (SCM)0)
+ /* skip over not-yet-active frame */
+ p += 3;
+ else if (n == i)
+ {
+ *p = val;
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ p++;
+ n++;
+ }
+ }
+ SCM_OUT_OF_RANGE (SCM_ARG2, index);
+}
+#undef FUNC_NAME
- return SCM_UNSPECIFIED;
+SCM_DEFINE (scm_vm_frame_instruction_pointer, "vm-frame-instruction-pointer", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_vm_frame_instruction_pointer
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return scm_from_ulong ((unsigned long)
+ (SCM_VM_FRAME_IP (frame)
+ - SCM_PROGRAM_DATA (scm_vm_frame_program (frame))->base));
}
#undef FUNC_NAME
@@ -209,24 +263,6 @@ SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_vm_frame_stack
-{
- SCM *top, *bottom, ret = SCM_EOL;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
-
- top = SCM_VM_FRAME_SP (frame);
- bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame));
- while (bottom <= top)
- ret = scm_cons (*bottom++, ret);
-
- return ret;
-}
-#undef FUNC_NAME
-
extern SCM
scm_c_vm_frame_prev (SCM frame)
{
diff --git a/libguile/frames.h b/libguile/frames.h
index 0165924a7..f744c2b24 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -31,15 +31,15 @@
---------------
| ... |
- | Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs = SCM_FRAME_UPPER_ADDRESS (fp)
- +==================+
+ | Intermed. val. 0 | <- fp + nargs + nlocs
+ +------------------+
| Local variable 1 |
- | Local variable 0 | <- fp + bp->nargs
+ | Local variable 0 | <- fp + nargs
| Argument 1 |
- | Argument 0 | <- fp
+ | Argument 0 | <- fp = SCM_FRAME_STACK_ADDRESS (fp)
| Program | <- fp - 1
- +------------------+
- | Return address |
+ +==================+
+ | Return address | <- SCM_FRAME_UPPER_ADDRESS (fp)
| MV return address|
| Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp)
+==================+
@@ -50,10 +50,8 @@
assumed to be as long as SCM objects. */
#define SCM_FRAME_DATA_ADDRESS(fp) (fp - 4)
-#define SCM_FRAME_UPPER_ADDRESS(fp) \
- (fp \
- + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
- + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
+#define SCM_FRAME_STACK_ADDRESS(fp) (fp)
+#define SCM_FRAME_UPPER_ADDRESS(fp) (fp - 2)
#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 4)
#define SCM_FRAME_BYTE_CAST(x) ((scm_t_uint8 *) SCM_UNPACK (x))
@@ -71,8 +69,8 @@
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
-#define SCM_FRAME_VARIABLE(fp,i) fp[i]
-#define SCM_FRAME_PROGRAM(fp) fp[-1]
+#define SCM_FRAME_VARIABLE(fp,i) SCM_FRAME_STACK_ADDRESS (fp)[i]
+#define SCM_FRAME_PROGRAM(fp) SCM_FRAME_STACK_ADDRESS (fp)[-1]
/*
@@ -105,12 +103,13 @@ SCM_API SCM scm_vm_frame_p (SCM obj);
SCM_API SCM scm_vm_frame_program (SCM frame);
SCM_API SCM scm_vm_frame_arguments (SCM frame);
SCM_API SCM scm_vm_frame_source (SCM frame);
+SCM_API SCM scm_vm_frame_num_locals (SCM frame);
SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index);
SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
+SCM_API SCM scm_vm_frame_instruction_pointer (SCM frame);
SCM_API SCM scm_vm_frame_return_address (SCM frame);
SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
-SCM_API SCM scm_vm_frame_stack (SCM frame);
SCM_API SCM scm_c_vm_frame_prev (SCM frame);
diff --git a/libguile/futures.c b/libguile/futures.c
deleted file mode 100644
index b330f4ded..000000000
--- a/libguile/futures.c
+++ /dev/null
@@ -1,375 +0,0 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006, 2008 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
- */
-
-
-
-
-#if 0
-
-/* This whole file is not being compiled. See futures.h for the
- reason.
-*/
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/_scm.h"
-#include "libguile/eval.h"
-#include "libguile/ports.h"
-#include "libguile/validate.h"
-#include "libguile/stime.h"
-#include "libguile/threads.h"
-
-#include "libguile/futures.h"
-
-#define LINK(list, obj) \
-do { \
- SCM_SET_FUTURE_NEXT (obj, list); \
- list = obj; \
-} while (0)
-
-#define UNLINK(list, obj) \
-do { \
- obj = list; \
- list = SCM_FUTURE_NEXT (list); \
-} while (0)
-
-scm_i_pthread_mutex_t future_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
-static SCM futures = SCM_EOL;
-static SCM young = SCM_EOL;
-static SCM old = SCM_EOL;
-static SCM undead = SCM_EOL;
-
-static long last_switch;
-
-#ifdef SCM_FUTURES_DEBUG
-static int n_dead = 0;
-
-static SCM
-count (SCM ls)
-{
- int n = 0;
- while (!scm_is_null (ls))
- {
- ++n;
- ls = SCM_FUTURE_NEXT (ls);
- }
- return scm_from_int (n);
-}
-
-extern SCM scm_future_cache_status (void);
-
-SCM_DEFINE (scm_future_cache_status, "future-cache-status", 0, 0, 0,
- (),
- "Return a list containing number of futures, youngs, olds, undeads and deads.")
-#define FUNC_NAME s_scm_future_cache_status
-{
- int nd = n_dead;
- n_dead = 0;
- return scm_list_5 (count (futures),
- count (young),
- count (old),
- count (undead),
- scm_from_int (nd));
-}
-#undef FUNC_NAME
-
-#endif
-
-SCM *scm_loc_sys_thread_handler;
-
-SCM_DEFINE (scm_make_future, "make-future", 1, 0, 0,
- (SCM thunk),
- "Make a future evaluating THUNK.")
-#define FUNC_NAME s_scm_make_future
-{
- SCM_VALIDATE_THUNK (1, thunk);
- return scm_i_make_future (thunk);
-}
-#undef FUNC_NAME
-
-static char *s_future = "future";
-
-static void
-cleanup (scm_t_future *future)
-{
- scm_i_pthread_mutex_destroy (&future->mutex);
- scm_i_pthread_cond_destroy (&future->cond);
- scm_gc_free (future, sizeof (*future), s_future);
-#ifdef SCM_FUTURES_DEBUG
- ++n_dead;
-#endif
-}
-
-static SCM
-future_loop (scm_t_future *future)
-{
- scm_i_scm_pthread_mutex_lock (&future->mutex);
- do {
- if (future->status == SCM_FUTURE_SIGNAL_ME)
- scm_i_pthread_cond_broadcast (&future->cond);
- future->status = SCM_FUTURE_COMPUTING;
- future->data = (SCM_CLOSUREP (future->data)
- ? scm_i_call_closure_0 (future->data)
- : scm_call_0 (future->data));
- scm_i_scm_pthread_cond_wait (&future->cond, &future->mutex);
- } while (!future->die_p);
- future->status = SCM_FUTURE_DEAD;
- scm_i_pthread_mutex_unlock (&future->mutex);
- return SCM_UNSPECIFIED;
-}
-
-static SCM
-future_handler (scm_t_future *future, SCM key, SCM args)
-{
- future->status = SCM_FUTURE_DEAD;
- scm_i_pthread_mutex_unlock (&future->mutex);
- return scm_apply_1 (*scm_loc_sys_thread_handler, key, args);
-}
-
-static SCM
-alloc_future (SCM thunk)
-{
- scm_t_future *f = scm_gc_malloc (sizeof (*f), s_future);
- SCM future;
- f->data = SCM_BOOL_F;
- scm_i_pthread_mutex_init (&f->mutex, NULL);
- scm_i_pthread_cond_init (&f->cond, NULL);
- f->die_p = 0;
- f->status = SCM_FUTURE_TASK_ASSIGNED;
- scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
- SCM_NEWSMOB2 (future, scm_tc16_future, futures, f);
- SCM_SET_FUTURE_DATA (future, thunk);
- futures = future;
- scm_i_pthread_mutex_unlock (&future_admin_mutex);
- scm_spawn_thread ((scm_t_catch_body) future_loop,
- SCM_FUTURE (future),
- (scm_t_catch_handler) future_handler,
- SCM_FUTURE (future));
- return future;
-}
-
-static void
-kill_future (SCM future)
-{
- SCM_FUTURE (future)->die_p = 1;
- LINK (undead, future);
-}
-
-SCM
-scm_i_make_future (SCM thunk)
-{
- SCM future;
- scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
- while (1)
- {
- if (!scm_is_null (old))
- UNLINK (old, future);
- else if (!scm_is_null (young))
- UNLINK (young, future);
- else
- {
- scm_i_pthread_mutex_unlock (&future_admin_mutex);
- return alloc_future (thunk);
- }
- if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (future)))
- kill_future (future);
- else if (!SCM_FUTURE_ALIVE_P (future))
- {
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
- cleanup (SCM_FUTURE (future));
- }
- else
- break;
- }
- LINK (futures, future);
- scm_i_pthread_mutex_unlock (&future_admin_mutex);
- SCM_SET_FUTURE_DATA (future, thunk);
- SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_TASK_ASSIGNED);
- scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
- return future;
-}
-
-
-static int
-future_print (SCM exp, SCM port, scm_print_state *pstate)
-{
- int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<future ", port);
- SCM_SET_WRITINGP (pstate, 1);
- scm_iprin1 (SCM_FUTURE_DATA (exp), port, pstate);
- SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
- return !0;
-}
-
-SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0,
- (SCM future),
- "If the future @var{x} has not been computed yet, compute and\n"
- "return @var{x}, otherwise just return the previously computed\n"
- "value.")
-#define FUNC_NAME s_scm_future_ref
-{
- SCM res;
- SCM_VALIDATE_FUTURE (1, future);
- scm_i_scm_pthread_mutex_lock (SCM_FUTURE_MUTEX (future));
- if (SCM_FUTURE_STATUS (future) != SCM_FUTURE_COMPUTING)
- {
- SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_SIGNAL_ME);
- scm_i_scm_pthread_cond_wait (SCM_FUTURE_COND (future),
- SCM_FUTURE_MUTEX (future));
- }
- if (!SCM_FUTURE_ALIVE_P (future))
- {
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
- SCM_MISC_ERROR ("requesting result from failed future ~A",
- scm_list_1 (future));
- }
- res = SCM_FUTURE_DATA (future);
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
- return res;
-}
-#undef FUNC_NAME
-
-static void
-kill_futures (SCM victims)
-{
- while (!scm_is_null (victims))
- {
- SCM future;
- UNLINK (victims, future);
- kill_future (future);
- scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
- }
-}
-
-static void
-cleanup_undead ()
-{
- SCM next = undead, *nextloc = &undead;
- while (!scm_is_null (next))
- {
- if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (next)))
- goto next;
- else if (SCM_FUTURE_ALIVE_P (next))
- {
- scm_i_pthread_cond_signal (SCM_FUTURE_COND (next));
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next));
- next:
- SCM_SET_GC_MARK (next);
- nextloc = SCM_FUTURE_NEXTLOC (next);
- next = *nextloc;
- }
- else
- {
- SCM future;
- UNLINK (next, future);
- scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
- cleanup (SCM_FUTURE (future));
- *nextloc = next;
- }
- }
-}
-
-static void
-mark_futures (SCM futures)
-{
- while (!scm_is_null (futures))
- {
- SCM_SET_GC_MARK (futures);
- futures = SCM_FUTURE_NEXT (futures);
- }
-}
-
-static void *
-scan_futures (void *dummy1, void *dummy2, void *dummy3)
-{
- SCM next, *nextloc;
-
- long now = scm_c_get_internal_run_time ();
- if (now - last_switch > SCM_TIME_UNITS_PER_SECOND)
- {
- /* switch out old (> 1 sec), unused futures */
- kill_futures (old);
- old = young;
- young = SCM_EOL;
- last_switch = now;
- }
- else
- mark_futures (young);
-
- next = futures;
- nextloc = &futures;
- while (!scm_is_null (next))
- {
- if (!SCM_GC_MARK_P (next))
- goto free;
- keep:
- nextloc = SCM_FUTURE_NEXTLOC (next);
- next = *nextloc;
- }
- goto exit;
- while (!scm_is_null (next))
- {
- if (SCM_GC_MARK_P (next))
- {
- *nextloc = next;
- goto keep;
- }
- free:
- {
- SCM future;
- UNLINK (next, future);
- SCM_SET_GC_MARK (future);
- LINK (young, future);
- }
- }
- *nextloc = SCM_EOL;
- exit:
- cleanup_undead ();
- mark_futures (old);
- return 0;
-}
-
-scm_t_bits scm_tc16_future;
-
-void
-scm_init_futures ()
-{
- last_switch = scm_c_get_internal_run_time ();
-
- scm_loc_sys_thread_handler
- = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F));
-
- scm_tc16_future = scm_make_smob_type ("future", 0);
- scm_set_smob_print (scm_tc16_future, future_print);
-
- scm_c_hook_add (&scm_before_sweep_c_hook, scan_futures, 0, 0);
-#include "libguile/futures.x"
-}
-
-#endif
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/futures.h b/libguile/futures.h
deleted file mode 100644
index 5d7712e1a..000000000
--- a/libguile/futures.h
+++ /dev/null
@@ -1,91 +0,0 @@
-/* classes: h_files */
-
-#ifndef SCM_FUTURES_H
-#define SCM_FUTURES_H
-
-/* Copyright (C) 2002, 2003, 2006, 2008 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
- */
-
-
-
-#if 0
-
-/* Futures have the following known bugs, which should be fixed before
- including them in Guile:
-
- - The implementation of the thread cache needs to be better so that
- it behaves reasonable under heavy use.
-
- - The dynamic state of a thread needs to be properly initialized
- when it is retrieved from the cache.
-*/
-
-#include "libguile/__scm.h"
-#include "libguile/threads.h"
-
-
-
-typedef struct scm_t_future {
- SCM data;
- scm_i_pthread_mutex_t mutex;
- scm_i_pthread_cond_t cond;
- int status;
- int die_p;
-} scm_t_future;
-
-#define SCM_FUTURE_DEAD 0
-#define SCM_FUTURE_SIGNAL_ME -1
-#define SCM_FUTURE_COMPUTING 1
-#define SCM_FUTURE_TASK_ASSIGNED 2
-
-#define SCM_VALIDATE_FUTURE(pos, obj) \
- SCM_ASSERT_TYPE (SCM_TYP16_PREDICATE (scm_tc16_future, obj), \
- obj, pos, FUNC_NAME, "future");
-#define SCM_FUTURE(future) ((scm_t_future *) SCM_SMOB_DATA_2 (future))
-#define SCM_FUTURE_MUTEX(future) (&SCM_FUTURE (future)->mutex)
-#define SCM_FUTURE_COND(future) (&SCM_FUTURE (future)->cond)
-#define SCM_FUTURE_STATUS(future) (SCM_FUTURE (future)->status)
-#define SCM_SET_FUTURE_STATUS(future, x) \
- do { SCM_FUTURE (future)->status = (x); } while (0)
-#define SCM_FUTURE_ALIVE_P(future) (SCM_FUTURE_STATUS (future))
-#define SCM_FUTURE_DATA(future) (SCM_FUTURE (future)->data)
-#define SCM_SET_FUTURE_DATA(future, x) \
- do { SCM_FUTURE (future)->data = (x); } while (0)
-#define SCM_FUTURE_NEXT SCM_SMOB_OBJECT
-#define SCM_FUTURE_NEXTLOC SCM_SMOB_OBJECT_LOC
-#define SCM_SET_FUTURE_NEXT SCM_SET_SMOB_OBJECT
-
-SCM_API scm_t_bits scm_tc16_future;
-
-extern SCM *scm_loc_sys_thread_handler;
-
-SCM_INTERNAL SCM scm_i_make_future (SCM thunk);
-SCM_API SCM scm_make_future (SCM thunk);
-SCM_API SCM scm_future_ref (SCM future);
-
-void scm_init_futures (void);
-
-#endif /* Futures are disabled for now. */
-
-#endif /* SCM_FUTURES_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index e48d2cfd1..669f7894b 100644
--- a/libguile/gc-malloc.c
+++ b/libguile/gc-malloc.c
@@ -205,9 +205,8 @@ scm_gc_malloc (size_t size, const char *what)
void *
scm_gc_calloc (size_t size, const char *what)
{
- void *ptr = scm_gc_malloc (size, what);
- memset (ptr, 0x0, size);
- return ptr;
+ /* `GC_MALLOC ()' always returns a zeroed buffer. */
+ return scm_gc_malloc (size, what);
}
@@ -236,7 +235,7 @@ scm_gc_free (void *mem, size_t size, const char *what)
char *
scm_gc_strndup (const char *str, size_t n, const char *what)
{
- char *dst = GC_MALLOC (n+1);
+ char *dst = GC_MALLOC_ATOMIC (n + 1);
memcpy (dst, str, n);
dst[n] = 0;
return dst;
diff --git a/libguile/gc.c b/libguile/gc.c
index d3c53c748..96e3c306f 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -56,7 +56,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
#include "libguile/gc.h"
#include "libguile/dynwind.h"
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
@@ -146,18 +146,7 @@ scm_assert_cell_valid (SCM cell)
*/
if (scm_expensive_debug_cell_accesses_p)
scm_i_expensive_validation_check (cell);
-#if (SCM_DEBUG_MARKING_API == 0)
- if (!SCM_GC_MARK_P (cell))
- {
- fprintf (stderr,
- "scm_assert_cell_valid: this object is unmarked. \n"
- "It has been garbage-collected in the last GC run: "
- "%lux\n",
- (unsigned long) SCM_UNPACK (cell));
- abort ();
- }
-#endif /* SCM_DEBUG_MARKING_API */
-
+
scm_i_cell_validation_already_running = 0; /* re-enable */
}
}
@@ -680,7 +669,6 @@ scm_init_storage ()
#endif
- scm_stand_in_procs = scm_make_weak_key_hash_table (scm_from_int (257));
scm_protects = scm_c_make_hash_table (31);
return 0;
diff --git a/libguile/gc.h b/libguile/gc.h
index 40dab2ff5..34c9b8474 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -123,7 +123,7 @@ typedef struct scm_t_cell
SCM_API int scm_debug_cell_accesses_p;
SCM_API int scm_expensive_debug_cell_accesses_p;
SCM_API int scm_debug_cells_gc_interval ;
-void scm_i_expensive_validation_check (SCM cell);
+SCM_API void scm_i_expensive_validation_check (SCM cell);
#endif
SCM_INTERNAL scm_i_pthread_mutex_t scm_i_gc_admin_mutex;
@@ -139,11 +139,11 @@ void *scm_ia64_ar_bsp (const void *);
#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_API size_t scm_default_init_heap_size_1;
-SCM_API int scm_default_min_yield_1;
-SCM_API size_t scm_default_init_heap_size_2;
-SCM_API int scm_default_min_yield_2;
-SCM_API size_t scm_default_max_segment_size;
+SCM_DEPRECATED size_t scm_default_init_heap_size_1;
+SCM_DEPRECATED int scm_default_min_yield_1;
+SCM_DEPRECATED size_t scm_default_init_heap_size_2;
+SCM_DEPRECATED int scm_default_min_yield_2;
+SCM_DEPRECATED size_t scm_default_max_segment_size;
#else
#define scm_default_init_heap_size_1 deprecated
#define scm_default_min_yield_1 deprecated
@@ -243,23 +243,23 @@ SCM_API void scm_init_gc (void);
#if SCM_ENABLE_DEPRECATED == 1
-SCM_API SCM scm_deprecated_newcell (void);
-SCM_API SCM scm_deprecated_newcell2 (void);
+SCM_DEPRECATED SCM scm_deprecated_newcell (void);
+SCM_DEPRECATED SCM scm_deprecated_newcell2 (void);
#define SCM_NEWCELL(_into) \
do { _into = scm_deprecated_newcell (); } while (0)
#define SCM_NEWCELL2(_into) \
do { _into = scm_deprecated_newcell2 (); } while (0)
-SCM_API void * scm_must_malloc (size_t len, const char *what);
-SCM_API void * scm_must_realloc (void *where,
- size_t olen, size_t len,
- const char *what);
-SCM_API char *scm_must_strdup (const char *str);
-SCM_API char *scm_must_strndup (const char *str, size_t n);
-SCM_API void scm_done_malloc (long size);
-SCM_API void scm_done_free (long size);
-SCM_API void scm_must_free (void *obj);
+SCM_DEPRECATED void * scm_must_malloc (size_t len, const char *what);
+SCM_DEPRECATED void * scm_must_realloc (void *where,
+ size_t olen, size_t len,
+ const char *what);
+SCM_DEPRECATED char *scm_must_strdup (const char *str);
+SCM_DEPRECATED char *scm_must_strndup (const char *str, size_t n);
+SCM_DEPRECATED void scm_done_malloc (long size);
+SCM_DEPRECATED void scm_done_free (long size);
+SCM_DEPRECATED void scm_must_free (void *obj);
#endif
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index 0e897ca8c..bc0c2df20 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -404,6 +404,13 @@ main (int argc, char *argv[])
pf ("typedef long int scm_t_off;\n");
#endif
+ pf ("/* Define to 1 if the compiler supports the "
+ "`__thread' storage class. */\n");
+ if (SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS)
+ pf ("#define SCM_HAVE_THREAD_STORAGE_CLASS\n");
+ else
+ pf ("/* #undef SCM_HAVE_THREAD_STORAGE_CLASS */\n");
+
#if USE_DLL_IMPORT
pf ("\n");
pf ("/* Define some additional CPP macros on Win32 platforms. */\n");
diff --git a/libguile/gen-scmconfig.h.in b/libguile/gen-scmconfig.h.in
index 1be95af94..770e08196 100644
--- a/libguile/gen-scmconfig.h.in
+++ b/libguile/gen-scmconfig.h.in
@@ -30,6 +30,7 @@
#define SCM_I_GSC_USE_NULL_THREADS @SCM_I_GSC_USE_NULL_THREADS@
#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT@
#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER@
+#define SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS @SCM_I_GSC_HAVE_THREAD_STORAGE_CLASS@
#define SCM_I_GSC_HAVE_STRUCT_DIRENT64 @SCM_I_GSC_HAVE_STRUCT_DIRENT64@
/*
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 6394405dd..8bbbed4d1 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -39,16 +39,26 @@ scm_is_array (SCM obj)
return scm_i_array_implementation_for_obj (obj) ? 1 : 0;
}
-SCM_DEFINE (scm_array_p, "array?", 1, 0, 0,
- (SCM obj),
+SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
+ (SCM obj),
"Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
"not.")
-#define FUNC_NAME s_scm_array_p
+#define FUNC_NAME s_scm_array_p_2
{
return scm_from_bool (scm_is_array (obj));
}
#undef FUNC_NAME
+/* The array type predicate, with an extra argument kept for backward
+ compatibility. Note that we can't use `SCM_DEFINE' directly because there
+ would be an argument count mismatch that would be caught by
+ `snarf-check-and-output-texi.scm'. */
+SCM
+scm_array_p (SCM obj, SCM unused)
+{
+ return scm_array_p_2 (obj);
+}
+
int
scm_is_typed_array (SCM obj, SCM type)
{
diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h
index cc7214e8b..1f9b6ad3d 100644
--- a/libguile/generalized-arrays.h
+++ b/libguile/generalized-arrays.h
@@ -35,7 +35,8 @@
/** Arrays */
SCM_API int scm_is_array (SCM obj);
-SCM_API SCM scm_array_p (SCM v);
+SCM_API SCM scm_array_p (SCM v, SCM unused);
+SCM_INTERNAL SCM scm_array_p_2 (SCM);
SCM_API int scm_is_typed_array (SCM obj, SCM type);
SCM_API SCM scm_typed_array_p (SCM v, SCM type);
diff --git a/libguile/goops.c b/libguile/goops.c
index 4616fa240..24a823f28 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -282,11 +282,15 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
else
{
- SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
- SCM class = scm_make_extended_class_from_symbol (scm_is_true (name)
- ? name
- : scm_nullstr,
- SCM_I_OPERATORP (x));
+ SCM class, name;
+
+ name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
+ if (!scm_is_symbol (name))
+ name = scm_string_to_symbol (scm_nullstr);
+
+ class =
+ scm_make_extended_class_from_symbol (name,
+ SCM_I_OPERATORP (x));
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
}
@@ -1650,12 +1654,13 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
*/
SCM_CRITICAL_SECTION_START;
{
- SCM car = SCM_CAR (old);
- SCM cdr = SCM_CDR (old);
- SCM_SETCAR (old, SCM_CAR (new));
- SCM_SETCDR (old, SCM_CDR (new));
- SCM_SETCAR (new, car);
- SCM_SETCDR (new, cdr);
+ scm_t_bits word0, word1;
+ word0 = SCM_CELL_WORD_0 (old);
+ word1 = SCM_CELL_WORD_1 (old);
+ SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
+ SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
+ SCM_SET_CELL_WORD_0 (new, word0);
+ SCM_SET_CELL_WORD_1 (new, word1);
}
SCM_CRITICAL_SECTION_END;
return SCM_UNSPECIFIED;
@@ -1672,13 +1677,14 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
SCM_CRITICAL_SECTION_START;
{
- SCM car = SCM_CAR (old);
- SCM cdr = SCM_CDR (old);
- SCM_SETCAR (old, SCM_CAR (new));
- SCM_SETCDR (old, SCM_CDR (new));
+ scm_t_bits word0, word1;
+ word0 = SCM_CELL_WORD_0 (old);
+ word1 = SCM_CELL_WORD_1 (old);
+ SCM_SET_CELL_WORD_0 (old, SCM_CELL_WORD_0 (new));
+ SCM_SET_CELL_WORD_1 (old, SCM_CELL_WORD_1 (new));
SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old);
- SCM_SETCAR (new, car);
- SCM_SETCDR (new, cdr);
+ SCM_SET_CELL_WORD_0 (new, word0);
+ SCM_SET_CELL_WORD_1 (new, word1);
SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
}
SCM_CRITICAL_SECTION_END;
@@ -3000,7 +3006,7 @@ scm_wrap_component (SCM class, SCM container, void *data)
obj,
SCM_BOOL_F,
scm_struct_ihashq,
- scm_sloppy_assq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
0);
SCM_SETCDR (handle, container);
return obj;
diff --git a/libguile/guardians.c b/libguile/guardians.c
index 580e212d0..51aa43310 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -62,7 +62,7 @@
#include "libguile/eval.h"
#include "libguile/guardians.h"
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index 5c03d281f..4ba2ef9ab 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -207,7 +207,7 @@ make_hash_table (int flags, unsigned long k, const char *func_name)
void
scm_i_rehash (SCM table,
- unsigned long (*hash_fn)(),
+ scm_t_hash_fn hash_fn,
void *closure,
const char* func_name)
{
@@ -429,9 +429,13 @@ SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
}
#undef FUNC_NAME
+
+/* Accessing hash table entries. */
SCM
-scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
+scm_hash_fn_get_handle (SCM table, SCM obj,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void * closure)
#define FUNC_NAME "scm_hash_fn_get_handle"
{
int weak = 0;
@@ -468,8 +472,9 @@ scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*as
SCM
-scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(), void * closure)
+scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void * closure)
#define FUNC_NAME "scm_hash_fn_create_handle_x"
{
int weak = 0;
@@ -559,9 +564,10 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_
#undef FUNC_NAME
-SCM
-scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(), void * closure)
+SCM
+scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void *closure)
{
SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
if (scm_is_pair (it))
@@ -573,9 +579,10 @@ scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn)(),
-SCM
-scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(), void * closure)
+SCM
+scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void *closure)
{
SCM it;
@@ -587,8 +594,8 @@ scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(),
SCM
scm_hash_fn_remove_x (SCM table, SCM obj,
- unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(),
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
void *closure)
{
int weak = 0;
@@ -659,7 +666,10 @@ SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
"Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
- return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_get_handle (table, key,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
@@ -671,7 +681,10 @@ SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
- return scm_hash_fn_create_handle_x (table, key, init, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_create_handle_x (table, key, init,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
@@ -686,7 +699,10 @@ SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0,
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
- return scm_hash_fn_ref (table, key, dflt, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_ref (table, key, dflt,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
@@ -698,7 +714,10 @@ SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
"store @var{value} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
- return scm_hash_fn_set_x (table, key, val, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_set_x (table, key, val,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
@@ -710,7 +729,10 @@ SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
"@var{table}. Uses @code{eq?} for equality tests.")
#define FUNC_NAME s_scm_hashq_remove_x
{
- return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_remove_x (table, key,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
@@ -725,7 +747,10 @@ SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
"Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
- return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_get_handle (table, key,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
@@ -737,8 +762,10 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
- return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv,
- scm_sloppy_assv, 0);
+ return scm_hash_fn_create_handle_x (table, key, init,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
@@ -753,7 +780,10 @@ SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
- return scm_hash_fn_ref (table, key, dflt, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_ref (table, key, dflt,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
@@ -765,7 +795,10 @@ SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
"store @var{value} there. Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_set_x
{
- return scm_hash_fn_set_x (table, key, val, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_set_x (table, key, val,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
@@ -776,7 +809,10 @@ SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
"@var{table}. Uses @code{eqv?} for equality tests.")
#define FUNC_NAME s_scm_hashv_remove_x
{
- return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_remove_x (table, key,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
@@ -790,7 +826,10 @@ SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
"Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
- return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_get_handle (table, key,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
@@ -802,7 +841,10 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hash_create_handle_x
{
- return scm_hash_fn_create_handle_x (table, key, init, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_create_handle_x (table, key, init,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
@@ -817,7 +859,10 @@ SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
- return scm_hash_fn_ref (table, key, dflt, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_ref (table, key, dflt,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
@@ -830,7 +875,10 @@ SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
"testing.")
#define FUNC_NAME s_scm_hash_set_x
{
- return scm_hash_fn_set_x (table, key, val, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_set_x (table, key, val,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
@@ -842,7 +890,10 @@ SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
"@var{table}. Uses @code{equal?} for equality tests.")
#define FUNC_NAME s_scm_hash_remove_x
{
- return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_remove_x (table, key,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
@@ -858,17 +909,20 @@ typedef struct scm_t_ihashx_closure
static unsigned long
-scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure)
+scm_ihashx (SCM obj, unsigned long n, void *arg)
{
- SCM answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
+ SCM answer;
+ scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
+ answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
return scm_to_ulong (answer);
}
static SCM
-scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure)
+scm_sloppy_assx (SCM obj, SCM alist, void *arg)
{
+ scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
return scm_call_2 (closure->assoc, obj, alist);
}
@@ -985,7 +1039,8 @@ SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0,
static const char s_scm_hash_fold[];
SCM
-scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
+scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
+ SCM init, SCM table)
{
long i, n;
SCM buckets, result = init;
@@ -1049,7 +1104,8 @@ scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
static const char s_scm_hash_for_each[];
void
-scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table)
+scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn, void *closure,
+ SCM table)
{
long i, n;
SCM buckets;
@@ -1091,7 +1147,8 @@ SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
SCM_VALIDATE_PROC (1, proc);
if (!SCM_HASHTABLE_P (table))
SCM_VALIDATE_VECTOR (3, table);
- return scm_internal_hash_fold (scm_call_3, (void *) SCM_UNPACK (proc), init, table);
+ return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3,
+ (void *) SCM_UNPACK (proc), init, table);
}
#undef FUNC_NAME
@@ -1131,7 +1188,7 @@ SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
if (!SCM_HASHTABLE_P (table))
SCM_VALIDATE_VECTOR (2, table);
- scm_internal_hash_for_each_handle (call,
+ scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) call,
(void *) SCM_UNPACK (proc),
table);
return SCM_UNSPECIFIED;
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
index 8f8ebf9ce..b60cd4349 100644
--- a/libguile/hashtab.h
+++ b/libguile/hashtab.h
@@ -3,7 +3,7 @@
#ifndef SCM_HASHTAB_H
#define SCM_HASHTAB_H
-/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -64,6 +64,22 @@ SCM_API scm_t_bits scm_tc16_hashtable;
#define SCM_SET_HASHTABLE_BUCKET(h, i, x) \
SCM_SIMPLE_VECTOR_SET (SCM_HASHTABLE_VECTOR (h), i, x)
+/* Function that computes a hash of OBJ modulo MAX. */
+typedef unsigned long (*scm_t_hash_fn) (SCM obj, unsigned long max,
+ void *closure);
+
+/* Function that returns the value associated with OBJ in ALIST according to
+ some equality predicate. */
+typedef SCM (*scm_t_assoc_fn) (SCM obj, SCM alist, void *closure);
+
+/* Function to fold over the entries of a hash table. */
+typedef SCM (*scm_t_hash_fold_fn) (void *closure, SCM key, SCM value,
+ SCM result);
+
+/* Function to iterate over the handles (key-value pairs) of a hash
+ table. */
+typedef SCM (*scm_t_hash_handle_fn) (void *closure, SCM handle);
+
typedef struct scm_t_hashtable {
int flags; /* properties of table */
unsigned long n_items; /* number of items in table */
@@ -71,17 +87,11 @@ typedef struct scm_t_hashtable {
unsigned long upper; /* when to grow */
int size_index; /* index into hashtable_size */
int min_size_index; /* minimum size_index */
- unsigned long (*hash_fn) (); /* for rehashing after a GC. */
+ scm_t_hash_fn hash_fn; /* for rehashing after a GC. */
} scm_t_hashtable;
-#if 0
-typedef unsigned int scm_t_hash_fn (SCM obj, unsigned int d, void *closure);
-typedef SCM scm_t_assoc_fn (SCM key, SCM alist, void *closure);
-typedef SCM scm_t_delete_fn (SCM elt, SCM list);
-#endif
-
SCM_API SCM scm_vector_to_hash_table (SCM vector);
SCM_API SCM scm_c_make_hash_table (unsigned long k);
SCM_API SCM scm_make_hash_table (SCM n);
@@ -94,16 +104,34 @@ SCM_API SCM scm_weak_key_hash_table_p (SCM h);
SCM_API SCM scm_weak_value_hash_table_p (SCM h);
SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);
-SCM_INTERNAL void scm_i_rehash (SCM table, unsigned long (*hash_fn)(),
+SCM_INTERNAL void scm_i_rehash (SCM table, scm_t_hash_fn hash_fn,
void *closure, const char *func_name);
-SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
-SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
-SCM_API SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
-SCM_API SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
-SCM_API SCM scm_hash_fn_remove_x (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
-SCM_API SCM scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table);
-SCM_API void scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table);
+
+SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
+ void *closure);
+SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
+ void *closure);
+SCM_API SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
+ void *closure);
+SCM_API SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
+ void *closure);
+SCM_API SCM scm_hash_fn_remove_x (SCM table, SCM obj,
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
+ void *closure);
+SCM_API SCM scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
+ SCM init, SCM table);
+SCM_API void scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn,
+ void *closure, SCM table);
SCM_API SCM scm_hash_clear_x (SCM table);
SCM_API SCM scm_hashq_get_handle (SCM table, SCM obj);
diff --git a/libguile/i18n.c b/libguile/i18n.c
index fd15227b5..7deb39536 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -23,6 +23,7 @@
#include <alloca.h>
#include "libguile/_scm.h"
+#include "libguile/extensions.h"
#include "libguile/feature.h"
#include "libguile/i18n.h"
#include "libguile/strings.h"
@@ -36,6 +37,8 @@
#include <string.h> /* `strcoll ()' */
#include <ctype.h> /* `toupper ()' et al. */
#include <errno.h>
+#include <unicase.h>
+#include <unistr.h>
#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
/* The GNU thread-aware locale API is documented in ``Thread-Aware Locale
@@ -503,8 +506,22 @@ get_current_locale (SCM *result)
return err;
}
+#else /* USE_GNU_LOCALE_API */
+
+/* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
+#define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
+ do \
+ { \
+ scm_t_locale old_loc; \
+ \
+ old_loc = uselocale (_c_locale); \
+ _statement ; \
+ uselocale (old_loc); \
+ } \
+ while (0)
+
-#endif /* !USE_GNU_LOCALE_API */
+#endif /* USE_GNU_LOCALE_API */
@@ -709,39 +726,123 @@ SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0,
A similar API can be found in MzScheme starting from version 200:
http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */
+#define SCM_STRING_TO_U32_BUF(s1, c_s1) \
+ do \
+ { \
+ if (scm_i_is_narrow_string (s1)) \
+ { \
+ size_t i, len; \
+ const char *buf = scm_i_string_chars (s1); \
+ \
+ len = scm_i_string_length (s1); \
+ c_s1 = (scm_t_wchar *) alloca (sizeof (scm_t_wchar) * (len + 1)); \
+ \
+ for (i = 0; i < len; i ++) \
+ c_s1[i] = (unsigned char ) buf[i]; \
+ c_s1[len] = 0; \
+ } \
+ else \
+ c_s1 = (scm_t_wchar *) scm_i_string_wide_chars (s1); \
+ } while (0)
+
-/* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return
- an integer whose sign is the same as the difference between C_S1 and
- C_S2. */
+/* Compare UTF-32 strings according to LOCALE. Returns a negative value if
+ S1 compares smaller than S2, a positive value if S1 compares larger than
+ S2, or 0 if they compare equal. */
static inline int
-compare_strings (const char *c_s1, const char *c_s2, SCM locale,
- const char *func_name)
+compare_u32_strings (SCM s1, SCM s2, SCM locale, const char *func_name)
#define FUNC_NAME func_name
{
int result;
scm_t_locale c_locale;
+ scm_t_wchar *c_s1, *c_s2;
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
+
+ SCM_STRING_TO_U32_BUF (s1, c_s1);
+ SCM_STRING_TO_U32_BUF (s2, c_s2);
+
+ if (c_locale)
+ RUN_IN_LOCALE_SECTION (c_locale,
+ result = u32_strcoll ((const scm_t_uint32 *) c_s1,
+ (const scm_t_uint32 *) c_s2));
+ else
+ result = u32_strcoll ((const scm_t_uint32 *) c_s1,
+ (const scm_t_uint32 *) c_s2);
+
+ scm_remember_upto_here_2 (s1, s2);
+ scm_remember_upto_here (locale);
+ return result;
+}
+#undef FUNC_NAME
+
+/* Return the current language of the locale. */
+static const char *
+locale_language ()
+{
+ /* FIXME: If the locale has been set with 'uselocale',
+ libunistring's uc_locale_language will return the incorrect
+ language: it will return the language appropriate for the global
+ (non-thread-specific) locale.
+
+ There appears to be no portable way to extract the language from
+ the thread-specific locale_t. There is no LANGUAGE capability in
+ nl_langinfo or nl_langinfo_l.
+
+ Thus, uc_locale_language needs to be fixed upstream. */
+ return uc_locale_language ();
+}
+
+static inline int
+u32_locale_casecoll (const char *func_name, const scm_t_uint32 *c_s1,
+ const scm_t_uint32 *c_s2,
+ int *result)
+{
+ /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must note
+ make any non-local exit. */
+
+ int ret;
+ const char *loc = locale_language ();
+ ret = u32_casecoll (c_s1, u32_strlen (c_s1),
+ c_s2, u32_strlen (c_s2),
+ loc, UNINORM_NFC, result);
+
+ return ret == 0 ? ret : errno;
+}
+
+static inline int
+compare_u32_strings_ci (SCM s1, SCM s2, SCM locale, const char *func_name)
+#define FUNC_NAME func_name
+{
+ int result, ret = 0;
+ scm_t_locale c_locale;
+ scm_t_wchar *c_s1, *c_s2;
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
+ SCM_STRING_TO_U32_BUF (s1, c_s1);
+ SCM_STRING_TO_U32_BUF (s2, c_s2);
+
if (c_locale)
+ RUN_IN_LOCALE_SECTION
+ (c_locale,
+ ret = u32_locale_casecoll (func_name,
+ (const scm_t_uint32 *) c_s1,
+ (const scm_t_uint32 *) c_s2,
+ &result));
+ else
+ ret = u32_locale_casecoll (func_name,
+ (const scm_t_uint32 *) c_s1,
+ (const scm_t_uint32 *) c_s2,
+ &result);
+
+ if (SCM_UNLIKELY (ret != 0))
{
-#ifdef USE_GNU_LOCALE_API
- result = strcoll_l (c_s1, c_s2, c_locale);
-#else
-#ifdef HAVE_STRCOLL
- RUN_IN_LOCALE_SECTION (c_locale, result = strcoll (c_s1, c_s2));
-#else
- result = strcmp (c_s1, c_s2);
-#endif
-#endif /* !USE_GNU_LOCALE_API */
+ errno = ret;
+ scm_syserror (FUNC_NAME);
}
- else
-#ifdef HAVE_STRCOLL
- result = strcoll (c_s1, c_s2);
-#else
- result = strcmp (c_s1, c_s2);
-#endif
+ scm_remember_upto_here_2 (s1, s2);
+ scm_remember_upto_here (locale);
return result;
}
@@ -785,71 +886,6 @@ str_downcase_l (register char *dst, register const char *src,
#endif
-/* Compare null-terminated strings C_S1 and C_S2 in a case-independent way
- according to LOCALE. Return an integer whose sign is the same as the
- difference between C_S1 and C_S2. */
-static inline int
-compare_strings_ci (const char *c_s1, const char *c_s2, SCM locale,
- const char *func_name)
-#define FUNC_NAME func_name
-{
- int result;
- scm_t_locale c_locale;
- char *c_us1, *c_us2;
-
- SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
-
- c_us1 = (char *) alloca (strlen (c_s1) + 1);
- c_us2 = (char *) alloca (strlen (c_s2) + 1);
-
- if (c_locale)
- {
-#ifdef USE_GNU_LOCALE_API
- str_upcase_l (c_us1, c_s1, c_locale);
- str_upcase_l (c_us2, c_s2, c_locale);
-
- result = strcoll_l (c_us1, c_us2, c_locale);
-#else
- int err;
- scm_t_locale_settings prev_locale;
-
- err = enter_locale_section (c_locale, &prev_locale);
- if (err)
- {
- scm_locale_error (func_name, err);
- return 0;
- }
-
- str_upcase (c_us1, c_s1);
- str_upcase (c_us2, c_s2);
-
-#ifdef HAVE_STRCOLL
- result = strcoll (c_us1, c_us2);
-#else
- result = strcmp (c_us1, c_us2);
-#endif /* !HAVE_STRCOLL */
-
- leave_locale_section (&prev_locale);
- free_locale_settings (&prev_locale);
-#endif /* !USE_GNU_LOCALE_API */
- }
- else
- {
- str_upcase (c_us1, c_s1);
- str_upcase (c_us2, c_s2);
-
-#ifdef HAVE_STRCOLL
- result = strcoll (c_us1, c_us2);
-#else
- result = strcmp (c_us1, c_us2);
-#endif
- }
-
- return result;
-}
-#undef FUNC_NAME
-
-
SCM_DEFINE (scm_string_locale_lt, "string-locale<?", 2, 1, 0,
(SCM s1, SCM s2, SCM locale),
"Compare strings @var{s1} and @var{s2} in a locale-dependent way."
@@ -859,17 +895,11 @@ SCM_DEFINE (scm_string_locale_lt, "string-locale<?", 2, 1, 0,
#define FUNC_NAME s_scm_string_locale_lt
{
int result;
- const char *c_s1, *c_s2;
SCM_VALIDATE_STRING (1, s1);
SCM_VALIDATE_STRING (2, s2);
- c_s1 = scm_i_string_chars (s1);
- c_s2 = scm_i_string_chars (s2);
-
- result = compare_strings (c_s1, c_s2, locale, FUNC_NAME);
-
- scm_remember_upto_here_2 (s1, s2);
+ result = compare_u32_strings (s1, s2, locale, FUNC_NAME);
return scm_from_bool (result < 0);
}
@@ -884,17 +914,11 @@ SCM_DEFINE (scm_string_locale_gt, "string-locale>?", 2, 1, 0,
#define FUNC_NAME s_scm_string_locale_gt
{
int result;
- const char *c_s1, *c_s2;
SCM_VALIDATE_STRING (1, s1);
SCM_VALIDATE_STRING (2, s2);
- c_s1 = scm_i_string_chars (s1);
- c_s2 = scm_i_string_chars (s2);
-
- result = compare_strings (c_s1, c_s2, locale, FUNC_NAME);
-
- scm_remember_upto_here_2 (s1, s2);
+ result = compare_u32_strings (s1, s2, locale, FUNC_NAME);
return scm_from_bool (result > 0);
}
@@ -910,17 +934,11 @@ SCM_DEFINE (scm_string_locale_ci_lt, "string-locale-ci<?", 2, 1, 0,
#define FUNC_NAME s_scm_string_locale_ci_lt
{
int result;
- const char *c_s1, *c_s2;
SCM_VALIDATE_STRING (1, s1);
SCM_VALIDATE_STRING (2, s2);
- c_s1 = scm_i_string_chars (s1);
- c_s2 = scm_i_string_chars (s2);
-
- result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
-
- scm_remember_upto_here_2 (s1, s2);
+ result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
return scm_from_bool (result < 0);
}
@@ -936,17 +954,11 @@ SCM_DEFINE (scm_string_locale_ci_gt, "string-locale-ci>?", 2, 1, 0,
#define FUNC_NAME s_scm_string_locale_ci_gt
{
int result;
- const char *c_s1, *c_s2;
SCM_VALIDATE_STRING (1, s1);
SCM_VALIDATE_STRING (2, s2);
- c_s1 = scm_i_string_chars (s1);
- c_s2 = scm_i_string_chars (s2);
-
- result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
-
- scm_remember_upto_here_2 (s1, s2);
+ result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
return scm_from_bool (result > 0);
}
@@ -962,17 +974,11 @@ SCM_DEFINE (scm_string_locale_ci_eq, "string-locale-ci=?", 2, 1, 0,
#define FUNC_NAME s_scm_string_locale_ci_eq
{
int result;
- const char *c_s1, *c_s2;
SCM_VALIDATE_STRING (1, s1);
SCM_VALIDATE_STRING (2, s2);
- c_s1 = scm_i_string_chars (s1);
- c_s2 = scm_i_string_chars (s2);
-
- result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
-
- scm_remember_upto_here_2 (s1, s2);
+ result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
return scm_from_bool (result == 0);
}
@@ -985,15 +991,16 @@ SCM_DEFINE (scm_char_locale_lt, "char-locale<?", 2, 1, 0,
"according to @var{locale} or to the current locale.")
#define FUNC_NAME s_scm_char_locale_lt
{
- char c_c1[2], c_c2[2];
+ int result;
SCM_VALIDATE_CHAR (1, c1);
SCM_VALIDATE_CHAR (2, c2);
- c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
- c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
+ result = compare_u32_strings (scm_string (scm_list_1 (c1)),
+ scm_string (scm_list_1 (c2)),
+ locale, FUNC_NAME);
- return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) < 0);
+ return scm_from_bool (result < 0);
}
#undef FUNC_NAME
@@ -1003,15 +1010,16 @@ SCM_DEFINE (scm_char_locale_gt, "char-locale>?", 2, 1, 0,
"according to @var{locale} or to the current locale.")
#define FUNC_NAME s_scm_char_locale_gt
{
- char c_c1[2], c_c2[2];
+ int result;
SCM_VALIDATE_CHAR (1, c1);
SCM_VALIDATE_CHAR (2, c2);
- c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
- c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
+ result = compare_u32_strings (scm_string (scm_list_1 (c1)),
+ scm_string (scm_list_1 (c2)),
+ locale, FUNC_NAME);
- return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) > 0);
+ return scm_from_bool (result > 0);
}
#undef FUNC_NAME
@@ -1023,15 +1031,13 @@ SCM_DEFINE (scm_char_locale_ci_lt, "char-locale-ci<?", 2, 1, 0,
#define FUNC_NAME s_scm_char_locale_ci_lt
{
int result;
- char c_c1[2], c_c2[2];
SCM_VALIDATE_CHAR (1, c1);
SCM_VALIDATE_CHAR (2, c2);
- c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
- c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
-
- result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
+ result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
+ scm_string (scm_list_1 (c2)),
+ locale, FUNC_NAME);
return scm_from_bool (result < 0);
}
@@ -1045,15 +1051,13 @@ SCM_DEFINE (scm_char_locale_ci_gt, "char-locale-ci>?", 2, 1, 0,
#define FUNC_NAME s_scm_char_locale_ci_gt
{
int result;
- char c_c1[2], c_c2[2];
SCM_VALIDATE_CHAR (1, c1);
SCM_VALIDATE_CHAR (2, c2);
- c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
- c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
-
- result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
+ result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
+ scm_string (scm_list_1 (c2)),
+ locale, FUNC_NAME);
return scm_from_bool (result > 0);
}
@@ -1067,15 +1071,13 @@ SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0,
#define FUNC_NAME s_scm_char_locale_ci_eq
{
int result;
- char c_c1[2], c_c2[2];
SCM_VALIDATE_CHAR (1, c1);
SCM_VALIDATE_CHAR (2, c2);
- c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
- c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
-
- result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
+ result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
+ scm_string (scm_list_1 (c2)),
+ locale, FUNC_NAME);
return scm_from_bool (result == 0);
}
@@ -1085,33 +1087,79 @@ SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0,
/* Locale-dependent alphabetic character mapping. */
+static inline int
+u32_locale_tocase (const scm_t_uint32 *c_s1, size_t len,
+ scm_t_uint32 **p_c_s2, size_t * p_len2,
+ scm_t_uint32 *(*func) (const scm_t_uint32 *, size_t,
+ const char *, uninorm_t,
+ scm_t_uint32 *, size_t *))
+{
+ /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must not
+ make any non-local exit. */
+
+ scm_t_uint32 *ret;
+ const char *loc = locale_language ();
+
+ /* The first NULL here indicates that no NFC or NFKC normalization
+ is done. The second NULL means the return buffer is
+ malloc'ed here. */
+ ret = func (c_s1, len, loc, NULL, NULL, p_len2);
+
+ if (ret == NULL)
+ {
+ *p_c_s2 = (scm_t_uint32 *) NULL;
+ *p_len2 = 0;
+ return errno;
+ }
+ *p_c_s2 = ret;
+
+ return 0;
+}
+
+
+
SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0,
(SCM chr, SCM locale),
"Return the lowercase character that corresponds to @var{chr} "
"according to either @var{locale} or the current locale.")
#define FUNC_NAME s_scm_char_locale_downcase
{
- char c_chr;
- int c_result;
+ int ret;
scm_t_locale c_locale;
+ scm_t_wchar *buf;
+ scm_t_uint32 *downbuf;
+ size_t downlen;
+ SCM str, downchar;
SCM_VALIDATE_CHAR (1, chr);
- c_chr = SCM_CHAR (chr);
-
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+ str = scm_i_make_wide_string (1, &buf);
+ buf[0] = SCM_CHAR (chr);
+
if (c_locale != NULL)
+ RUN_IN_LOCALE_SECTION (c_locale, ret =
+ u32_locale_tocase ((scm_t_uint32 *) buf, 1,
+ &downbuf,
+ &downlen, u32_tolower));
+ else
+ ret =
+ u32_locale_tocase ((scm_t_uint32 *) buf, 1, &downbuf,
+ &downlen, u32_tolower);
+
+ if (SCM_UNLIKELY (ret != 0))
{
-#ifdef USE_GNU_LOCALE_API
- c_result = tolower_l ((int) c_chr, c_locale);
-#else
- RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower ((int) c_chr));
-#endif
+ errno = ret;
+ scm_syserror (FUNC_NAME);
}
+
+ if (downlen == 1)
+ downchar = SCM_MAKE_CHAR ((scm_t_wchar) downbuf[0]);
else
- c_result = tolower ((int) c_chr);
+ downchar = chr;
+ free (downbuf);
- return (SCM_MAKE_CHAR (c_result));
+ return downchar;
}
#undef FUNC_NAME
@@ -1121,27 +1169,40 @@ SCM_DEFINE (scm_char_locale_upcase, "char-locale-upcase", 1, 1, 0,
"according to either @var{locale} or the current locale.")
#define FUNC_NAME s_scm_char_locale_upcase
{
- char c_chr;
- int c_result;
+ int ret;
scm_t_locale c_locale;
+ scm_t_wchar *buf;
+ scm_t_uint32 *upbuf;
+ size_t uplen;
+ SCM str, upchar;
SCM_VALIDATE_CHAR (1, chr);
- c_chr = SCM_CHAR (chr);
-
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+ str = scm_i_make_wide_string (1, &buf);
+ buf[0] = SCM_CHAR (chr);
+
if (c_locale != NULL)
+ RUN_IN_LOCALE_SECTION (c_locale, ret =
+ u32_locale_tocase ((scm_t_uint32 *) buf, 1,
+ &upbuf,
+ &uplen, u32_toupper));
+ else
+ ret =
+ u32_locale_tocase ((scm_t_uint32 *) buf, 1, &upbuf,
+ &uplen, u32_toupper);
+
+ if (SCM_UNLIKELY (ret != 0))
{
-#ifdef USE_GNU_LOCALE_API
- c_result = toupper_l ((int) c_chr, c_locale);
-#else
- RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper ((int) c_chr));
-#endif
+ errno = ret;
+ scm_syserror (FUNC_NAME);
}
+ if (uplen == 1)
+ upchar = SCM_MAKE_CHAR ((scm_t_wchar) upbuf[0]);
else
- c_result = toupper ((int) c_chr);
-
- return (SCM_MAKE_CHAR (c_result));
+ upchar = chr;
+ free (upbuf);
+ return upchar;
}
#undef FUNC_NAME
@@ -1152,30 +1213,45 @@ SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0,
"locale.")
#define FUNC_NAME s_scm_string_locale_upcase
{
- const char *c_str;
- char *c_ustr;
+ scm_t_wchar *c_str, *c_buf;
+ scm_t_uint32 *c_upstr;
+ size_t len, uplen;
+ int ret;
scm_t_locale c_locale;
+ SCM upstr;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
-
- c_str = scm_i_string_chars (str);
- c_ustr = (char *) alloca (strlen (c_str) + 1);
+ len = scm_i_string_length (str);
+ if (len == 0)
+ return scm_nullstr;
+ SCM_STRING_TO_U32_BUF (str, c_str);
if (c_locale)
- {
-#ifdef USE_GNU_LOCALE_API
- str_upcase_l (c_ustr, c_str, c_locale);
-#else
- RUN_IN_LOCALE_SECTION (c_locale, str_upcase (c_ustr, c_str));
-#endif
- }
+ RUN_IN_LOCALE_SECTION (c_locale, ret =
+ u32_locale_tocase ((scm_t_uint32 *) c_str, len,
+ &c_upstr,
+ &uplen, u32_toupper));
else
- str_upcase (c_ustr, c_str);
+ ret =
+ u32_locale_tocase ((scm_t_uint32 *) c_str, len,
+ &c_upstr, &uplen, u32_toupper);
scm_remember_upto_here (str);
- return (scm_from_locale_string (c_ustr));
+ if (SCM_UNLIKELY (ret != 0))
+ {
+ errno = ret;
+ scm_syserror (FUNC_NAME);
+ }
+
+ upstr = scm_i_make_wide_string (uplen, &c_buf);
+ memcpy (c_buf, c_upstr, uplen * sizeof (scm_t_wchar));
+ free (c_upstr);
+
+ scm_i_try_narrow_string (upstr);
+
+ return upstr;
}
#undef FUNC_NAME
@@ -1186,30 +1262,45 @@ SCM_DEFINE (scm_string_locale_downcase, "string-locale-downcase", 1, 1, 0,
"locale.")
#define FUNC_NAME s_scm_string_locale_downcase
{
- const char *c_str;
- char *c_lstr;
+ scm_t_wchar *c_str, *c_buf;
+ scm_t_uint32 *c_downstr;
+ size_t len, downlen;
+ int ret;
scm_t_locale c_locale;
+ SCM downstr;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
-
- c_str = scm_i_string_chars (str);
- c_lstr = (char *) alloca (strlen (c_str) + 1);
+ len = scm_i_string_length (str);
+ if (len == 0)
+ return scm_nullstr;
+ SCM_STRING_TO_U32_BUF (str, c_str);
if (c_locale)
- {
-#ifdef USE_GNU_LOCALE_API
- str_downcase_l (c_lstr, c_str, c_locale);
-#else
- RUN_IN_LOCALE_SECTION (c_locale, str_downcase (c_lstr, c_str));
-#endif
- }
+ RUN_IN_LOCALE_SECTION (c_locale, ret =
+ u32_locale_tocase ((scm_t_uint32 *) c_str, len,
+ &c_downstr,
+ &downlen, u32_tolower));
else
- str_downcase (c_lstr, c_str);
+ ret =
+ u32_locale_tocase ((scm_t_uint32 *) c_str, len,
+ &c_downstr, &downlen, u32_tolower);
scm_remember_upto_here (str);
- return (scm_from_locale_string (c_lstr));
+ if (SCM_UNLIKELY (ret != 0))
+ {
+ errno = ret;
+ scm_syserror (FUNC_NAME);
+ }
+
+ downstr = scm_i_make_wide_string (downlen, &c_buf);
+ memcpy (c_buf, c_downstr, downlen * sizeof (scm_t_wchar));
+ free (c_downstr);
+
+ scm_i_try_narrow_string (downstr);
+
+ return downstr;
}
#undef FUNC_NAME
@@ -1328,15 +1419,16 @@ SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact",
2. `nl_langinfo ()' is not available on Windows.
3. `nl_langinfo ()' may return strings encoded in a locale different from
- the current one, thereby defeating `scm_from_locale_string ()'.
- Example: support the current locale is "Latin-1" and one asks:
+ the current one.
+ For example:
(nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8"))
- The result will be a UTF-8 string. However, `scm_from_locale_string',
- which expects a Latin-1 string, won't be able to make much sense of the
- returned string. Thus, we'd need an `scm_from_string ()' variant where
- the locale (or charset) is explicitly passed. */
+ returns a result that is a UTF-8 string, regardless of the
+ setting of the current locale. If nl_langinfo supports CODESET,
+ we can convert the string properly using scm_from_stringn. If
+ CODESET is not supported, we won't be able to make much sense of
+ the returned string. */
SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
@@ -1354,6 +1446,9 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
nl_item c_item;
char *c_result;
scm_t_locale c_locale;
+#ifdef HAVE_LANGINFO_CODESET
+ char *codeset;
+#endif
SCM_VALIDATE_INT_COPY (2, item, c_item);
SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
@@ -1370,7 +1465,10 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
{
#ifdef USE_GNU_LOCALE_API
c_result = nl_langinfo_l (c_item, c_locale);
-#else
+#ifdef HAVE_LANGINFO_CODESET
+ codeset = nl_langinfo_l (CODESET, c_locale);
+#endif /* HAVE_LANGINFO_CODESET */
+#else /* !USE_GNU_LOCALE_API */
/* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
mutex is already taken. */
int lsec_err;
@@ -1394,6 +1492,9 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
else
{
c_result = nl_langinfo (c_item);
+#ifdef HAVE_LANGINFO_CODESET
+ codeset = nl_langinfo (CODESET);
+#endif /* HAVE_LANGINFO_CODESET */
restore_locale_settings (&lsec_prev_locale);
free_locale_settings (&lsec_prev_locale);
@@ -1401,7 +1502,12 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
#endif
}
else
- c_result = nl_langinfo (c_item);
+ {
+ c_result = nl_langinfo (c_item);
+#ifdef HAVE_LANGINFO_CODESET
+ codeset = nl_langinfo (CODESET);
+#endif /* HAVE_LANGINFO_CODESET */
+ }
c_result = strdup (c_result);
scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
@@ -1509,9 +1615,16 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
#endif
default:
- /* FIXME: `locale_string ()' is not appropriate here because of
- encoding issues (see comment above). */
- result = scm_take_locale_string (c_result);
+#ifdef HAVE_LANGINFO_CODESET
+ result = scm_from_stringn (c_result, strlen (c_result),
+ codeset,
+ SCM_FAILED_CONVERSION_QUESTION_MARK);
+#else /* !HAVE_LANGINFO_CODESET */
+ /* This may be incorrectly encoded if the locale differs
+ from the c_locale. */
+ result = scm_from_locale_string (c_result);
+#endif /* !HAVE_LANGINFO_CODESET */
+ free (c_result);
}
}
@@ -1707,6 +1820,15 @@ scm_init_i18n ()
SCM_VARIABLE_SET (scm_global_locale, global_locale_smob);
}
+void
+scm_bootstrap_i18n ()
+{
+ scm_c_register_extension ("libguile", "scm_init_i18n",
+ (scm_t_extension_init_func) scm_init_i18n,
+ NULL);
+
+}
+
/*
Local Variables:
diff --git a/libguile/i18n.h b/libguile/i18n.h
index df2970b4e..16045eb0c 100644
--- a/libguile/i18n.h
+++ b/libguile/i18n.h
@@ -3,7 +3,7 @@
#ifndef SCM_I18N_H
#define SCM_I18N_H
-/* Copyright (C) 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -42,9 +42,12 @@ SCM_API SCM scm_string_locale_upcase (SCM chr, SCM locale);
SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale);
SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale);
SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale);
-SCM_API SCM scm_nl_langinfo (SCM item, SCM locale);
-SCM_API void scm_init_i18n (void);
+SCM_INTERNAL SCM scm_nl_langinfo (SCM item, SCM locale);
+
+SCM_INTERNAL void scm_init_i18n (void);
+SCM_INTERNAL void scm_bootstrap_i18n (void);
+
#endif /* SCM_I18N_H */
diff --git a/libguile/inet_aton.c b/libguile/inet_aton.c
index ebef71f55..c89378bb1 100644
--- a/libguile/inet_aton.c
+++ b/libguile/inet_aton.c
@@ -103,14 +103,14 @@ inet_aton(const char *cp_arg, struct in_addr *addr)
base = 8;
}
while ((c = *cp) != '\0') {
- if (isascii(c) && isdigit(c)) {
+ if (isascii ((int) c) && isdigit ((int) c)) {
val = (val * base) + (c - '0');
cp++;
continue;
}
- if (base == 16 && isascii(c) && isxdigit(c)) {
+ if (base == 16 && isascii ((int) c) && isxdigit ((int) c)) {
val = (val << 4) +
- (c + 10 - (islower(c) ? 'a' : 'A'));
+ (c + 10 - (islower((int) c) ? 'a' : 'A'));
cp++;
continue;
}
@@ -132,7 +132,7 @@ inet_aton(const char *cp_arg, struct in_addr *addr)
/*
* Check for trailing characters.
*/
- if (*cp && (!isascii(*cp) || !isspace(*cp)))
+ if (*cp && (!isascii ((int) (*cp)) || !isspace ((int) (*cp))))
return (0);
/*
* Concoct the address according to
diff --git a/libguile/init.c b/libguile/init.c
index 940d515f6..68156ef28 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -60,7 +60,6 @@
#include "libguile/filesys.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
-#include "libguile/futures.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
#include "libguile/generalized-arrays.h"
@@ -71,6 +70,7 @@
#include "libguile/hashtab.h"
#include "libguile/hooks.h"
#include "libguile/gettext.h"
+#include "libguile/i18n.h"
#include "libguile/iselect.h"
#include "libguile/ioext.h"
#include "libguile/keywords.h"
@@ -478,11 +478,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_dynwind ();
scm_init_eq ();
scm_init_error ();
-#if 0
- /* See futures.h for a comment why futures are not enabled.
- */
- scm_init_futures ();
-#endif
scm_init_fluids ();
scm_init_feature (); /* Requires fluids */
scm_init_backtrace (); /* Requires fluids */
@@ -561,6 +556,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_load_path ();
scm_init_standard_ports (); /* Requires fports */
scm_init_dynamic_linking ();
+ scm_bootstrap_i18n ();
#if SCM_ENABLE_ELISP
scm_init_lang ();
#endif /* SCM_ENABLE_ELISP */
diff --git a/libguile/inline.h b/libguile/inline.h
index 49431697f..09a1b5a35 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -78,7 +78,7 @@
"inline.c", when `inline' is not supported at all or when "extern inline"
is used. */
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
@@ -243,7 +243,7 @@ SCM_C_EXTERN_INLINE
SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
{
- if (SCM_UNLIKELY (p < 0 && -p > h->base))
+ if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
@@ -256,7 +256,7 @@ SCM_C_EXTERN_INLINE
void
scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
{
- if (SCM_UNLIKELY (p < 0 && -p > h->base))
+ if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
diff --git a/libguile/lang.h b/libguile/lang.h
index 47128de57..b86fb2e0a 100644
--- a/libguile/lang.h
+++ b/libguile/lang.h
@@ -3,7 +3,7 @@
#ifndef SCM_LANG_H
#define SCM_LANG_H
-/* Copyright (C) 1998, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1998, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -39,7 +39,7 @@ SCM_INTERNAL void scm_init_lang (void);
#endif /* ! SCM_ENABLE_ELISP */
-#define SCM_NULL_OR_NIL_P(x) (scm_is_null (x) || SCM_NILP (x))
+#define SCM_NULL_OR_NIL_P(x) (scm_is_null_or_nil (x))
#endif /* SCM_LANG_H */
diff --git a/libguile/load.c b/libguile/load.c
index fa25b0f84..50af25643 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -601,6 +601,8 @@ compiled_is_fresh (SCM full_filename, SCM compiled_filename)
return res;
}
+SCM_KEYWORD (kw_env, "env");
+
static SCM
do_try_autocompile (void *data)
{
@@ -617,7 +619,9 @@ do_try_autocompile (void *data)
if (scm_is_true (compile_file))
{
- SCM res = scm_call_1 (scm_variable_ref (compile_file), source);
+ /* Auto-compile in the context of the current module. */
+ SCM res = scm_call_3 (scm_variable_ref (compile_file), source,
+ kw_env, scm_current_module ());
scm_puts (";;; compiled ", scm_current_error_port ());
scm_display (res, scm_current_error_port ());
scm_newline (scm_current_error_port ());
@@ -681,8 +685,8 @@ scm_try_autocompile (SCM source)
NULL, NULL);
}
-SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
- (SCM filename, SCM exception_on_not_found),
+SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
+ (SCM args),
"Search @var{%load-path} for the file named @var{filename} and\n"
"load it into the top-level environment. If @var{filename} is a\n"
"relative pathname and is not found in the list of search paths,\n"
@@ -691,9 +695,33 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
"@code{#f} is returned instead.")
#define FUNC_NAME s_scm_primitive_load_path
{
+ SCM filename, exception_on_not_found;
SCM full_filename, compiled_filename;
int compiled_is_fallback = 0;
+ if (scm_is_string (args))
+ {
+ /* C code written for 1.8 and earlier expects this function to take a
+ single argument (the file name). */
+ filename = args;
+ exception_on_not_found = SCM_UNDEFINED;
+ }
+ else
+ {
+ /* Starting from 1.9, this function takes 1 required and 1 optional
+ argument. */
+ long len;
+
+ SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, args, len);
+ if (len < 1 || len > 2)
+ scm_error_num_args_subr (FUNC_NAME);
+
+ filename = SCM_CAR (args);
+ SCM_VALIDATE_STRING (SCM_ARG1, filename);
+
+ exception_on_not_found = len > 1 ? SCM_CADR (args) : SCM_UNDEFINED;
+ }
+
if (SCM_UNBNDP (exception_on_not_found))
exception_on_not_found = SCM_BOOL_T;
@@ -752,7 +780,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
scm_puts (";;; found fresh local cache at ", scm_current_error_port ());
scm_display (fallback, scm_current_error_port ());
scm_newline (scm_current_error_port ());
- return scm_load_compiled_with_vm (compiled_filename);
+ return scm_load_compiled_with_vm (fallback);
}
}
@@ -771,13 +799,16 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
SCM
scm_c_primitive_load_path (const char *filename)
{
- return scm_primitive_load_path (scm_from_locale_string (filename),
- SCM_BOOL_T);
+ return scm_primitive_load_path (scm_from_locale_string (filename));
}
/* Information about the build environment. */
+SCM_VARIABLE_INIT (sys_host_type, "%host-type",
+ scm_from_locale_string (HOST_TYPE));
+
+
/* Initialize the scheme variable %guile-build-info, based on data
provided by the Makefile, via libpath.h. */
static void
diff --git a/libguile/load.h b/libguile/load.h
index 1a1a86528..cf825fc0f 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -3,7 +3,7 @@
#ifndef SCM_LOAD_H
#define SCM_LOAD_H
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -34,7 +34,7 @@ SCM_API SCM scm_sys_library_dir (void);
SCM_API SCM scm_sys_site_dir (void);
SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts, SCM require_exts);
SCM_API SCM scm_sys_search_load_path (SCM filename);
-SCM_API SCM scm_primitive_load_path (SCM filename, SCM exception_on_not_found);
+SCM_API SCM scm_primitive_load_path (SCM filename_and_exception_on_not_found);
SCM_API SCM scm_c_primitive_load_path (const char *filename);
SCM_INTERNAL SCM scm_sys_warn_autocompilation_enabled (void);
SCM_INTERNAL void scm_init_load_path (void);
diff --git a/libguile/macros.c b/libguile/macros.c
index 3e0942c43..7d60a8ea1 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -22,6 +22,8 @@
# include <config.h>
#endif
+#define SCM_BUILDING_DEPRECATED_CODE
+
#include "libguile/_scm.h"
#include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */
#include "libguile/eval.h"
diff --git a/libguile/macros.h b/libguile/macros.h
index 8ff41c4a4..f05d2f161 100644
--- a/libguile/macros.h
+++ b/libguile/macros.h
@@ -3,7 +3,7 @@
#ifndef SCM_MACROS_H
#define SCM_MACROS_H
-/* Copyright (C) 1998,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1998,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -61,7 +61,7 @@ SCM_API SCM scm_make_synt (const char *name,
SCM_INTERNAL void scm_init_macros (void);
#if SCM_ENABLE_DEPRECATED == 1
-SCM_API SCM scm_makmacro (SCM code);
+SCM_DEPRECATED SCM scm_makmacro (SCM code);
#endif
#endif /* SCM_MACROS_H */
diff --git a/libguile/modules.c b/libguile/modules.c
index deae23a59..c7f0a46b0 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008 Free Software Foundation, Inc.
+/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -46,6 +46,12 @@ static SCM the_module;
static SCM the_root_module_var;
+static SCM unbound_variable (const char *func, SCM sym)
+{
+ scm_error (scm_from_locale_symbol ("unbound-variable"), func,
+ "Unbound variable: ~S", scm_list_1 (sym), SCM_BOOL_F);
+}
+
static SCM
the_root_module ()
{
@@ -740,7 +746,7 @@ scm_module_lookup (SCM module, SCM sym)
var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
if (scm_is_false (var))
- SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
+ unbound_variable (FUNC_NAME, sym);
return var;
}
#undef FUNC_NAME
@@ -757,7 +763,7 @@ scm_lookup (SCM sym)
SCM var =
scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
if (scm_is_false (var))
- scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
+ unbound_variable (NULL, sym);
return var;
}
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 2bb4e6040..ab4db3dab 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -23,13 +23,9 @@
/* objcode data should be directly mappable to this C structure. */
struct scm_objcode {
- scm_t_uint8 nargs;
- scm_t_uint8 nrest;
- scm_t_uint16 nlocs;
scm_t_uint32 len; /* the maximum index of base[] */
scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of
base[] for metadata */
- scm_t_uint32 unused; /* pad so that `base' is 8-byte aligned */
scm_t_uint8 base[0];
};
@@ -46,9 +42,6 @@ SCM_API scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len)
#define SCM_OBJCODE_META_LEN(x) (SCM_OBJCODE_DATA (x)->metalen)
#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x))
-#define SCM_OBJCODE_NARGS(x) (SCM_OBJCODE_DATA (x)->nargs)
-#define SCM_OBJCODE_NREST(x) (SCM_OBJCODE_DATA (x)->nrest)
-#define SCM_OBJCODE_NLOCS(x) (SCM_OBJCODE_DATA (x)->nlocs)
#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
diff --git a/libguile/pairs.c b/libguile/pairs.c
index aaaeb110f..fb8b21f11 100644
--- a/libguile/pairs.c
+++ b/libguile/pairs.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -27,11 +27,25 @@
#include "libguile/pairs.h"
+#include "verify.h"
+
/* {Pairs}
*/
+/*
+ * This compile-time test verifies the properties needed for the
+ * efficient test macro scm_is_null_or_nil defined in pairs.h,
+ * which is defined in terms of the SCM_MATCHES_BITS_IN_COMMON macro.
+ *
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information.
+ */
+verify (SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION \
+ (SCM_ELISP_NIL, SCM_EOL));
+
+
#if (SCM_DEBUG_PAIR_ACCESSES == 1)
#include "libguile/ports.h"
diff --git a/libguile/pairs.h b/libguile/pairs.h
index a6d44d289..47bb187ff 100644
--- a/libguile/pairs.h
+++ b/libguile/pairs.h
@@ -3,7 +3,7 @@
#ifndef SCM_PAIRS_H
#define SCM_PAIRS_H
-/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -34,7 +34,32 @@
# define SCM_VALIDATE_PAIR(cell, expr) (expr)
#endif
-#define scm_is_null(x) (scm_is_eq ((x), SCM_EOL))
+/*
+ * Use scm_is_null_and_not_nil if it's important (for correctness)
+ * that %nil must NOT be considered null.
+ */
+#define scm_is_null_and_not_nil(x) (scm_is_eq ((x), SCM_EOL))
+
+/*
+ * Use scm_is_null_assume_not_nil if %nil will never be tested,
+ * for increased efficiency.
+ */
+#define scm_is_null_assume_not_nil(x) (scm_is_eq ((x), SCM_EOL))
+
+/*
+ * See the comments preceeding the definitions of SCM_BOOL_F and
+ * SCM_MATCHES_BITS_IN_COMMON in tags.h for more information on
+ * how the following macro works.
+ */
+#if SCM_ENABLE_ELISP
+# define scm_is_null_or_nil(x) \
+ (SCM_MATCHES_BITS_IN_COMMON ((x), SCM_ELISP_NIL, SCM_EOL))
+#else
+# define scm_is_null_or_nil(x) (scm_is_null_assume_not_nil (x))
+#endif
+
+/* XXX Should scm_is_null treat %nil as null by default? */
+#define scm_is_null(x) (scm_is_null_and_not_nil(x))
#define SCM_CAR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x)))
#define SCM_CDR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (x)))
diff --git a/libguile/ports.c b/libguile/ports.c
index e3d2b0da6..c3415c770 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -127,12 +127,6 @@ end_input_default (SCM port SCM_UNUSED, int offset SCM_UNUSED)
{
}
-static size_t
-scm_port_free0 (SCM port)
-{
- return 0;
-}
-
scm_t_bits
scm_make_port_type (char *name,
int (*fill_input) (SCM port),
@@ -153,7 +147,7 @@ scm_make_port_type (char *name,
scm_ptobs[scm_numptob].name = name;
scm_ptobs[scm_numptob].mark = 0;
- scm_ptobs[scm_numptob].free = scm_port_free0;
+ scm_ptobs[scm_numptob].free = NULL;
scm_ptobs[scm_numptob].print = scm_port_print;
scm_ptobs[scm_numptob].equalp = 0;
scm_ptobs[scm_numptob].close = 0;
@@ -593,7 +587,7 @@ scm_new_port_table_entry (scm_t_bits tag)
if ((enc = scm_i_get_port_encoding (SCM_BOOL_F)) == NULL)
entry->encoding = NULL;
else
- entry->encoding = strdup (enc);
+ entry->encoding = scm_gc_strdup (enc, "port");
entry->ilseq_handler = scm_i_get_conversion_strategy (SCM_BOOL_F);
SCM_SET_CELL_TYPE (z, tag);
@@ -633,14 +627,11 @@ scm_i_remove_port (SCM port)
#define FUNC_NAME "scm_remove_port"
{
scm_t_port *p = SCM_PTAB_ENTRY (port);
- if (p->putback_buf)
- scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer");
- if (p->encoding)
- {
- free (p->encoding);
- p->encoding = NULL;
- }
- scm_gc_free (p, sizeof (scm_t_port), "port");
+
+ scm_port_non_buffer (p);
+
+ p->putback_buf = NULL;
+ p->putback_buf_size = 0;
SCM_SETPTAB_ENTRY (port, 0);
scm_hashq_remove_x (scm_i_port_weak_hash, port);
@@ -1358,7 +1349,7 @@ scm_c_read (SCM port, void *buffer, size_t size)
requested number of bytes. (Note that a single scm_fill_input
call does not guarantee to fill the whole of the port's read
buffer.) */
- if (pt->read_buf_size <= 1)
+ if (pt->read_buf_size <= 1 && pt->encoding == NULL)
{
/* The port that we are reading from is unbuffered - i.e. does
not have its own persistent buffer - but we have a buffer,
@@ -1370,7 +1361,14 @@ scm_c_read (SCM port, void *buffer, size_t size)
We need to make sure that the port's normal (1 byte) buffer
is reinstated in case one of the scm_fill_input () calls
throws an exception; we use the scm_dynwind_* API to achieve
- that. */
+ that.
+
+ A consequence of this optimization is that the fill_input
+ functions can't unget characters. That'll push data to the
+ pushback buffer instead of this psb buffer. */
+#if SCM_DEBUG == 1
+ unsigned char *pback = pt->putback_buf;
+#endif
psb.pt = pt;
psb.buffer = buffer;
psb.size = size;
@@ -1385,8 +1383,15 @@ scm_c_read (SCM port, void *buffer, size_t size)
pt->read_buf_size -= (pt->read_end - pt->read_pos);
pt->read_pos = pt->read_buf = pt->read_end;
}
+#if SCM_DEBUG == 1
+ if (pback != pt->putback_buf
+ || pt->read_buf - (unsigned char *) buffer < 0)
+ scm_misc_error (FUNC_NAME,
+ "scm_c_read must not call a fill function that pushes "
+ "back characters onto an unbuffered port", SCM_EOL);
+#endif
n_read += pt->read_buf - (unsigned char *) buffer;
-
+
/* Reinstate the port's normal buffer. */
scm_dynwind_end ();
}
@@ -1490,8 +1495,6 @@ scm_unget_byte (int c, SCM port)
{
size_t new_size = pt->read_buf_size * 2;
unsigned char *tmp = (unsigned char *)
- /* XXX: Can we use `GC_REALLOC' with `GC_MALLOC_ATOMIC'-allocated
- data? (Ludo) */
scm_gc_realloc (pt->putback_buf, pt->read_buf_size, new_size,
"putback buffer");
@@ -1952,7 +1955,7 @@ scm_i_get_port_encoding (SCM port)
}
}
-/* Returns ENC is if is a recognized encoding. If it isn't, it tries
+/* Returns ENC if it is a recognized encoding. If it isn't, it tries
to find an alias of ENC that is valid. Otherwise, it returns
NULL. */
static const char *
@@ -2016,12 +2019,10 @@ scm_i_set_port_encoding_x (SCM port, const char *enc)
{
/* Set the character encoding for this port. */
pt = SCM_PTAB_ENTRY (port);
- if (pt->encoding)
- free (pt->encoding);
if (valid_enc == NULL)
pt->encoding = NULL;
else
- pt->encoding = strdup (valid_enc);
+ pt->encoding = scm_gc_strdup (valid_enc, "port");
}
}
diff --git a/libguile/ports.h b/libguile/ports.h
index 0f46e7f51..2ac736e44 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -310,7 +310,7 @@ SCM_API SCM scm_sys_make_void_port (SCM mode);
SCM_INTERNAL void scm_init_ports (void);
#if SCM_ENABLE_DEPRECATED==1
-SCM_API scm_t_port * scm_add_to_port_table (SCM port);
+SCM_DEPRECATED scm_t_port * scm_add_to_port_table (SCM port);
#endif
#ifdef GUILE_DEBUG
diff --git a/libguile/print.c b/libguile/print.c
index 3bb6cb167..b07e2067f 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -63,18 +63,17 @@
static const char *iflagnames[] =
{
"#f",
+ "#nil", /* Elisp nil value. Should print from elisp as symbol `nil'. */
+ "#<XXX UNUSED LISP FALSE -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
+ "()",
"#t",
+ "#<XXX UNUSED BOOLEAN -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
+ "#<unspecified>",
"#<undefined>",
"#<eof>",
- "()",
- "#<unspecified>",
/* Unbound slot marker for GOOPS. For internal use in GOOPS only. */
"#<unbound>",
-
- /* Elisp nil value. This is its Scheme name; whenever it's printed in
- * Elisp, it should appear as the symbol `nil'. */
- "#nil"
};
SCM_SYMBOL (sym_reader, "reader");
@@ -463,13 +462,26 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
/* Print the character if is graphic character. */
{
scm_t_wchar *wbuf;
- SCM wstr = scm_i_make_wide_string (1, &wbuf);
+ SCM wstr;
char *buf;
size_t len;
const char *enc;
enc = scm_i_get_port_encoding (port);
- wbuf[0] = i;
+ if (uc_combining_class (i) == UC_CCC_NR)
+ {
+ wstr = scm_i_make_wide_string (1, &wbuf);
+ wbuf[0] = i;
+ }
+ else
+ {
+ /* Character is a combining character: print it connected
+ to a dotted circle instead of connecting it to the
+ backslash in '#\' */
+ wstr = scm_i_make_wide_string (2, &wbuf);
+ wbuf[0] = SCM_CODEPOINT_DOTTED_CIRCLE;
+ wbuf[1] = i;
+ }
if (enc == NULL)
{
if (i <= 0xFF)
@@ -1220,8 +1232,8 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
SCM_VALIDATE_CHAR (1, chr);
SCM_VALIDATE_OPORT_VALUE (2, port);
-
- scm_putc ((int) SCM_CHAR (chr), SCM_COERCE_OUTPORT (port));
+
+ scm_i_charprint (SCM_CHAR (chr), SCM_COERCE_OUTPORT (port));
#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 5054291b1..dcbfba794 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -42,6 +42,9 @@
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
+static SCM non_closure_props;
+static scm_i_pthread_mutex_t non_closure_props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
SCM
scm_i_procedure_arity (SCM proc)
{
@@ -74,10 +77,10 @@ scm_i_procedure_arity (SCM proc)
r = 1;
break;
case scm_tc7_program:
- a += SCM_PROGRAM_DATA (proc)->nargs;
- r = SCM_PROGRAM_DATA (proc)->nrest;
- a -= r;
- break;
+ if (scm_i_program_arity (proc, &a, &o, &r))
+ break;
+ else
+ return SCM_BOOL_F;
case scm_tc7_lsubr_2:
a += 2;
r = 1;
@@ -137,92 +140,99 @@ scm_i_procedure_arity (SCM proc)
return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
}
-/* XXX - instead of using a stand-in value for everything except
- closures, we should find other ways to store the procedure
- properties for those other kinds of procedures. For example, subrs
- have their own property slot, which is unused at present.
-*/
-
-static SCM
-scm_stand_in_scm_proc(SCM proc)
-{
- SCM handle, answer;
- handle = scm_hashq_get_handle (scm_stand_in_procs, proc);
- if (scm_is_false (handle))
- {
- answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL);
- scm_hashq_set_x (scm_stand_in_procs, proc, answer);
- }
- else
- answer = SCM_CDR (handle);
- return answer;
-}
+/* FIXME: instead of the weak hash, perhaps for some kinds of procedures, use
+ other means; for example subrs have their own property slot, which is unused
+ at present. */
SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
(SCM proc),
"Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
+ SCM props;
+
SCM_VALIDATE_PROC (1, proc);
- return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
- SCM_PROCPROPS (SCM_CLOSUREP (proc)
- ? proc
- : scm_stand_in_scm_proc (proc)));
+ if (SCM_CLOSUREP (proc))
+ props = SCM_PROCPROPS (proc);
+ else
+ {
+ scm_i_pthread_mutex_lock (&non_closure_props_lock);
+ props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ }
+ return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc), props);
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
- (SCM proc, SCM new_val),
- "Set @var{obj}'s property list to @var{alist}.")
+ (SCM proc, SCM alist),
+ "Set @var{proc}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_procedure_properties_x
{
- if (!SCM_CLOSUREP (proc))
- proc = scm_stand_in_scm_proc(proc);
- SCM_VALIDATE_CLOSURE (1, proc);
- SCM_SETPROCPROPS (proc, new_val);
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_CLOSUREP (proc))
+ SCM_SETPROCPROPS (proc, alist);
+ else
+ {
+ scm_i_pthread_mutex_lock (&non_closure_props_lock);
+ scm_hashq_set_x (non_closure_props, proc, alist);
+ scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
- (SCM p, SCM k),
- "Return the property of @var{obj} with name @var{key}.")
+ (SCM proc, SCM key),
+ "Return the property of @var{proc} with name @var{key}.")
#define FUNC_NAME s_scm_procedure_property
{
- SCM assoc;
- if (scm_is_eq (k, scm_sym_arity))
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (scm_is_eq (key, scm_sym_arity))
+ /* avoid a cons in this case */
+ return scm_i_procedure_arity (proc);
+ else
{
- SCM arity;
- SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)),
- p, SCM_ARG1, FUNC_NAME);
- return arity;
+ SCM props;
+ if (SCM_CLOSUREP (proc))
+ props = SCM_PROCPROPS (proc);
+ else
+ {
+ scm_i_pthread_mutex_lock (&non_closure_props_lock);
+ props = scm_hashq_ref (non_closure_props, proc, SCM_EOL);
+ scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ }
+ return scm_assq_ref (props, key);
}
- SCM_VALIDATE_PROC (1, p);
- assoc = scm_sloppy_assq (k,
- SCM_PROCPROPS (SCM_CLOSUREP (p)
- ? p
- : scm_stand_in_scm_proc (p)));
- return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
- (SCM p, SCM k, SCM v),
- "In @var{obj}'s property list, set the property named @var{key} to\n"
- "@var{value}.")
+ (SCM proc, SCM key, SCM val),
+ "In @var{proc}'s property list, set the property named @var{key} to\n"
+ "@var{val}.")
#define FUNC_NAME s_scm_set_procedure_property_x
{
- SCM assoc;
- if (!SCM_CLOSUREP (p))
- p = scm_stand_in_scm_proc(p);
- SCM_VALIDATE_CLOSURE (1, p);
- if (scm_is_eq (k, scm_sym_arity))
+ SCM_VALIDATE_PROC (1, proc);
+
+ if (scm_is_eq (key, scm_sym_arity))
SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
- assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
- if (SCM_NIMP (assoc))
- SCM_SETCDR (assoc, v);
+
+ if (SCM_CLOSUREP (proc))
+ SCM_SETPROCPROPS (proc,
+ scm_assq_set_x (SCM_PROCPROPS (proc), key, val));
else
- SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
+ {
+ scm_i_pthread_mutex_lock (&non_closure_props_lock);
+ scm_hashq_set_x (non_closure_props, proc,
+ scm_assq_set_x (scm_hashq_ref (non_closure_props, proc,
+ SCM_EOL),
+ key, val));
+ scm_i_pthread_mutex_unlock (&non_closure_props_lock);
+ }
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -233,6 +243,7 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
void
scm_init_procprop ()
{
+ non_closure_props = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/procprop.x"
}
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 04cd38442..7a1131489 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -3,7 +3,7 @@
#ifndef SCM_PROCPROP_H
#define SCM_PROCPROP_H
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -35,9 +35,9 @@ SCM_API SCM scm_sym_system_procedure;
SCM_INTERNAL SCM scm_i_procedure_arity (SCM proc);
SCM_API SCM scm_procedure_properties (SCM proc);
-SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM new_val);
-SCM_API SCM scm_procedure_property (SCM p, SCM k);
-SCM_API SCM scm_set_procedure_property_x (SCM p, SCM k, SCM v);
+SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
+SCM_API SCM scm_procedure_property (SCM proc, SCM key);
+SCM_API SCM scm_set_procedure_property_x (SCM proc, SCM key, SCM val);
SCM_INTERNAL void scm_init_procprop (void);
#endif /* SCM_PROCPROP_H */
diff --git a/libguile/procs.c b/libguile/procs.c
index 40d6231bb..5de2f33f1 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -144,16 +144,18 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
case scm_tc7_gsubr:
return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0);
case scm_tc7_program:
- return scm_from_bool (SCM_PROGRAM_DATA (obj)->nargs == 0
- || (SCM_PROGRAM_DATA (obj)->nargs == 1
- && SCM_PROGRAM_DATA (obj)->nrest));
+ {
+ int a, o, r;
+ if (scm_i_program_arity (obj, &a, &o, &r))
+ return scm_from_bool (a == 0);
+ else
+ return SCM_BOOL_F;
+ }
case scm_tc7_pws:
obj = SCM_PROCEDURE (obj);
goto again;
default:
- if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0)
- return SCM_BOOL_T;
- /* otherwise fall through */
+ return SCM_BOOL_F;
}
}
return SCM_BOOL_F;
diff --git a/libguile/programs.c b/libguile/programs.c
index b2bf80674..7399fa05f 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -102,22 +102,6 @@ SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_arity
-{
- struct scm_objcode *p;
-
- SCM_VALIDATE_PROGRAM (1, program);
-
- p = SCM_PROGRAM_DATA (program);
- return scm_list_3 (SCM_I_MAKINUM (p->nargs),
- SCM_I_MAKINUM (p->nrest),
- SCM_I_MAKINUM (p->nlocs));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
(SCM program),
"")
@@ -209,6 +193,23 @@ SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_arities
+{
+ SCM meta;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ meta = scm_program_meta (program);
+ if (scm_is_false (meta))
+ return SCM_BOOL_F;
+
+ return scm_caddr (scm_call_0 (meta));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
(SCM program),
"")
@@ -222,7 +223,7 @@ SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
if (scm_is_false (meta))
return SCM_EOL;
- return scm_cddr (scm_call_0 (meta));
+ return scm_cdddr (scm_call_0 (meta));
}
#undef FUNC_NAME
@@ -281,11 +282,51 @@ SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
}
#undef FUNC_NAME
+/* This one is a shim to pre-case-lambda internal interfaces. Avoid it if you
+ can -- use program-arguments or the like. */
+static SCM sym_arglist;
+int
+scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
+{
+ SCM arities, x;
+
+ arities = scm_program_arities (program);
+ if (!scm_is_pair (arities))
+ return 0;
+ /* take the last arglist, it will be least specific */
+ while (scm_is_pair (scm_cdr (arities)))
+ arities = scm_cdr (arities);
+ x = scm_cddar (arities);
+ if (scm_is_pair (x))
+ {
+ *req = scm_to_int (scm_car (x));
+ x = scm_cdr (x);
+ if (scm_is_pair (x))
+ {
+ *opt = scm_to_int (scm_car (x));
+ x = scm_cdr (x);
+ if (scm_is_pair (x))
+ *rest = scm_is_true (scm_car (x));
+ else
+ *rest = 0;
+ }
+ else
+ *opt = *rest = 0;
+ }
+ else
+ *req = *opt = *rest = 0;
+
+ return 1;
+}
+
void
scm_bootstrap_programs (void)
{
+ /* arglist can't be snarfed, because snarfage is only loaded when (system vm
+ program) is loaded. perhaps static-alloc will fix this. */
+ sym_arglist = scm_from_locale_symbol ("arglist");
scm_c_register_extension ("libguile", "scm_init_programs",
(scm_t_extension_init_func)scm_init_programs, NULL);
}
diff --git a/libguile/programs.h b/libguile/programs.h
index d52631fbb..836f1ff0d 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -26,7 +26,7 @@
* Programs
*/
-#define SCM_F_PROGRAM_IS_BOOT (1<<16)
+#define SCM_F_PROGRAM_IS_BOOT 0x100
#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x))
@@ -40,11 +40,11 @@ SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
SCM_API SCM scm_program_p (SCM obj);
SCM_API SCM scm_program_base (SCM program);
-SCM_API SCM scm_program_arity (SCM program);
SCM_API SCM scm_program_meta (SCM program);
SCM_API SCM scm_program_bindings (SCM program);
SCM_API SCM scm_program_sources (SCM program);
SCM_API SCM scm_program_source (SCM program, SCM ip);
+SCM_API SCM scm_program_arities (SCM program);
SCM_API SCM scm_program_properties (SCM program);
SCM_API SCM scm_program_name (SCM program);
SCM_API SCM scm_program_objects (SCM program);
@@ -54,6 +54,7 @@ SCM_API SCM scm_program_objcode (SCM program);
SCM_API SCM scm_c_program_source (SCM program, size_t ip);
+SCM_INTERNAL int scm_i_program_arity (SCM program, int *req, int *opt, int *rest);
SCM_INTERNAL void scm_i_program_print (SCM program, SCM port,
scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_programs (void);
diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h
index 4f72a4293..ca72f1674 100644
--- a/libguile/pthread-threads.h
+++ b/libguile/pthread-threads.h
@@ -30,7 +30,7 @@
#include <sched.h>
/* `libgc' intercepts pthread calls by defining wrapping macros. */
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
/* Threads
*/
diff --git a/libguile/read.c b/libguile/read.c
index d91c868e1..fc56418df 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -181,8 +181,10 @@ static SCM *scm_read_hash_procedures;
|| ((_chr) == 'd') || ((_chr) == 'l'))
/* Read an SCSH block comment. */
-static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
-static SCM scm_read_commented_expression (int chr, SCM port);
+static inline SCM scm_read_scsh_block_comment (scm_t_wchar, SCM);
+static SCM scm_read_r6rs_block_comment (scm_t_wchar, SCM);
+static SCM scm_read_commented_expression (scm_t_wchar, SCM);
+static SCM scm_get_hash_procedure (int);
/* Read from PORT until a delimiter (e.g., a whitespace) is read. Return
zero if the whole token fits in BUF, non-zero otherwise. */
@@ -289,6 +291,13 @@ flush_ws (SCM port, const char *eoferr)
case ';':
scm_read_commented_expression (c, port);
break;
+ case '|':
+ if (scm_is_false (scm_get_hash_procedure (c)))
+ {
+ scm_read_r6rs_block_comment (c, port);
+ break;
+ }
+ /* fall through */
default:
scm_ungetc (c, port);
return '#';
@@ -313,7 +322,6 @@ flush_ws (SCM port, const char *eoferr)
static SCM scm_read_expression (SCM port);
static SCM scm_read_sharp (int chr, SCM port);
-static SCM scm_get_hash_procedure (int c);
static SCM recsexpr (SCM obj, long line, int column, SCM filename);
@@ -844,16 +852,25 @@ scm_read_character (scm_t_wchar chr, SCM port)
return SCM_MAKE_CHAR (scm_i_string_ref (charname, 0));
cp = scm_i_string_ref (charname, 0);
+ if (cp == SCM_CODEPOINT_DOTTED_CIRCLE && charname_len == 2)
+ return SCM_MAKE_CHAR (scm_i_string_ref (charname, 1));
+
if (cp >= '0' && cp < '8')
{
/* Dirk:FIXME:: This type of character syntax is not R5RS
* compliant. Further, it should be verified that the constant
- * does only consist of octal digits. Finally, it should be
- * checked whether the resulting fixnum is in the range of
- * characters. */
+ * does only consist of octal digits. */
SCM p = scm_string_to_number (charname, scm_from_uint (8));
if (SCM_I_INUMP (p))
- return SCM_MAKE_CHAR (SCM_I_INUM (p));
+ {
+ scm_t_wchar c = SCM_I_INUM (p);
+ if (SCM_IS_UNICODE_CHAR (c))
+ return SCM_MAKE_CHAR (c);
+ else
+ scm_i_input_error (FUNC_NAME, port,
+ "out-of-range octal character escape: ~a",
+ scm_list_1 (charname));
+ }
}
/* The names of characters should never have non-Latin1
@@ -982,6 +999,45 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
}
static SCM
+scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port)
+{
+ /* Unlike SCSH-style block comments, SRFI-30/R6RS block comments may be
+ nested. So care must be taken. */
+ int nesting_level = 1;
+ int opening_seen = 0, closing_seen = 0;
+
+ while (nesting_level > 0)
+ {
+ int c = scm_getc (port);
+
+ if (c == EOF)
+ scm_i_input_error (__FUNCTION__, port,
+ "unterminated `#| ... |#' comment", SCM_EOL);
+
+ if (opening_seen)
+ {
+ if (c == '|')
+ nesting_level++;
+ opening_seen = 0;
+ }
+ else if (closing_seen)
+ {
+ if (c == '#')
+ nesting_level--;
+ closing_seen = 0;
+ }
+ else if (c == '|')
+ closing_seen = 1;
+ else if (c == '#')
+ opening_seen = 1;
+ else
+ opening_seen = closing_seen = 0;
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
scm_read_commented_expression (scm_t_wchar chr, SCM port)
{
scm_t_wchar c;
@@ -1164,8 +1220,19 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
default:
result = scm_read_sharp_extension (chr, port);
if (scm_is_eq (result, SCM_UNSPECIFIED))
- scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
- scm_list_1 (SCM_MAKE_CHAR (chr)));
+ {
+ /* To remain compatible with 1.8 and earlier, the following
+ characters have lower precedence than `read-hash-extend'
+ characters. */
+ switch (chr)
+ {
+ case '|':
+ return scm_read_r6rs_block_comment (chr, port);
+ default:
+ scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (chr)));
+ }
+ }
else
return result;
}
@@ -1437,7 +1504,9 @@ scm_scan_for_encoding (SCM port)
/* grab the next token */
i = 0;
while (pos + i - header <= SCM_ENCODING_SEARCH_SIZE
- && (isalnum(pos[i]) || pos[i] == '_' || pos[i] == '-' || pos[i] == '.'))
+ && pos + i - header < bytes_read
+ && (isalnum((int) pos[i]) || pos[i] == '_' || pos[i] == '-'
+ || pos[i] == '.'))
i++;
if (i == 0)
diff --git a/libguile/root.h b/libguile/root.h
index 676a7b44c..46b9be013 100644
--- a/libguile/root.h
+++ b/libguile/root.h
@@ -3,7 +3,7 @@
#ifndef SCM_ROOT_H
#define SCM_ROOT_H
-/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -34,13 +34,12 @@
#define scm_nullvect scm_sys_protects[2]
#define scm_nullstr scm_sys_protects[3]
#define scm_keyword_obarray scm_sys_protects[4]
-#define scm_stand_in_procs scm_sys_protects[5]
-#define scm_object_whash scm_sys_protects[6]
-#define scm_asyncs scm_sys_protects[7]
-#define scm_protects scm_sys_protects[8]
-#define scm_properties_whash scm_sys_protects[9]
-#define scm_source_whash scm_sys_protects[10]
-#define SCM_NUM_PROTECTS 11
+#define scm_object_whash scm_sys_protects[5]
+#define scm_asyncs scm_sys_protects[6]
+#define scm_protects scm_sys_protects[7]
+#define scm_properties_whash scm_sys_protects[8]
+#define scm_source_whash scm_sys_protects[9]
+#define SCM_NUM_PROTECTS 10
SCM_API SCM scm_sys_protects[];
diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c
index d9b36c574..f38d15c75 100644
--- a/libguile/scmsigs.c
+++ b/libguile/scmsigs.c
@@ -340,7 +340,10 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
install_handler (csig, SCM_BOOL_F, SCM_BOOL_F);
}
else
- SCM_OUT_OF_RANGE (2, handler);
+ {
+ SCM_CRITICAL_SECTION_END;
+ SCM_OUT_OF_RANGE (2, handler);
+ }
}
else if (scm_is_false (handler))
{
diff --git a/libguile/smob.c b/libguile/smob.c
index 86bb22f47..42a51fdff 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -38,7 +38,7 @@
#include "libguile/smob.h"
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>
@@ -97,6 +97,7 @@ scm_markcdr (SCM ptr)
return SCM_CELL_OBJECT_1 (ptr);
}
+
/* {Free}
*/
@@ -106,16 +107,7 @@ scm_free0 (SCM ptr SCM_UNUSED)
return 0;
}
-size_t
-scm_smob_free (SCM obj)
-{
- long n = SCM_SMOBNUM (obj);
- if (scm_smobs[n].size > 0)
- scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
- scm_smobs[n].size, SCM_SMOBNAME (n));
- return 0;
-}
-
+
/* {Print}
*/
@@ -307,11 +299,7 @@ scm_make_smob_type (char const *name, size_t size)
scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
scm_smobs[new_smob].name = name;
- if (size != 0)
- {
- scm_smobs[new_smob].size = size;
- scm_smobs[new_smob].free = scm_smob_free;
- }
+ scm_smobs[new_smob].size = size;
/* Make a class object if Goops is present. */
if (SCM_UNPACK (scm_smob_class[0]) != 0)
diff --git a/libguile/smob.h b/libguile/smob.h
index d435bacb8..ee0e53e64 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -26,7 +26,7 @@
#include "libguile/__scm.h"
#include "libguile/print.h"
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
@@ -167,7 +167,6 @@ SCM_API void scm_i_finalize_smob (GC_PTR obj, GC_PTR data);
SCM_API SCM scm_mark0 (SCM ptr);
SCM_API SCM scm_markcdr (SCM ptr);
SCM_API size_t scm_free0 (SCM ptr);
-SCM_API size_t scm_smob_free (SCM obj);
SCM_API int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate);
/* The following set of functions is the standard way to create new
diff --git a/libguile/socket.c b/libguile/socket.c
index 3a81ed9d0..ea2ba5ccb 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -349,7 +349,7 @@ scm_to_ipv6 (scm_t_uint8 dst[16], SCM src)
scm_remember_upto_here_1 (src);
}
else
- scm_wrong_type_arg (NULL, 0, src);
+ scm_wrong_type_arg_msg ("scm_to_ipv6", 0, src, "integer");
}
#ifdef HAVE_INET_PTON
@@ -399,8 +399,8 @@ SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0,
"@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
"@lisp\n"
"(inet-ntop AF_INET 2130706433) @result{} \"127.0.0.1\"\n"
- "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n"
- "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n"
+ "(inet-ntop AF_INET6 (- (expt 2 128) 1))\n"
+ " @result{} \"ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\"\n"
"@end lisp")
#define FUNC_NAME s_scm_inet_ntop
{
@@ -1169,7 +1169,8 @@ scm_to_sockaddr (SCM address, size_t *address_size)
{
struct sockaddr_in6 c_inet6;
- scm_to_ipv6 (c_inet6.sin6_addr.s6_addr, address);
+ scm_to_ipv6 (c_inet6.sin6_addr.s6_addr,
+ SCM_SIMPLE_VECTOR_REF (address, 1));
c_inet6.sin6_port =
htons (scm_to_ushort (SCM_SIMPLE_VECTOR_REF (address, 2)));
c_inet6.sin6_flowinfo =
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
index 89063bed4..ca8818ac4 100644
--- a/libguile/srcprop.h
+++ b/libguile/srcprop.h
@@ -3,7 +3,7 @@
#ifndef SCM_SRCPROP_H
#define SCM_SRCPROP_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -35,12 +35,15 @@
#define scm_whash_handle SCM
-#define scm_whash_get_handle(whash, key) scm_hash_fn_get_handle (whash, key, scm_ihashq, scm_sloppy_assq, 0)
+#define scm_whash_get_handle(whash, key) \
+ scm_hashq_get_handle ((whash), (key))
#define SCM_WHASHFOUNDP(h) (scm_is_true (h))
#define SCM_WHASHREF(whash, handle) SCM_CDR (handle)
#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj)
-#define scm_whash_create_handle(whash, key) scm_hash_fn_create_handle_x (whash, key, SCM_UNSPECIFIED, scm_ihashq, scm_sloppy_assq, 0)
-#define scm_whash_lookup(whash, obj) scm_hash_fn_ref (whash, obj, SCM_BOOL_F, scm_ihashq, scm_sloppy_assq, 0)
+#define scm_whash_create_handle(whash, key) \
+ scm_hashq_create_handle_x ((whash), (key), SCM_UNSPECIFIED)
+#define scm_whash_lookup(whash, obj) \
+ scm_hashq_ref ((whash), (obj), SCM_BOOL_F)
#define scm_whash_insert(whash, key, obj) \
do { \
register SCM w = (whash); \
diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c
index 7c0013193..38ef32049 100644
--- a/libguile/srfi-14.c
+++ b/libguile/srfi-14.c
@@ -1,6 +1,6 @@
/* srfi-14.c --- SRFI-14 procedures for Guile
*
- * Copyright (C) 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2007, 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
@@ -29,10 +29,23 @@
#include "libguile.h"
#include "libguile/srfi-14.h"
#include "libguile/strings.h"
+#include "libguile/chars.h"
/* Include the pre-computed standard charset data. */
#include "libguile/srfi-14.i.c"
+scm_t_char_range cs_full_ranges[] = {
+ {0x0000, SCM_CODEPOINT_SURROGATE_START - 1}
+ ,
+ {SCM_CODEPOINT_SURROGATE_END + 1, SCM_CODEPOINT_MAX}
+};
+
+scm_t_char_set cs_full = {
+ 2,
+ cs_full_ranges
+};
+
+
#define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset))
#define SCM_CHARSET_SET(cs, idx) \
@@ -85,18 +98,11 @@ scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n)
/* This char is one below the current range. */
if (i > 0 && cs->ranges[i - 1].hi + 1 == n)
{
- /* It is also one above the previous range, so combine them. */
- cs->ranges[i - 1].hi = cs->ranges[i].hi;
- if (i < len - 1)
- memmove (cs->ranges + i, cs->ranges + (i + 1),
- sizeof (scm_t_char_range) * (len - i - 1));
- cs->ranges = scm_gc_realloc (cs->ranges,
- sizeof (scm_t_char_range) * len,
- sizeof (scm_t_char_range) * (len -
- 1),
- "character-set");
- cs->len = len - 1;
- return;
+ /* It is also one above the previous range. */
+ /* This is an impossible condition: in the previous
+ iteration, the test for 'one above the current range'
+ should already have inserted the character here. */
+ abort ();
}
else
{
@@ -167,6 +173,103 @@ scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n)
return;
}
+/* Put LO to HI inclusive into charset CS. */
+static void
+scm_i_charset_set_range (scm_t_char_set *cs, scm_t_wchar lo, scm_t_wchar hi)
+{
+ size_t i;
+
+ i = 0;
+ while (i < cs->len)
+ {
+ /* Already in this range */
+ if (cs->ranges[i].lo <= lo && cs->ranges[i].hi >= hi)
+ return;
+
+ /* cur: +---+
+ new: +---+
+ */
+ if (cs->ranges[i].lo - 1 > hi)
+ {
+ /* Add a new range below the current one. */
+ cs->ranges = scm_gc_realloc (cs->ranges,
+ sizeof (scm_t_char_range) * cs->len,
+ sizeof (scm_t_char_range) * (cs->len + 1),
+ "character-set");
+ memmove (cs->ranges + (i + 1), cs->ranges + i,
+ sizeof (scm_t_char_range) * (cs->len - i));
+ cs->ranges[i].lo = lo;
+ cs->ranges[i].hi = hi;
+ cs->len += 1;
+ return;
+ }
+
+ /* cur: +---+ or +---+ or +---+
+ new: +---+ +---+ +---+
+ */
+ if (cs->ranges[i].lo > lo
+ && (cs->ranges[i].lo - 1 <= hi && cs->ranges[i].hi >= hi))
+ {
+ cs->ranges[i].lo = lo;
+ return;
+ }
+
+ /* cur: +---+ or +---+ or +---+
+ new: +---+ +---+ +---+
+ */
+ else if (cs->ranges[i].hi + 1 >= lo && cs->ranges[i].hi < hi)
+ {
+ if (cs->ranges[i].lo > lo)
+ cs->ranges[i].lo = lo;
+ if (cs->ranges[i].hi < hi)
+ cs->ranges[i].hi = hi;
+ while (i < cs->len - 1)
+ {
+ /* cur: --+ +---+
+ new: -----+
+ */
+ if (cs->ranges[i + 1].lo - 1 > hi)
+ break;
+
+ /* cur: --+ +---+ or --+ +---+ or --+ +--+
+ new: -----+ ------+ ---------+
+ */
+ /* Combine this range with the previous one. */
+ if (cs->ranges[i + 1].hi > hi)
+ cs->ranges[i].hi = cs->ranges[i + 1].hi;
+ if (i + 1 < cs->len)
+ memmove (cs->ranges + i + 1, cs->ranges + i + 2,
+ sizeof (scm_t_char_range) * (cs->len - i - 2));
+ cs->ranges = scm_gc_realloc (cs->ranges,
+ sizeof (scm_t_char_range) * cs->len,
+ sizeof (scm_t_char_range) * (cs->len - 1),
+ "character-set");
+ cs->len -= 1;
+ }
+ return;
+ }
+ i ++;
+ }
+
+ /* This is a new range above all previous ranges. */
+ if (cs->len == 0)
+ {
+ cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set");
+ }
+ else
+ {
+ cs->ranges = scm_gc_realloc (cs->ranges,
+ sizeof (scm_t_char_range) * cs->len,
+ sizeof (scm_t_char_range) * (cs->len + 1),
+ "character-set");
+ }
+ cs->len += 1;
+ cs->ranges[cs->len - 1].lo = lo;
+ cs->ranges[cs->len - 1].hi = hi;
+
+ return;
+}
+
/* If N is in charset CS, remove it. */
void
scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n)
@@ -301,7 +404,7 @@ static void
charsets_union (scm_t_char_set *a, scm_t_char_set *b)
{
size_t i = 0;
- scm_t_wchar blo, bhi, n;
+ scm_t_wchar blo, bhi;
if (b->len == 0)
return;
@@ -315,13 +418,11 @@ charsets_union (scm_t_char_set *a, scm_t_char_set *b)
return;
}
- /* This needs optimization. */
while (i < b->len)
{
blo = b->ranges[i].lo;
bhi = b->ranges[i].hi;
- for (n = blo; n <= bhi; n++)
- scm_i_charset_set (a, n);
+ scm_i_charset_set_range (a, blo, bhi);
i++;
}
@@ -373,22 +474,35 @@ charsets_intersection (scm_t_char_set *a, scm_t_char_set *b)
return;
}
+#define SCM_ADD_RANGE(low, high) \
+ do { \
+ p->ranges[idx].lo = (low); \
+ p->ranges[idx++].hi = (high); \
+ } while (0)
+#define SCM_ADD_RANGE_SKIP_SURROGATES(low, high) \
+ do { \
+ p->ranges[idx].lo = (low); \
+ p->ranges[idx++].hi = SCM_CODEPOINT_SURROGATE_START - 1; \
+ p->ranges[idx].lo = SCM_CODEPOINT_SURROGATE_END + 1; \
+ p->ranges[idx++].hi = (high); \
+ } while (0)
+
+
+
/* Make P the compelement of Q. */
static void
charsets_complement (scm_t_char_set *p, scm_t_char_set *q)
{
int k, idx;
+ idx = 0;
if (q->len == 0)
{
/* Fill with all valid codepoints. */
p->len = 2;
p->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * 2,
"character-set");
- p->ranges[0].lo = 0;
- p->ranges[0].hi = 0xd7ff;
- p->ranges[1].lo = 0xe000;
- p->ranges[1].hi = SCM_CODEPOINT_MAX;
+ SCM_ADD_RANGE_SKIP_SURROGATES (0, SCM_CODEPOINT_MAX);
return;
}
@@ -396,33 +510,42 @@ charsets_complement (scm_t_char_set *p, scm_t_char_set *q)
scm_gc_free (p->ranges, sizeof (scm_t_char_set) * p->len,
"character-set");
+ /* Count the number of ranges needed for the output. */
p->len = 0;
if (q->ranges[0].lo > 0)
p->len++;
if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
p->len++;
- p->len += q->len - 1;
+ p->len += q->len;
p->ranges =
(scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) * p->len,
"character-set");
- idx = 0;
if (q->ranges[0].lo > 0)
{
- p->ranges[idx].lo = 0;
- p->ranges[idx++].hi = q->ranges[0].lo - 1;
+ if (q->ranges[0].lo > SCM_CODEPOINT_SURROGATE_END)
+ SCM_ADD_RANGE_SKIP_SURROGATES (0, q->ranges[0].lo - 1);
+ else
+ SCM_ADD_RANGE (0, q->ranges[0].lo - 1);
}
for (k = 1; k < q->len; k++)
{
- p->ranges[idx].lo = q->ranges[k - 1].hi + 1;
- p->ranges[idx++].hi = q->ranges[k].lo - 1;
+ if (q->ranges[k - 1].hi < SCM_CODEPOINT_SURROGATE_START
+ && q->ranges[k].lo - 1 > SCM_CODEPOINT_SURROGATE_END)
+ SCM_ADD_RANGE_SKIP_SURROGATES (q->ranges[k - 1].hi + 1, q->ranges[k].lo - 1);
+ else
+ SCM_ADD_RANGE (q->ranges[k - 1].hi + 1, q->ranges[k].lo - 1);
}
if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
{
- p->ranges[idx].lo = q->ranges[q->len - 1].hi + 1;
- p->ranges[idx].hi = SCM_CODEPOINT_MAX;
+ if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_SURROGATE_START)
+ SCM_ADD_RANGE_SKIP_SURROGATES (q->ranges[q->len - 1].hi + 1, SCM_CODEPOINT_MAX);
+ else
+ SCM_ADD_RANGE (q->ranges[q->len - 1].hi + 1, SCM_CODEPOINT_MAX);
}
return;
}
+#undef SCM_ADD_RANGE
+#undef SCM_ADD_RANGE_SKIP_SURROGATES
/* Replace A with elements only found in one of A or B. */
static void
@@ -1161,7 +1284,7 @@ SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0,
for (k = 0; k < p->len; k++)
for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++)
{
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
if (scm_is_true (res))
SCM_CHARSET_SET (base_cs, n);
@@ -1171,27 +1294,18 @@ SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
- (SCM lower, SCM upper, SCM error, SCM base_cs),
- "Return a character set containing all characters whose\n"
- "character codes lie in the half-open range\n"
- "[@var{lower},@var{upper}).\n"
- "\n"
- "If @var{error} is a true value, an error is signalled if the\n"
- "specified range contains characters which are not contained in\n"
- "the implemented character range. If @var{error} is @code{#f},\n"
- "these characters are silently left out of the resultung\n"
- "character set.\n"
- "\n"
- "The characters in @var{base_cs} are added to the result, if\n"
- "given.")
-#define FUNC_NAME s_scm_ucs_range_to_char_set
+/* Return a character set containing all the characters from [LOWER,UPPER),
+ giving range errors if ERROR, adding chars from BASE_CS, and recycling
+ BASE_CS if REUSE is true. */
+static SCM
+scm_i_ucs_range_to_char_set (const char *FUNC_NAME, SCM lower, SCM upper,
+ SCM error, SCM base_cs, int reuse)
{
SCM cs;
size_t clower, cupper;
clower = scm_to_size_t (lower);
- cupper = scm_to_size_t (upper);
+ cupper = scm_to_size_t (upper) - 1;
SCM_ASSERT_RANGE (2, upper, cupper >= clower);
if (!SCM_UNBNDP (error))
{
@@ -1199,28 +1313,66 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
{
SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
+ if (clower < SCM_CODEPOINT_SURROGATE_START
+ && cupper > SCM_CODEPOINT_SURROGATE_END)
+ scm_error(scm_out_of_range_key,
+ FUNC_NAME, "invalid range - contains surrogate characters: ~S to ~S",
+ scm_list_2 (lower, upper), scm_list_1 (upper));
}
}
- if (clower > 0x10FFFF)
- clower = 0x10FFFF;
- if (cupper > 0x10FFFF)
- cupper = 0x10FFFF;
+
if (SCM_UNBNDP (base_cs))
cs = make_char_set (FUNC_NAME);
else
{
- SCM_VALIDATE_SMOB (4, base_cs, charset);
- cs = scm_char_set_copy (base_cs);
+ SCM_VALIDATE_SMOB (3, base_cs, charset);
+ if (reuse)
+ cs = base_cs;
+ else
+ cs = scm_char_set_copy (base_cs);
}
- /* It not be difficult to write a more optimized version of the
- following. */
- while (clower < cupper)
+
+ if ((clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
+ && (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END))
+ return cs;
+
+ if (clower > SCM_CODEPOINT_MAX)
+ clower = SCM_CODEPOINT_MAX;
+ if (clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
+ clower = SCM_CODEPOINT_SURROGATE_END + 1;
+ if (cupper > SCM_CODEPOINT_MAX)
+ cupper = SCM_CODEPOINT_MAX;
+ if (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END)
+ cupper = SCM_CODEPOINT_SURROGATE_START - 1;
+ if (clower < SCM_CODEPOINT_SURROGATE_START && cupper > SCM_CODEPOINT_SURROGATE_END)
{
- SCM_CHARSET_SET (cs, clower);
- clower++;
+ scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, SCM_CODEPOINT_SURROGATE_START - 1);
+ scm_i_charset_set_range (SCM_CHARSET_DATA (cs), SCM_CODEPOINT_SURROGATE_END + 1, cupper);
}
+ else
+ scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, cupper);
return cs;
}
+
+SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
+ (SCM lower, SCM upper, SCM error, SCM base_cs),
+ "Return a character set containing all characters whose\n"
+ "character codes lie in the half-open range\n"
+ "[@var{lower},@var{upper}).\n"
+ "\n"
+ "If @var{error} is a true value, an error is signalled if the\n"
+ "specified range contains characters which are not valid\n"
+ "Unicode code points. If @var{error} is @code{#f},\n"
+ "these characters are silently left out of the resultung\n"
+ "character set.\n"
+ "\n"
+ "The characters in @var{base_cs} are added to the result, if\n"
+ "given.")
+#define FUNC_NAME s_scm_ucs_range_to_char_set
+{
+ return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
+ error, base_cs, 0);
+}
#undef FUNC_NAME
@@ -1240,28 +1392,9 @@ SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0,
"returned.")
#define FUNC_NAME s_scm_ucs_range_to_char_set_x
{
- size_t clower, cupper;
-
- clower = scm_to_size_t (lower);
- cupper = scm_to_size_t (upper);
- SCM_ASSERT_RANGE (2, upper, cupper >= clower);
- if (scm_is_true (error))
- {
- SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
- SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
- }
- if (clower > SCM_CODEPOINT_MAX)
- clower = SCM_CODEPOINT_MAX;
- if (cupper > SCM_CODEPOINT_MAX)
- cupper = SCM_CODEPOINT_MAX;
-
- while (clower < cupper)
- {
- if (SCM_IS_UNICODE_CHAR (clower))
- SCM_CHARSET_SET (base_cs, clower);
- clower++;
- }
- return base_cs;
+ SCM_VALIDATE_SMOB (4, base_cs, charset);
+ return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
+ error, base_cs, 1);
}
#undef FUNC_NAME
@@ -1455,7 +1588,9 @@ SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0,
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_SMOB (2, cs, charset);
- cs_data = (scm_t_char_set *) cs;
+ cs_data = SCM_CHARSET_DATA (cs);
+ if (cs_data->len == 0)
+ return SCM_BOOL_T;
for (k = 0; k < cs_data->len; k++)
for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
@@ -1819,7 +1954,8 @@ SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
(char-set-xor a a a) -> char set #\a
(char-set-xor! a a a) -> char set #\a
*/
- return scm_char_set_xor (scm_cons (cs1, rest));
+ cs1 = scm_char_set_xor (scm_cons (cs1, rest));
+ return cs1;
}
#undef FUNC_NAME
@@ -1862,6 +1998,7 @@ SCM scm_char_set_hex_digit;
SCM scm_char_set_blank;
SCM scm_char_set_ascii;
SCM scm_char_set_empty;
+SCM scm_char_set_designated;
SCM scm_char_set_full;
@@ -1876,31 +2013,59 @@ define_charset (const char *name, const scm_t_char_set *p)
return scm_permanent_object (cs);
}
-#ifdef SCM_CHARSET_DEBUG
-SCM_DEFINE (scm_debug_char_set, "debug-char-set", 1, 0, 0,
- (SCM charset),
- "Print out the internal C structure of @var{charset}.\n")
-#define FUNC_NAME s_scm_debug_char_set
+SCM_DEFINE (scm_sys_char_set_dump, "%char-set-dump", 1, 0, 0, (SCM charset),
+ "Returns an association list containing debugging information\n"
+ "for @var{charset}. The association list has the following entries."
+ "@table @code\n"
+ "@item char-set\n"
+ "The char-set itself.\n"
+ "@item len\n"
+ "The number of character ranges the char-set contains\n"
+ "@item ranges\n"
+ "A list of lists where each sublist a range of code points\n"
+ "and their associated characters"
+ "@end table")
+#define FUNC_NAME s_scm_sys_char_set_dump
{
- int i;
- scm_t_char_set *cs = SCM_CHARSET_DATA (charset);
- fprintf (stderr, "cs %p\n", cs);
- fprintf (stderr, "len %d\n", cs->len);
- fprintf (stderr, "arr %p\n", cs->ranges);
+ SCM e1, e2, e3;
+ SCM ranges = SCM_EOL, elt;
+ size_t i;
+ scm_t_char_set *cs;
+ char codepoint_string_lo[9], codepoint_string_hi[9];
+
+ SCM_VALIDATE_SMOB (1, charset, charset);
+ cs = SCM_CHARSET_DATA (charset);
+
+ e1 = scm_cons (scm_from_locale_symbol ("char-set"),
+ charset);
+ e2 = scm_cons (scm_from_locale_symbol ("n"),
+ scm_from_size_t (cs->len));
+
for (i = 0; i < cs->len; i++)
{
- if (cs->ranges[i].lo == cs->ranges[i].hi)
- fprintf (stderr, "%04x\n", cs->ranges[i].lo);
+ if (cs->ranges[i].lo > 0xFFFF)
+ sprintf (codepoint_string_lo, "U+%06x", cs->ranges[i].lo);
else
- fprintf (stderr, "%04x..%04x\t[%d]\n",
- cs->ranges[i].lo,
- cs->ranges[i].hi, cs->ranges[i].hi - cs->ranges[i].lo + 1);
+ sprintf (codepoint_string_lo, "U+%04x", cs->ranges[i].lo);
+ if (cs->ranges[i].hi > 0xFFFF)
+ sprintf (codepoint_string_hi, "U+%06x", cs->ranges[i].hi);
+ else
+ sprintf (codepoint_string_hi, "U+%04x", cs->ranges[i].hi);
+
+ elt = scm_list_4 (SCM_MAKE_CHAR (cs->ranges[i].lo),
+ SCM_MAKE_CHAR (cs->ranges[i].hi),
+ scm_from_locale_string (codepoint_string_lo),
+ scm_from_locale_string (codepoint_string_hi));
+ ranges = scm_append (scm_list_2 (ranges,
+ scm_list_1 (elt)));
}
- printf ("\n");
- return SCM_UNSPECIFIED;
+ e3 = scm_cons (scm_from_locale_symbol ("ranges"),
+ ranges);
+
+ return scm_list_3 (e1, e2, e3);
}
#undef FUNC_NAME
-#endif /* SCM_CHARSET_DEBUG */
+
@@ -1937,6 +2102,7 @@ scm_init_srfi_14 (void)
scm_char_set_blank = define_charset ("char-set:blank", &cs_blank);
scm_char_set_ascii = define_charset ("char-set:ascii", &cs_ascii);
scm_char_set_empty = define_charset ("char-set:empty", &cs_empty);
+ scm_char_set_designated = define_charset ("char-set:designated", &cs_designated);
scm_char_set_full = define_charset ("char-set:full", &cs_full);
#include "libguile/srfi-14.x"
diff --git a/libguile/srfi-14.h b/libguile/srfi-14.h
index 1b9c29518..4b1a4b298 100644
--- a/libguile/srfi-14.h
+++ b/libguile/srfi-14.h
@@ -100,9 +100,7 @@ SCM_API SCM scm_char_set_intersection_x (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_difference_x (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_xor_x (SCM cs1, SCM rest);
SCM_API SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest);
-#if SCM_CHARSET_DEBUG
-SCM_API SCM scm_debug_char_set (SCM cs);
-#endif /* SCM_CHARSET_DEBUG */
+SCM_API SCM scm_sys_char_set_dump (SCM charset);
SCM_API SCM scm_char_set_lower_case;
SCM_API SCM scm_char_set_upper_case;
diff --git a/libguile/srfi-14.i.c b/libguile/srfi-14.i.c
index 5ef21f333..fd537daf3 100644
--- a/libguile/srfi-14.i.c
+++ b/libguile/srfi-14.i.c
@@ -2,7 +2,8 @@
/* This file is #include'd by srfi-14.c. */
-/* This file was generated from http://unicode.org/Public/UNIDATA/UnicodeData.txt
+/* This file was generated from
+ http://unicode.org/Public/UNIDATA/UnicodeData.txt
with the unidata_to_charset.pl script. */
scm_t_char_range cs_lower_case_ranges[] = {
@@ -6252,7 +6253,7 @@ scm_t_char_set cs_empty = {
cs_empty_ranges
};
-scm_t_char_range cs_full_ranges[] = {
+scm_t_char_range cs_designated_ranges[] = {
{0x0000, 0x0377}
,
{0x037a, 0x037e}
@@ -6925,7 +6926,7 @@ scm_t_char_range cs_full_ranges[] = {
,
{0xac00, 0xd7a3}
,
- {0xd800, 0xfa2d}
+ {0xe000, 0xfa2d}
,
{0xfa30, 0xfa6a}
,
@@ -7144,7 +7145,7 @@ scm_t_char_range cs_full_ranges[] = {
{0x100000, 0x10fffd}
};
-scm_t_char_set cs_full = {
+scm_t_char_set cs_designated = {
445,
- cs_full_ranges
+ cs_designated_ranges
};
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index 302414364..af8eaa3c3 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -28,7 +28,7 @@
#include "libguile/_scm.h"
#include "libguile/__scm.h"
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
#include "libguile/srfi-4.h"
#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h
index 3a45fd9e0..48001abe3 100644
--- a/libguile/srfi-4.h
+++ b/libguile/srfi-4.h
@@ -286,7 +286,7 @@ SCM_INTERNAL scm_i_t_array_set scm_i_uniform_vector_set_proc (SCM uvec);
interface.
*/
-SCM_API size_t scm_uniform_element_size (SCM obj);
+SCM_DEPRECATED size_t scm_uniform_element_size (SCM obj);
#endif
diff --git a/libguile/stackchk.h b/libguile/stackchk.h
index 6aa0fec18..ed149067b 100644
--- a/libguile/stackchk.h
+++ b/libguile/stackchk.h
@@ -3,7 +3,7 @@
#ifndef SCM_STACKCHK_H
#define SCM_STACKCHK_H
-/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -34,7 +34,7 @@
*/
#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT
-#ifdef STACK_CHECKING
+#if defined BUILDING_LIBGUILE && defined STACK_CHECKING
# if SCM_STACK_GROWS_UP
# define SCM_STACK_OVERFLOW_P(s)\
(SCM_STACK_PTR (s) \
@@ -52,7 +52,7 @@
}
#else
# define SCM_CHECK_STACK /**/
-#endif /* STACK_CHECKING */
+#endif
SCM_API int scm_stack_checking_enabled_p;
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 45566cafa..a70186371 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -143,6 +143,11 @@ stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
{
scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
+ /* If current frame is a macro during expansion, we should
+ skip the previously recorded macro transformer
+ application frame. */
+ if (SCM_MACROEXPP (*dframe) && n > 0)
+ --n;
n += (info - vect) / 2 + 1;
/* Data in the apply part of an eval info frame comes from previous
stack frame if the scm_t_debug_info vector is overflowed. */
@@ -151,7 +156,7 @@ stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
&& !SCM_UNBNDP (info[1].a.proc))
++n;
}
- else if (SCM_APPLYFRAMEP (*dframe))
+ else
{
scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
if (SCM_PROGRAM_P (vect[0].a.proc))
@@ -177,8 +182,6 @@ stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
else
++n; /* increment for non-program apply frame */
}
- else
- ++n;
}
if (dframe && SCM_VOIDFRAMEP (*dframe))
*id = RELOC_INFO(dframe->vect, offset)[0].id;
@@ -282,6 +285,7 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
{
*(iframe - 1) = *iframe;
--iframe;
+ ++n;
}
info = RELOC_INFO (dframe->info, offset);
vect = RELOC_INFO (dframe->vect, offset);
diff --git a/libguile/strings.c b/libguile/strings.c
index 03ead8138..21295addf 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1379,7 +1379,7 @@ scm_is_string (SCM obj)
return IS_STRING (obj);
}
-static SCM
+SCM
scm_from_stringn (const char *str, size_t len, const char *encoding,
scm_t_string_failed_conversion_handler handler)
{
@@ -1388,6 +1388,9 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
int wide = 0;
SCM res;
+ if (len == 0)
+ return scm_nullstr;
+
if (encoding == NULL)
{
/* If encoding is null, use Latin-1. */
@@ -1575,7 +1578,7 @@ unistring_escapes_to_guile_escapes (char **bufp, size_t *lenp)
}
char *
-scm_to_locale_stringn (SCM str, size_t * lenp)
+scm_to_locale_stringn (SCM str, size_t *lenp)
{
SCM outport;
scm_t_port *pt;
@@ -1682,6 +1685,8 @@ scm_to_stringn (SCM str, size_t *lenp, const char *encoding,
scm_list_2 (scm_from_locale_string (enc),
str));
}
+ if (handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ unistring_escapes_to_guile_escapes (&buf, &len);
}
if (lenp)
*lenp = len;
diff --git a/libguile/strings.h b/libguile/strings.h
index 910d51ee6..4e5f70098 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -111,6 +111,10 @@ SCM_API SCM scm_substring_shared (SCM str, SCM start, SCM end);
SCM_API SCM scm_substring_copy (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_append (SCM args);
+SCM_API SCM scm_from_stringn (const char *str, size_t len,
+ const char *encoding,
+ scm_t_string_failed_conversion_handler
+ handler);
SCM_API SCM scm_c_make_string (size_t len, SCM chr);
SCM_API size_t scm_c_string_length (SCM str);
SCM_API size_t scm_c_symbol_length (SCM sym);
@@ -202,9 +206,9 @@ SCM_API SCM scm_sys_stringbuf_hist (void);
#if SCM_ENABLE_DEPRECATED
-SCM_API int scm_i_deprecated_stringp (SCM obj);
-SCM_API char *scm_i_deprecated_string_chars (SCM str);
-SCM_API size_t scm_i_deprecated_string_length (SCM str);
+SCM_DEPRECATED int scm_i_deprecated_stringp (SCM obj);
+SCM_DEPRECATED char *scm_i_deprecated_string_chars (SCM str);
+SCM_DEPRECATED size_t scm_i_deprecated_string_length (SCM str);
#define SCM_STRINGP(x) scm_i_deprecated_stringp(x)
#define SCM_STRING_CHARS(x) scm_i_deprecated_string_chars(x)
diff --git a/libguile/strports.c b/libguile/strports.c
index 490a15f8b..95e93c9ef 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -290,7 +290,7 @@ st_truncate (SCM port, scm_t_off length)
}
SCM
-scm_i_mkstrport (SCM pos, const char *locale_str, size_t str_len, long modes, const char *caller)
+scm_i_mkstrport (SCM pos, const char *utf8_str, size_t str_len, long modes, const char *caller)
{
SCM z, str;
scm_t_port *pt;
@@ -301,11 +301,11 @@ scm_i_mkstrport (SCM pos, const char *locale_str, size_t str_len, long modes, co
to a locale representation for storage. But, since string ports
rely on string functionality for their memory management, we need
to create a new string that has the 8-bit locale representation
- of the underlying string. This violates the guideline that the
- internal encoding of characters in strings is in unicode
- codepoints. */
+ of the underlying string.
+
+ locale_str is already in the locale of the port. */
str = scm_i_make_string (str_len, &buf);
- memcpy (buf, locale_str, str_len);
+ memcpy (buf, utf8_str, str_len);
c_pos = scm_to_unsigned_integer (pos, 0, str_len);
@@ -323,12 +323,14 @@ scm_i_mkstrport (SCM pos, const char *locale_str, size_t str_len, long modes, co
pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
pt->rw_random = 1;
-
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
/* ensure write_pos is writable. */
if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
st_flush (z);
+
+ scm_i_set_port_encoding_x (z, "UTF-8");
+ scm_i_set_conversion_strategy_x (z, SCM_FAILED_CONVERSION_ERROR);
return z;
}
@@ -348,13 +350,18 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
of the underlying string. This violates the guideline that the
internal encoding of characters in strings is in unicode
codepoints. */
- buf = scm_to_locale_stringn (str, &str_len);
+
+ /* String ports are are always initialized with "UTF-8" as their
+ encoding. */
+ buf = scm_to_stringn (str, &str_len, "UTF-8", SCM_FAILED_CONVERSION_ERROR);
z = scm_i_mkstrport (pos, buf, str_len, modes, caller);
free (buf);
return z;
}
-/* create a new string from a string port's buffer. */
+/* Create a new string from a string port's buffer, converting from
+ the port's 8-bit locale-specific representation to the standard
+ string representation. */
SCM scm_strport_to_string (SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -363,27 +370,20 @@ SCM scm_strport_to_string (SCM port)
if (pt->rw_active == SCM_PORT_WRITE)
st_flush (port);
- str = scm_from_locale_stringn ((char *)pt->read_buf, pt->read_buf_size);
- scm_remember_upto_here_1 (port);
- return str;
-}
-
-/* Create a vector containing the locale representation of the string in the
- port's buffer. */
-SCM scm_strport_to_locale_u8vector (SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- SCM vec;
- char *buf;
-
- if (pt->rw_active == SCM_PORT_WRITE)
- st_flush (port);
+ if (pt->read_buf_size == 0)
+ return scm_nullstr;
- buf = scm_malloc (pt->read_buf_size);
- memcpy (buf, pt->read_buf, pt->read_buf_size);
- vec = scm_take_u8vector ((unsigned char *) buf, pt->read_buf_size);
+ if (pt->encoding == NULL)
+ {
+ char *buf;
+ str = scm_i_make_string (pt->read_buf_size, &buf);
+ memcpy (buf, pt->read_buf, pt->read_buf_size);
+ }
+ else
+ str = scm_from_stringn ((char *)pt->read_buf, pt->read_buf_size,
+ pt->encoding, pt->ilseq_handler);
scm_remember_upto_here_1 (port);
- return vec;
+ return str;
}
SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
@@ -410,25 +410,6 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_call_with_output_locale_u8vector, "call-with-output-locale-u8vector", 1, 0, 0,
- (SCM proc),
- "Calls the one-argument procedure @var{proc} with a newly created output\n"
- "port. When the function returns, a vector containing the bytes of a\n"
- "locale representation of the characters written into the port is returned\n")
-#define FUNC_NAME s_scm_call_with_output_locale_u8vector
-{
- SCM p;
-
- p = scm_mkstrport (SCM_INUM0,
- scm_make_string (SCM_INUM0, SCM_UNDEFINED),
- SCM_OPN | SCM_WRTNG,
- FUNC_NAME);
- scm_call_1 (proc, p);
-
- return scm_get_output_locale_u8vector (p);
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0,
(SCM proc),
"Calls the one-argument procedure @var{proc} with a newly created output\n"
@@ -473,27 +454,6 @@ SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_open_input_locale_u8vector, "open-input-locale-u8vector", 1, 0, 0,
- (SCM vec),
- "Take a u8vector containing the bytes of a string encoded in the\n"
- "current locale and return an input port that delivers characters\n"
- "from the string. The port can be closed by\n"
- "@code{close-input-port}, though its storage will be reclaimed\n"
- "by the garbage collector if it becomes inaccessible.")
-#define FUNC_NAME s_scm_open_input_locale_u8vector
-{
- scm_t_array_handle hnd;
- ssize_t inc;
- size_t len;
- const scm_t_uint8 *buf;
-
- buf = scm_u8vector_elements (vec, &hnd, &len, &inc);
- SCM p = scm_i_mkstrport(SCM_INUM0, (const char *) buf, len, SCM_OPN | SCM_RDNG, FUNC_NAME);
- scm_array_handle_release (&hnd);
- return p;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0,
(void),
"Return an output port that will accumulate characters for\n"
@@ -526,19 +486,6 @@ SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_get_output_locale_u8vector, "get-output-locale-u8vector", 1, 0, 0,
- (SCM port),
- "Given an output port created by @code{open-output-string},\n"
- "return a u8 vector containing the characters of the string\n"
- "encoded in the current locale.")
-#define FUNC_NAME s_scm_get_output_locale_u8vector
-{
- SCM_VALIDATE_OPOUTSTRPORT (1, port);
- return scm_strport_to_locale_u8vector (port);
-}
-#undef FUNC_NAME
-
-
/* Given a null-terminated string EXPR containing a Scheme expression
read it, and return it as an SCM value. */
SCM
@@ -626,7 +573,6 @@ scm_make_stptob ()
{
scm_t_bits tc = scm_make_port_type ("string", stfill_buffer, st_write);
- scm_set_port_mark (tc, scm_markstream);
scm_set_port_end_input (tc, st_end_input);
scm_set_port_flush (tc, st_flush);
scm_set_port_seek (tc, st_seek);
diff --git a/libguile/strports.h b/libguile/strports.h
index b2ded01f1..d93266a12 100644
--- a/libguile/strports.h
+++ b/libguile/strports.h
@@ -47,16 +47,12 @@ SCM_API SCM scm_mkstrport (SCM pos, SCM str, long modes, const char * caller);
SCM_INTERNAL SCM scm_i_mkstrport (SCM pos, const char *locale_str, size_t str_len,
long modes, const char *caller);
SCM_API SCM scm_strport_to_string (SCM port);
-SCM_API SCM scm_strport_to_locale_u8vector (SCM port);
SCM_API SCM scm_object_to_string (SCM obj, SCM printer);
SCM_API SCM scm_call_with_output_string (SCM proc);
-SCM_API SCM scm_call_with_output_locale_u8vector (SCM proc);
SCM_API SCM scm_call_with_input_string (SCM str, SCM proc);
SCM_API SCM scm_open_input_string (SCM str);
-SCM_API SCM scm_open_input_locale_u8vector (SCM str);
SCM_API SCM scm_open_output_string (void);
SCM_API SCM scm_get_output_string (SCM port);
-SCM_API SCM scm_get_output_locale_u8vector (SCM port);
SCM_API SCM scm_c_read_string (const char *expr);
SCM_API SCM scm_c_eval_string (const char *expr);
SCM_API SCM scm_c_eval_string_in_module (const char *expr, SCM module);
diff --git a/libguile/struct.c b/libguile/struct.c
index b7e72a719..9dd900e37 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -41,7 +41,7 @@
#include <string.h>
#endif
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
@@ -795,7 +795,7 @@ SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
*/
unsigned long
-scm_struct_ihashq (SCM obj, unsigned long n)
+scm_struct_ihashq (SCM obj, unsigned long n, void *closure)
{
/* The length of the hash table should be a relative prime it's not
necessary to shift down the address. */
@@ -809,7 +809,7 @@ scm_struct_create_handle (SCM obj)
obj,
SCM_BOOL_F,
scm_struct_ihashq,
- scm_sloppy_assq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
0);
if (scm_is_false (SCM_CDR (handle)))
SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
diff --git a/libguile/struct.h b/libguile/struct.h
index 12069b487..a4626f3dd 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRUCT_H
#define SCM_STRUCT_H
-/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -96,7 +96,7 @@ SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
SCM_API SCM scm_struct_vtable_tag (SCM handle);
-SCM_API unsigned long scm_struct_ihashq (SCM obj, unsigned long n);
+SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
SCM_API SCM scm_struct_create_handle (SCM obj);
SCM_API SCM scm_struct_vtable_name (SCM vtable);
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
diff --git a/libguile/tags.h b/libguile/tags.h
index 146f2a59c..4a68f9c78 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -506,12 +506,54 @@ enum scm_tc8_tags
#define SCM_MAKIFLAG(n) SCM_MAKE_ITAG8 ((n), scm_tc8_flag)
#define SCM_IFLAGNUM(n) (SCM_ITAG8_DATA (n))
+/*
+ * IMPORTANT NOTE regarding IFLAG numbering!!!
+ *
+ * Several macros depend upon careful IFLAG numbering of SCM_BOOL_F,
+ * SCM_BOOL_T, SCM_ELISP_NIL, SCM_EOL, and the two SCM_XXX_*_DONT_USE
+ * constants. In particular:
+ *
+ * - SCM_BOOL_F and SCM_BOOL_T must differ in exactly one bit position.
+ * (used to implement scm_is_bool_and_not_nil, aka scm_is_bool)
+ *
+ * - SCM_ELISP_NIL and SCM_BOOL_F must differ in exactly one bit position.
+ * (used to implement scm_is_false_or_nil and
+ * scm_is_true_and_not_nil)
+ *
+ * - SCM_ELISP_NIL and SCM_EOL must differ in exactly one bit position.
+ * (used to implement scm_is_null_or_nil)
+ *
+ * - SCM_ELISP_NIL, SCM_BOOL_F, SCM_EOL, SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE
+ * must all be equal except for two bit positions.
+ * (used to implement scm_is_lisp_false)
+ *
+ * - SCM_ELISP_NIL, SCM_BOOL_F, SCM_BOOL_T, SCM_XXX_ANOTHER_BOOLEAN_DONT_USE
+ * must all be equal except for two bit positions.
+ * (used to implement scm_is_bool_or_nil)
+ *
+ * These properties allow the aforementioned macros to be implemented
+ * by bitwise ANDing with a mask and then comparing with a constant,
+ * using as a common basis the macro SCM_MATCHES_BITS_IN_COMMON,
+ * defined below. The properties are checked at compile-time using
+ * `verify' macros near the top of boolean.c and pairs.c.
+ */
#define SCM_BOOL_F SCM_MAKIFLAG (0)
-#define SCM_BOOL_T SCM_MAKIFLAG (1)
-#define SCM_UNDEFINED SCM_MAKIFLAG (2)
-#define SCM_EOF_VAL SCM_MAKIFLAG (3)
-#define SCM_EOL SCM_MAKIFLAG (4)
-#define SCM_UNSPECIFIED SCM_MAKIFLAG (5)
+#define SCM_ELISP_NIL SCM_MAKIFLAG (1)
+
+#ifdef BUILDING_LIBGUILE
+#define SCM_XXX_ANOTHER_LISP_FALSE_DONT_USE SCM_MAKIFLAG (2)
+#endif
+
+#define SCM_EOL SCM_MAKIFLAG (3)
+#define SCM_BOOL_T SCM_MAKIFLAG (4)
+
+#ifdef BUILDING_LIBGUILE
+#define SCM_XXX_ANOTHER_BOOLEAN_DONT_USE SCM_MAKIFLAG (5)
+#endif
+
+#define SCM_UNSPECIFIED SCM_MAKIFLAG (6)
+#define SCM_UNDEFINED SCM_MAKIFLAG (7)
+#define SCM_EOF_VAL SCM_MAKIFLAG (8)
/* When a variable is unbound this is marked by the SCM_UNDEFINED
* value. The following is an unbound value which can be handled on
@@ -521,19 +563,57 @@ enum scm_tc8_tags
* the code which handles this value in C so that SCM_UNDEFINED can be
* used instead. It is not ideal to let this kind of unique and
* strange values loose on the Scheme level. */
-#define SCM_UNBOUND SCM_MAKIFLAG (6)
-
-/* The Elisp nil value. */
-#define SCM_ELISP_NIL SCM_MAKIFLAG (7)
-
+#define SCM_UNBOUND SCM_MAKIFLAG (9)
#define SCM_UNBNDP(x) (scm_is_eq ((x), SCM_UNDEFINED))
+/*
+ * SCM_MATCHES_BITS_IN_COMMON(x,a,b) returns 1 if and only if x
+ * matches both a and b in every bit position where a and b are equal;
+ * otherwise it returns 0. Bit positions where a and b differ are
+ * ignored.
+ *
+ * This is used to efficiently compare against two values which differ
+ * in exactly one bit position, or against four values which differ in
+ * exactly two bit positions. It is the basis for the following
+ * macros:
+ *
+ * scm_is_null_or_nil,
+ * scm_is_false_or_nil,
+ * scm_is_true_and_not_nil,
+ * scm_is_lisp_false,
+ * scm_is_lisp_true,
+ * scm_is_bool_and_not_nil (aka scm_is_bool)
+ * scm_is_bool_or_nil.
+ */
+#define SCM_MATCHES_BITS_IN_COMMON(x,a,b) \
+ ((SCM_UNPACK(x) & ~(SCM_UNPACK(a) ^ SCM_UNPACK(b))) == \
+ (SCM_UNPACK(a) & SCM_UNPACK(b)))
+
+/*
+ * These macros are used for compile-time verification that the
+ * constants have the properties needed for the above macro to work
+ * properly.
+ */
+#ifdef BUILDING_LIBGUILE
+#define SCM_WITH_LEAST_SIGNIFICANT_1_BIT_CLEARED(x) ((x) & ((x)-1))
+#define SCM_HAS_EXACTLY_ONE_BIT_SET(x) \
+ ((x) != 0 && SCM_WITH_LEAST_SIGNIFICANT_1_BIT_CLEARED (x) == 0)
+#define SCM_HAS_EXACTLY_TWO_BITS_SET(x) \
+ (SCM_HAS_EXACTLY_ONE_BIT_SET (SCM_WITH_LEAST_SIGNIFICANT_1_BIT_CLEARED (x)))
+
+#define SCM_VALUES_DIFFER_IN_EXACTLY_ONE_BIT_POSITION(a,b) \
+ (SCM_HAS_EXACTLY_ONE_BIT_SET (SCM_UNPACK(a) ^ SCM_UNPACK(b)))
+#define SCM_VALUES_DIFFER_IN_EXACTLY_TWO_BIT_POSITIONS(a,b,c,d) \
+ (SCM_HAS_EXACTLY_TWO_BITS_SET ((SCM_UNPACK(a) ^ SCM_UNPACK(b)) | \
+ (SCM_UNPACK(b) ^ SCM_UNPACK(c)) | \
+ (SCM_UNPACK(c) ^ SCM_UNPACK(d))))
+#endif /* BUILDING_LIBGUILE */
/* Evaluator byte codes ('immediate symbols'). These constants are used only
* in eval but their values have to be allocated here. The indices of the
- * SCM_IM_ symbols must agree with the declarations in print.c:
+ * SCM_IM_ symbols must agree with the declarations in eval.c:
* scm_isymnames. */
#define SCM_ISYMP(n) (SCM_ITAG8 (n) == scm_tc8_isym)
@@ -559,12 +639,11 @@ enum scm_tc8_tags
#define SCM_IM_SLOT_REF SCM_MAKISYM (17)
#define SCM_IM_SLOT_SET_X SCM_MAKISYM (18)
#define SCM_IM_DELAY SCM_MAKISYM (19)
-#define SCM_IM_FUTURE SCM_MAKISYM (20)
-#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (21)
-#define SCM_IM_ELSE SCM_MAKISYM (22)
-#define SCM_IM_ARROW SCM_MAKISYM (23)
-#define SCM_IM_NIL_COND SCM_MAKISYM (24) /* Multi-language support */
-#define SCM_IM_BIND SCM_MAKISYM (25) /* Multi-language support */
+#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (20)
+#define SCM_IM_ELSE SCM_MAKISYM (21)
+#define SCM_IM_ARROW SCM_MAKISYM (22)
+#define SCM_IM_NIL_COND SCM_MAKISYM (23) /* Multi-language support */
+#define SCM_IM_BIND SCM_MAKISYM (24) /* Multi-language support */
diff --git a/libguile/threads.c b/libguile/threads.c
index f440bf59d..2ca4f15e9 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -22,7 +22,7 @@
# include <config.h>
#endif
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
#include "libguile/_scm.h"
#if HAVE_UNISTD_H
@@ -53,6 +53,7 @@
#include "libguile/init.h"
#include "libguile/scmsigs.h"
#include "libguile/strings.h"
+#include "libguile/weaks.h"
#ifdef __MINGW32__
#ifndef ETIMEDOUT
@@ -84,8 +85,14 @@ to_timespec (SCM t, scm_t_timespec *waittime)
}
}
+
/*** Queues */
+/* Note: We annotate with "GC-robust" assignments whose purpose is to avoid
+ the risk of false references leading to unbounded retained space as
+ described in "Bounding Space Usage of Conservative Garbage Collectors",
+ H.J. Boehm, 2001. */
+
/* Make an empty queue data structure.
*/
static SCM
@@ -128,6 +135,10 @@ remqueue (SCM q, SCM c)
if (scm_is_eq (c, SCM_CAR (q)))
SCM_SETCAR (q, SCM_CDR (c));
SCM_SETCDR (prev, SCM_CDR (c));
+
+ /* GC-robust */
+ SCM_SETCDR (c, SCM_EOL);
+
SCM_CRITICAL_SECTION_END;
return 1;
}
@@ -157,6 +168,10 @@ dequeue (SCM q)
if (scm_is_null (SCM_CDR (q)))
SCM_SETCAR (q, SCM_EOL);
SCM_CRITICAL_SECTION_END;
+
+ /* GC-robust */
+ SCM_SETCDR (c, SCM_EOL);
+
return SCM_CAR (c);
}
}
@@ -199,15 +214,7 @@ thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
return 1;
}
-static size_t
-thread_free (SCM obj)
-{
- scm_i_thread *t = SCM_I_THREAD_DATA (obj);
- assert (t->exited);
- scm_gc_free (t, sizeof (*t), "thread");
- return 0;
-}
-
+
/*** Blocking on queues. */
/* See also scm_i_queue_async_cell for how such a block is
@@ -279,141 +286,31 @@ unblock_from_queue (SCM queue)
return thread;
}
+
/* Getting into and out of guile mode.
*/
-/* Ken Raeburn observes that the implementation of suspend and resume
- (and the things that build on top of them) are very likely not
- correct (see below). We will need fix this eventually, and that's
- why scm_leave_guile/scm_enter_guile are not exported in the API.
-
- Ken writes:
-
- Consider this sequence:
-
- Function foo, called in Guile mode, calls suspend (maybe indirectly
- through scm_leave_guile), which does this:
-
- // record top of stack for the GC
- t->top = SCM_STACK_PTR (&t); // just takes address of automatic
- var 't'
- // save registers.
- SCM_FLUSH_REGISTER_WINDOWS; // sparc only
- SCM_I_SETJMP (t->regs); // here's most of the magic
-
- ... and returns.
-
- Function foo has a SCM value X, a handle on a non-immediate object, in
- a caller-saved register R, and it's the only reference to the object
- currently.
-
- The compiler wants to use R in suspend, so it pushes the current
- value, X, into a stack slot which will be reloaded on exit from
- suspend; then it loads stuff into R and goes about its business. The
- setjmp call saves (some of) the current registers, including R, which
- no longer contains X. (This isn't a problem for a normal
- setjmp/longjmp situation, where longjmp would be called before
- setjmp's caller returns; the old value for X would be loaded back from
- the stack after the longjmp, before the function returned.)
-
- So, suspend returns, loading X back into R (and invalidating the jump
- buffer) in the process. The caller foo then goes off and calls a
- bunch of other functions out of Guile mode, occasionally storing X on
- the stack again, but, say, much deeper on the stack than suspend's
- stack frame went, and the stack slot where suspend had written X has
- long since been overwritten with other values.
-
- Okay, nothing actively broken so far. Now, let garbage collection
- run, triggered by another thread.
-
- The thread calling foo is out of Guile mode at the time, so the
- garbage collector just scans a range of stack addresses. Too bad that
- X isn't stored there. So the pointed-to storage goes onto the free
- list, and I think you can see where things go from there.
-
- Is there anything I'm missing that'll prevent this scenario from
- happening? I mean, aside from, "well, suspend and scm_leave_guile
- don't have many local variables, so they probably won't need to save
- any registers on most systems, so we hope everything will wind up in
- the jump buffer and we'll just get away with it"?
-
- (And, going the other direction, if scm_leave_guile and suspend push
- the stack pointer over onto a new page, and foo doesn't make further
- function calls and thus the stack pointer no longer includes that
- page, are we guaranteed that the kernel cannot release the now-unused
- stack page that contains the top-of-stack pointer we just saved? I
- don't know if any OS actually does that. If it does, we could get
- faults in garbage collection.)
-
- I don't think scm_without_guile has to have this problem, as it gets
- more control over the stack handling -- but it should call setjmp
- itself. I'd probably try something like:
-
- // record top of stack for the GC
- t->top = SCM_STACK_PTR (&t);
- // save registers.
- SCM_FLUSH_REGISTER_WINDOWS;
- SCM_I_SETJMP (t->regs);
- res = func(data);
- scm_enter_guile (t);
-
- ... though even that's making some assumptions about the stack
- ordering of local variables versus caller-saved registers.
-
- For something like scm_leave_guile to work, I don't think it can just
- rely on invalidated jump buffers. A valid jump buffer, and a handle
- on the stack state at the point when the jump buffer was initialized,
- together, would work fine, but I think then we're talking about macros
- invoking setjmp in the caller's stack frame, and requiring that the
- caller of scm_leave_guile also call scm_enter_guile before returning,
- kind of like pthread_cleanup_push/pop calls that have to be paired up
- in a function. (In fact, the pthread ones have to be paired up
- syntactically, as if they might expand to a compound statement
- incorporating the user's code, and invoking a compiler's
- exception-handling primitives. Which might be something to think
- about for cases where Guile is used with C++ exceptions or
- pthread_cancel.)
-*/
+#ifdef SCM_HAVE_THREAD_STORAGE_CLASS
-scm_i_pthread_key_t scm_i_thread_key;
+/* When thread-local storage (TLS) is available, a pointer to the
+ current-thread object is kept in TLS. Note that storing the thread-object
+ itself in TLS (rather than a pointer to some malloc'd memory) is not
+ possible since thread objects may live longer than the actual thread they
+ represent. */
+SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread = NULL;
-static void
-resume (scm_i_thread *t)
-{
- t->top = NULL;
-}
+# define SET_CURRENT_THREAD(_t) scm_i_current_thread = (_t)
-typedef void* scm_t_guile_ticket;
+#else /* !SCM_HAVE_THREAD_STORAGE_CLASS */
-static void
-scm_enter_guile (scm_t_guile_ticket ticket)
-{
- scm_i_thread *t = (scm_i_thread *)ticket;
- if (t)
- {
- resume (t);
- }
-}
+/* Key used to retrieve the current thread with `pthread_getspecific ()'. */
+scm_i_pthread_key_t scm_i_thread_key;
-static scm_i_thread *
-suspend (void)
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
+# define SET_CURRENT_THREAD(_t) \
+ scm_i_pthread_setspecific (scm_i_thread_key, (_t))
- /* record top of stack for the GC */
- t->top = SCM_STACK_PTR (&t);
- /* save registers. */
- SCM_FLUSH_REGISTER_WINDOWS;
- SCM_I_SETJMP (t->regs);
- return t;
-}
+#endif /* !SCM_HAVE_THREAD_STORAGE_CLASS */
-static scm_t_guile_ticket
-scm_leave_guile ()
-{
- scm_i_thread *t = suspend ();
- return (scm_t_guile_ticket) t;
-}
static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
static scm_i_thread *all_threads = NULL;
@@ -440,6 +337,7 @@ guilify_self_1 (SCM_STACKITEM *base)
t->active_asyncs = SCM_EOL;
t->block_asyncs = 1;
t->pending_asyncs = 1;
+ t->critical_section_level = 0;
t->last_debug_frame = NULL;
t->base = base;
#ifdef __ia64__
@@ -478,7 +376,7 @@ guilify_self_1 (SCM_STACKITEM *base)
t->exited = 0;
t->guile_mode = 0;
- scm_i_pthread_setspecific (scm_i_thread_key, t);
+ SET_CURRENT_THREAD (t);
scm_i_pthread_mutex_lock (&thread_admin_mutex);
t->next_thread = all_threads;
@@ -563,14 +461,18 @@ do_thread_exit (void *v)
while (!scm_is_null (t->mutexes))
{
- SCM mutex = SCM_CAR (t->mutexes);
- fat_mutex *m = SCM_MUTEX_DATA (mutex);
- scm_i_pthread_mutex_lock (&m->lock);
+ SCM mutex = SCM_WEAK_PAIR_CAR (t->mutexes);
- unblock_from_queue (m->waiting);
+ if (!SCM_UNBNDP (mutex))
+ {
+ fat_mutex *m = SCM_MUTEX_DATA (mutex);
- scm_i_pthread_mutex_unlock (&m->lock);
- t->mutexes = SCM_CDR (t->mutexes);
+ scm_i_pthread_mutex_lock (&m->lock);
+ unblock_from_queue (m->waiting);
+ scm_i_pthread_mutex_unlock (&m->lock);
+ }
+
+ t->mutexes = SCM_WEAK_PAIR_CDR (t->mutexes);
}
scm_i_pthread_mutex_unlock (&t->admin_mutex);
@@ -592,7 +494,7 @@ on_thread_exit (void *v)
t->held_mutex = NULL;
}
- scm_i_pthread_setspecific (scm_i_thread_key, v);
+ SET_CURRENT_THREAD (v);
/* Ensure the signal handling thread has been launched, because we might be
shutting it down. */
@@ -614,6 +516,10 @@ on_thread_exit (void *v)
if (*tp == t)
{
*tp = t->next_thread;
+
+ /* GC-robust */
+ t->next_thread = NULL;
+
break;
}
thread_count--;
@@ -627,9 +533,11 @@ on_thread_exit (void *v)
scm_i_pthread_mutex_unlock (&thread_admin_mutex);
- scm_i_pthread_setspecific (scm_i_thread_key, NULL);
+ SET_CURRENT_THREAD (NULL);
}
+#ifndef SCM_HAVE_THREAD_STORAGE_CLASS
+
static scm_i_pthread_once_t init_thread_key_once = SCM_I_PTHREAD_ONCE_INIT;
static void
@@ -638,6 +546,8 @@ init_thread_key (void)
scm_i_pthread_key_create (&scm_i_thread_key, NULL);
}
+#endif
+
/* Perform any initializations necessary to bring the current thread
into guile mode, initializing Guile itself, if necessary.
@@ -655,9 +565,12 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
{
scm_i_thread *t;
+#ifndef SCM_HAVE_THREAD_STORAGE_CLASS
scm_i_pthread_once (&init_thread_key_once, init_thread_key);
+#endif
- if ((t = SCM_I_CURRENT_THREAD) == NULL)
+ t = SCM_I_CURRENT_THREAD;
+ if (t == NULL)
{
/* This thread has not been guilified yet.
*/
@@ -699,7 +612,7 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
t->base = base;
#endif
- scm_enter_guile ((scm_t_guile_ticket) t);
+ t->top = NULL;
return 1;
}
else
@@ -806,7 +719,6 @@ scm_with_guile (void *(*func)(void *), void *data)
SCM_UNUSED static void
scm_leave_guile_cleanup (void *x)
{
- scm_leave_guile ();
on_thread_exit (SCM_I_CURRENT_THREAD);
}
@@ -823,7 +735,6 @@ scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent)
scm_i_pthread_cleanup_push (scm_leave_guile_cleanup, NULL);
res = scm_c_with_continuation_barrier (func, data);
scm_i_pthread_cleanup_pop (0);
- scm_leave_guile ();
}
else
res = scm_c_with_continuation_barrier (func, data);
@@ -834,14 +745,18 @@ scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent)
/*** Non-guile mode. */
-#if (defined HAVE_GC_DO_BLOCKING) && (!defined HAVE_DECL_GC_DO_BLOCKING)
+#ifdef HAVE_GC_DO_BLOCKING
-/* This declaration is missing from the public headers of GC 7.1. */
-extern void GC_do_blocking (void (*) (void *), void *);
+# ifndef HAVE_GC_FN_TYPE
+/* This typedef is missing from the public headers of GC 7.1 and earlier. */
+typedef void * (* GC_fn_type) (void *);
+# endif /* HAVE_GC_FN_TYPE */
-#endif
+# ifndef HAVE_DECL_GC_DO_BLOCKING
+/* This declaration is missing from the public headers of GC 7.1. */
+extern void GC_do_blocking (GC_fn_type, void *);
+# endif /* HAVE_DECL_GC_DO_BLOCKING */
-#ifdef HAVE_GC_DO_BLOCKING
struct without_guile_arg
{
void * (*function) (void *);
@@ -861,7 +776,9 @@ without_guile_trampoline (void *closure)
SCM_I_CURRENT_THREAD->guile_mode = 1;
}
-#endif
+
+#endif /* HAVE_GC_DO_BLOCKING */
+
void *
scm_without_guile (void *(*func)(void *), void *data)
@@ -875,7 +792,7 @@ scm_without_guile (void *(*func)(void *), void *data)
arg.function = func;
arg.data = data;
- GC_do_blocking (without_guile_trampoline, &arg);
+ GC_do_blocking ((GC_fn_type) without_guile_trampoline, &arg);
result = arg.result;
}
else
@@ -1215,7 +1132,6 @@ fat_mutex_free (SCM mx)
{
fat_mutex *m = SCM_MUTEX_DATA (mx);
scm_i_pthread_mutex_destroy (&m->lock);
- scm_gc_free (m, sizeof (fat_mutex), "mutex");
return 0;
}
@@ -1318,7 +1234,14 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret)
{
scm_i_thread *t = SCM_I_THREAD_DATA (new_owner);
scm_i_pthread_mutex_lock (&t->admin_mutex);
- t->mutexes = scm_cons (mutex, t->mutexes);
+
+ /* Only keep a weak reference to MUTEX so that it's not
+ retained when not referenced elsewhere (bug #27450). Note
+ that the weak pair itself it still retained, but it's better
+ than retaining MUTEX and the threads referred to by its
+ associated queue. */
+ t->mutexes = scm_weak_car_pair (mutex, t->mutexes);
+
scm_i_pthread_mutex_unlock (&t->admin_mutex);
}
*ret = 1;
@@ -1621,14 +1544,6 @@ SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0,
}
#undef FUNC_NAME
-static size_t
-fat_cond_free (SCM mx)
-{
- fat_cond *c = SCM_CONDVAR_DATA (mx);
- scm_gc_free (c, sizeof (fat_cond), "condition-variable");
- return 0;
-}
-
static int
fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
@@ -1727,26 +1642,6 @@ SCM_DEFINE (scm_condition_variable_p, "condition-variable?", 1, 0, 0,
}
#undef FUNC_NAME
-/*** Marking stacks */
-
-/* XXX - what to do with this? Do we need to handle this for blocked
- threads as well?
-*/
-#ifdef __ia64__
-# define SCM_MARK_BACKING_STORE() do { \
- ucontext_t ctx; \
- SCM_STACKITEM * top, * bot; \
- getcontext (&ctx); \
- scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
- ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
- / sizeof (SCM_STACKITEM))); \
- bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
- top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
- scm_mark_locations (bot, top - bot); } while (0)
-#else
-# define SCM_MARK_BACKING_STORE()
-#endif
-
/*** Select */
@@ -1870,11 +1765,13 @@ scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t *mutex)
int
scm_pthread_cond_wait (scm_i_pthread_cond_t *cond, scm_i_pthread_mutex_t *mutex)
{
- scm_t_guile_ticket t = scm_leave_guile ();
- ((scm_i_thread *)t)->held_mutex = mutex;
- int res = scm_i_pthread_cond_wait (cond, mutex);
- ((scm_i_thread *)t)->held_mutex = NULL;
- scm_enter_guile (t);
+ int res;
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ t->held_mutex = mutex;
+ res = scm_i_pthread_cond_wait (cond, mutex);
+ t->held_mutex = NULL;
+
return res;
}
@@ -1883,11 +1780,13 @@ scm_pthread_cond_timedwait (scm_i_pthread_cond_t *cond,
scm_i_pthread_mutex_t *mutex,
const scm_t_timespec *wt)
{
- scm_t_guile_ticket t = scm_leave_guile ();
- ((scm_i_thread *)t)->held_mutex = mutex;
- int res = scm_i_pthread_cond_timedwait (cond, mutex, wt);
- ((scm_i_thread *)t)->held_mutex = NULL;
- scm_enter_guile (t);
+ int res;
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ t->held_mutex = mutex;
+ res = scm_i_pthread_cond_timedwait (cond, mutex, wt);
+ t->held_mutex = NULL;
+
return res;
}
@@ -1989,7 +1888,6 @@ static int threads_initialized_p = 0;
/* This mutex is used by SCM_CRITICAL_SECTION_START/END.
*/
scm_i_pthread_mutex_t scm_i_critical_section_mutex;
-int scm_i_critical_section_level = 0;
static SCM dynwind_critical_section_mutex;
@@ -2036,7 +1934,6 @@ scm_init_threads ()
{
scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_i_thread));
scm_set_smob_print (scm_tc16_thread, thread_print);
- scm_set_smob_free (scm_tc16_thread, thread_free); /* XXX: Could be removed */
scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (fat_mutex));
scm_set_smob_print (scm_tc16_mutex, fat_mutex_print);
@@ -2045,7 +1942,6 @@ scm_init_threads ()
scm_tc16_condvar = scm_make_smob_type ("condition-variable",
sizeof (fat_cond));
scm_set_smob_print (scm_tc16_condvar, fat_cond_print);
- scm_set_smob_free (scm_tc16_condvar, fat_cond_free);
scm_i_default_dynamic_state = SCM_BOOL_F;
guilify_self_2 (SCM_BOOL_F);
diff --git a/libguile/threads.h b/libguile/threads.h
index 55102df17..5afe45faa 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -3,7 +3,7 @@
#ifndef SCM_THREADS_H
#define SCM_THREADS_H
-/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -117,6 +117,9 @@ typedef struct scm_i_thread {
scm_t_contregs *pending_rbs_continuation;
#endif
+ /* Whether this thread is in a critical section. */
+ int critical_section_level;
+
} scm_i_thread;
#define SCM_I_IS_THREAD(x) SCM_SMOB_PREDICATE (scm_tc16_thread, x)
@@ -189,15 +192,29 @@ SCM_API SCM scm_thread_exited_p (SCM thread);
SCM_API void scm_dynwind_critical_section (SCM mutex);
-#define SCM_I_CURRENT_THREAD \
- ((scm_i_thread *) scm_i_pthread_getspecific (scm_i_thread_key))
-SCM_API scm_i_pthread_key_t scm_i_thread_key;
+#ifdef BUILDING_LIBGUILE
+
+# ifdef SCM_HAVE_THREAD_STORAGE_CLASS
+
+SCM_INTERNAL SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread;
+# define SCM_I_CURRENT_THREAD (scm_i_current_thread)
+
+# else /* !SCM_HAVE_THREAD_STORAGE_CLASS */
+
+SCM_INTERNAL scm_i_pthread_key_t scm_i_thread_key;
+# define SCM_I_CURRENT_THREAD \
+ ((scm_i_thread *) scm_i_pthread_getspecific (scm_i_thread_key))
+
+# endif /* !SCM_HAVE_THREAD_STORAGE_CLASS */
+
+# define scm_i_dynwinds() (SCM_I_CURRENT_THREAD->dynwinds)
+# define scm_i_set_dynwinds(w) (SCM_I_CURRENT_THREAD->dynwinds = (w))
+# define scm_i_last_debug_frame() (SCM_I_CURRENT_THREAD->last_debug_frame)
+# define scm_i_set_last_debug_frame(f) \
+ (SCM_I_CURRENT_THREAD->last_debug_frame = (f))
+
+#endif /* BUILDING_LIBGUILE */
-#define scm_i_dynwinds() (SCM_I_CURRENT_THREAD->dynwinds)
-#define scm_i_set_dynwinds(w) (SCM_I_CURRENT_THREAD->dynwinds = (w))
-#define scm_i_last_debug_frame() (SCM_I_CURRENT_THREAD->last_debug_frame)
-#define scm_i_set_last_debug_frame(f) \
- (SCM_I_CURRENT_THREAD->last_debug_frame = (f))
SCM_INTERNAL scm_i_pthread_mutex_t scm_i_misc_mutex;
diff --git a/libguile/throw.c b/libguile/throw.c
index cf6ea4a49..07d215f41 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -732,7 +732,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
SCM dynpair = SCM_UNDEFINED;
SCM winds;
- if (scm_i_critical_section_level)
+ if (SCM_I_CURRENT_THREAD->critical_section_level)
{
SCM s = args;
int i = 0;
diff --git a/libguile/unidata_to_charset.pl b/libguile/unidata_to_charset.pl
index 6871e67ee..d086c8ec4 100755
--- a/libguile/unidata_to_charset.pl
+++ b/libguile/unidata_to_charset.pl
@@ -254,10 +254,14 @@ sub empty {
return 0;
}
-# Full -- All characters.
-sub full {
+# Designated -- All characters except for the surrogates
+sub designated {
my($codepoint, $name, $category, $uppercase, $lowercase)= @_;
- return 1;
+ if ($category =~ (/Cs/)) {
+ return 0;
+ } else {
+ return 1;
+ }
}
@@ -362,7 +366,7 @@ sub compute {
# Write a bit of a header
print $out "/* srfi-14.i.c -- standard SRFI-14 character set data */\n\n";
print $out "/* This file is #include'd by srfi-14.c. */\n\n";
-print $out "/* This file was generated from\n"
+print $out "/* This file was generated from\n";
print $out " http://unicode.org/Public/UNIDATA/UnicodeData.txt\n";
print $out " with the unidata_to_charset.pl script. */\n\n";
@@ -383,7 +387,7 @@ compute "symbol";
compute "blank";
compute "ascii";
compute "empty";
-compute "full";
+compute "designated";
close $in;
close $out;
diff --git a/libguile/uniform.c b/libguile/uniform.c
index 28125da8b..6bab85675 100644
--- a/libguile/uniform.c
+++ b/libguile/uniform.c
@@ -44,13 +44,24 @@ const size_t scm_i_array_element_type_sizes[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = {
64, 128
};
-/* FIXME: return bit size instead of byte size? */
size_t
scm_array_handle_uniform_element_size (scm_t_array_handle *h)
{
size_t ret = scm_i_array_element_type_sizes[h->element_type];
if (ret && ret % 8 == 0)
return ret / 8;
+ else if (ret)
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "byte-aligned uniform array");
+ else
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
+}
+
+size_t
+scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h)
+{
+ size_t ret = scm_i_array_element_type_sizes[h->element_type];
+ if (ret)
+ return ret;
else
scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}
@@ -110,14 +121,15 @@ SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
SCM_DEFINE (scm_uniform_vector_element_type, "uniform-vector-element-type", 1, 0, 0,
(SCM v),
- "Return the number of elements in the uniform vector, @var{v}.")
+ "Return the type of the elements in the uniform vector, @var{v}.")
#define FUNC_NAME s_scm_uniform_vector_element_type
{
scm_t_array_handle h;
- size_t len;
- ssize_t inc;
SCM ret;
- scm_uniform_vector_elements (v, &h, &len, &inc);
+
+ if (!scm_is_uniform_vector (v))
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, v, "uniform vector");
+ scm_array_get_handle (v, &h);
ret = scm_array_handle_element_type (&h);
scm_array_handle_release (&h);
return ret;
@@ -144,15 +156,9 @@ SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1, 0
SCM
scm_c_uniform_vector_ref (SCM v, size_t idx)
{
- SCM ret;
- scm_t_array_handle h;
- size_t len;
- ssize_t inc;
-
- scm_uniform_vector_elements (v, &h, &len, &inc);
- ret = scm_array_handle_ref (&h, idx*inc);
- scm_array_handle_release (&h);
- return ret;
+ if (!scm_is_uniform_vector (v))
+ scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
+ return scm_c_generalized_vector_ref (v, idx);
}
SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
@@ -168,13 +174,9 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
void
scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
{
- scm_t_array_handle h;
- size_t len;
- ssize_t inc;
-
- scm_uniform_vector_elements (v, &h, &len, &inc);
- scm_array_handle_set (&h, idx*inc, val);
- scm_array_handle_release (&h);
+ if (!scm_is_uniform_vector (v))
+ scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
+ scm_c_generalized_vector_set_x (v, idx, val);
}
SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
@@ -193,15 +195,9 @@ SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
"Convert the uniform numeric vector @var{uvec} to a list.")
#define FUNC_NAME s_scm_uniform_vector_to_list
{
- SCM ret;
- scm_t_array_handle h;
- size_t len;
- ssize_t inc;
-
- scm_uniform_vector_elements (uvec, &h, &len, &inc);
- ret = scm_generalized_vector_to_list (uvec);
- scm_array_handle_release (&h);
- return ret;
+ if (!scm_is_uniform_vector (uvec))
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector");
+ return scm_generalized_vector_to_list (uvec);
}
#undef FUNC_NAME
diff --git a/libguile/uniform.h b/libguile/uniform.h
index b1f396594..f0d5915f6 100644
--- a/libguile/uniform.h
+++ b/libguile/uniform.h
@@ -36,8 +36,10 @@ SCM_INTERNAL const size_t scm_i_array_element_type_sizes[];
#define SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED(t) \
(scm_i_array_element_type_sizes[(t)] != 0)
-/* returns type size in bits */
+/* type size in bytes */
SCM_API size_t scm_array_handle_uniform_element_size (scm_t_array_handle *h);
+/* type size in bits */
+SCM_API size_t scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h);
SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h);
SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h);
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 5e710505a..b1b5890f4 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -41,7 +41,7 @@
#include "libguile/dynwind.h"
#include "libguile/deprecation.h"
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index b373cd017..5d8f65587 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -51,7 +51,6 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
size_t free_vars_count = 0; /* length of FREE_VARS */
SCM *objects = NULL; /* constant objects */
size_t object_count = 0; /* length of OBJECTS */
- SCM *stack_base = vp->stack_base; /* stack base address */
SCM *stack_limit = vp->stack_limit; /* stack limit address */
/* Internal variables */
@@ -108,16 +107,16 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
/* Initial frame */
CACHE_REGISTER ();
PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* ra */
PUSH (0); /* mvra */
+ PUSH ((SCM)ip); /* ra */
CACHE_PROGRAM ();
PUSH (program);
fp = sp + 1;
- INIT_FRAME ();
+ ip = bp->base;
/* MV-call frame, function & arguments */
PUSH ((SCM)fp); /* dynamic link */
- PUSH (0); /* ra */
PUSH (0); /* mvra */
+ PUSH (0); /* ra */
PUSH (prog);
if (SCM_UNLIKELY (sp + nargs >= stack_limit))
goto vm_error_too_many_args;
@@ -171,6 +170,21 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
finish_args = SCM_EOL;
goto vm_error;
+ vm_error_kwargs_length_not_even:
+ err_msg = scm_from_locale_string ("Bad keyword argument list: odd length");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_kwargs_invalid_keyword:
+ err_msg = scm_from_locale_string ("Bad keyword argument list: expected keyword");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_kwargs_unrecognized_keyword:
+ err_msg = scm_from_locale_string ("Bad keyword argument list: unrecognized keyword");
+ finish_args = SCM_EOL;
+ goto vm_error;
+
vm_error_too_many_args:
err_msg = scm_from_locale_string ("VM: Too many arguments");
finish_args = scm_list_1 (scm_from_int (nargs));
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 3c1bbf681..d69328944 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -107,7 +107,6 @@
ip = vp->ip; \
sp = vp->sp; \
fp = vp->fp; \
- stack_base = fp ? SCM_FRAME_UPPER_ADDRESS (fp) - 1 : vp->stack_base; \
}
#define SYNC_REGISTER() \
@@ -256,7 +255,7 @@
goto vm_error_stack_overflow
#define CHECK_UNDERFLOW() \
- if (sp < stack_base) \
+ if (sp < SCM_FRAME_UPPER_ADDRESS (fp)) \
goto vm_error_stack_underflow;
#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
@@ -336,7 +335,6 @@ do { \
#define FETCH() (*ip++)
#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
-#define FETCH_WIDTH(width) do { width=*ip++; } while (0)
#undef CLOCK
#if VM_USE_CLOCK
@@ -361,46 +359,9 @@ do { \
}
-/*
- * Stack frame
- */
-
-#define INIT_ARGS() \
-{ \
- if (SCM_UNLIKELY (bp->nrest)) \
- { \
- int n = nargs - (bp->nargs - 1); \
- if (n < 0) \
- goto vm_error_wrong_num_args; \
- /* NB, can cause GC while setting up the \
- stack frame */ \
- POP_LIST (n); \
- } \
- else \
- { \
- if (SCM_UNLIKELY (nargs != bp->nargs)) \
- goto vm_error_wrong_num_args; \
- } \
-}
-
/* See frames.h for the layout of stack frames */
/* When this is called, bp points to the new program data,
and the arguments are already on the stack */
-#define INIT_FRAME() \
-{ \
- int i; \
- \
- /* New registers */ \
- sp += bp->nlocs; \
- CHECK_OVERFLOW (); \
- stack_base = sp; \
- ip = bp->base; \
- \
- /* Init local variables */ \
- for (i=bp->nlocs; i;) \
- sp[-(--i)] = SCM_UNDEFINED; \
-}
-
#define DROP_FRAME() \
{ \
sp -= 3; \
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 0cace147d..ff963d64c 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -32,13 +32,13 @@
VM_DEFINE_FUNCTION (100, not, "not", 1)
{
ARGS1 (x);
- RETURN (SCM_BOOL (SCM_FALSEP (x)));
+ RETURN (SCM_BOOL (scm_is_false_or_nil (x)));
}
VM_DEFINE_FUNCTION (101, not_not, "not-not", 1)
{
ARGS1 (x);
- RETURN (SCM_BOOL (!SCM_FALSEP (x)));
+ RETURN (SCM_BOOL (!scm_is_false_or_nil (x)));
}
VM_DEFINE_FUNCTION (102, eq, "eq?", 2)
@@ -56,13 +56,13 @@ VM_DEFINE_FUNCTION (103, not_eq, "not-eq?", 2)
VM_DEFINE_FUNCTION (104, nullp, "null?", 1)
{
ARGS1 (x);
- RETURN (SCM_BOOL (SCM_NULLP (x)));
+ RETURN (SCM_BOOL (scm_is_null_or_nil (x)));
}
VM_DEFINE_FUNCTION (105, not_nullp, "not-null?", 1)
{
ARGS1 (x);
- RETURN (SCM_BOOL (!SCM_NULLP (x)));
+ RETURN (SCM_BOOL (!scm_is_null_or_nil (x)));
}
VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2)
@@ -433,10 +433,17 @@ BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
VM_DEFINE_FUNCTION (142, bv_s16_native_ref, "bv-s16-native-ref", 2)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
VM_DEFINE_FUNCTION (143, bv_u32_native_ref, "bv-u32-native-ref", 2)
-/* FIXME: u32 is always a fixnum on 64-bit builds */
+#if SIZEOF_VOID_P > 4
+BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
+#else
BV_INT_REF (u32, uint32, 4)
+#endif
VM_DEFINE_FUNCTION (144, bv_s32_native_ref, "bv-s32-native-ref", 2)
+#if SIZEOF_VOID_P > 4
+BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
+#else
BV_INT_REF (s32, int32, 4)
+#endif
VM_DEFINE_FUNCTION (145, bv_u64_native_ref, "bv-u64-native-ref", 2)
BV_INT_REF (u64, uint64, 8)
VM_DEFINE_FUNCTION (146, bv_s64_native_ref, "bv-s64-native-ref", 2)
@@ -541,10 +548,17 @@ BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
VM_DEFINE_INSTRUCTION (160, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
VM_DEFINE_INSTRUCTION (161, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
-/* FIXME: u32 is always a fixnum on 64-bit builds */
+#if SIZEOF_VOID_P > 4
+BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
+#else
BV_INT_SET (u32, uint32, 4)
+#endif
VM_DEFINE_INSTRUCTION (162, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
+#if SIZEOF_VOID_P > 4
+BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
+#else
BV_INT_SET (s32, int32, 4)
+#endif
VM_DEFINE_INSTRUCTION (163, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
BV_INT_SET (u64, uint64, 8)
VM_DEFINE_INSTRUCTION (164, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 0662f8188..f58ffce58 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -46,14 +46,18 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
}
{
- ASSERT (sp == stack_base);
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
+#ifdef VM_ENABLE_STACK_NULLING
+ SCM *old_sp = sp;
+#endif
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = NULL;
+ /* Setting the ip here doesn't actually affect control flow, as the calling
+ code will restore its own registers, but it does help when walking the
+ stack */
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- NULLSTACK (stack_base - sp);
+ NULLSTACK (old_sp - sp);
}
goto vm_done;
@@ -273,7 +277,28 @@ VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (23, variable_ref, "variable-ref", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
+{
+ if (LOCAL_REF (FETCH ()) == SCM_UNDEFINED)
+ PUSH (SCM_BOOL_F);
+ else
+ PUSH (SCM_BOOL_T);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
+{
+ unsigned int i = FETCH ();
+ i <<= 8;
+ i += FETCH ();
+ if (LOCAL_REF (i) == SCM_UNDEFINED)
+ PUSH (SCM_BOOL_F);
+ else
+ PUSH (SCM_BOOL_T);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 0, 1)
{
SCM x = *sp;
@@ -292,7 +317,16 @@ VM_DEFINE_INSTRUCTION (23, variable_ref, "variable-ref", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (24, toplevel_ref, "toplevel-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 0, 1)
+{
+ if (VARIABLE_BOUNDP (*sp))
+ *sp = SCM_BOOL_T;
+ else
+ *sp = SCM_BOOL_F;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM what;
@@ -315,7 +349,7 @@ VM_DEFINE_INSTRUCTION (24, toplevel_ref, "toplevel-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (25, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -342,14 +376,14 @@ VM_DEFINE_INSTRUCTION (25, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
/* set */
-VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0)
{
LOCAL_SET (FETCH (), *sp);
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (27, long_local_set, "long-local-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -359,14 +393,14 @@ VM_DEFINE_INSTRUCTION (27, long_local_set, "long-local-set", 2, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 1, 0)
{
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
}
-VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM what;
@@ -385,7 +419,7 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (30, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -411,63 +445,64 @@ VM_DEFINE_INSTRUCTION (30, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
* branch and jump
*/
-/* offset must be a signed 16 bit int!!! */
+/* offset must be at least 24 bits wide, and signed */
#define FETCH_OFFSET(offset) \
{ \
- int h = FETCH (); \
- int l = FETCH (); \
- offset = (h << 8) + l; \
+ offset = FETCH () << 16; \
+ offset += FETCH () << 8; \
+ offset += FETCH (); \
+ offset -= (offset & (1<<23)) << 1; \
}
#define BR(p) \
{ \
- scm_t_int16 offset; \
+ scm_t_int32 offset; \
FETCH_OFFSET (offset); \
if (p) \
- ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); \
+ ip += offset; \
NULLSTACK (1); \
DROP (); \
NEXT; \
}
-VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
{
- scm_t_int16 offset;
+ scm_t_int32 offset;
FETCH_OFFSET (offset);
- ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8);
+ ip += offset;
NEXT;
}
-VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0)
{
- BR (!SCM_FALSEP (*sp));
+ BR (scm_is_true_and_not_nil (*sp));
}
-VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
{
- BR (SCM_FALSEP (*sp));
+ BR (scm_is_false_or_nil (*sp));
}
-VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
{
sp--; /* underflow? */
BR (SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
{
sp--; /* underflow? */
BR (!SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
{
- BR (SCM_NULLP (*sp));
+ BR (scm_is_null_or_nil (*sp));
}
-VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
{
- BR (!SCM_NULLP (*sp));
+ BR (!scm_is_null_or_nil (*sp));
}
@@ -475,15 +510,218 @@ VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
* Subprogram call
*/
-VM_DEFINE_INSTRUCTION (38, new_frame, "new-frame", 0, 0, 3)
+VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0)
{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ scm_t_int32 offset;
+ FETCH_OFFSET (offset);
+ if (sp - (fp - 1) != n)
+ ip += offset;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ scm_t_int32 offset;
+ FETCH_OFFSET (offset);
+ if (sp - (fp - 1) < n)
+ ip += offset;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ scm_t_int32 offset;
+ FETCH_OFFSET (offset);
+ if (sp - (fp - 1) > n)
+ ip += offset;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ if (sp - (fp - 1) != n)
+ goto vm_error_wrong_num_args;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ if (sp - (fp - 1) < n)
+ goto vm_error_wrong_num_args;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1)
+{
+ scm_t_ptrdiff n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ while (sp - (fp - 1) < n)
+ PUSH (SCM_UNDEFINED);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1)
+{
+ SCM *walk;
+ scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
+ nreq = FETCH () << 8;
+ nreq += FETCH ();
+ nreq_and_opt = FETCH () << 8;
+ nreq_and_opt += FETCH ();
+ ntotal = FETCH () << 8;
+ ntotal += FETCH ();
+
+ /* look in optionals for first keyword or last positional */
+ /* starting after the last required positional arg */
+ walk = fp + nreq;
+ while (/* while we have args */
+ walk <= sp
+ /* and we still have positionals to fill */
+ && walk - fp < nreq_and_opt
+ /* and we haven't reached a keyword yet */
+ && !scm_is_keyword (*walk))
+ /* bind this optional arg (by leaving it in place) */
+ walk++;
+ /* now shuffle up, from walk to ntotal */
+ {
+ scm_t_ptrdiff nshuf = sp - walk + 1, i;
+ sp = (fp - 1) + ntotal + nshuf;
+ CHECK_OVERFLOW ();
+ for (i = 0; i < nshuf; i++)
+ sp[-i] = walk[nshuf-i-1];
+ }
+ /* and fill optionals & keyword args with SCM_UNDEFINED */
+ while (walk <= (fp - 1) + ntotal)
+ *walk++ = SCM_UNDEFINED;
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0)
+{
+ scm_t_uint16 idx;
+ scm_t_ptrdiff nkw;
+ int allow_other_keys_and_rest;
+ SCM kw;
+ idx = FETCH () << 8;
+ idx += FETCH ();
+ nkw = FETCH () << 8;
+ nkw += FETCH ();
+ allow_other_keys_and_rest = FETCH ();
+
+ if (!(allow_other_keys_and_rest & 2)
+ &&(sp - (fp - 1) - nkw) % 2)
+ goto vm_error_kwargs_length_not_even;
+
+ CHECK_OBJECT (idx);
+ kw = OBJECT_REF (idx);
+ /* switch nkw to be a negative index below sp */
+ for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw += 2)
+ {
+ SCM walk;
+ if (!scm_is_keyword (sp[nkw]))
+ {
+ if (allow_other_keys_and_rest & 2)
+ /* reached the end of keywords, but we have a rest arg; just cut
+ out */
+ break;
+ else
+ goto vm_error_kwargs_invalid_keyword;
+ }
+ for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
+ {
+ if (scm_is_eq (SCM_CAAR (walk), sp[nkw]))
+ {
+ SCM si = SCM_CDAR (walk);
+ LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si),
+ sp[nkw + 1]);
+ break;
+ }
+ }
+ if (!(allow_other_keys_and_rest & 1) && !scm_is_pair (walk))
+ goto vm_error_kwargs_unrecognized_keyword;
+ }
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1)
+{
+ scm_t_ptrdiff n;
+ SCM rest = SCM_EOL;
+ n = FETCH () << 8;
+ n += FETCH ();
+ while (sp - (fp - 1) > n)
+ /* No need to check for underflow. */
+ CONS (rest, *sp--, rest);
+ PUSH (rest);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1)
+{
+ scm_t_ptrdiff n;
+ scm_t_uint32 i;
+ SCM rest = SCM_EOL;
+ n = FETCH () << 8;
+ n += FETCH ();
+ i = FETCH () << 8;
+ i += FETCH ();
+ while (sp - (fp - 1) > n)
+ /* No need to check for underflow. */
+ CONS (rest, *sp--, rest);
+ LOCAL_SET (i, rest);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1)
+{
+ SCM *old_sp;
+ scm_t_int32 n;
+ n = FETCH () << 8;
+ n += FETCH ();
+ old_sp = sp;
+ sp = (fp - 1) + n;
+
+ if (old_sp < sp)
+ {
+ CHECK_OVERFLOW ();
+ while (old_sp < sp)
+ *++old_sp = SCM_UNDEFINED;
+ }
+ else
+ NULLSTACK (old_sp - sp);
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3)
+{
+ /* NB: if you change this, see frames.c:vm-frame-num-locals */
+ /* and frames.h, vm-engine.c, etc of course */
PUSH ((SCM)fp); /* dynamic link */
PUSH (0); /* mvra */
PUSH (0); /* ra */
NEXT;
}
-VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
@@ -501,13 +739,12 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
{
program = x;
CACHE_PROGRAM ();
- INIT_ARGS ();
- fp = sp - bp->nargs + 1;
+ fp = sp - nargs + 1;
ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
- INIT_FRAME ();
+ ip = bp->base;
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
@@ -545,7 +782,7 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
@@ -562,7 +799,8 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
{
int i;
#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp;
+ SCM *old_sp = sp;
+ CHECK_STACK_LEAK ();
#endif
EXIT_HOOK ();
@@ -570,22 +808,15 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
/* switch programs */
program = x;
CACHE_PROGRAM ();
- INIT_ARGS ();
-
-#ifdef VM_ENABLE_STACK_NULLING
- old_sp = sp;
- CHECK_STACK_LEAK ();
-#endif
+ /* shuffle down the program and the arguments */
+ for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
+ SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
- /* delay shuffling the new program+args down so that if INIT_ARGS had to
- cons up a rest arg, going into GC, the stack still made sense */
- for (i = -1, sp = sp - bp->nargs + 1; i < bp->nargs; i++)
- fp[i] = sp[i];
sp = fp + i - 1;
NULLSTACK (old_sp - sp);
- INIT_FRAME ();
+ ip = bp->base;
ENTER_HOOK ();
APPLY_HOOK ();
@@ -624,7 +855,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (55, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -633,7 +864,7 @@ VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (56, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -642,15 +873,15 @@ VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1)
{
SCM x;
- scm_t_int16 offset;
+ scm_t_int32 offset;
scm_t_uint8 *mvra;
nargs = FETCH ();
FETCH_OFFSET (offset);
- mvra = ip + ((scm_t_ptrdiff)offset) * 8 - ((unsigned long)ip) % 8;
+ mvra = ip + offset;
x = sp[-nargs];
@@ -661,13 +892,12 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
{
program = x;
CACHE_PROGRAM ();
- INIT_ARGS ();
- fp = sp - bp->nargs + 1;
+ fp = sp - nargs + 1;
ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
- INIT_FRAME ();
+ ip = bp->base;
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
@@ -705,7 +935,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (58, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -724,7 +954,7 @@ VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (59, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -743,7 +973,7 @@ VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (60, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -780,7 +1010,7 @@ VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (61, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -812,7 +1042,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (62, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
@@ -823,20 +1053,19 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
SCM ret;
POP (ret);
- ASSERT (sp == stack_base);
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
+
+#ifdef VM_ENABLE_STACK_NULLING
+ SCM *old_sp = sp;
+#endif
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp);
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
- {
+
#ifdef VM_ENABLE_STACK_NULLING
- int nullcount = stack_base - sp;
+ NULLSTACK (old_sp - sp);
#endif
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
- NULLSTACK (nullcount);
- }
/* Set return value (sp is already pushed) */
*sp = ret;
@@ -849,7 +1078,7 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (63, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say. */
@@ -858,11 +1087,10 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
EXIT_HOOK ();
RETURN_HOOK ();
- ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
-
- /* data[1] is the mv return address */
if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
{
+ /* A multiply-valued continuation */
+ SCM *vals = sp - nvalues;
int i;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
@@ -871,12 +1099,11 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
- *++sp = stack_base[1+i];
+ *++sp = vals[i+1];
*++sp = SCM_I_MAKINUM (nvalues);
- /* Finally set new stack_base */
- NULLSTACK (stack_base - sp + nvalues + 1);
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ /* Finally null the end of the stack */
+ NULLSTACK (vals + nvalues - sp);
}
else if (nvalues >= 1)
{
@@ -884,17 +1111,17 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
break with guile tradition and try and do something sensible. (Also,
this block handles the single-valued return to an mv
continuation.) */
+ SCM *vals = sp - nvalues;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
ip = SCM_FRAME_RETURN_ADDRESS (fp);
fp = SCM_FRAME_DYNAMIC_LINK (fp);
/* Push first value */
- *++sp = stack_base[1];
+ *++sp = vals[1];
- /* Finally set new stack_base */
- NULLSTACK (stack_base - sp + nvalues + 1);
- stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+ /* Finally null the end of the stack */
+ NULLSTACK (vals + nvalues - sp);
}
else
goto vm_error_no_values;
@@ -906,7 +1133,7 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (64, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -929,7 +1156,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (65, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -952,7 +1179,7 @@ VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (52, box, "box", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (66, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@@ -966,7 +1193,7 @@ VM_DEFINE_INSTRUCTION (52, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
-VM_DEFINE_INSTRUCTION (53, empty_box, "empty-box", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (67, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@@ -974,7 +1201,7 @@ VM_DEFINE_INSTRUCTION (53, empty_box, "empty-box", 1, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (54, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (68, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@@ -982,7 +1209,7 @@ VM_DEFINE_INSTRUCTION (54, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (55, local_boxed_set, "local-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (69, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@@ -992,7 +1219,7 @@ VM_DEFINE_INSTRUCTION (55, local_boxed_set, "local-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (56, free_ref, "free-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (70, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@@ -1003,7 +1230,7 @@ VM_DEFINE_INSTRUCTION (56, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
-VM_DEFINE_INSTRUCTION (57, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (71, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@@ -1014,7 +1241,7 @@ VM_DEFINE_INSTRUCTION (57, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (58, free_boxed_set, "free-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (72, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@@ -1026,7 +1253,7 @@ VM_DEFINE_INSTRUCTION (58, free_boxed_set, "free-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure", 0, 2, 1)
+VM_DEFINE_INSTRUCTION (73, make_closure, "make-closure", 0, 2, 1)
{
SCM vect;
POP (vect);
@@ -1037,7 +1264,7 @@ VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure", 0, 2, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (60, make_variable, "make-variable", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (74, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@@ -1045,7 +1272,7 @@ VM_DEFINE_INSTRUCTION (60, make_variable, "make-variable", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (61, fix_closure, "fix-closure", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (75, fix_closure, "fix-closure", 2, 0, 1)
{
SCM x, vect;
unsigned int i = FETCH ();
@@ -1059,7 +1286,7 @@ VM_DEFINE_INSTRUCTION (61, fix_closure, "fix-closure", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (62, define, "define", 0, 0, 2)
+VM_DEFINE_INSTRUCTION (76, define, "define", 0, 0, 2)
{
SCM sym, val;
POP (sym);
@@ -1071,7 +1298,7 @@ VM_DEFINE_INSTRUCTION (62, define, "define", 0, 0, 2)
NEXT;
}
-VM_DEFINE_INSTRUCTION (63, make_keyword, "make-keyword", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (77, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@@ -1079,7 +1306,7 @@ VM_DEFINE_INSTRUCTION (63, make_keyword, "make-keyword", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (64, make_symbol, "make-symbol", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (78, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
diff --git a/libguile/vm.c b/libguile/vm.c
index 95aaa4fe4..df02f0595 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -25,7 +25,7 @@
#include <string.h>
#include <assert.h>
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>
#include "_scm.h"
@@ -180,9 +180,8 @@ static SCM
really_make_boot_program (long nargs)
{
SCM u8vec;
- scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
- scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop,
- scm_op_halt };
+ scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
+ scm_op_make_int8_1, scm_op_halt };
struct scm_objcode *bp;
SCM ret;
@@ -192,18 +191,14 @@ really_make_boot_program (long nargs)
bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
memcpy (bp->base, text, sizeof (text));
- bp->nargs = 0;
- bp->nrest = 0;
- bp->nlocs = 0;
bp->len = sizeof(text);
bp->metalen = 0;
- bp->unused = 0;
u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
sizeof (struct scm_objcode) + sizeof (text));
ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
SCM_BOOL_F, SCM_BOOL_F);
- SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
+ SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
return ret;
}
@@ -357,7 +352,8 @@ vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
corresponding VM. */
vm = * ((struct scm_vm **) addr);
- if ((SCM *) addr != vm->stack_base - 1
+ if (vm == NULL
+ || (SCM *) addr != vm->stack_base - 1
|| vm->stack_limit - vm->stack_base != vm->stack_size)
/* ADDR must be a pointer to a free-list element, which we must ignore
(see warning in <gc/gc_mark.h>). */
diff --git a/libguile/vports.c b/libguile/vports.c
index cea11c61d..4fab2df18 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 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
@@ -92,19 +92,26 @@ sf_fill_input (SCM port)
{
SCM p = SCM_PACK (SCM_STREAM (port));
SCM ans;
+ scm_t_port *pt;
ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */
if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
return EOF;
SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
- {
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- *pt->read_buf = SCM_CHAR (ans);
- pt->read_pos = pt->read_buf;
- pt->read_end = pt->read_buf + 1;
- return *pt->read_buf;
- }
+ pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->encoding == NULL)
+ {
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ *pt->read_buf = SCM_CHAR (ans);
+ pt->read_pos = pt->read_buf;
+ pt->read_end = pt->read_buf + 1;
+ return *pt->read_buf;
+ }
+ else
+ scm_ungetc (SCM_CHAR (ans), port);
+ return SCM_CHAR (ans);
}
@@ -213,7 +220,6 @@ scm_make_sfptob ()
{
scm_t_bits tc = scm_make_port_type ("soft", sf_fill_input, sf_write);
- scm_set_port_mark (tc, scm_markstream);
scm_set_port_flush (tc, sf_flush);
scm_set_port_close (tc, sf_close);
scm_set_port_input_waiting (tc, sf_input_waiting);
diff --git a/libguile/weaks.c b/libguile/weaks.c
index 4719980a7..913166ffd 100644
--- a/libguile/weaks.c
+++ b/libguile/weaks.c
@@ -32,7 +32,7 @@
#include "libguile/validate.h"
#include "libguile/weaks.h"
-#include "libguile/boehm-gc.h"
+#include "libguile/bdw-gc.h"
#include <gc/gc_typed.h>
diff --git a/libguile/weaks.h b/libguile/weaks.h
index 908e27628..eecc6184e 100644
--- a/libguile/weaks.h
+++ b/libguile/weaks.h
@@ -3,7 +3,7 @@
#ifndef SCM_WEAKS_H
#define SCM_WEAKS_H
-/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -55,9 +55,9 @@
/* Weak pairs. */
-SCM_API SCM scm_weak_car_pair (SCM car, SCM cdr);
-SCM_API SCM scm_weak_cdr_pair (SCM car, SCM cdr);
-SCM_API SCM scm_doubly_weak_pair (SCM car, SCM cdr);
+SCM_INTERNAL SCM scm_weak_car_pair (SCM car, SCM cdr);
+SCM_INTERNAL SCM scm_weak_cdr_pair (SCM car, SCM cdr);
+SCM_INTERNAL SCM scm_doubly_weak_pair (SCM car, SCM cdr);
/* Testing the weak component(s) of a cell for reachability. */
#define SCM_WEAK_PAIR_WORD_DELETED_P(_cell, _word) \
@@ -71,10 +71,12 @@ SCM_API SCM scm_doubly_weak_pair (SCM car, SCM cdr);
((SCM_WEAK_PAIR_CAR_DELETED_P (_cell)) \
|| (SCM_WEAK_PAIR_CDR_DELETED_P (_cell)))
-/* Accessing the components of a weak cell. */
+/* Accessing the components of a weak cell. These return `SCM_UNDEFINED' if
+ the car/cdr has been collected. */
#define SCM_WEAK_PAIR_WORD(_cell, _word) \
- ((SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), (_word))) \
- ? SCM_BOOL_F : SCM_CAR (pair))
+ (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), (_word)) \
+ ? SCM_UNDEFINED \
+ : SCM_CELL_OBJECT ((_cell), (_word)))
#define SCM_WEAK_PAIR_CAR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 0))
#define SCM_WEAK_PAIR_CDR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 1))
diff --git a/libguile/win32-socket.c b/libguile/win32-socket.c
index e845d886a..825b4c499 100644
--- a/libguile/win32-socket.c
+++ b/libguile/win32-socket.c
@@ -435,7 +435,7 @@ scm_i_socket_uncomment (char *line)
while (end > line && (*end == '\r' || *end == '\n'))
*end-- = '\0';
}
- while (end > line && isspace (*end))
+ while (end > line && isspace ((int) (*end)))
*end-- = '\0';
return end;
diff --git a/meta/Makefile.am b/meta/Makefile.am
index 34e7f2cf3..dbcf9da7a 100644
--- a/meta/Makefile.am
+++ b/meta/Makefile.am
@@ -21,10 +21,10 @@
## Fifth Floor, Boston, MA 02110-1301 USA
bin_SCRIPTS = guile-config guile-tools
-EXTRA_DIST= $(bin_SCRIPTS) \
+EXTRA_DIST= \
guile.m4 ChangeLog-2008 \
guile-2.0.pc.in guile-2.0-uninstalled.pc.in \
- guile-tools.in
+ guile-tools.in guile-config.in
pkgconfigdir = $(libdir)/pkgconfig
pkgconfig_DATA = guile-2.0.pc
@@ -33,3 +33,15 @@ pkgconfig_DATA = guile-2.0.pc
## doing this. When that happens, switch over.
aclocaldir = $(datadir)/aclocal
aclocal_DATA = guile.m4
+
+guile-config: $(srcdir)/guile-config.in
+ guile="@bindir@/`echo guile | $(SED) -e '$(program_transform_name)'`" ; \
+ cat $(srcdir)/guile-config.in \
+ | $(SED) -e "s,@pkgconfigdir@,$(pkgconfigdir),g ; \
+ s,@""PKG_CONFIG@,$(PKG_CONFIG),g ; \
+ s,@installed_guile@,$$guile,g" \
+ > guile-config.out
+ mv guile-config.out guile-config
+ chmod +x guile-config
+
+CLEANFILES = guile-config
diff --git a/meta/gdb-uninstalled-guile.in b/meta/gdb-uninstalled-guile.in
index d55e215cb..389bcc9b2 100644
--- a/meta/gdb-uninstalled-guile.in
+++ b/meta/gdb-uninstalled-guile.in
@@ -36,5 +36,8 @@ set -e
top_builddir="@top_builddir_absolute@"
XDG_CACHE_HOME=${top_builddir}/cache
export XDG_CACHE_HOME
-exec ${top_builddir}/meta/uninstalled-env libtool --mode=execute \
+exec ${top_builddir}/meta/uninstalled-env ${top_builddir}/libtool --mode=execute \
gdb --args ${top_builddir}/libguile/guile "$@"
+
+# And for GDB in Emacs, evaluate this form:
+# (gdb "@top_builddir_absolute@/meta/uninstalled-env ../libtool --mode=execute gdb --annotate=3 --args @top_builddir_absolute@/libguile/guile")
diff --git a/meta/guile-2.0.pc.in b/meta/guile-2.0.pc.in
index 5cacaaa3e..c73a171f4 100644
--- a/meta/guile-2.0.pc.in
+++ b/meta/guile-2.0.pc.in
@@ -7,6 +7,7 @@ datadir=@datadir@
pkgdatadir=@datadir@/guile
sitedir=@sitedir@
+extensionsdir=@libdir@/guile/@GUILE_EFFECTIVE_VERSION@/extensions
libguileinterface=@LIBGUILE_INTERFACE@
Name: GNU Guile
diff --git a/meta/guile-config b/meta/guile-config.in
index 6c640c40c..0226f685e 100755
--- a/meta/guile-config
+++ b/meta/guile-config.in
@@ -1,5 +1,9 @@
#!/bin/sh
-exec guile -e main -s $0 "$@"
+PKG_CONFIG_PATH="@pkgconfigdir@:$PKG_CONFIG_PATH"
+GUILE_AUTO_COMPILE=0
+export PKG_CONFIG_PATH GUILE_AUTO_COMPILE
+
+exec "@installed_guile@" -e main -s $0 "$@"
!#
;;;; guile-config --- utility for linking programs with Guile
;;;; Jim Blandy <jim@red-bean.com> --- September 1997
@@ -27,6 +31,8 @@ exec guile -e main -s $0 "$@"
(ice-9 rdelim))
+(define %pkg-config-program "@PKG_CONFIG@")
+
;;;; main function, command-line processing
;;; The script's entry point.
@@ -74,7 +80,7 @@ exec guile -e main -s $0 "$@"
(define guile-module "guile-2.0")
(define (pkg-config . args)
- (let* ((real-args (cons "pkg-config" args))
+ (let* ((real-args (cons %pkg-config-program args))
(pipe (apply open-pipe* OPEN_READ real-args))
(output (read-delimited "" pipe))
(ret (close-pipe pipe)))
@@ -82,7 +88,7 @@ exec guile -e main -s $0 "$@"
((0) (if (eof-object? output) "" output))
(else (display-line-error
(format #f "error: ~s exited with non-zero error code ~A"
- (cons "pkg-config" args) (status:exit-val ret)))
+ (cons %pkg-config-program args) (status:exit-val ret)))
;; assume pkg-config sent diagnostics to stdout
(exit (status:exit-val ret))))))
diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in
index 9a6227230..58d50ca1b 100644
--- a/meta/uninstalled-env.in
+++ b/meta/uninstalled-env.in
@@ -88,6 +88,10 @@ export GUILE_LOAD_COMPILED_PATH
if ( env | grep -v -q -E '^GUILE_SYSTEM_COMPILED_PATH=' ); then
export GUILE_SYSTEM_COMPILED_PATH=
fi
+# Don't look in installed dirs for dlopen-able modules
+if ( env | grep -v -q -E '^GUILE_SYSTEM_EXTENSIONS_PATH=' ); then
+ export GUILE_SYSTEM_EXTENSIONS_PATH=
+fi
# handle LTDL_LIBRARY_PATH (no clobber)
ltdl_prefix=""
diff --git a/module/Makefile.am b/module/Makefile.am
index 668b8a597..d205e0f19 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -51,7 +51,6 @@ SOURCES = \
$(OOP_SOURCES) \
$(SYSTEM_SOURCES) \
$(SCRIPTS_SOURCES) \
- $(GHIL_LANG_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
$(BRAINFUCK_LANG_SOURCES)
@@ -69,11 +68,9 @@ ice-9/psyntax-pp.scm: ice-9/psyntax.scm
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
SCHEME_LANG_SOURCES = \
- language/scheme/compile-ghil.scm \
language/scheme/spec.scm \
language/scheme/compile-tree-il.scm \
- language/scheme/decompile-tree-il.scm \
- language/scheme/inline.scm
+ language/scheme/decompile-tree-il.scm
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
@@ -84,9 +81,6 @@ TREE_IL_LANG_SOURCES = \
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 \
language/glil/decompile-assembly.scm
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 21e3506cd..585247747 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,4 +1,4 @@
-;;; installed-scm-file
+;;; -*- mode: scheme; coding: utf-8; -*-
;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
;;;; Free Software Foundation, Inc.
@@ -899,39 +899,39 @@
(set! %load-hook %load-announce)
-;;; Returns the .go file corresponding to `name'. Does not search load
-;;; paths, only the fallback path. If the .go file is missing or out of
-;;; date, and autocompilation is enabled, will try autocompilation, just
-;;; as primitive-load-path does internally. primitive-load is
-;;; unaffected. Returns #f if autocompilation failed or was disabled.
-(define (autocompiled-file-name name)
- (catch #t
- (lambda ()
- (let* ((cfn ((@ (system base compile) compiled-file-name) name))
- (scmstat (stat name))
- (gostat (stat cfn #f)))
- (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
- cfn
- (begin
- (if gostat
- (format (current-error-port)
- ";;; note: source file ~a\n;;; newer than compiled ~a\n"
- name cfn))
- (cond
- (%load-should-autocompile
- (%warn-autocompilation-enabled)
- (format (current-error-port) ";;; compiling ~a\n" name)
- (let ((cfn ((@ (system base compile) compile-file) name)))
- (format (current-error-port) ";;; compiled ~a\n" cfn)
- cfn))
- (else #f))))))
- (lambda (k . args)
- (format (current-error-port)
- ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
- name k args)
- #f)))
-
(define (load name . reader)
+ ;; Returns the .go file corresponding to `name'. Does not search load
+ ;; paths, only the fallback path. If the .go file is missing or out of
+ ;; date, and autocompilation is enabled, will try autocompilation, just
+ ;; as primitive-load-path does internally. primitive-load is
+ ;; unaffected. Returns #f if autocompilation failed or was disabled.
+ (define (autocompiled-file-name name)
+ (catch #t
+ (lambda ()
+ (let* ((cfn ((@ (system base compile) compiled-file-name) name))
+ (scmstat (stat name))
+ (gostat (stat cfn #f)))
+ (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
+ cfn
+ (begin
+ (if gostat
+ (format (current-error-port)
+ ";;; note: source file ~a\n;;; newer than compiled ~a\n"
+ name cfn))
+ (cond
+ (%load-should-autocompile
+ (%warn-autocompilation-enabled)
+ (format (current-error-port) ";;; compiling ~a\n" name)
+ (let ((cfn ((@ (system base compile) compile-file) name
+ #:env (current-module))))
+ (format (current-error-port) ";;; compiled ~a\n" cfn)
+ cfn))
+ (else #f))))))
+ (lambda (k . args)
+ (format (current-error-port)
+ ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
+ name k args)
+ #f)))
(with-fluid* current-reader (and (pair? reader) (car reader))
(lambda ()
(let ((cfn (autocompiled-file-name name)))
@@ -1422,6 +1422,7 @@
;; XXX: The following line introduces a circular reference that
;; precludes garbage collection of modules with the current weak hash
;; table semantics (see
+ ;; http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and
;; http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
;; for details). Since it doesn't appear to be used (only in
;; `scm_lookup_closure_module ()', which has 1 caller), we just comment
@@ -2007,6 +2008,11 @@
;; Import the default set of bindings (from the SCM module) in MODULE.
(module-use! module the-scm-module)))
+(define (make-fresh-user-module)
+ (let ((m (make-module)))
+ (beautify-user-module! m)
+ m))
+
;; NOTE: This binding is used in libguile/modules.c.
;;
(define resolve-module
@@ -2624,8 +2630,6 @@ module '(ice-9 q) '(make-q q-length))}."
(apply make-stack #t save-stack primitive-eval #t 0 narrowing))
((load-stack)
(apply make-stack #t save-stack 0 #t 0 narrowing))
- ((tk-stack)
- (apply make-stack #t save-stack tk-stack-mark #t 0 narrowing))
((#t)
(apply make-stack #t save-stack 0 1 narrowing))
(else
@@ -2704,11 +2708,14 @@ module '(ice-9 q) '(make-q q-length))}."
;;; The default repl-reader function. We may override this if we've
;;; the readline library.
(define repl-reader
- (lambda (prompt)
+ (lambda (prompt . reader)
(display (if (string? prompt) prompt (prompt)))
(force-output)
(run-hook before-read-hook)
- ((or (fluid-ref current-reader) read) (current-input-port))))
+ ((or (and (pair? reader) (car reader))
+ (fluid-ref current-reader)
+ read)
+ (current-input-port))))
(define (scm-style-repl)
@@ -2810,15 +2817,7 @@ module '(ice-9 q) '(make-q q-length))}."
(display ";;; QUIT executed, repl exitting")
(newline)
(repl-report)))
- args))
-
- (-abort (lambda ()
- (if scm-repl-verbose
- (begin
- (display ";;; ABORT executed.")
- (newline)
- (repl-report)))
- (repl -read -eval -print))))
+ args)))
(let ((status (error-catching-repl -read
-eval
@@ -3034,6 +3033,13 @@ module '(ice-9 q) '(make-q q-length))}."
(defmacro name args . body)
(export-syntax name)))))
+;; And now for the most important macro.
+(define-syntax λ
+ (syntax-rules ()
+ ((_ formals body ...)
+ (lambda formals body ...))))
+
+
;; Export a local variable
;; This function is called from "modules.c". If you change it, be
@@ -3250,6 +3256,7 @@ module '(ice-9 q) '(make-q q-length))}."
(define %cond-expand-features
;; Adjust the above comment when changing this.
'(guile
+ guile-2
r5rs
srfi-0 ;; cond-expand itself
srfi-4 ;; homogenous numeric vectors
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index c8d762143..c55e13b28 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -185,3 +185,20 @@
`(begin *unspecified* . ,exps)))
(else
`(begin))))
+
+(read-hash-extend
+ #\y
+ (lambda (c port)
+ (issue-deprecation-warning
+ "The `#y' bitvector syntax is deprecated. Use `#*' instead.")
+ (let ((x (read port)))
+ (cond
+ ((list? x)
+ (list->bitvector
+ (map (lambda (x)
+ (cond ((zero? x) #f)
+ ((eqv? x 1) #t)
+ (else (error "invalid #y element" x))))
+ x)))
+ (else
+ (error "#y needs to be followed by a list" x))))))
diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm
index dd14e6754..e63ec7421 100644
--- a/module/ice-9/i18n.scm
+++ b/module/ice-9/i18n.scm
@@ -1,22 +1,22 @@
;;;; i18n.scm --- internationalization support
-;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 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 <ludovic.courtes@laas.fr>
+;;; Author: Ludovic Courtès <ludo@gnu.org>
;;; Commentary:
;;;
@@ -84,7 +84,7 @@
(eval-when (eval load compile)
- (load-extension "libguile-i18n-v-0" "scm_init_i18n"))
+ (load-extension "libguile" "scm_init_i18n"))
;;;
diff --git a/module/ice-9/optargs.scm b/module/ice-9/optargs.scm
index 3093e15a4..138cf6028 100644
--- a/module/ice-9/optargs.scm
+++ b/module/ice-9/optargs.scm
@@ -1,6 +1,6 @@
;;;; optargs.scm -- support for optional arguments
;;;;
-;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -58,14 +58,15 @@
;;; Code:
(define-module (ice-9 optargs)
- :export-syntax (let-optional
- let-optional*
- let-keywords
- let-keywords*
- define* lambda*
- define*-public
- defmacro*
- defmacro*-public))
+ #:use-module (system base pmatch)
+ #:re-export (lambda* define*)
+ #:export (let-optional
+ let-optional*
+ let-keywords
+ let-keywords*
+ define*-public
+ defmacro*
+ defmacro*-public))
;; let-optional rest-arg (binding ...) . body
;; let-optional* rest-arg (binding ...) . body
@@ -83,12 +84,52 @@
;; bound to whatever may have been left of rest-arg.
;;
-(defmacro let-optional (REST-ARG BINDINGS . BODY)
- (let-optional-template REST-ARG BINDINGS BODY 'let))
-
-(defmacro let-optional* (REST-ARG BINDINGS . BODY)
- (let-optional-template REST-ARG BINDINGS BODY 'let*))
-
+(define (vars&inits bindings)
+ (let lp ((bindings bindings) (vars '()) (inits '()))
+ (syntax-case bindings ()
+ (()
+ (values (reverse vars) (reverse inits)))
+ (((v init) . rest) (identifier? #'v)
+ (lp #'rest (cons #'v vars) (cons #'init inits)))
+ ((v . rest) (identifier? #'v)
+ (lp #'rest (cons #'v vars) (cons #'#f inits))))))
+
+(define-syntax let-optional
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (n+1 (1+ (length vars)))
+ (vars (append vars (list #'rest-arg)))
+ ((t ...) (generate-temporaries vars))
+ ((i ...) inits))
+ #'(let ((t (lambda vars i))
+ ...)
+ (apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 n n n+1 #f '())
+ (list t ...)
+ #f
+ rest-arg)
+ (error "sth" rest-arg)))))))))))
+
+(define-syntax let-optional*
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (n+1 (1+ (length vars)))
+ (vars (append vars (list #'rest-arg)))
+ ((i ...) inits))
+ #'(apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 n n n+1 #f '())
+ (list (lambda vars i) ...)
+ #f
+ rest-arg)
+ (error "sth" rest-arg))))))))))
;; let-keywords rest-arg allow-other-keys? (binding ...) . body
@@ -106,82 +147,52 @@
;;
-(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
- (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))
-
-(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
- (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))
-
-
-;; some utility procedures for implementing the various let-forms.
-
-(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
- (let ((bindings (map (lambda (x)
- (if (list? x)
- x
- (list x #f)))
- BINDINGS)))
- `(,let-type ,(map proc bindings) ,@BODY)))
-
-(define (let-optional-template REST-ARG BINDINGS BODY let-type)
- (if (null? BINDINGS)
- `(let () ,@BODY)
- (let-o-k-template REST-ARG BINDINGS BODY let-type
- (lambda (optional)
- `(,(car optional)
- (cond
- ((not (null? ,REST-ARG))
- (let ((result (car ,REST-ARG)))
- ,(list 'set! REST-ARG
- `(cdr ,REST-ARG))
- result))
- (else
- ,(cadr optional))))))))
-
-(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type)
- (if (null? BINDINGS)
- `(let () ,@BODY)
- (let* ((kb-list-gensym (gensym "kb:G"))
- (bindfilter (lambda (key)
- `(,(car key)
- (cond
- ((assq ',(car key) ,kb-list-gensym)
- => cdr)
- (else
- ,(cadr key)))))))
- `(let ((,kb-list-gensym ((@@ (ice-9 optargs) rest-arg->keyword-binding-list)
- ,REST-ARG ',(map (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
- BINDINGS)
- ,ALLOW-OTHER-KEYS?)))
- ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))
-
-
-(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
- (if (null? rest-arg)
- '()
- (let loop ((first (car rest-arg))
- (rest (cdr rest-arg))
- (accum '()))
- (let ((next (lambda (a)
- (if (null? (cdr rest))
- a
- (loop (cadr rest) (cddr rest) a)))))
- (if (keyword? first)
- (cond
- ((memq first keywords)
- (if (null? rest)
- (error "Keyword argument has no value.")
- (next (cons (cons (keyword->symbol first)
- (car rest)) accum))))
- ((not allow-other-keys?)
- (error "Unknown keyword in arguments."))
- (else (if (null? rest)
- accum
- (next accum))))
- (if (null? rest)
- accum
- (loop (car rest) (cdr rest) accum)))))))
-
+(define-syntax let-keywords
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (vars vars)
+ ((kw ...) (map symbol->keyword
+ (map syntax->datum vars)))
+ ((idx ...) (iota (length vars)))
+ ((t ...) (generate-temporaries vars))
+ ((i ...) inits))
+ #'(let ((t (lambda vars i))
+ ...)
+ (apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
+ (list t ...)
+ #f
+ rest-arg)
+ (error "sth" rest-arg))))))))
+ ((_ rest-arg aok (binding ...) b0 b1 ...)
+ #'(let ((r rest-arg))
+ (let-keywords r aok (binding ...) b0 b1 ...))))))
+
+(define-syntax let-keywords*
+ (lambda (x)
+ (syntax-case x ()
+ ((_ rest-arg aok (binding ...) b0 b1 ...) (identifier? #'rest-arg)
+ (call-with-values (lambda () (vars&inits #'(binding ...)))
+ (lambda (vars inits)
+ (with-syntax ((n (length vars))
+ (vars vars)
+ ((kw ...) (map symbol->keyword
+ (map syntax->datum vars)))
+ ((idx ...) (iota (length vars)))
+ ((i ...) inits))
+ #'(apply (lambda vars b0 b1 ...)
+ (or (parse-lambda-case '(0 0 #f n aok ((kw . idx) ...))
+ (list (lambda vars i) ...)
+ #f
+ rest-arg)
+ (error "sth" rest-arg)))))))
+ ((_ rest-arg aok (binding ...) b0 b1 ...)
+ #'(let ((r rest-arg))
+ (let-keywords* r aok (binding ...) b0 b1 ...))))))
;; lambda* args . body
;; lambda extended for optional and keyword arguments
@@ -230,173 +241,24 @@
;; Lisp dialects.
-(defmacro lambda* (ARGLIST . BODY)
- (parse-arglist
- ARGLIST
- (lambda (non-optional-args optionals keys aok? rest-arg)
- ;; Check for syntax errors.
- (if (not (every? symbol? non-optional-args))
- (error "Syntax error in fixed argument declaration."))
- (if (not (every? ext-decl? optionals))
- (error "Syntax error in optional argument declaration."))
- (if (not (every? ext-decl? keys))
- (error "Syntax error in keyword argument declaration."))
- (if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
- (error "Syntax error in rest argument declaration."))
- ;; generate the code.
- (let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
- (lambda-gensym (gensym "lambda*:L")))
- (if (not (and (null? optionals) (null? keys)))
- `(let ((,lambda-gensym
- (lambda (,@non-optional-args . ,rest-gensym)
- ;; Make sure that if the proc had a docstring, we put it
- ;; here where it will be visible.
- ,@(if (and (not (null? BODY))
- (string? (car BODY)))
- (list (car BODY))
- '())
- (let-optional*
- ,rest-gensym
- ,optionals
- (let-keywords* ,rest-gensym
- ,aok?
- ,keys
- ,@(if (and (not rest-arg) (null? keys))
- `((if (not (null? ,rest-gensym))
- (error "Too many arguments.")))
- '())
- (let ()
- ,@BODY))))))
- (set-procedure-property! ,lambda-gensym 'arglist
- '(,non-optional-args
- ,optionals
- ,keys
- ,aok?
- ,rest-arg))
- ,lambda-gensym)
- `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
- ,@BODY))))))
-
-
-(define (every? pred lst)
- (or (null? lst)
- (and (pred (car lst))
- (every? pred (cdr lst)))))
-
-(define (ext-decl? obj)
- (or (symbol? obj)
- (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
-
-;; XXX - not tail recursive
-(define (improper-list-copy obj)
- (if (pair? obj)
- (cons (car obj) (improper-list-copy (cdr obj)))
- obj))
-
-(define (parse-arglist arglist cont)
- (define (split-list-at val lst cont)
- (cond
- ((memq val lst)
- => (lambda (pos)
- (if (memq val (cdr pos))
- (error (with-output-to-string
- (lambda ()
- (map display `(,val
- " specified more than once in argument list.")))))
- (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
- (else (cont lst '() #f))))
- (define (parse-opt-and-fixed arglist keys aok? rest cont)
- (split-list-at
- #:optional arglist
- (lambda (before after split?)
- (if (and split? (null? after))
- (error "#:optional specified but no optional arguments declared.")
- (cont before after keys aok? rest)))))
- (define (parse-keys arglist rest cont)
- (split-list-at
- #:allow-other-keys arglist
- (lambda (aok-before aok-after aok-split?)
- (if (and aok-split? (not (null? aok-after)))
- (error "#:allow-other-keys not at end of keyword argument declarations.")
- (split-list-at
- #:key aok-before
- (lambda (key-before key-after key-split?)
- (cond
- ((and aok-split? (not key-split?))
- (error "#:allow-other-keys specified but no keyword arguments declared."))
- (key-split?
- (cond
- ((null? key-after) (error "#:key specified but no keyword arguments declared."))
- ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments."))
- (else (parse-opt-and-fixed key-before key-after aok-split? rest cont))))
- (else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
- (define (parse-rest arglist cont)
- (cond
- ((null? arglist) (cont '() '() '() #f #f))
- ((not (pair? arglist)) (cont '() '() '() #f arglist))
- ((not (list? arglist))
- (let* ((copy (improper-list-copy arglist))
- (lp (last-pair copy))
- (ra (cdr lp)))
- (set-cdr! lp '())
- (if (memq #:rest copy)
- (error "Cannot specify both #:rest and dotted rest argument.")
- (parse-keys copy ra cont))))
- (else (split-list-at
- #:rest arglist
- (lambda (before after split?)
- (if split?
- (case (length after)
- ((0) (error "#:rest not followed by argument."))
- ((1) (parse-keys before (car after) cont))
- (else (error "#:rest argument must be declared last.")))
- (parse-keys before #f cont)))))))
-
- (parse-rest arglist cont))
-
-
-
;; define* args . body
;; define*-public args . body
;; define and define-public extended for optional and keyword arguments
;;
;; define* and define*-public support optional arguments with
-;; a similar syntax to lambda*. They also support arbitrary-depth
-;; currying, just like Guile's define. Some examples:
+;; a similar syntax to lambda*. Some examples:
;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
;; defines a procedure x with a fixed argument y, an optional agument
;; a, another optional argument z with default value 3, a keyword argument w,
;; and a rest argument u.
-;; (define-public* ((foo #:optional bar) #:optional baz) '())
-;; This illustrates currying. A procedure foo is defined, which,
-;; when called with an optional argument bar, returns a procedure that
-;; takes an optional argument baz.
;;
;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
;; in the same way as lambda*.
-(defmacro define* (ARGLIST . BODY)
- (define*-guts 'define ARGLIST BODY))
-
-(defmacro define*-public (ARGLIST . BODY)
- (define*-guts 'define-public ARGLIST BODY))
-
-;; The guts of define* and define*-public.
-(define (define*-guts DT ARGLIST BODY)
- (define (nest-lambda*s arglists)
- (if (null? arglists)
- BODY
- `((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
- (define (define*-guts-helper ARGLIST arglists)
- (let ((first (car ARGLIST))
- (al (cons (cdr ARGLIST) arglists)))
- (if (symbol? first)
- `(,DT ,first ,@(nest-lambda*s al))
- (define*-guts-helper first al))))
- (if (symbol? ARGLIST)
- `(,DT ,ARGLIST ,@BODY)
- (define*-guts-helper ARGLIST '())))
-
+(define-syntax define*-public
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (define-public id (lambda* args b0 b1 ...)))))
;; defmacro* name args . body
@@ -409,12 +271,92 @@
;; semantics. Here is an example of a macro with an optional argument:
;; (defmacro* transmorgify (a #:optional b)
-(defmacro defmacro* (NAME ARGLIST . BODY)
- `(define-macro ,NAME #f (lambda* ,ARGLIST ,@BODY)))
-
-(defmacro defmacro*-public (NAME ARGLIST . BODY)
- `(begin
- (defmacro* ,NAME ,ARGLIST ,@BODY)
- (export-syntax ,NAME)))
-
-;;; optargs.scm ends here
+(define-syntax defmacro*
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (defmacro id (lambda* args b0 b1 ...)))))
+(define-syntax defmacro*-public
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (begin
+ (defmacro id (lambda* args b0 b1 ...))
+ (export-syntax id)))))
+
+;;; Support for optional & keyword args with the interpreter.
+(define *uninitialized* (list 'uninitialized))
+(define (parse-lambda-case spec inits predicate args)
+ (pmatch spec
+ ((,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
+ (define (req args prev tail n)
+ (cond
+ ((zero? n)
+ (if prev (set-cdr! prev '()))
+ (let ((slots-tail (make-list (- nargs nreq) *uninitialized*)))
+ (opt (if prev (append! args slots-tail) slots-tail)
+ slots-tail tail nopt inits)))
+ ((null? tail)
+ #f) ;; fail
+ (else
+ (req args tail (cdr tail) (1- n)))))
+ (define (opt slots slots-tail args-tail n inits)
+ (cond
+ ((zero? n)
+ (rest-or-key slots slots-tail args-tail inits rest-idx))
+ ((null? args-tail)
+ (set-car! slots-tail (apply (car inits) slots))
+ (opt slots (cdr slots-tail) '() (1- n) (cdr inits)))
+ (else
+ (set-car! slots-tail (car args-tail))
+ (opt slots (cdr slots-tail) (cdr args-tail) (1- n) (cdr inits)))))
+ (define (rest-or-key slots slots-tail args-tail inits rest-idx)
+ (cond
+ (rest-idx
+ ;; it has to be this way, vars are allocated in this order
+ (set-car! slots-tail args-tail)
+ (if (pair? kw-indices)
+ (key slots (cdr slots-tail) args-tail inits)
+ (rest-or-key slots (cdr slots-tail) '() inits #f)))
+ ((pair? kw-indices)
+ ;; fail early here, because once we're in keyword land we throw
+ ;; errors instead of failing
+ (and (or (null? args-tail) rest-idx (keyword? (car args-tail)))
+ (key slots slots-tail args-tail inits)))
+ ((pair? args-tail)
+ #f) ;; fail
+ (else
+ (pred slots))))
+ (define (key slots slots-tail args-tail inits)
+ (cond
+ ((null? args-tail)
+ (if (null? inits)
+ (pred slots)
+ (begin
+ (if (eq? (car slots-tail) *uninitialized*)
+ (set-car! slots-tail (apply (car inits) slots)))
+ (key slots (cdr slots-tail) '() (cdr inits)))))
+ ((not (keyword? (car args-tail)))
+ (if rest-idx
+ ;; no error checking, everything goes to the rest..
+ (key slots slots-tail '() inits)
+ (error "bad keyword argument list" args-tail)))
+ ((and (keyword? (car args-tail))
+ (pair? (cdr args-tail))
+ (assq-ref kw-indices (car args-tail)))
+ => (lambda (i)
+ (list-set! slots i (cadr args-tail))
+ (key slots slots-tail (cddr args-tail) inits)))
+ ((and (keyword? (car args-tail))
+ (pair? (cdr args-tail))
+ allow-other-keys?)
+ (key slots slots-tail (cddr args-tail) inits))
+ (else (error "unrecognized keyword" args-tail))))
+ (define (pred slots)
+ (cond
+ (predicate
+ (if (apply predicate slots)
+ slots
+ #f))
+ (else slots)))
+ (let ((args (list-copy args)))
+ (req args #f args nreq)))
+ (else (error "unexpected spec" spec))))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index fecd2b25d..1dc6469bf 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1,122 +1,2176 @@
(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}#)
+(letrec ((#{and-map*\ 31}#
+ (lambda (#{f\ 69}# #{first\ 70}# . #{rest\ 71}#)
+ (let ((#{t\ 72}# (null? #{first\ 70}#)))
+ (if #{t\ 72}#
+ #{t\ 72}#
+ (if (null? #{rest\ 71}#)
+ (letrec ((#{andmap\ 73}#
+ (lambda (#{first\ 74}#)
+ (let ((#{x\ 75}# (car #{first\ 74}#))
+ (#{first\ 76}# (cdr #{first\ 74}#)))
+ (if (null? #{first\ 76}#)
+ (#{f\ 69}# #{x\ 75}#)
+ (if (#{f\ 69}# #{x\ 75}#)
+ (#{andmap\ 73}# #{first\ 76}#)
#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}#)
+ (#{andmap\ 73}# #{first\ 70}#))
+ (letrec ((#{andmap\ 77}#
+ (lambda (#{first\ 78}# #{rest\ 79}#)
+ (let ((#{x\ 80}# (car #{first\ 78}#))
+ (#{xr\ 81}# (map car #{rest\ 79}#))
+ (#{first\ 82}# (cdr #{first\ 78}#))
+ (#{rest\ 83}# (map cdr #{rest\ 79}#)))
+ (if (null? #{first\ 82}#)
+ (apply #{f\ 69}#
+ (cons #{x\ 80}# #{xr\ 81}#))
+ (if (apply #{f\ 69}#
+ (cons #{x\ 80}# #{xr\ 81}#))
+ (#{andmap\ 77}#
+ #{first\ 82}#
+ #{rest\ 83}#)
#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}#
+ (#{andmap\ 77}# #{first\ 70}# #{rest\ 71}#))))))))
+ (letrec ((#{lambda-var-list\ 182}#
+ (lambda (#{vars\ 306}#)
+ (letrec ((#{lvl\ 307}#
+ (lambda (#{vars\ 308}# #{ls\ 309}# #{w\ 310}#)
+ (if (pair? #{vars\ 308}#)
+ (#{lvl\ 307}#
+ (cdr #{vars\ 308}#)
+ (cons (#{wrap\ 159}#
+ (car #{vars\ 308}#)
+ #{w\ 310}#
#f)
- #{ls\ 1472}#)
- #{w\ 1473}#)
- (if (#{id?\ 1297}# #{vars\ 1471}#)
- (cons (#{wrap\ 1325}#
- #{vars\ 1471}#
- #{w\ 1473}#
+ #{ls\ 309}#)
+ #{w\ 310}#)
+ (if (#{id?\ 131}# #{vars\ 308}#)
+ (cons (#{wrap\ 159}#
+ #{vars\ 308}#
+ #{w\ 310}#
#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}#
+ #{ls\ 309}#)
+ (if (null? #{vars\ 308}#)
+ #{ls\ 309}#
+ (if (#{syntax-object?\ 115}# #{vars\ 308}#)
+ (#{lvl\ 307}#
+ (#{syntax-object-expression\ 116}#
+ #{vars\ 308}#)
+ #{ls\ 309}#
+ (#{join-wraps\ 150}#
+ #{w\ 310}#
+ (#{syntax-object-wrap\ 117}#
+ #{vars\ 308}#)))
+ (cons #{vars\ 308}# #{ls\ 309}#))))))))
+ (#{lvl\ 307}#
+ #{vars\ 306}#
'()
'(())))))
- (#{gen-var\ 1344}#
- (lambda (#{id\ 1474}#)
- (let ((#{id\ 1475}#
- (if (#{syntax-object?\ 1281}# #{id\ 1474}#)
- (#{syntax-object-expression\ 1282}# #{id\ 1474}#)
- #{id\ 1474}#)))
+ (#{gen-var\ 181}#
+ (lambda (#{id\ 311}#)
+ (let ((#{id\ 312}#
+ (if (#{syntax-object?\ 115}# #{id\ 311}#)
+ (#{syntax-object-expression\ 116}# #{id\ 311}#)
+ #{id\ 311}#)))
(gensym
- (string-append (symbol->string #{id\ 1475}#) " ")))))
- (#{strip\ 1343}#
- (lambda (#{x\ 1476}# #{w\ 1477}#)
+ (string-append (symbol->string #{id\ 312}#) " ")))))
+ (#{strip\ 180}#
+ (lambda (#{x\ 313}# #{w\ 314}#)
(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}#
+ (#{wrap-marks\ 134}# #{w\ 314}#))
+ #{x\ 313}#
+ (letrec ((#{f\ 315}# (lambda (#{x\ 316}#)
+ (if (#{syntax-object?\ 115}#
+ #{x\ 316}#)
+ (#{strip\ 180}#
+ (#{syntax-object-expression\ 116}#
+ #{x\ 316}#)
+ (#{syntax-object-wrap\ 117}#
+ #{x\ 316}#))
+ (if (pair? #{x\ 316}#)
+ (let ((#{a\ 317}# (#{f\ 315}# (car #{x\ 316}#)))
+ (#{d\ 318}# (#{f\ 315}# (cdr #{x\ 316}#))))
+ (if (if (eq? #{a\ 317}#
+ (car #{x\ 316}#))
+ (eq? #{d\ 318}#
+ (cdr #{x\ 316}#))
+ #f)
+ #{x\ 316}#
+ (cons #{a\ 317}# #{d\ 318}#)))
+ (if (vector? #{x\ 316}#)
+ (let ((#{old\ 319}#
+ (vector->list
+ #{x\ 316}#)))
+ (let ((#{new\ 320}#
+ (map #{f\ 315}#
+ #{old\ 319}#)))
+ (if (#{and-map*\ 31}#
+ eq?
+ #{old\ 319}#
+ #{new\ 320}#)
+ #{x\ 316}#
+ (list->vector
+ #{new\ 320}#))))
+ #{x\ 316}#))))))
+ (#{f\ 315}# #{x\ 313}#)))))
+ (#{chi-lambda-case\ 179}#
+ (lambda (#{e\ 321}#
+ #{r\ 322}#
+ #{w\ 323}#
+ #{s\ 324}#
+ #{mod\ 325}#
+ #{get-formals\ 326}#
+ #{clauses\ 327}#)
+ (letrec ((#{expand-body\ 332}#
+ (lambda (#{req\ 333}#
+ #{opt\ 334}#
+ #{rest\ 335}#
+ #{kw\ 336}#
+ #{pred\ 337}#
+ #{body\ 338}#
+ #{vars\ 339}#
+ #{r*\ 340}#
+ #{w*\ 341}#
+ #{inits\ 342}#)
+ ((lambda (#{tmp\ 343}#)
+ ((lambda (#{tmp\ 344}#)
+ (if (if #{tmp\ 344}#
+ (apply (lambda (#{docstring\ 345}#
+ #{e1\ 346}#
+ #{e2\ 347}#)
+ (string?
+ (syntax->datum
+ #{docstring\ 345}#)))
+ #{tmp\ 344}#)
+ #f)
+ (apply (lambda (#{docstring\ 348}#
+ #{e1\ 349}#
+ #{e2\ 350}#)
+ (values
+ (syntax->datum
+ #{docstring\ 348}#)
+ #{req\ 333}#
+ #{opt\ 334}#
+ #{rest\ 335}#
+ #{kw\ 336}#
+ #{inits\ 342}#
+ #{vars\ 339}#
+ #{pred\ 337}#
+ (#{chi-body\ 171}#
+ (cons #{e1\ 349}# #{e2\ 350}#)
+ (#{source-wrap\ 160}#
+ #{e\ 321}#
+ #{w\ 323}#
+ #{s\ 324}#
+ #{mod\ 325}#)
+ #{r*\ 340}#
+ #{w*\ 341}#
+ #{mod\ 325}#)))
+ #{tmp\ 344}#)
+ ((lambda (#{tmp\ 352}#)
+ (if #{tmp\ 352}#
+ (apply (lambda (#{e1\ 353}#
+ #{e2\ 354}#)
+ (values
+ #f
+ #{req\ 333}#
+ #{opt\ 334}#
+ #{rest\ 335}#
+ #{kw\ 336}#
+ #{inits\ 342}#
+ #{vars\ 339}#
+ #{pred\ 337}#
+ (#{chi-body\ 171}#
+ (cons #{e1\ 353}#
+ #{e2\ 354}#)
+ (#{source-wrap\ 160}#
+ #{e\ 321}#
+ #{w\ 323}#
+ #{s\ 324}#
+ #{mod\ 325}#)
+ #{r*\ 340}#
+ #{w*\ 341}#
+ #{mod\ 325}#)))
+ #{tmp\ 352}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 343}#)))
+ ($sc-dispatch
+ #{tmp\ 343}#
+ '(any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 343}#
+ '(any any . each-any))))
+ #{body\ 338}#)))
+ (#{expand-pred\ 331}#
+ (lambda (#{req\ 356}#
+ #{opt\ 357}#
+ #{rest\ 358}#
+ #{kw\ 359}#
+ #{pred\ 360}#
+ #{body\ 361}#
+ #{vars\ 362}#
+ #{r*\ 363}#
+ #{w*\ 364}#
+ #{inits\ 365}#)
+ (#{expand-body\ 332}#
+ #{req\ 356}#
+ #{opt\ 357}#
+ #{rest\ 358}#
+ #{kw\ 359}#
+ (if #{pred\ 360}#
+ (#{chi\ 167}#
+ #{pred\ 360}#
+ #{r*\ 363}#
+ #{w*\ 364}#
+ #{mod\ 325}#)
+ #f)
+ #{body\ 361}#
+ #{vars\ 362}#
+ #{r*\ 363}#
+ #{w*\ 364}#
+ #{inits\ 365}#)))
+ (#{expand-kw\ 330}#
+ (lambda (#{req\ 366}#
+ #{opt\ 367}#
+ #{rest\ 368}#
+ #{kw\ 369}#
+ #{pred\ 370}#
+ #{body\ 371}#
+ #{vars\ 372}#
+ #{r*\ 373}#
+ #{w*\ 374}#
+ #{aok\ 375}#
+ #{out\ 376}#
+ #{inits\ 377}#)
+ (if (pair? #{kw\ 369}#)
+ ((lambda (#{tmp\ 378}#)
+ ((lambda (#{tmp\ 379}#)
+ (if #{tmp\ 379}#
+ (apply (lambda (#{k\ 380}#
+ #{id\ 381}#
+ #{i\ 382}#)
+ (let ((#{v\ 383}# (#{gen-var\ 181}#
+ #{id\ 381}#)))
+ (let ((#{l\ 384}# (#{gen-labels\ 137}#
+ (list #{v\ 383}#))))
+ (let ((#{r**\ 385}#
+ (#{extend-var-env\ 126}#
+ #{l\ 384}#
+ (list #{v\ 383}#)
+ #{r*\ 373}#)))
+ (let ((#{w**\ 386}#
+ (#{make-binding-wrap\ 148}#
+ (list #{id\ 381}#)
+ #{l\ 384}#
+ #{w*\ 374}#)))
+ (#{expand-kw\ 330}#
+ #{req\ 366}#
+ #{opt\ 367}#
+ #{rest\ 368}#
+ (cdr #{kw\ 369}#)
+ #{pred\ 370}#
+ #{body\ 371}#
+ (cons #{v\ 383}#
+ #{vars\ 372}#)
+ #{r**\ 385}#
+ #{w**\ 386}#
+ #{aok\ 375}#
+ (cons (list (syntax->datum
+ #{k\ 380}#)
+ (syntax->datum
+ #{id\ 381}#)
+ #{v\ 383}#)
+ #{out\ 376}#)
+ (cons (#{chi\ 167}#
+ #{i\ 382}#
+ #{r*\ 373}#
+ #{w*\ 374}#
+ #{mod\ 325}#)
+ #{inits\ 377}#)))))))
+ #{tmp\ 379}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 378}#)))
+ ($sc-dispatch
+ #{tmp\ 378}#
+ '(any any any))))
+ (car #{kw\ 369}#))
+ (#{expand-pred\ 331}#
+ #{req\ 366}#
+ #{opt\ 367}#
+ #{rest\ 368}#
+ (if (let ((#{t\ 387}# #{aok\ 375}#))
+ (if #{t\ 387}#
+ #{t\ 387}#
+ (pair? #{out\ 376}#)))
+ (cons #{aok\ 375}# (reverse #{out\ 376}#))
+ #f)
+ #{pred\ 370}#
+ #{body\ 371}#
+ (reverse #{vars\ 372}#)
+ #{r*\ 373}#
+ #{w*\ 374}#
+ (reverse #{inits\ 377}#)))))
+ (#{expand-opt\ 329}#
+ (lambda (#{req\ 388}#
+ #{opt\ 389}#
+ #{rest\ 390}#
+ #{kw\ 391}#
+ #{pred\ 392}#
+ #{body\ 393}#
+ #{vars\ 394}#
+ #{r*\ 395}#
+ #{w*\ 396}#
+ #{out\ 397}#
+ #{inits\ 398}#)
+ (if (pair? #{opt\ 389}#)
+ ((lambda (#{tmp\ 399}#)
+ ((lambda (#{tmp\ 400}#)
+ (if #{tmp\ 400}#
+ (apply (lambda (#{id\ 401}# #{i\ 402}#)
+ (let ((#{v\ 403}# (#{gen-var\ 181}#
+ #{id\ 401}#)))
+ (let ((#{l\ 404}# (#{gen-labels\ 137}#
+ (list #{v\ 403}#))))
+ (let ((#{r**\ 405}#
+ (#{extend-var-env\ 126}#
+ #{l\ 404}#
+ (list #{v\ 403}#)
+ #{r*\ 395}#)))
+ (let ((#{w**\ 406}#
+ (#{make-binding-wrap\ 148}#
+ (list #{id\ 401}#)
+ #{l\ 404}#
+ #{w*\ 396}#)))
+ (#{expand-opt\ 329}#
+ #{req\ 388}#
+ (cdr #{opt\ 389}#)
+ #{rest\ 390}#
+ #{kw\ 391}#
+ #{pred\ 392}#
+ #{body\ 393}#
+ (cons #{v\ 403}#
+ #{vars\ 394}#)
+ #{r**\ 405}#
+ #{w**\ 406}#
+ (cons (syntax->datum
+ #{id\ 401}#)
+ #{out\ 397}#)
+ (cons (#{chi\ 167}#
+ #{i\ 402}#
+ #{r*\ 395}#
+ #{w*\ 396}#
+ #{mod\ 325}#)
+ #{inits\ 398}#)))))))
+ #{tmp\ 400}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 399}#)))
+ ($sc-dispatch
+ #{tmp\ 399}#
+ '(any any))))
+ (car #{opt\ 389}#))
+ (if #{rest\ 390}#
+ (let ((#{v\ 407}# (#{gen-var\ 181}#
+ #{rest\ 390}#)))
+ (let ((#{l\ 408}# (#{gen-labels\ 137}#
+ (list #{v\ 407}#))))
+ (let ((#{r*\ 409}#
+ (#{extend-var-env\ 126}#
+ #{l\ 408}#
+ (list #{v\ 407}#)
+ #{r*\ 395}#)))
+ (let ((#{w*\ 410}#
+ (#{make-binding-wrap\ 148}#
+ (list #{rest\ 390}#)
+ #{l\ 408}#
+ #{w*\ 396}#)))
+ (#{expand-kw\ 330}#
+ #{req\ 388}#
+ (if (pair? #{out\ 397}#)
+ (reverse #{out\ 397}#)
+ #f)
+ (syntax->datum #{rest\ 390}#)
+ (if (pair? #{kw\ 391}#)
+ (cdr #{kw\ 391}#)
+ #{kw\ 391}#)
+ #{pred\ 392}#
+ #{body\ 393}#
+ (cons #{v\ 407}# #{vars\ 394}#)
+ #{r*\ 409}#
+ #{w*\ 410}#
+ (if (pair? #{kw\ 391}#)
+ (car #{kw\ 391}#)
+ #f)
+ '()
+ #{inits\ 398}#)))))
+ (#{expand-kw\ 330}#
+ #{req\ 388}#
+ (if (pair? #{out\ 397}#)
+ (reverse #{out\ 397}#)
+ #f)
+ #f
+ (if (pair? #{kw\ 391}#)
+ (cdr #{kw\ 391}#)
+ #{kw\ 391}#)
+ #{pred\ 392}#
+ #{body\ 393}#
+ #{vars\ 394}#
+ #{r*\ 395}#
+ #{w*\ 396}#
+ (if (pair? #{kw\ 391}#) (car #{kw\ 391}#) #f)
+ '()
+ #{inits\ 398}#)))))
+ (#{expand-req\ 328}#
+ (lambda (#{req\ 411}#
+ #{opt\ 412}#
+ #{rest\ 413}#
+ #{kw\ 414}#
+ #{pred\ 415}#
+ #{body\ 416}#)
+ (let ((#{vars\ 417}#
+ (map #{gen-var\ 181}# #{req\ 411}#))
+ (#{labels\ 418}#
+ (#{gen-labels\ 137}# #{req\ 411}#)))
+ (let ((#{r*\ 419}#
+ (#{extend-var-env\ 126}#
+ #{labels\ 418}#
+ #{vars\ 417}#
+ #{r\ 322}#))
+ (#{w*\ 420}#
+ (#{make-binding-wrap\ 148}#
+ #{req\ 411}#
+ #{labels\ 418}#
+ #{w\ 323}#)))
+ (#{expand-opt\ 329}#
+ (map syntax->datum #{req\ 411}#)
+ #{opt\ 412}#
+ #{rest\ 413}#
+ #{kw\ 414}#
+ #{pred\ 415}#
+ #{body\ 416}#
+ (reverse #{vars\ 417}#)
+ #{r*\ 419}#
+ #{w*\ 420}#
+ '()
+ '()))))))
+ ((lambda (#{tmp\ 421}#)
+ ((lambda (#{tmp\ 422}#)
+ (if #{tmp\ 422}#
+ (apply (lambda () (values #f #f)) #{tmp\ 422}#)
+ ((lambda (#{tmp\ 423}#)
+ (if #{tmp\ 423}#
+ (apply (lambda (#{args\ 424}#
+ #{e1\ 425}#
+ #{e2\ 426}#
+ #{args*\ 427}#
+ #{e1*\ 428}#
+ #{e2*\ 429}#)
+ (call-with-values
+ (lambda ()
+ (#{get-formals\ 326}#
+ #{args\ 424}#))
+ (lambda (#{req\ 430}#
+ #{opt\ 431}#
+ #{rest\ 432}#
+ #{kw\ 433}#
+ #{pred\ 434}#)
+ (call-with-values
+ (lambda ()
+ (#{expand-req\ 328}#
+ #{req\ 430}#
+ #{opt\ 431}#
+ #{rest\ 432}#
+ #{kw\ 433}#
+ #{pred\ 434}#
+ (cons #{e1\ 425}#
+ #{e2\ 426}#)))
+ (lambda (#{docstring\ 436}#
+ #{req\ 437}#
+ #{opt\ 438}#
+ #{rest\ 439}#
+ #{kw\ 440}#
+ #{inits\ 441}#
+ #{vars\ 442}#
+ #{pred\ 443}#
+ #{body\ 444}#)
+ (call-with-values
+ (lambda ()
+ (#{chi-lambda-case\ 179}#
+ #{e\ 321}#
+ #{r\ 322}#
+ #{w\ 323}#
+ #{s\ 324}#
+ #{mod\ 325}#
+ #{get-formals\ 326}#
+ (map (lambda (#{tmp\ 447}#
+ #{tmp\ 446}#
+ #{tmp\ 445}#)
+ (cons #{tmp\ 445}#
+ (cons #{tmp\ 446}#
+ #{tmp\ 447}#)))
+ #{e2*\ 429}#
+ #{e1*\ 428}#
+ #{args*\ 427}#)))
+ (lambda (#{docstring*\ 449}#
+ #{else*\ 450}#)
+ (values
+ (let ((#{t\ 451}# #{docstring\ 436}#))
+ (if #{t\ 451}#
+ #{t\ 451}#
+ #{docstring*\ 449}#))
+ (#{build-lambda-case\ 107}#
+ #{s\ 324}#
+ #{req\ 437}#
+ #{opt\ 438}#
+ #{rest\ 439}#
+ #{kw\ 440}#
+ #{inits\ 441}#
+ #{vars\ 442}#
+ #{pred\ 443}#
+ #{body\ 444}#
+ #{else*\ 450}#)))))))))
+ #{tmp\ 423}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 421}#)))
+ ($sc-dispatch
+ #{tmp\ 421}#
+ '((any any . each-any)
+ .
+ #(each (any any . each-any)))))))
+ ($sc-dispatch #{tmp\ 421}# (quote ()))))
+ #{clauses\ 327}#))))
+ (#{lambda*-formals\ 178}#
+ (lambda (#{orig-args\ 452}#)
+ (letrec ((#{check\ 458}#
+ (lambda (#{req\ 459}#
+ #{opt\ 460}#
+ #{rest\ 461}#
+ #{kw\ 462}#
+ #{pred\ 463}#)
+ (if (#{distinct-bound-ids?\ 157}#
+ (append
+ #{req\ 459}#
+ (map car #{opt\ 460}#)
+ (if #{rest\ 461}#
+ (list #{rest\ 461}#)
+ '())
+ (if (pair? #{kw\ 462}#)
+ (map cadr (cdr #{kw\ 462}#))
+ '())))
+ (values
+ #{req\ 459}#
+ #{opt\ 460}#
+ #{rest\ 461}#
+ #{kw\ 462}#
+ #{pred\ 463}#)
+ (syntax-violation
+ 'lambda*
+ "duplicate identifier in argument list"
+ #{orig-args\ 452}#))))
+ (#{rest\ 457}#
+ (lambda (#{args\ 464}#
+ #{req\ 465}#
+ #{opt\ 466}#
+ #{kw\ 467}#
+ #{pred\ 468}#)
+ ((lambda (#{tmp\ 469}#)
+ ((lambda (#{tmp\ 470}#)
+ (if (if #{tmp\ 470}#
+ (apply (lambda (#{r\ 471}#)
+ (#{id?\ 131}# #{r\ 471}#))
+ #{tmp\ 470}#)
+ #f)
+ (apply (lambda (#{r\ 472}#)
+ (#{check\ 458}#
+ #{req\ 465}#
+ #{opt\ 466}#
+ #{r\ 472}#
+ #{kw\ 467}#
+ #{pred\ 468}#))
+ #{tmp\ 470}#)
+ ((lambda (#{else\ 473}#)
+ (syntax-violation
+ 'lambda*
+ "invalid rest argument"
+ #{orig-args\ 452}#
+ #{args\ 464}#))
+ #{tmp\ 469}#)))
+ (list #{tmp\ 469}#)))
+ #{args\ 464}#)))
+ (#{pred\ 456}#
+ (lambda (#{args\ 474}#
+ #{req\ 475}#
+ #{opt\ 476}#
+ #{kw\ 477}#)
+ ((lambda (#{tmp\ 478}#)
+ ((lambda (#{tmp\ 479}#)
+ (if #{tmp\ 479}#
+ (apply (lambda (#{x\ 480}#)
+ (#{check\ 458}#
+ #{req\ 475}#
+ #{opt\ 476}#
+ #f
+ #{kw\ 477}#
+ #{x\ 480}#))
+ #{tmp\ 479}#)
+ ((lambda (#{tmp\ 481}#)
+ (if (if #{tmp\ 481}#
+ (apply (lambda (#{x\ 482}#
+ #{a\ 483}#
+ #{b\ 484}#)
+ (eq? (syntax->datum
+ #{a\ 483}#
+ #:rest)))
+ #{tmp\ 481}#)
+ #f)
+ (apply (lambda (#{x\ 485}#
+ #{a\ 486}#
+ #{b\ 487}#)
+ (#{rest\ 457}#
+ #{b\ 487}#
+ #{req\ 475}#
+ #{opt\ 476}#
+ #f
+ #{kw\ 477}#
+ #{x\ 485}#))
+ #{tmp\ 481}#)
+ ((lambda (#{tmp\ 488}#)
+ (if (if #{tmp\ 488}#
+ (apply (lambda (#{x\ 489}#
+ #{b\ 490}#)
+ (#{id?\ 131}#
+ #{b\ 490}#))
+ #{tmp\ 488}#)
+ #f)
+ (apply (lambda (#{x\ 491}#
+ #{b\ 492}#)
+ (#{rest\ 457}#
+ #{b\ 492}#
+ #{req\ 475}#
+ #{opt\ 476}#
+ #f
+ #{kw\ 477}#
+ #{x\ 491}#))
+ #{tmp\ 488}#)
+ ((lambda (#{else\ 493}#)
+ (syntax-violation
+ 'lambda*
+ "invalid argument list following #:predicate"
+ #{orig-args\ 452}#
+ #{args\ 474}#))
+ #{tmp\ 478}#)))
+ ($sc-dispatch
+ #{tmp\ 478}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 478}#
+ '(any any any)))))
+ ($sc-dispatch #{tmp\ 478}# (quote (any)))))
+ #{args\ 474}#)))
+ (#{key\ 455}#
+ (lambda (#{args\ 494}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ #{rkey\ 497}#)
+ ((lambda (#{tmp\ 498}#)
+ ((lambda (#{tmp\ 499}#)
+ (if #{tmp\ 499}#
+ (apply (lambda ()
+ (#{check\ 458}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ #f
+ (cons #f
+ (reverse #{rkey\ 497}#))
+ #f))
+ #{tmp\ 499}#)
+ ((lambda (#{tmp\ 500}#)
+ (if (if #{tmp\ 500}#
+ (apply (lambda (#{a\ 501}#
+ #{b\ 502}#)
+ (#{id?\ 131}#
+ #{a\ 501}#))
+ #{tmp\ 500}#)
+ #f)
+ (apply (lambda (#{a\ 503}# #{b\ 504}#)
+ ((lambda (#{tmp\ 505}#)
+ ((lambda (#{k\ 506}#)
+ (#{key\ 455}#
+ #{b\ 504}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ (cons (cons #{k\ 506}#
+ (cons #{a\ 503}#
+ '(#(syntax-object
+ #f
+ ((top)
+ #(ribcage
+ #(k)
+ #((top))
+ #("i"))
+ #(ribcage
+ #(a
+ b)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(args
+ req
+ opt
+ rkey)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (check rest
+ pred
+ key
+ opt
+ req)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ #(orig-args)
+ #((top))
+ #("i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top)
+ (top))
+ ("i"
+ "i")))
+ (hygiene
+ guile)))))
+ #{rkey\ 497}#)))
+ #{tmp\ 505}#))
+ (symbol->keyword
+ (syntax->datum
+ #{a\ 503}#))))
+ #{tmp\ 500}#)
+ ((lambda (#{tmp\ 507}#)
+ (if (if #{tmp\ 507}#
+ (apply (lambda (#{a\ 508}#
+ #{init\ 509}#
+ #{b\ 510}#)
+ (#{id?\ 131}#
+ #{a\ 508}#))
+ #{tmp\ 507}#)
+ #f)
+ (apply (lambda (#{a\ 511}#
+ #{init\ 512}#
+ #{b\ 513}#)
+ ((lambda (#{tmp\ 514}#)
+ ((lambda (#{k\ 515}#)
+ (#{key\ 455}#
+ #{b\ 513}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ (cons (list #{k\ 515}#
+ #{a\ 511}#
+ #{init\ 512}#)
+ #{rkey\ 497}#)))
+ #{tmp\ 514}#))
+ (symbol->keyword
+ (syntax->datum
+ #{a\ 511}#))))
+ #{tmp\ 507}#)
+ ((lambda (#{tmp\ 516}#)
+ (if (if #{tmp\ 516}#
+ (apply (lambda (#{a\ 517}#
+ #{init\ 518}#
+ #{k\ 519}#
+ #{b\ 520}#)
+ (if (#{id?\ 131}#
+ #{a\ 517}#)
+ (keyword?
+ (syntax->datum
+ #{k\ 519}#))
+ #f))
+ #{tmp\ 516}#)
+ #f)
+ (apply (lambda (#{a\ 521}#
+ #{init\ 522}#
+ #{k\ 523}#
+ #{b\ 524}#)
+ (#{key\ 455}#
+ #{b\ 524}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ (cons (list #{k\ 523}#
+ #{a\ 521}#
+ #{init\ 522}#)
+ #{rkey\ 497}#)))
+ #{tmp\ 516}#)
+ ((lambda (#{tmp\ 525}#)
+ (if (if #{tmp\ 525}#
+ (apply (lambda (#{aok\ 526}#)
+ (eq? (syntax->datum
+ #{aok\ 526}#)
+ #:allow-other-keys))
+ #{tmp\ 525}#)
+ #f)
+ (apply (lambda (#{aok\ 527}#)
+ (#{check\ 458}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ #f
+ (cons #t
+ (reverse
+ #{rkey\ 497}#))
+ #f))
+ #{tmp\ 525}#)
+ ((lambda (#{tmp\ 528}#)
+ (if (if #{tmp\ 528}#
+ (apply (lambda (#{aok\ 529}#
+ #{a\ 530}#
+ #{b\ 531}#)
+ (if (eq? (syntax->datum
+ #{aok\ 529}#)
+ #:allow-other-keys)
+ (eq? (syntax->datum
+ #{a\ 530}#)
+ #:predicate)
+ #f))
+ #{tmp\ 528}#)
+ #f)
+ (apply (lambda (#{aok\ 532}#
+ #{a\ 533}#
+ #{b\ 534}#)
+ (#{pred\ 456}#
+ #{b\ 534}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ (cons #t
+ (reverse
+ #{rkey\ 497}#))))
+ #{tmp\ 528}#)
+ ((lambda (#{tmp\ 535}#)
+ (if (if #{tmp\ 535}#
+ (apply (lambda (#{aok\ 536}#
+ #{a\ 537}#
+ #{b\ 538}#)
+ (if (eq? (syntax->datum
+ #{aok\ 536}#)
+ #:allow-other-keys)
+ (eq? (syntax->datum
+ #{a\ 537}#)
+ #:rest)
+ #f))
+ #{tmp\ 535}#)
+ #f)
+ (apply (lambda (#{aok\ 539}#
+ #{a\ 540}#
+ #{b\ 541}#)
+ (#{rest\ 457}#
+ #{b\ 541}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ (cons #t
+ (reverse
+ #{rkey\ 497}#))))
+ #{tmp\ 535}#)
+ ((lambda (#{tmp\ 542}#)
+ (if (if #{tmp\ 542}#
+ (apply (lambda (#{aok\ 543}#
+ #{r\ 544}#)
+ (if (eq? (syntax->datum
+ #{aok\ 543}#)
+ #:allow-other-keys)
+ (#{id?\ 131}#
+ #{r\ 544}#)
+ #f))
+ #{tmp\ 542}#)
+ #f)
+ (apply (lambda (#{aok\ 545}#
+ #{r\ 546}#)
+ (#{rest\ 457}#
+ #{r\ 546}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ (cons #t
+ (reverse
+ #{rkey\ 497}#))))
+ #{tmp\ 542}#)
+ ((lambda (#{tmp\ 547}#)
+ (if (if #{tmp\ 547}#
+ (apply (lambda (#{a\ 548}#
+ #{b\ 549}#)
+ (eq? (syntax->datum
+ #{a\ 548}#)
+ #:predicate))
+ #{tmp\ 547}#)
+ #f)
+ (apply (lambda (#{a\ 550}#
+ #{b\ 551}#)
+ (#{pred\ 456}#
+ #{b\ 551}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ (cons #f
+ (reverse
+ #{rkey\ 497}#))))
+ #{tmp\ 547}#)
+ ((lambda (#{tmp\ 552}#)
+ (if (if #{tmp\ 552}#
+ (apply (lambda (#{a\ 553}#
+ #{b\ 554}#)
+ (eq? (syntax->datum
+ #{a\ 553}#)
+ #:rest))
+ #{tmp\ 552}#)
+ #f)
+ (apply (lambda (#{a\ 555}#
+ #{b\ 556}#)
+ (#{rest\ 457}#
+ #{b\ 556}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ (cons #f
+ (reverse
+ #{rkey\ 497}#))
+ #f))
+ #{tmp\ 552}#)
+ ((lambda (#{tmp\ 557}#)
+ (if (if #{tmp\ 557}#
+ (apply (lambda (#{r\ 558}#)
+ (#{id?\ 131}#
+ #{r\ 558}#))
+ #{tmp\ 557}#)
+ #f)
+ (apply (lambda (#{r\ 559}#)
+ (#{rest\ 457}#
+ #{r\ 559}#
+ #{req\ 495}#
+ #{opt\ 496}#
+ (cons #f
+ (reverse
+ #{rkey\ 497}#))
+ #f))
+ #{tmp\ 557}#)
+ ((lambda (#{else\ 560}#)
+ (syntax-violation
+ 'lambda*
+ "invalid keyword argument list"
+ #{orig-args\ 452}#
+ #{args\ 494}#))
+ #{tmp\ 498}#)))
+ (list #{tmp\ 498}#))))
+ ($sc-dispatch
+ #{tmp\ 498}#
+ '(any any)))))
+ ($sc-dispatch
+ #{tmp\ 498}#
+ '(any .
+ any)))))
+ ($sc-dispatch
+ #{tmp\ 498}#
+ '(any .
+ any)))))
+ ($sc-dispatch
+ #{tmp\ 498}#
+ '(any any
+ any)))))
+ ($sc-dispatch
+ #{tmp\ 498}#
+ '(any any . any)))))
+ ($sc-dispatch
+ #{tmp\ 498}#
+ '(any)))))
+ ($sc-dispatch
+ #{tmp\ 498}#
+ '((any any any) . any)))))
+ ($sc-dispatch
+ #{tmp\ 498}#
+ '((any any) . any)))))
+ ($sc-dispatch
+ #{tmp\ 498}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 498}# (quote ()))))
+ #{args\ 494}#)))
+ (#{opt\ 454}#
+ (lambda (#{args\ 561}# #{req\ 562}# #{ropt\ 563}#)
+ ((lambda (#{tmp\ 564}#)
+ ((lambda (#{tmp\ 565}#)
+ (if #{tmp\ 565}#
+ (apply (lambda ()
+ (#{check\ 458}#
+ #{req\ 562}#
+ (reverse #{ropt\ 563}#)
+ #f
+ '()
+ #f))
+ #{tmp\ 565}#)
+ ((lambda (#{tmp\ 566}#)
+ (if (if #{tmp\ 566}#
+ (apply (lambda (#{a\ 567}#
+ #{b\ 568}#)
+ (#{id?\ 131}#
+ #{a\ 567}#))
+ #{tmp\ 566}#)
+ #f)
+ (apply (lambda (#{a\ 569}# #{b\ 570}#)
+ (#{opt\ 454}#
+ #{b\ 570}#
+ #{req\ 562}#
+ (cons (cons #{a\ 569}#
+ '(#(syntax-object
+ #f
+ ((top)
+ #(ribcage
+ #(a b)
+ #((top)
+ (top))
+ #("i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(args
+ req
+ ropt)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ (check rest
+ pred
+ key
+ opt
+ req)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ #(orig-args)
+ #((top))
+ #("i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top)
+ (top))
+ ("i"
+ "i")))
+ (hygiene
+ guile))))
+ #{ropt\ 563}#)))
+ #{tmp\ 566}#)
+ ((lambda (#{tmp\ 571}#)
+ (if (if #{tmp\ 571}#
+ (apply (lambda (#{a\ 572}#
+ #{init\ 573}#
+ #{b\ 574}#)
+ (#{id?\ 131}#
+ #{a\ 572}#))
+ #{tmp\ 571}#)
+ #f)
+ (apply (lambda (#{a\ 575}#
+ #{init\ 576}#
+ #{b\ 577}#)
+ (#{opt\ 454}#
+ #{b\ 577}#
+ #{req\ 562}#
+ (cons (list #{a\ 575}#
+ #{init\ 576}#)
+ #{ropt\ 563}#)))
+ #{tmp\ 571}#)
+ ((lambda (#{tmp\ 578}#)
+ (if (if #{tmp\ 578}#
+ (apply (lambda (#{a\ 579}#
+ #{b\ 580}#)
+ (eq? (syntax->datum
+ #{a\ 579}#)
+ #:key))
+ #{tmp\ 578}#)
+ #f)
+ (apply (lambda (#{a\ 581}#
+ #{b\ 582}#)
+ (#{key\ 455}#
+ #{b\ 582}#
+ #{req\ 562}#
+ (reverse
+ #{ropt\ 563}#)
+ '()))
+ #{tmp\ 578}#)
+ ((lambda (#{tmp\ 583}#)
+ (if (if #{tmp\ 583}#
+ (apply (lambda (#{a\ 584}#
+ #{b\ 585}#)
+ (eq? (syntax->datum
+ #{a\ 584}#)
+ #:predicate))
+ #{tmp\ 583}#)
+ #f)
+ (apply (lambda (#{a\ 586}#
+ #{b\ 587}#)
+ (#{pred\ 456}#
+ #{b\ 587}#
+ #{req\ 562}#
+ (reverse
+ #{ropt\ 563}#)
+ '()))
+ #{tmp\ 583}#)
+ ((lambda (#{tmp\ 588}#)
+ (if (if #{tmp\ 588}#
+ (apply (lambda (#{a\ 589}#
+ #{b\ 590}#)
+ (eq? (syntax->datum
+ #{a\ 589}#)
+ #:rest))
+ #{tmp\ 588}#)
+ #f)
+ (apply (lambda (#{a\ 591}#
+ #{b\ 592}#)
+ (#{rest\ 457}#
+ #{b\ 592}#
+ #{req\ 562}#
+ (reverse
+ #{ropt\ 563}#)
+ '()
+ #f))
+ #{tmp\ 588}#)
+ ((lambda (#{tmp\ 593}#)
+ (if (if #{tmp\ 593}#
+ (apply (lambda (#{r\ 594}#)
+ (#{id?\ 131}#
+ #{r\ 594}#))
+ #{tmp\ 593}#)
+ #f)
+ (apply (lambda (#{r\ 595}#)
+ (#{rest\ 457}#
+ #{r\ 595}#
+ #{req\ 562}#
+ (reverse
+ #{ropt\ 563}#)
+ '()
+ #f))
+ #{tmp\ 593}#)
+ ((lambda (#{else\ 596}#)
+ (syntax-violation
+ 'lambda*
+ "invalid optional argument list"
+ #{orig-args\ 452}#
+ #{args\ 561}#))
+ #{tmp\ 564}#)))
+ (list #{tmp\ 564}#))))
+ ($sc-dispatch
+ #{tmp\ 564}#
+ '(any any)))))
+ ($sc-dispatch
+ #{tmp\ 564}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 564}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 564}#
+ '((any any) . any)))))
+ ($sc-dispatch
+ #{tmp\ 564}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 564}# (quote ()))))
+ #{args\ 561}#)))
+ (#{req\ 453}#
+ (lambda (#{args\ 597}# #{rreq\ 598}#)
+ ((lambda (#{tmp\ 599}#)
+ ((lambda (#{tmp\ 600}#)
+ (if #{tmp\ 600}#
+ (apply (lambda ()
+ (#{check\ 458}#
+ (reverse #{rreq\ 598}#)
+ '()
+ #f
+ '()
+ #f))
+ #{tmp\ 600}#)
+ ((lambda (#{tmp\ 601}#)
+ (if (if #{tmp\ 601}#
+ (apply (lambda (#{a\ 602}#
+ #{b\ 603}#)
+ (#{id?\ 131}#
+ #{a\ 602}#))
+ #{tmp\ 601}#)
+ #f)
+ (apply (lambda (#{a\ 604}# #{b\ 605}#)
+ (#{req\ 453}#
+ #{b\ 605}#
+ (cons #{a\ 604}#
+ #{rreq\ 598}#)))
+ #{tmp\ 601}#)
+ ((lambda (#{tmp\ 606}#)
+ (if (if #{tmp\ 606}#
+ (apply (lambda (#{a\ 607}#
+ #{b\ 608}#)
+ (eq? (syntax->datum
+ #{a\ 607}#)
+ #:optional))
+ #{tmp\ 606}#)
+ #f)
+ (apply (lambda (#{a\ 609}#
+ #{b\ 610}#)
+ (#{opt\ 454}#
+ #{b\ 610}#
+ (reverse
+ #{rreq\ 598}#)
+ '()))
+ #{tmp\ 606}#)
+ ((lambda (#{tmp\ 611}#)
+ (if (if #{tmp\ 611}#
+ (apply (lambda (#{a\ 612}#
+ #{b\ 613}#)
+ (eq? (syntax->datum
+ #{a\ 612}#)
+ #:key))
+ #{tmp\ 611}#)
+ #f)
+ (apply (lambda (#{a\ 614}#
+ #{b\ 615}#)
+ (#{key\ 455}#
+ #{b\ 615}#
+ (reverse
+ #{rreq\ 598}#)
+ '()
+ '()))
+ #{tmp\ 611}#)
+ ((lambda (#{tmp\ 616}#)
+ (if (if #{tmp\ 616}#
+ (apply (lambda (#{a\ 617}#
+ #{b\ 618}#)
+ (eq? (syntax->datum
+ #{a\ 617}#)
+ #:predicate))
+ #{tmp\ 616}#)
+ #f)
+ (apply (lambda (#{a\ 619}#
+ #{b\ 620}#)
+ (#{pred\ 456}#
+ #{b\ 620}#
+ (reverse
+ #{rreq\ 598}#)
+ '()
+ '()))
+ #{tmp\ 616}#)
+ ((lambda (#{tmp\ 621}#)
+ (if (if #{tmp\ 621}#
+ (apply (lambda (#{a\ 622}#
+ #{b\ 623}#)
+ (eq? (syntax->datum
+ #{a\ 622}#)
+ #:rest))
+ #{tmp\ 621}#)
+ #f)
+ (apply (lambda (#{a\ 624}#
+ #{b\ 625}#)
+ (#{rest\ 457}#
+ #{b\ 625}#
+ (reverse
+ #{rreq\ 598}#)
+ '()
+ '()
+ #f))
+ #{tmp\ 621}#)
+ ((lambda (#{tmp\ 626}#)
+ (if (if #{tmp\ 626}#
+ (apply (lambda (#{r\ 627}#)
+ (#{id?\ 131}#
+ #{r\ 627}#))
+ #{tmp\ 626}#)
+ #f)
+ (apply (lambda (#{r\ 628}#)
+ (#{rest\ 457}#
+ #{r\ 628}#
+ (reverse
+ #{rreq\ 598}#)
+ '()
+ '()
+ #f))
+ #{tmp\ 626}#)
+ ((lambda (#{else\ 629}#)
+ (syntax-violation
+ 'lambda*
+ "invalid argument list"
+ #{orig-args\ 452}#
+ #{args\ 597}#))
+ #{tmp\ 599}#)))
+ (list #{tmp\ 599}#))))
+ ($sc-dispatch
+ #{tmp\ 599}#
+ '(any any)))))
+ ($sc-dispatch
+ #{tmp\ 599}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 599}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 599}#
+ '(any . any)))))
+ ($sc-dispatch
+ #{tmp\ 599}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 599}# (quote ()))))
+ #{args\ 597}#))))
+ (#{req\ 453}# #{orig-args\ 452}# (quote ())))))
+ (#{chi-simple-lambda\ 177}#
+ (lambda (#{e\ 630}#
+ #{r\ 631}#
+ #{w\ 632}#
+ #{s\ 633}#
+ #{mod\ 634}#
+ #{req\ 635}#
+ #{rest\ 636}#
+ #{docstring\ 637}#
+ #{body\ 638}#)
+ (let ((#{ids\ 639}#
+ (if #{rest\ 636}#
+ (append #{req\ 635}# (list #{rest\ 636}#))
+ #{req\ 635}#)))
+ (let ((#{vars\ 640}#
+ (map #{gen-var\ 181}# #{ids\ 639}#)))
+ (let ((#{labels\ 641}#
+ (#{gen-labels\ 137}# #{ids\ 639}#)))
+ (#{build-simple-lambda\ 105}#
+ #{s\ 633}#
+ (map syntax->datum #{req\ 635}#)
+ (if #{rest\ 636}#
+ (syntax->datum #{rest\ 636}#)
+ #f)
+ #{vars\ 640}#
+ #{docstring\ 637}#
+ (#{chi-body\ 171}#
+ #{body\ 638}#
+ (#{source-wrap\ 160}#
+ #{e\ 630}#
+ #{w\ 632}#
+ #{s\ 633}#
+ #{mod\ 634}#)
+ (#{extend-var-env\ 126}#
+ #{labels\ 641}#
+ #{vars\ 640}#
+ #{r\ 631}#)
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 639}#
+ #{labels\ 641}#
+ #{w\ 632}#)
+ #{mod\ 634}#)))))))
+ (#{lambda-formals\ 176}#
+ (lambda (#{orig-args\ 642}#)
+ (letrec ((#{check\ 644}#
+ (lambda (#{req\ 645}# #{rest\ 646}#)
+ (if (#{distinct-bound-ids?\ 157}#
+ (if #{rest\ 646}#
+ (cons #{rest\ 646}# #{req\ 645}#)
+ #{req\ 645}#))
+ (values #{req\ 645}# #f #{rest\ 646}# #f #f)
+ (syntax-violation
+ 'lambda
+ "duplicate identifier in argument list"
+ #{orig-args\ 642}#))))
+ (#{req\ 643}#
+ (lambda (#{args\ 647}# #{rreq\ 648}#)
+ ((lambda (#{tmp\ 649}#)
+ ((lambda (#{tmp\ 650}#)
+ (if #{tmp\ 650}#
+ (apply (lambda ()
+ (#{check\ 644}#
+ (reverse #{rreq\ 648}#)
+ #f))
+ #{tmp\ 650}#)
+ ((lambda (#{tmp\ 651}#)
+ (if (if #{tmp\ 651}#
+ (apply (lambda (#{a\ 652}#
+ #{b\ 653}#)
+ (#{id?\ 131}#
+ #{a\ 652}#))
+ #{tmp\ 651}#)
+ #f)
+ (apply (lambda (#{a\ 654}# #{b\ 655}#)
+ (#{req\ 643}#
+ #{b\ 655}#
+ (cons #{a\ 654}#
+ #{rreq\ 648}#)))
+ #{tmp\ 651}#)
+ ((lambda (#{tmp\ 656}#)
+ (if (if #{tmp\ 656}#
+ (apply (lambda (#{r\ 657}#)
+ (#{id?\ 131}#
+ #{r\ 657}#))
+ #{tmp\ 656}#)
+ #f)
+ (apply (lambda (#{r\ 658}#)
+ (#{check\ 644}#
+ (reverse
+ #{rreq\ 648}#)
+ #{r\ 658}#))
+ #{tmp\ 656}#)
+ ((lambda (#{else\ 659}#)
+ (syntax-violation
+ 'lambda
+ "invalid argument list"
+ #{orig-args\ 642}#
+ #{args\ 647}#))
+ #{tmp\ 649}#)))
+ (list #{tmp\ 649}#))))
+ ($sc-dispatch
+ #{tmp\ 649}#
+ '(any . any)))))
+ ($sc-dispatch #{tmp\ 649}# (quote ()))))
+ #{args\ 647}#))))
+ (#{req\ 643}# #{orig-args\ 642}# (quote ())))))
+ (#{ellipsis?\ 175}#
+ (lambda (#{x\ 660}#)
+ (if (#{nonsymbol-id?\ 130}# #{x\ 660}#)
+ (#{free-id=?\ 154}#
+ #{x\ 660}#
'#(syntax-object
...
((top)
@@ -127,11 +2181,14 @@
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -213,7 +2270,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -347,6 +2406,11 @@
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
@@ -459,6 +2523,11 @@
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
@@ -466,1401 +2535,1223 @@
("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}#
+ (#{chi-void\ 174}#
+ (lambda () (#{build-void\ 95}# #f)))
+ (#{eval-local-transformer\ 173}#
+ (lambda (#{expanded\ 661}# #{mod\ 662}#)
+ (let ((#{p\ 663}# (#{local-eval-hook\ 91}#
+ #{expanded\ 661}#
+ #{mod\ 662}#)))
+ (if (procedure? #{p\ 663}#)
+ #{p\ 663}#
(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}#))
+ #{p\ 663}#)))))
+ (#{chi-local-syntax\ 172}#
+ (lambda (#{rec?\ 664}#
+ #{e\ 665}#
+ #{r\ 666}#
+ #{w\ 667}#
+ #{s\ 668}#
+ #{mod\ 669}#
+ #{k\ 670}#)
+ ((lambda (#{tmp\ 671}#)
+ ((lambda (#{tmp\ 672}#)
+ (if #{tmp\ 672}#
+ (apply (lambda (#{_\ 673}#
+ #{id\ 674}#
+ #{val\ 675}#
+ #{e1\ 676}#
+ #{e2\ 677}#)
+ (let ((#{ids\ 678}# #{id\ 674}#))
+ (if (not (#{valid-bound-ids?\ 156}#
+ #{ids\ 678}#))
(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}#)
+ #{e\ 665}#)
+ (let ((#{labels\ 680}#
+ (#{gen-labels\ 137}#
+ #{ids\ 678}#)))
+ (let ((#{new-w\ 681}#
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 678}#
+ #{labels\ 680}#
+ #{w\ 667}#)))
+ (#{k\ 670}# (cons #{e1\ 676}#
+ #{e2\ 677}#)
+ (#{extend-env\ 125}#
+ #{labels\ 680}#
+ (let ((#{w\ 683}# (if #{rec?\ 664}#
+ #{new-w\ 681}#
+ #{w\ 667}#))
+ (#{trans-r\ 684}#
+ (#{macros-only-env\ 127}#
+ #{r\ 666}#)))
+ (map (lambda (#{x\ 685}#)
+ (cons 'macro
+ (#{eval-local-transformer\ 173}#
+ (#{chi\ 167}#
+ #{x\ 685}#
+ #{trans-r\ 684}#
+ #{w\ 683}#
+ #{mod\ 669}#)
+ #{mod\ 669}#)))
+ #{val\ 675}#))
+ #{r\ 666}#)
+ #{new-w\ 681}#
+ #{s\ 668}#
+ #{mod\ 669}#))))))
+ #{tmp\ 672}#)
+ ((lambda (#{_\ 687}#)
(syntax-violation
#f
"bad local syntax definition"
- (#{source-wrap\ 1326}#
- #{e\ 1489}#
- #{w\ 1491}#
- #{s\ 1492}#
- #{mod\ 1493}#)))
- #{tmp\ 1495}#)))
+ (#{source-wrap\ 160}#
+ #{e\ 665}#
+ #{w\ 667}#
+ #{s\ 668}#
+ #{mod\ 669}#)))
+ #{tmp\ 671}#)))
($sc-dispatch
- #{tmp\ 1495}#
+ #{tmp\ 671}#
'(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}#
+ #{e\ 665}#)))
+ (#{chi-body\ 171}#
+ (lambda (#{body\ 688}#
+ #{outer-form\ 689}#
+ #{r\ 690}#
+ #{w\ 691}#
+ #{mod\ 692}#)
+ (let ((#{r\ 693}# (cons '("placeholder" placeholder)
+ #{r\ 690}#)))
+ (let ((#{ribcage\ 694}#
+ (#{make-ribcage\ 138}#
'()
'()
'())))
- (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}#)
+ (let ((#{w\ 695}# (#{make-wrap\ 133}#
+ (#{wrap-marks\ 134}# #{w\ 691}#)
+ (cons #{ribcage\ 694}#
+ (#{wrap-subst\ 135}#
+ #{w\ 691}#)))))
+ (letrec ((#{parse\ 696}#
+ (lambda (#{body\ 697}#
+ #{ids\ 698}#
+ #{labels\ 699}#
+ #{var-ids\ 700}#
+ #{vars\ 701}#
+ #{vals\ 702}#
+ #{bindings\ 703}#)
+ (if (null? #{body\ 697}#)
(syntax-violation
#f
"no expressions in body"
- #{outer-form\ 1555}#)
- (let ((#{e\ 1571}# (cdar #{body\ 1563}#))
- (#{er\ 1572}# (caar #{body\ 1563}#)))
+ #{outer-form\ 689}#)
+ (let ((#{e\ 705}# (cdar #{body\ 697}#))
+ (#{er\ 706}# (caar #{body\ 697}#)))
(call-with-values
(lambda ()
- (#{syntax-type\ 1331}#
- #{e\ 1571}#
- #{er\ 1572}#
+ (#{syntax-type\ 165}#
+ #{e\ 705}#
+ #{er\ 706}#
'(())
- (#{source-annotation\ 1288}#
- #{er\ 1572}#)
- #{ribcage\ 1560}#
- #{mod\ 1558}#
+ (#{source-annotation\ 122}#
+ #{er\ 706}#)
+ #{ribcage\ 694}#
+ #{mod\ 692}#
#f))
- (lambda (#{type\ 1573}#
- #{value\ 1574}#
- #{e\ 1575}#
- #{w\ 1576}#
- #{s\ 1577}#
- #{mod\ 1578}#)
- (if (memv #{type\ 1573}#
+ (lambda (#{type\ 707}#
+ #{value\ 708}#
+ #{e\ 709}#
+ #{w\ 710}#
+ #{s\ 711}#
+ #{mod\ 712}#)
+ (if (memv #{type\ 707}#
'(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}#)))
+ (let ((#{id\ 713}#
+ (#{wrap\ 159}#
+ #{value\ 708}#
+ #{w\ 710}#
+ #{mod\ 712}#))
+ (#{label\ 714}#
+ (#{gen-label\ 136}#)))
+ (let ((#{var\ 715}#
+ (#{gen-var\ 181}#
+ #{id\ 713}#)))
(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}#)
+ (#{extend-ribcage!\ 147}#
+ #{ribcage\ 694}#
+ #{id\ 713}#
+ #{label\ 714}#)
+ (#{parse\ 696}#
+ (cdr #{body\ 697}#)
+ (cons #{id\ 713}#
+ #{ids\ 698}#)
+ (cons #{label\ 714}#
+ #{labels\ 699}#)
+ (cons #{id\ 713}#
+ #{var-ids\ 700}#)
+ (cons #{var\ 715}#
+ #{vars\ 701}#)
+ (cons (cons #{er\ 706}#
+ (#{wrap\ 159}#
+ #{e\ 709}#
+ #{w\ 710}#
+ #{mod\ 712}#))
+ #{vals\ 702}#)
(cons (cons 'lexical
- #{var\ 1581}#)
- #{bindings\ 1569}#)))))
- (if (memv #{type\ 1573}#
+ #{var\ 715}#)
+ #{bindings\ 703}#)))))
+ (if (memv #{type\ 707}#
'(define-syntax-form))
- (let ((#{id\ 1582}#
- (#{wrap\ 1325}#
- #{value\ 1574}#
- #{w\ 1576}#
- #{mod\ 1578}#))
- (#{label\ 1583}#
- (#{gen-label\ 1302}#)))
+ (let ((#{id\ 716}#
+ (#{wrap\ 159}#
+ #{value\ 708}#
+ #{w\ 710}#
+ #{mod\ 712}#))
+ (#{label\ 717}#
+ (#{gen-label\ 136}#)))
(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}#
+ (#{extend-ribcage!\ 147}#
+ #{ribcage\ 694}#
+ #{id\ 716}#
+ #{label\ 717}#)
+ (#{parse\ 696}#
+ (cdr #{body\ 697}#)
+ (cons #{id\ 716}#
+ #{ids\ 698}#)
+ (cons #{label\ 717}#
+ #{labels\ 699}#)
+ #{var-ids\ 700}#
+ #{vars\ 701}#
+ #{vals\ 702}#
(cons (cons 'macro
- (cons #{er\ 1572}#
- (#{wrap\ 1325}#
- #{e\ 1575}#
- #{w\ 1576}#
- #{mod\ 1578}#)))
- #{bindings\ 1569}#))))
- (if (memv #{type\ 1573}#
+ (cons #{er\ 706}#
+ (#{wrap\ 159}#
+ #{e\ 709}#
+ #{w\ 710}#
+ #{mod\ 712}#)))
+ #{bindings\ 703}#))))
+ (if (memv #{type\ 707}#
'(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}#)
+ ((lambda (#{tmp\ 718}#)
+ ((lambda (#{tmp\ 719}#)
+ (if #{tmp\ 719}#
+ (apply (lambda (#{_\ 720}#
+ #{e1\ 721}#)
+ (#{parse\ 696}#
+ (letrec ((#{f\ 722}# (lambda (#{forms\ 723}#)
+ (if (null? #{forms\ 723}#)
+ (cdr #{body\ 697}#)
+ (cons (cons #{er\ 706}#
+ (#{wrap\ 159}#
+ (car #{forms\ 723}#)
+ #{w\ 710}#
+ #{mod\ 712}#))
+ (#{f\ 722}# (cdr #{forms\ 723}#)))))))
+ (#{f\ 722}# #{e1\ 721}#))
+ #{ids\ 698}#
+ #{labels\ 699}#
+ #{var-ids\ 700}#
+ #{vars\ 701}#
+ #{vals\ 702}#
+ #{bindings\ 703}#))
+ #{tmp\ 719}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1584}#)))
+ #{tmp\ 718}#)))
($sc-dispatch
- #{tmp\ 1584}#
+ #{tmp\ 718}#
'(any . each-any))))
- #{e\ 1575}#)
- (if (memv #{type\ 1573}#
+ #{e\ 709}#)
+ (if (memv #{type\ 707}#
'(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}#
+ (#{chi-local-syntax\ 172}#
+ #{value\ 708}#
+ #{e\ 709}#
+ #{er\ 706}#
+ #{w\ 710}#
+ #{s\ 711}#
+ #{mod\ 712}#
+ (lambda (#{forms\ 725}#
+ #{er\ 726}#
+ #{w\ 727}#
+ #{s\ 728}#
+ #{mod\ 729}#)
+ (#{parse\ 696}#
+ (letrec ((#{f\ 730}# (lambda (#{forms\ 731}#)
+ (if (null? #{forms\ 731}#)
+ (cdr #{body\ 697}#)
+ (cons (cons #{er\ 726}#
+ (#{wrap\ 159}#
+ (car #{forms\ 731}#)
+ #{w\ 727}#
+ #{mod\ 729}#))
+ (#{f\ 730}# (cdr #{forms\ 731}#)))))))
+ (#{f\ 730}# #{forms\ 725}#))
+ #{ids\ 698}#
+ #{labels\ 699}#
+ #{var-ids\ 700}#
+ #{vars\ 701}#
+ #{vals\ 702}#
+ #{bindings\ 703}#)))
+ (if (null? #{ids\ 698}#)
+ (#{build-sequence\ 110}#
#f
- (map (lambda (#{x\ 1598}#)
- (#{chi\ 1333}#
- (cdr #{x\ 1598}#)
- (car #{x\ 1598}#)
+ (map (lambda (#{x\ 732}#)
+ (#{chi\ 167}#
+ (cdr #{x\ 732}#)
+ (car #{x\ 732}#)
'(())
- #{mod\ 1578}#))
- (cons (cons #{er\ 1572}#
- (#{source-wrap\ 1326}#
- #{e\ 1575}#
- #{w\ 1576}#
- #{s\ 1577}#
- #{mod\ 1578}#))
- (cdr #{body\ 1563}#))))
+ #{mod\ 712}#))
+ (cons (cons #{er\ 706}#
+ (#{source-wrap\ 160}#
+ #{e\ 709}#
+ #{w\ 710}#
+ #{s\ 711}#
+ #{mod\ 712}#))
+ (cdr #{body\ 697}#))))
(begin
- (if (not (#{valid-bound-ids?\ 1322}#
- #{ids\ 1564}#))
+ (if (not (#{valid-bound-ids?\ 156}#
+ #{ids\ 698}#))
(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}#)
+ #{outer-form\ 689}#))
+ (letrec ((#{loop\ 733}#
+ (lambda (#{bs\ 734}#
+ #{er-cache\ 735}#
+ #{r-cache\ 736}#)
+ (if (not (null? #{bs\ 734}#))
+ (let ((#{b\ 737}# (car #{bs\ 734}#)))
+ (if (eq? (car #{b\ 737}#)
'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}#))))
+ (let ((#{er\ 738}#
+ (cadr #{b\ 737}#)))
+ (let ((#{r-cache\ 739}#
+ (if (eq? #{er\ 738}#
+ #{er-cache\ 735}#)
+ #{r-cache\ 736}#
+ (#{macros-only-env\ 127}#
+ #{er\ 738}#))))
(begin
(set-cdr!
- #{b\ 1603}#
- (#{eval-local-transformer\ 1340}#
- (#{chi\ 1333}#
- (cddr #{b\ 1603}#)
- #{r-cache\ 1605}#
+ #{b\ 737}#
+ (#{eval-local-transformer\ 173}#
+ (#{chi\ 167}#
+ (cddr #{b\ 737}#)
+ #{r-cache\ 739}#
'(())
- #{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}#
+ #{mod\ 712}#)
+ #{mod\ 712}#))
+ (#{loop\ 733}#
+ (cdr #{bs\ 734}#)
+ #{er\ 738}#
+ #{r-cache\ 739}#))))
+ (#{loop\ 733}#
+ (cdr #{bs\ 734}#)
+ #{er-cache\ 735}#
+ #{r-cache\ 736}#)))))))
+ (#{loop\ 733}#
+ #{bindings\ 703}#
#f
#f))
(set-cdr!
- #{r\ 1559}#
- (#{extend-env\ 1291}#
- #{labels\ 1565}#
- #{bindings\ 1569}#
- (cdr #{r\ 1559}#)))
- (#{build-letrec\ 1279}#
+ #{r\ 693}#
+ (#{extend-env\ 125}#
+ #{labels\ 699}#
+ #{bindings\ 703}#
+ (cdr #{r\ 693}#)))
+ (#{build-letrec\ 113}#
#f
(map syntax->datum
- #{var-ids\ 1566}#)
- #{vars\ 1567}#
- (map (lambda (#{x\ 1606}#)
- (#{chi\ 1333}#
- (cdr #{x\ 1606}#)
- (car #{x\ 1606}#)
+ #{var-ids\ 700}#)
+ #{vars\ 701}#
+ (map (lambda (#{x\ 740}#)
+ (#{chi\ 167}#
+ (cdr #{x\ 740}#)
+ (car #{x\ 740}#)
'(())
- #{mod\ 1578}#))
- #{vals\ 1568}#)
- (#{build-sequence\ 1276}#
+ #{mod\ 712}#))
+ #{vals\ 702}#)
+ (#{build-sequence\ 110}#
#f
- (map (lambda (#{x\ 1607}#)
- (#{chi\ 1333}#
- (cdr #{x\ 1607}#)
- (car #{x\ 1607}#)
+ (map (lambda (#{x\ 741}#)
+ (#{chi\ 167}#
+ (cdr #{x\ 741}#)
+ (car #{x\ 741}#)
'(())
- #{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}#)
+ #{mod\ 712}#))
+ (cons (cons #{er\ 706}#
+ (#{source-wrap\ 160}#
+ #{e\ 709}#
+ #{w\ 710}#
+ #{s\ 711}#
+ #{mod\ 712}#))
+ (cdr #{body\ 697}#))))))))))))))))))
+ (#{parse\ 696}#
+ (map (lambda (#{x\ 704}#)
+ (cons #{r\ 693}#
+ (#{wrap\ 159}#
+ #{x\ 704}#
+ #{w\ 695}#
+ #{mod\ 692}#)))
+ #{body\ 688}#)
'()
'()
'()
'()
'()
'())))))))
- (#{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)
+ (#{chi-macro\ 170}#
+ (lambda (#{p\ 742}#
+ #{e\ 743}#
+ #{r\ 744}#
+ #{w\ 745}#
+ #{rib\ 746}#
+ #{mod\ 747}#)
+ (letrec ((#{rebuild-macro-output\ 748}#
+ (lambda (#{x\ 749}# #{m\ 750}#)
+ (if (pair? #{x\ 749}#)
+ (cons (#{rebuild-macro-output\ 748}#
+ (car #{x\ 749}#)
+ #{m\ 750}#)
+ (#{rebuild-macro-output\ 748}#
+ (cdr #{x\ 749}#)
+ #{m\ 750}#))
+ (if (#{syntax-object?\ 115}# #{x\ 749}#)
+ (let ((#{w\ 751}# (#{syntax-object-wrap\ 117}#
+ #{x\ 749}#)))
+ (let ((#{ms\ 752}#
+ (#{wrap-marks\ 134}# #{w\ 751}#))
+ (#{s\ 753}# (#{wrap-subst\ 135}#
+ #{w\ 751}#)))
+ (if (if (pair? #{ms\ 752}#)
+ (eq? (car #{ms\ 752}#) #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}#
+ (#{make-syntax-object\ 114}#
+ (#{syntax-object-expression\ 116}#
+ #{x\ 749}#)
+ (#{make-wrap\ 133}#
+ (cdr #{ms\ 752}#)
+ (if #{rib\ 746}#
+ (cons #{rib\ 746}#
+ (cdr #{s\ 753}#))
+ (cdr #{s\ 753}#)))
+ (#{syntax-object-module\ 118}#
+ #{x\ 749}#))
+ (#{make-syntax-object\ 114}#
+ (#{syntax-object-expression\ 116}#
+ #{x\ 749}#)
+ (#{make-wrap\ 133}#
+ (cons #{m\ 750}# #{ms\ 752}#)
+ (if #{rib\ 746}#
+ (cons #{rib\ 746}#
(cons 'shift
- #{s\ 1619}#))
- (cons (quote shift) #{s\ 1619}#)))
- (let ((#{pmod\ 1620}#
- (procedure-module
- #{p\ 1608}#)))
- (if #{pmod\ 1620}#
+ #{s\ 753}#))
+ (cons (quote shift) #{s\ 753}#)))
+ (let ((#{pmod\ 754}#
+ (procedure-module #{p\ 742}#)))
+ (if #{pmod\ 754}#
(cons 'hygiene
- (module-name #{pmod\ 1620}#))
+ (module-name #{pmod\ 754}#))
'(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}#)
+ (if (vector? #{x\ 749}#)
+ (let ((#{n\ 755}# (vector-length
+ #{x\ 749}#)))
+ (let ((#{v\ 756}# (make-vector
+ #{n\ 755}#)))
+ (letrec ((#{loop\ 757}#
+ (lambda (#{i\ 758}#)
+ (if (#{fx=\ 88}#
+ #{i\ 758}#
+ #{n\ 755}#)
(begin
(if #f #f)
- #{v\ 1622}#)
+ #{v\ 756}#)
(begin
(vector-set!
- #{v\ 1622}#
- #{i\ 1624}#
- (#{rebuild-macro-output\ 1614}#
+ #{v\ 756}#
+ #{i\ 758}#
+ (#{rebuild-macro-output\ 748}#
(vector-ref
- #{x\ 1615}#
- #{i\ 1624}#)
- #{m\ 1616}#))
- (#{loop\ 1623}#
- (#{fx+\ 1254}#
- #{i\ 1624}#
+ #{x\ 749}#
+ #{i\ 758}#)
+ #{m\ 750}#))
+ (#{loop\ 757}#
+ (#{fx+\ 86}#
+ #{i\ 758}#
1)))))))
- (#{loop\ 1623}# 0))))
- (if (symbol? #{x\ 1615}#)
+ (#{loop\ 757}# 0))))
+ (if (symbol? #{x\ 749}#)
(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}#))
+ (#{source-wrap\ 160}#
+ #{e\ 743}#
+ #{w\ 745}#
+ (#{wrap-subst\ 135}# #{w\ 745}#)
+ #{mod\ 747}#)
+ #{x\ 749}#)
+ #{x\ 749}#)))))))
+ (#{rebuild-macro-output\ 748}#
+ (#{p\ 742}# (#{wrap\ 159}#
+ #{e\ 743}#
+ (#{anti-mark\ 146}# #{w\ 745}#)
+ #{mod\ 747}#))
(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}#)
+ (#{chi-application\ 169}#
+ (lambda (#{x\ 759}#
+ #{e\ 760}#
+ #{r\ 761}#
+ #{w\ 762}#
+ #{s\ 763}#
+ #{mod\ 764}#)
+ ((lambda (#{tmp\ 765}#)
+ ((lambda (#{tmp\ 766}#)
+ (if #{tmp\ 766}#
+ (apply (lambda (#{e0\ 767}# #{e1\ 768}#)
+ (#{build-application\ 96}#
+ #{s\ 763}#
+ #{x\ 759}#
+ (map (lambda (#{e\ 769}#)
+ (#{chi\ 167}#
+ #{e\ 769}#
+ #{r\ 761}#
+ #{w\ 762}#
+ #{mod\ 764}#))
+ #{e1\ 768}#)))
+ #{tmp\ 766}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1631}#)))
+ #{tmp\ 765}#)))
($sc-dispatch
- #{tmp\ 1631}#
+ #{tmp\ 765}#
'(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}#
+ #{e\ 760}#)))
+ (#{chi-expr\ 168}#
+ (lambda (#{type\ 771}#
+ #{value\ 772}#
+ #{e\ 773}#
+ #{r\ 774}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#)
+ (if (memv #{type\ 771}# (quote (lexical)))
+ (#{build-lexical-reference\ 98}#
'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)))
+ #{s\ 776}#
+ #{e\ 773}#
+ #{value\ 772}#)
+ (if (memv #{type\ 771}# (quote (core core-form)))
+ (#{value\ 772}#
+ #{e\ 773}#
+ #{r\ 774}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#)
+ (if (memv #{type\ 771}# (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}#
+ (lambda () (#{value\ 772}# #{e\ 773}#))
+ (lambda (#{id\ 778}# #{mod\ 779}#)
+ (#{build-global-reference\ 101}#
+ #{s\ 776}#
+ #{id\ 778}#
+ #{mod\ 779}#)))
+ (if (memv #{type\ 771}# (quote (lexical-call)))
+ (#{chi-application\ 169}#
+ (#{build-lexical-reference\ 98}#
'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}#)
+ (#{source-annotation\ 122}# (car #{e\ 773}#))
+ (car #{e\ 773}#)
+ #{value\ 772}#)
+ #{e\ 773}#
+ #{r\ 774}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#)
+ (if (memv #{type\ 771}# (quote (global-call)))
+ (#{chi-application\ 169}#
+ (#{build-global-reference\ 101}#
+ (#{source-annotation\ 122}# (car #{e\ 773}#))
+ (if (#{syntax-object?\ 115}# #{value\ 772}#)
+ (#{syntax-object-expression\ 116}#
+ #{value\ 772}#)
+ #{value\ 772}#)
+ (if (#{syntax-object?\ 115}# #{value\ 772}#)
+ (#{syntax-object-module\ 118}# #{value\ 772}#)
+ #{mod\ 777}#))
+ #{e\ 773}#
+ #{r\ 774}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#)
+ (if (memv #{type\ 771}# (quote (constant)))
+ (#{build-data\ 109}#
+ #{s\ 776}#
+ (#{strip\ 180}#
+ (#{source-wrap\ 160}#
+ #{e\ 773}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#)
'(())))
- (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}#)
+ (if (memv #{type\ 771}# (quote (global)))
+ (#{build-global-reference\ 101}#
+ #{s\ 776}#
+ #{value\ 772}#
+ #{mod\ 777}#)
+ (if (memv #{type\ 771}# (quote (call)))
+ (#{chi-application\ 169}#
+ (#{chi\ 167}#
+ (car #{e\ 773}#)
+ #{r\ 774}#
+ #{w\ 775}#
+ #{mod\ 777}#)
+ #{e\ 773}#
+ #{r\ 774}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#)
+ (if (memv #{type\ 771}# (quote (begin-form)))
+ ((lambda (#{tmp\ 780}#)
+ ((lambda (#{tmp\ 781}#)
+ (if #{tmp\ 781}#
+ (apply (lambda (#{_\ 782}#
+ #{e1\ 783}#
+ #{e2\ 784}#)
+ (#{chi-sequence\ 161}#
+ (cons #{e1\ 783}#
+ #{e2\ 784}#)
+ #{r\ 774}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#))
+ #{tmp\ 781}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1646}#)))
+ #{tmp\ 780}#)))
($sc-dispatch
- #{tmp\ 1646}#
+ #{tmp\ 780}#
'(any any . each-any))))
- #{e\ 1639}#)
- (if (memv #{type\ 1637}#
+ #{e\ 773}#)
+ (if (memv #{type\ 771}#
'(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}#
+ (#{chi-local-syntax\ 172}#
+ #{value\ 772}#
+ #{e\ 773}#
+ #{r\ 774}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#
+ #{chi-sequence\ 161}#)
+ (if (memv #{type\ 771}#
'(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}#)))
+ ((lambda (#{tmp\ 786}#)
+ ((lambda (#{tmp\ 787}#)
+ (if #{tmp\ 787}#
+ (apply (lambda (#{_\ 788}#
+ #{x\ 789}#
+ #{e1\ 790}#
+ #{e2\ 791}#)
+ (let ((#{when-list\ 792}#
+ (#{chi-when-list\ 164}#
+ #{e\ 773}#
+ #{x\ 789}#
+ #{w\ 775}#)))
(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}#)
+ #{when-list\ 792}#)
+ (#{chi-sequence\ 161}#
+ (cons #{e1\ 790}#
+ #{e2\ 791}#)
+ #{r\ 774}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#)
+ (#{chi-void\ 174}#))))
+ #{tmp\ 787}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1652}#)))
+ #{tmp\ 786}#)))
($sc-dispatch
- #{tmp\ 1652}#
+ #{tmp\ 786}#
'(any each-any any . each-any))))
- #{e\ 1639}#)
- (if (memv #{type\ 1637}#
+ #{e\ 773}#)
+ (if (memv #{type\ 771}#
'(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}#
+ #{e\ 773}#
+ (#{wrap\ 159}#
+ #{value\ 772}#
+ #{w\ 775}#
+ #{mod\ 777}#))
+ (if (memv #{type\ 771}#
'(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}#
+ (#{source-wrap\ 160}#
+ #{e\ 773}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#))
+ (if (memv #{type\ 771}#
'(displaced-lexical))
(syntax-violation
#f
"reference to identifier outside its scope"
- (#{source-wrap\ 1326}#
- #{e\ 1639}#
- #{w\ 1641}#
- #{s\ 1642}#
- #{mod\ 1643}#))
+ (#{source-wrap\ 160}#
+ #{e\ 773}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#))
(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}#)
+ (#{source-wrap\ 160}#
+ #{e\ 773}#
+ #{w\ 775}#
+ #{s\ 776}#
+ #{mod\ 777}#))))))))))))))))))
+ (#{chi\ 167}#
+ (lambda (#{e\ 795}# #{r\ 796}# #{w\ 797}# #{mod\ 798}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 1331}#
- #{e\ 1661}#
- #{r\ 1662}#
- #{w\ 1663}#
- (#{source-annotation\ 1288}# #{e\ 1661}#)
+ (#{syntax-type\ 165}#
+ #{e\ 795}#
+ #{r\ 796}#
+ #{w\ 797}#
+ (#{source-annotation\ 122}# #{e\ 795}#)
#f
- #{mod\ 1664}#
+ #{mod\ 798}#
#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}#)
+ (lambda (#{type\ 799}#
+ #{value\ 800}#
+ #{e\ 801}#
+ #{w\ 802}#
+ #{s\ 803}#
+ #{mod\ 804}#)
+ (#{chi-expr\ 168}#
+ #{type\ 799}#
+ #{value\ 800}#
+ #{e\ 801}#
+ #{r\ 796}#
+ #{w\ 802}#
+ #{s\ 803}#
+ #{mod\ 804}#)))))
+ (#{chi-top\ 166}#
+ (lambda (#{e\ 805}#
+ #{r\ 806}#
+ #{w\ 807}#
+ #{m\ 808}#
+ #{esew\ 809}#
+ #{mod\ 810}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 1331}#
- #{e\ 1671}#
- #{r\ 1672}#
- #{w\ 1673}#
- (#{source-annotation\ 1288}# #{e\ 1671}#)
+ (#{syntax-type\ 165}#
+ #{e\ 805}#
+ #{r\ 806}#
+ #{w\ 807}#
+ (#{source-annotation\ 122}# #{e\ 805}#)
#f
- #{mod\ 1676}#
+ #{mod\ 810}#
#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}#)
+ (lambda (#{type\ 818}#
+ #{value\ 819}#
+ #{e\ 820}#
+ #{w\ 821}#
+ #{s\ 822}#
+ #{mod\ 823}#)
+ (if (memv #{type\ 818}# (quote (begin-form)))
+ ((lambda (#{tmp\ 824}#)
+ ((lambda (#{tmp\ 825}#)
+ (if #{tmp\ 825}#
+ (apply (lambda (#{_\ 826}#) (#{chi-void\ 174}#))
+ #{tmp\ 825}#)
+ ((lambda (#{tmp\ 827}#)
+ (if #{tmp\ 827}#
+ (apply (lambda (#{_\ 828}#
+ #{e1\ 829}#
+ #{e2\ 830}#)
+ (#{chi-top-sequence\ 162}#
+ (cons #{e1\ 829}# #{e2\ 830}#)
+ #{r\ 806}#
+ #{w\ 821}#
+ #{s\ 822}#
+ #{m\ 808}#
+ #{esew\ 809}#
+ #{mod\ 823}#))
+ #{tmp\ 827}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1690}#)))
+ #{tmp\ 824}#)))
($sc-dispatch
- #{tmp\ 1690}#
+ #{tmp\ 824}#
'(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))
+ ($sc-dispatch #{tmp\ 824}# (quote (any)))))
+ #{e\ 820}#)
+ (if (memv #{type\ 818}# (quote (local-syntax-form)))
+ (#{chi-local-syntax\ 172}#
+ #{value\ 819}#
+ #{e\ 820}#
+ #{r\ 806}#
+ #{w\ 821}#
+ #{s\ 822}#
+ #{mod\ 823}#
+ (lambda (#{body\ 832}#
+ #{r\ 833}#
+ #{w\ 834}#
+ #{s\ 835}#
+ #{mod\ 836}#)
+ (#{chi-top-sequence\ 162}#
+ #{body\ 832}#
+ #{r\ 833}#
+ #{w\ 834}#
+ #{s\ 835}#
+ #{m\ 808}#
+ #{esew\ 809}#
+ #{mod\ 836}#)))
+ (if (memv #{type\ 818}# (quote (eval-when-form)))
+ ((lambda (#{tmp\ 837}#)
+ ((lambda (#{tmp\ 838}#)
+ (if #{tmp\ 838}#
+ (apply (lambda (#{_\ 839}#
+ #{x\ 840}#
+ #{e1\ 841}#
+ #{e2\ 842}#)
+ (let ((#{when-list\ 843}#
+ (#{chi-when-list\ 164}#
+ #{e\ 820}#
+ #{x\ 840}#
+ #{w\ 821}#))
+ (#{body\ 844}#
+ (cons #{e1\ 841}#
+ #{e2\ 842}#)))
+ (if (eq? #{m\ 808}# (quote e))
(if (memq 'eval
- #{when-list\ 1709}#)
- (#{chi-top-sequence\ 1328}#
- #{body\ 1710}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
+ #{when-list\ 843}#)
+ (#{chi-top-sequence\ 162}#
+ #{body\ 844}#
+ #{r\ 806}#
+ #{w\ 821}#
+ #{s\ 822}#
'e
'(eval)
- #{mod\ 1689}#)
- (#{chi-void\ 1341}#))
+ #{mod\ 823}#)
+ (#{chi-void\ 174}#))
(if (memq 'load
- #{when-list\ 1709}#)
- (if (let ((#{t\ 1713}#
- (memq 'compile
- #{when-list\ 1709}#)))
- (if #{t\ 1713}#
- #{t\ 1713}#
- (if (eq? #{m\ 1674}#
+ #{when-list\ 843}#)
+ (if (let ((#{t\ 847}# (memq 'compile
+ #{when-list\ 843}#)))
+ (if #{t\ 847}#
+ #{t\ 847}#
+ (if (eq? #{m\ 808}#
'c&e)
(memq 'eval
- #{when-list\ 1709}#)
+ #{when-list\ 843}#)
#f)))
- (#{chi-top-sequence\ 1328}#
- #{body\ 1710}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
+ (#{chi-top-sequence\ 162}#
+ #{body\ 844}#
+ #{r\ 806}#
+ #{w\ 821}#
+ #{s\ 822}#
'c&e
'(compile load)
- #{mod\ 1689}#)
- (if (memq #{m\ 1674}#
+ #{mod\ 823}#)
+ (if (memq #{m\ 808}#
'(c c&e))
- (#{chi-top-sequence\ 1328}#
- #{body\ 1710}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
+ (#{chi-top-sequence\ 162}#
+ #{body\ 844}#
+ #{r\ 806}#
+ #{w\ 821}#
+ #{s\ 822}#
'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}#
+ #{mod\ 823}#)
+ (#{chi-void\ 174}#)))
+ (if (let ((#{t\ 848}# (memq 'compile
+ #{when-list\ 843}#)))
+ (if #{t\ 848}#
+ #{t\ 848}#
+ (if (eq? #{m\ 808}#
'c&e)
(memq 'eval
- #{when-list\ 1709}#)
+ #{when-list\ 843}#)
#f)))
(begin
- (#{top-level-eval-hook\ 1258}#
- (#{chi-top-sequence\ 1328}#
- #{body\ 1710}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{s\ 1688}#
+ (#{top-level-eval-hook\ 90}#
+ (#{chi-top-sequence\ 162}#
+ #{body\ 844}#
+ #{r\ 806}#
+ #{w\ 821}#
+ #{s\ 822}#
'e
'(eval)
- #{mod\ 1689}#)
- #{mod\ 1689}#)
- (#{chi-void\ 1341}#))
- (#{chi-void\ 1341}#))))))
- #{tmp\ 1704}#)
+ #{mod\ 823}#)
+ #{mod\ 823}#)
+ (#{chi-void\ 174}#))
+ (#{chi-void\ 174}#))))))
+ #{tmp\ 838}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1703}#)))
+ #{tmp\ 837}#)))
($sc-dispatch
- #{tmp\ 1703}#
+ #{tmp\ 837}#
'(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}#))))
+ #{e\ 820}#)
+ (if (memv #{type\ 818}# (quote (define-syntax-form)))
+ (let ((#{n\ 849}# (#{id-var-name\ 153}#
+ #{value\ 819}#
+ #{w\ 821}#))
+ (#{r\ 850}# (#{macros-only-env\ 127}#
+ #{r\ 806}#)))
+ (if (memv #{m\ 808}# (quote (c)))
+ (if (memq (quote compile) #{esew\ 809}#)
+ (let ((#{e\ 851}# (#{chi-install-global\ 163}#
+ #{n\ 849}#
+ (#{chi\ 167}#
+ #{e\ 820}#
+ #{r\ 850}#
+ #{w\ 821}#
+ #{mod\ 823}#))))
(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}#))))
+ (#{top-level-eval-hook\ 90}#
+ #{e\ 851}#
+ #{mod\ 823}#)
+ (if (memq (quote load) #{esew\ 809}#)
+ #{e\ 851}#
+ (#{chi-void\ 174}#))))
+ (if (memq (quote load) #{esew\ 809}#)
+ (#{chi-install-global\ 163}#
+ #{n\ 849}#
+ (#{chi\ 167}#
+ #{e\ 820}#
+ #{r\ 850}#
+ #{w\ 821}#
+ #{mod\ 823}#))
+ (#{chi-void\ 174}#)))
+ (if (memv #{m\ 808}# (quote (c&e)))
+ (let ((#{e\ 852}# (#{chi-install-global\ 163}#
+ #{n\ 849}#
+ (#{chi\ 167}#
+ #{e\ 820}#
+ #{r\ 850}#
+ #{w\ 821}#
+ #{mod\ 823}#))))
(begin
- (#{top-level-eval-hook\ 1258}#
- #{e\ 1718}#
- #{mod\ 1689}#)
- #{e\ 1718}#))
+ (#{top-level-eval-hook\ 90}#
+ #{e\ 852}#
+ #{mod\ 823}#)
+ #{e\ 852}#))
(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}#
+ (if (memq (quote eval) #{esew\ 809}#)
+ (#{top-level-eval-hook\ 90}#
+ (#{chi-install-global\ 163}#
+ #{n\ 849}#
+ (#{chi\ 167}#
+ #{e\ 820}#
+ #{r\ 850}#
+ #{w\ 821}#
+ #{mod\ 823}#))
+ #{mod\ 823}#))
+ (#{chi-void\ 174}#)))))
+ (if (memv #{type\ 818}# (quote (define-form)))
+ (let ((#{n\ 853}# (#{id-var-name\ 153}#
+ #{value\ 819}#
+ #{w\ 821}#)))
+ (let ((#{type\ 854}#
+ (#{binding-type\ 123}#
+ (#{lookup\ 128}#
+ #{n\ 853}#
+ #{r\ 806}#
+ #{mod\ 823}#))))
+ (if (memv #{type\ 854}#
'(global core macro module-ref))
(begin
(if (if (not (module-local-variable
(current-module)
- #{n\ 1719}#))
+ #{n\ 853}#))
(current-module)
#f)
- (let ((#{old\ 1721}#
+ (let ((#{old\ 855}#
(module-variable
(current-module)
- #{n\ 1719}#)))
+ #{n\ 853}#)))
(module-define!
(current-module)
- #{n\ 1719}#
- (if (variable? #{old\ 1721}#)
- (variable-ref #{old\ 1721}#)
+ #{n\ 853}#
+ (if (variable? #{old\ 855}#)
+ (variable-ref #{old\ 855}#)
#f))))
- (let ((#{x\ 1722}#
- (#{build-global-definition\ 1272}#
- #{s\ 1688}#
- #{n\ 1719}#
- (#{chi\ 1333}#
- #{e\ 1686}#
- #{r\ 1672}#
- #{w\ 1687}#
- #{mod\ 1689}#))))
+ (let ((#{x\ 856}# (#{build-global-definition\ 104}#
+ #{s\ 822}#
+ #{n\ 853}#
+ (#{chi\ 167}#
+ #{e\ 820}#
+ #{r\ 806}#
+ #{w\ 821}#
+ #{mod\ 823}#))))
(begin
- (if (eq? #{m\ 1674}# (quote c&e))
- (#{top-level-eval-hook\ 1258}#
- #{x\ 1722}#
- #{mod\ 1689}#))
- #{x\ 1722}#)))
- (if (memv #{type\ 1720}#
+ (if (eq? #{m\ 808}# (quote c&e))
+ (#{top-level-eval-hook\ 90}#
+ #{x\ 856}#
+ #{mod\ 823}#))
+ #{x\ 856}#)))
+ (if (memv #{type\ 854}#
'(displaced-lexical))
(syntax-violation
#f
"identifier out of context"
- #{e\ 1686}#
- (#{wrap\ 1325}#
- #{value\ 1685}#
- #{w\ 1687}#
- #{mod\ 1689}#))
+ #{e\ 820}#
+ (#{wrap\ 159}#
+ #{value\ 819}#
+ #{w\ 821}#
+ #{mod\ 823}#))
(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}#)))
+ #{e\ 820}#
+ (#{wrap\ 159}#
+ #{value\ 819}#
+ #{w\ 821}#
+ #{mod\ 823}#))))))
+ (let ((#{x\ 857}# (#{chi-expr\ 168}#
+ #{type\ 818}#
+ #{value\ 819}#
+ #{e\ 820}#
+ #{r\ 806}#
+ #{w\ 821}#
+ #{s\ 822}#
+ #{mod\ 823}#)))
(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)))
+ (if (eq? #{m\ 808}# (quote c&e))
+ (#{top-level-eval-hook\ 90}#
+ #{x\ 857}#
+ #{mod\ 823}#))
+ #{x\ 857}#)))))))))))
+ (#{syntax-type\ 165}#
+ (lambda (#{e\ 858}#
+ #{r\ 859}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{rib\ 862}#
+ #{mod\ 863}#
+ #{for-car?\ 864}#)
+ (if (symbol? #{e\ 858}#)
+ (let ((#{n\ 865}# (#{id-var-name\ 153}#
+ #{e\ 858}#
+ #{w\ 860}#)))
+ (let ((#{b\ 866}# (#{lookup\ 128}#
+ #{n\ 865}#
+ #{r\ 859}#
+ #{mod\ 863}#)))
+ (let ((#{type\ 867}#
+ (#{binding-type\ 123}# #{b\ 866}#)))
+ (if (memv #{type\ 867}# (quote (lexical)))
(values
- #{type\ 1733}#
- (#{binding-value\ 1290}# #{b\ 1732}#)
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{type\ 1733}# (quote (global)))
+ #{type\ 867}#
+ (#{binding-value\ 124}# #{b\ 866}#)
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)
+ (if (memv #{type\ 867}# (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}#
+ #{type\ 867}#
+ #{n\ 865}#
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)
+ (if (memv #{type\ 867}# (quote (macro)))
+ (if #{for-car?\ 864}#
(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}#
+ #{type\ 867}#
+ (#{binding-value\ 124}# #{b\ 866}#)
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)
+ (#{syntax-type\ 165}#
+ (#{chi-macro\ 170}#
+ (#{binding-value\ 124}# #{b\ 866}#)
+ #{e\ 858}#
+ #{r\ 859}#
+ #{w\ 860}#
+ #{rib\ 862}#
+ #{mod\ 863}#)
+ #{r\ 859}#
'(())
- #{s\ 1727}#
- #{rib\ 1728}#
- #{mod\ 1729}#
+ #{s\ 861}#
+ #{rib\ 862}#
+ #{mod\ 863}#
#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}#)))
+ #{type\ 867}#
+ (#{binding-value\ 124}# #{b\ 866}#)
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)))))))
+ (if (pair? #{e\ 858}#)
+ (let ((#{first\ 868}# (car #{e\ 858}#)))
(call-with-values
(lambda ()
- (#{syntax-type\ 1331}#
- #{first\ 1734}#
- #{r\ 1725}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{rib\ 1728}#
- #{mod\ 1729}#
+ (#{syntax-type\ 165}#
+ #{first\ 868}#
+ #{r\ 859}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{rib\ 862}#
+ #{mod\ 863}#
#t))
- (lambda (#{ftype\ 1735}#
- #{fval\ 1736}#
- #{fe\ 1737}#
- #{fw\ 1738}#
- #{fs\ 1739}#
- #{fmod\ 1740}#)
- (if (memv #{ftype\ 1735}# (quote (lexical)))
+ (lambda (#{ftype\ 869}#
+ #{fval\ 870}#
+ #{fe\ 871}#
+ #{fw\ 872}#
+ #{fs\ 873}#
+ #{fmod\ 874}#)
+ (if (memv #{ftype\ 869}# (quote (lexical)))
(values
'lexical-call
- #{fval\ 1736}#
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}# (quote (global)))
+ #{fval\ 870}#
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)
+ (if (memv #{ftype\ 869}# (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}#
+ (#{make-syntax-object\ 114}#
+ #{fval\ 870}#
+ #{w\ 860}#
+ #{fmod\ 874}#)
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)
+ (if (memv #{ftype\ 869}# (quote (macro)))
+ (#{syntax-type\ 165}#
+ (#{chi-macro\ 170}#
+ #{fval\ 870}#
+ #{e\ 858}#
+ #{r\ 859}#
+ #{w\ 860}#
+ #{rib\ 862}#
+ #{mod\ 863}#)
+ #{r\ 859}#
'(())
- #{s\ 1727}#
- #{rib\ 1728}#
- #{mod\ 1729}#
- #{for-car?\ 1730}#)
- (if (memv #{ftype\ 1735}# (quote (module-ref)))
+ #{s\ 861}#
+ #{rib\ 862}#
+ #{mod\ 863}#
+ #{for-car?\ 864}#)
+ (if (memv #{ftype\ 869}# (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)))
+ (lambda () (#{fval\ 870}# #{e\ 858}#))
+ (lambda (#{sym\ 875}# #{mod\ 876}#)
+ (#{syntax-type\ 165}#
+ #{sym\ 875}#
+ #{r\ 859}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{rib\ 862}#
+ #{mod\ 876}#
+ #{for-car?\ 864}#)))
+ (if (memv #{ftype\ 869}# (quote (core)))
(values
'core-form
- #{fval\ 1736}#
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}#
+ #{fval\ 870}#
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)
+ (if (memv #{ftype\ 869}#
'(local-syntax))
(values
'local-syntax-form
- #{fval\ 1736}#
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}# (quote (begin)))
+ #{fval\ 870}#
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)
+ (if (memv #{ftype\ 869}# (quote (begin)))
(values
'begin-form
#f
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}#
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)
+ (if (memv #{ftype\ 869}#
'(eval-when))
(values
'eval-when-form
#f
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
- (if (memv #{ftype\ 1735}#
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)
+ (if (memv #{ftype\ 869}#
'(define))
- ((lambda (#{tmp\ 1743}#)
- ((lambda (#{tmp\ 1744}#)
- (if (if #{tmp\ 1744}#
- (apply (lambda (#{_\ 1745}#
- #{name\ 1746}#
- #{val\ 1747}#)
- (#{id?\ 1297}#
- #{name\ 1746}#))
- #{tmp\ 1744}#)
+ ((lambda (#{tmp\ 877}#)
+ ((lambda (#{tmp\ 878}#)
+ (if (if #{tmp\ 878}#
+ (apply (lambda (#{_\ 879}#
+ #{name\ 880}#
+ #{val\ 881}#)
+ (#{id?\ 131}#
+ #{name\ 880}#))
+ #{tmp\ 878}#)
#f)
- (apply (lambda (#{_\ 1748}#
- #{name\ 1749}#
- #{val\ 1750}#)
+ (apply (lambda (#{_\ 882}#
+ #{name\ 883}#
+ #{val\ 884}#)
(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}#))
+ #{name\ 883}#
+ #{val\ 884}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#))
+ #{tmp\ 878}#)
+ ((lambda (#{tmp\ 885}#)
+ (if (if #{tmp\ 885}#
+ (apply (lambda (#{_\ 886}#
+ #{name\ 887}#
+ #{args\ 888}#
+ #{e1\ 889}#
+ #{e2\ 890}#)
+ (if (#{id?\ 131}#
+ #{name\ 887}#)
+ (#{valid-bound-ids?\ 156}#
+ (#{lambda-var-list\ 182}#
+ #{args\ 888}#))
#f))
- #{tmp\ 1751}#)
+ #{tmp\ 885}#)
#f)
- (apply (lambda (#{_\ 1757}#
- #{name\ 1758}#
- #{args\ 1759}#
- #{e1\ 1760}#
- #{e2\ 1761}#)
+ (apply (lambda (#{_\ 891}#
+ #{name\ 892}#
+ #{args\ 893}#
+ #{e1\ 894}#
+ #{e2\ 895}#)
(values
'define-form
- (#{wrap\ 1325}#
- #{name\ 1758}#
- #{w\ 1726}#
- #{mod\ 1729}#)
- (#{decorate-source\ 1262}#
+ (#{wrap\ 159}#
+ #{name\ 892}#
+ #{w\ 860}#
+ #{mod\ 863}#)
+ (#{decorate-source\ 94}#
(cons '#(syntax-object
lambda
((top)
@@ -1953,11 +3844,14 @@
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -2039,7 +3933,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -2173,6 +4069,11 @@
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
@@ -2285,6 +4186,11 @@
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -2295,33 +4201,33 @@
"i")))
(hygiene
guile))
- (#{wrap\ 1325}#
- (cons #{args\ 1759}#
- (cons #{e1\ 1760}#
- #{e2\ 1761}#))
- #{w\ 1726}#
- #{mod\ 1729}#))
- #{s\ 1727}#)
+ (#{wrap\ 159}#
+ (cons #{args\ 893}#
+ (cons #{e1\ 894}#
+ #{e2\ 895}#))
+ #{w\ 860}#
+ #{mod\ 863}#))
+ #{s\ 861}#)
'(())
- #{s\ 1727}#
- #{mod\ 1729}#))
- #{tmp\ 1751}#)
- ((lambda (#{tmp\ 1763}#)
- (if (if #{tmp\ 1763}#
- (apply (lambda (#{_\ 1764}#
- #{name\ 1765}#)
- (#{id?\ 1297}#
- #{name\ 1765}#))
- #{tmp\ 1763}#)
+ #{s\ 861}#
+ #{mod\ 863}#))
+ #{tmp\ 885}#)
+ ((lambda (#{tmp\ 897}#)
+ (if (if #{tmp\ 897}#
+ (apply (lambda (#{_\ 898}#
+ #{name\ 899}#)
+ (#{id?\ 131}#
+ #{name\ 899}#))
+ #{tmp\ 897}#)
#f)
- (apply (lambda (#{_\ 1766}#
- #{name\ 1767}#)
+ (apply (lambda (#{_\ 900}#
+ #{name\ 901}#)
(values
'define-form
- (#{wrap\ 1325}#
- #{name\ 1767}#
- #{w\ 1726}#
- #{mod\ 1729}#)
+ (#{wrap\ 159}#
+ #{name\ 901}#
+ #{w\ 860}#
+ #{mod\ 863}#)
'(#(syntax-object
if
((top)
@@ -2405,11 +4311,14 @@
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -2491,7 +4400,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -2625,6 +4536,11 @@
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
@@ -2737,6 +4653,11 @@
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -2830,11 +4751,14 @@
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -2916,7 +4840,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -3050,6 +4976,11 @@
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
@@ -3162,6 +5093,11 @@
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -3255,11 +5191,14 @@
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -3341,7 +5280,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -3475,6 +5416,11 @@
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
@@ -3587,6 +5533,11 @@
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -3598,3179 +5549,3637 @@
(hygiene
guile)))
'(())
- #{s\ 1727}#
- #{mod\ 1729}#))
- #{tmp\ 1763}#)
+ #{s\ 861}#
+ #{mod\ 863}#))
+ #{tmp\ 897}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1743}#)))
+ #{tmp\ 877}#)))
($sc-dispatch
- #{tmp\ 1743}#
+ #{tmp\ 877}#
'(any any)))))
($sc-dispatch
- #{tmp\ 1743}#
+ #{tmp\ 877}#
'(any (any . any)
any
.
each-any)))))
($sc-dispatch
- #{tmp\ 1743}#
+ #{tmp\ 877}#
'(any any any))))
- #{e\ 1724}#)
- (if (memv #{ftype\ 1735}#
+ #{e\ 858}#)
+ (if (memv #{ftype\ 869}#
'(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}#)
+ ((lambda (#{tmp\ 902}#)
+ ((lambda (#{tmp\ 903}#)
+ (if (if #{tmp\ 903}#
+ (apply (lambda (#{_\ 904}#
+ #{name\ 905}#
+ #{val\ 906}#)
+ (#{id?\ 131}#
+ #{name\ 905}#))
+ #{tmp\ 903}#)
#f)
- (apply (lambda (#{_\ 1773}#
- #{name\ 1774}#
- #{val\ 1775}#)
+ (apply (lambda (#{_\ 907}#
+ #{name\ 908}#
+ #{val\ 909}#)
(values
'define-syntax-form
- #{name\ 1774}#
- #{val\ 1775}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#))
- #{tmp\ 1769}#)
+ #{name\ 908}#
+ #{val\ 909}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#))
+ #{tmp\ 903}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 1768}#)))
+ #{tmp\ 902}#)))
($sc-dispatch
- #{tmp\ 1768}#
+ #{tmp\ 902}#
'(any any any))))
- #{e\ 1724}#)
+ #{e\ 858}#)
(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}#)
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#))))))))))))))
+ (if (#{syntax-object?\ 115}# #{e\ 858}#)
+ (#{syntax-type\ 165}#
+ (#{syntax-object-expression\ 116}# #{e\ 858}#)
+ #{r\ 859}#
+ (#{join-wraps\ 150}#
+ #{w\ 860}#
+ (#{syntax-object-wrap\ 117}# #{e\ 858}#))
+ #{s\ 861}#
+ #{rib\ 862}#
+ (let ((#{t\ 910}# (#{syntax-object-module\ 118}#
+ #{e\ 858}#)))
+ (if #{t\ 910}# #{t\ 910}# #{mod\ 863}#))
+ #{for-car?\ 864}#)
+ (if (self-evaluating? #{e\ 858}#)
(values
'constant
#f
- #{e\ 1724}#
- #{w\ 1726}#
- #{s\ 1727}#
- #{mod\ 1729}#)
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)
(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}#
+ #{e\ 858}#
+ #{w\ 860}#
+ #{s\ 861}#
+ #{mod\ 863}#)))))))
+ (#{chi-when-list\ 164}#
+ (lambda (#{e\ 911}# #{when-list\ 912}# #{w\ 913}#)
+ (letrec ((#{f\ 914}# (lambda (#{when-list\ 915}#
+ #{situations\ 916}#)
+ (if (null? #{when-list\ 915}#)
+ #{situations\ 916}#
+ (#{f\ 914}# (cdr #{when-list\ 915}#)
+ (cons (let ((#{x\ 917}# (car #{when-list\ 915}#)))
+ (if (#{free-id=?\ 154}#
+ #{x\ 917}#
+ '#(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
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top)
+ (top))
+ ("i"
+ "i")))
+ (hygiene
+ guile)))
+ 'compile
+ (if (#{free-id=?\ 154}#
+ #{x\ 917}#
+ '#(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
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top)
+ (top))
+ ("i"
+ "i")))
+ (hygiene
+ guile)))
+ 'load
+ (if (#{free-id=?\ 154}#
+ #{x\ 917}#
+ '#(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
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top)
+ (top))
+ ("i"
+ "i")))
+ (hygiene
+ guile)))
+ 'eval
+ (syntax-violation
+ 'eval-when
+ "invalid situation"
+ #{e\ 911}#
+ (#{wrap\ 159}#
+ #{x\ 917}#
+ #{w\ 913}#
+ #f))))))
+ #{situations\ 916}#))))))
+ (#{f\ 914}# #{when-list\ 912}# (quote ())))))
+ (#{chi-install-global\ 163}#
+ (lambda (#{name\ 918}# #{e\ 919}#)
+ (#{build-global-definition\ 104}#
#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}#))
+ #{name\ 918}#
+ (if (let ((#{v\ 920}# (module-variable
+ (current-module)
+ #{name\ 918}#)))
+ (if #{v\ 920}#
+ (if (variable-bound? #{v\ 920}#)
+ (if (macro? (variable-ref #{v\ 920}#))
+ (not (eq? (macro-type (variable-ref #{v\ 920}#))
'syncase-macro))
#f)
#f)
#f))
- (#{build-application\ 1264}#
+ (#{build-application\ 96}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 108}#
#f
'make-extended-syncase-macro)
- (list (#{build-application\ 1264}#
+ (list (#{build-application\ 96}#
#f
- (#{build-primref\ 1274}# #f (quote module-ref))
- (list (#{build-application\ 1264}#
+ (#{build-primref\ 108}# #f (quote module-ref))
+ (list (#{build-application\ 96}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 108}#
#f
'current-module)
'())
- (#{build-data\ 1275}# #f #{name\ 1784}#)))
- (#{build-data\ 1275}# #f (quote macro))
- #{e\ 1785}#))
- (#{build-application\ 1264}#
+ (#{build-data\ 109}# #f #{name\ 918}#)))
+ (#{build-data\ 109}# #f (quote macro))
+ #{e\ 919}#))
+ (#{build-application\ 96}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 108}#
#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}#)
+ (list (#{build-data\ 109}# #f (quote macro))
+ #{e\ 919}#))))))
+ (#{chi-top-sequence\ 162}#
+ (lambda (#{body\ 921}#
+ #{r\ 922}#
+ #{w\ 923}#
+ #{s\ 924}#
+ #{m\ 925}#
+ #{esew\ 926}#
+ #{mod\ 927}#)
+ (#{build-sequence\ 110}#
+ #{s\ 924}#
+ (letrec ((#{dobody\ 928}#
+ (lambda (#{body\ 929}#
+ #{r\ 930}#
+ #{w\ 931}#
+ #{m\ 932}#
+ #{esew\ 933}#
+ #{mod\ 934}#)
+ (if (null? #{body\ 929}#)
'()
- (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\ 935}#
+ (#{chi-top\ 166}#
+ (car #{body\ 929}#)
+ #{r\ 930}#
+ #{w\ 931}#
+ #{m\ 932}#
+ #{esew\ 933}#
+ #{mod\ 934}#)))
+ (cons #{first\ 935}#
+ (#{dobody\ 928}#
+ (cdr #{body\ 929}#)
+ #{r\ 930}#
+ #{w\ 931}#
+ #{m\ 932}#
+ #{esew\ 933}#
+ #{mod\ 934}#)))))))
+ (#{dobody\ 928}#
+ #{body\ 921}#
+ #{r\ 922}#
+ #{w\ 923}#
+ #{m\ 925}#
+ #{esew\ 926}#
+ #{mod\ 927}#)))))
+ (#{chi-sequence\ 161}#
+ (lambda (#{body\ 936}#
+ #{r\ 937}#
+ #{w\ 938}#
+ #{s\ 939}#
+ #{mod\ 940}#)
+ (#{build-sequence\ 110}#
+ #{s\ 939}#
+ (letrec ((#{dobody\ 941}#
+ (lambda (#{body\ 942}#
+ #{r\ 943}#
+ #{w\ 944}#
+ #{mod\ 945}#)
+ (if (null? #{body\ 942}#)
'()
- (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}#))
+ (let ((#{first\ 946}#
+ (#{chi\ 167}#
+ (car #{body\ 942}#)
+ #{r\ 943}#
+ #{w\ 944}#
+ #{mod\ 945}#)))
+ (cons #{first\ 946}#
+ (#{dobody\ 941}#
+ (cdr #{body\ 942}#)
+ #{r\ 943}#
+ #{w\ 944}#
+ #{mod\ 945}#)))))))
+ (#{dobody\ 941}#
+ #{body\ 936}#
+ #{r\ 937}#
+ #{w\ 938}#
+ #{mod\ 940}#)))))
+ (#{source-wrap\ 160}#
+ (lambda (#{x\ 947}#
+ #{w\ 948}#
+ #{s\ 949}#
+ #{defmod\ 950}#)
+ (#{wrap\ 159}#
+ (#{decorate-source\ 94}# #{x\ 947}# #{s\ 949}#)
+ #{w\ 948}#
+ #{defmod\ 950}#)))
+ (#{wrap\ 159}#
+ (lambda (#{x\ 951}# #{w\ 952}# #{defmod\ 953}#)
+ (if (if (null? (#{wrap-marks\ 134}# #{w\ 952}#))
+ (null? (#{wrap-subst\ 135}# #{w\ 952}#))
#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}#))))
+ #{x\ 951}#
+ (if (#{syntax-object?\ 115}# #{x\ 951}#)
+ (#{make-syntax-object\ 114}#
+ (#{syntax-object-expression\ 116}# #{x\ 951}#)
+ (#{join-wraps\ 150}#
+ #{w\ 952}#
+ (#{syntax-object-wrap\ 117}# #{x\ 951}#))
+ (#{syntax-object-module\ 118}# #{x\ 951}#))
+ (if (null? #{x\ 951}#)
+ #{x\ 951}#
+ (#{make-syntax-object\ 114}#
+ #{x\ 951}#
+ #{w\ 952}#
+ #{defmod\ 953}#))))))
+ (#{bound-id-member?\ 158}#
+ (lambda (#{x\ 954}# #{list\ 955}#)
+ (if (not (null? #{list\ 955}#))
+ (let ((#{t\ 956}# (#{bound-id=?\ 155}#
+ #{x\ 954}#
+ (car #{list\ 955}#))))
+ (if #{t\ 956}#
+ #{t\ 956}#
+ (#{bound-id-member?\ 158}#
+ #{x\ 954}#
+ (cdr #{list\ 955}#))))
#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}#))
+ (#{distinct-bound-ids?\ 157}#
+ (lambda (#{ids\ 957}#)
+ (letrec ((#{distinct?\ 958}#
+ (lambda (#{ids\ 959}#)
+ (let ((#{t\ 960}# (null? #{ids\ 959}#)))
+ (if #{t\ 960}#
+ #{t\ 960}#
+ (if (not (#{bound-id-member?\ 158}#
+ (car #{ids\ 959}#)
+ (cdr #{ids\ 959}#)))
+ (#{distinct?\ 958}# (cdr #{ids\ 959}#))
#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}#))
+ (#{distinct?\ 958}# #{ids\ 957}#))))
+ (#{valid-bound-ids?\ 156}#
+ (lambda (#{ids\ 961}#)
+ (if (letrec ((#{all-ids?\ 962}#
+ (lambda (#{ids\ 963}#)
+ (let ((#{t\ 964}# (null? #{ids\ 963}#)))
+ (if #{t\ 964}#
+ #{t\ 964}#
+ (if (#{id?\ 131}# (car #{ids\ 963}#))
+ (#{all-ids?\ 962}# (cdr #{ids\ 963}#))
#f))))))
- (#{all-ids?\ 1828}# #{ids\ 1827}#))
- (#{distinct-bound-ids?\ 1323}# #{ids\ 1827}#)
+ (#{all-ids?\ 962}# #{ids\ 961}#))
+ (#{distinct-bound-ids?\ 157}# #{ids\ 961}#)
#f)))
- (#{bound-id=?\ 1321}#
- (lambda (#{i\ 1831}# #{j\ 1832}#)
- (if (if (#{syntax-object?\ 1281}# #{i\ 1831}#)
- (#{syntax-object?\ 1281}# #{j\ 1832}#)
+ (#{bound-id=?\ 155}#
+ (lambda (#{i\ 965}# #{j\ 966}#)
+ (if (if (#{syntax-object?\ 115}# #{i\ 965}#)
+ (#{syntax-object?\ 115}# #{j\ 966}#)
#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}#)))
+ (if (eq? (#{syntax-object-expression\ 116}# #{i\ 965}#)
+ (#{syntax-object-expression\ 116}# #{j\ 966}#))
+ (#{same-marks?\ 152}#
+ (#{wrap-marks\ 134}#
+ (#{syntax-object-wrap\ 117}# #{i\ 965}#))
+ (#{wrap-marks\ 134}#
+ (#{syntax-object-wrap\ 117}# #{j\ 966}#)))
#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 (()))))
+ (eq? #{i\ 965}# #{j\ 966}#))))
+ (#{free-id=?\ 154}#
+ (lambda (#{i\ 967}# #{j\ 968}#)
+ (if (eq? (let ((#{x\ 969}# #{i\ 967}#))
+ (if (#{syntax-object?\ 115}# #{x\ 969}#)
+ (#{syntax-object-expression\ 116}# #{x\ 969}#)
+ #{x\ 969}#))
+ (let ((#{x\ 970}# #{j\ 968}#))
+ (if (#{syntax-object?\ 115}# #{x\ 970}#)
+ (#{syntax-object-expression\ 116}# #{x\ 970}#)
+ #{x\ 970}#)))
+ (eq? (#{id-var-name\ 153}# #{i\ 967}# (quote (())))
+ (#{id-var-name\ 153}# #{j\ 968}# (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}#
+ (#{id-var-name\ 153}#
+ (lambda (#{id\ 971}# #{w\ 972}#)
+ (letrec ((#{search-vector-rib\ 975}#
+ (lambda (#{sym\ 981}#
+ #{subst\ 982}#
+ #{marks\ 983}#
+ #{symnames\ 984}#
+ #{ribcage\ 985}#)
+ (let ((#{n\ 986}# (vector-length
+ #{symnames\ 984}#)))
+ (letrec ((#{f\ 987}# (lambda (#{i\ 988}#)
+ (if (#{fx=\ 88}#
+ #{i\ 988}#
+ #{n\ 986}#)
+ (#{search\ 973}#
+ #{sym\ 981}#
+ (cdr #{subst\ 982}#)
+ #{marks\ 983}#)
+ (if (if (eq? (vector-ref
+ #{symnames\ 984}#
+ #{i\ 988}#)
+ #{sym\ 981}#)
+ (#{same-marks?\ 152}#
+ #{marks\ 983}#
+ (vector-ref
+ (#{ribcage-marks\ 141}#
+ #{ribcage\ 985}#)
+ #{i\ 988}#))
+ #f)
+ (values
+ (vector-ref
+ (#{ribcage-labels\ 142}#
+ #{ribcage\ 985}#)
+ #{i\ 988}#)
+ #{marks\ 983}#)
+ (#{f\ 987}# (#{fx+\ 86}#
+ #{i\ 988}#
+ 1)))))))
+ (#{f\ 987}# 0)))))
+ (#{search-list-rib\ 974}#
+ (lambda (#{sym\ 989}#
+ #{subst\ 990}#
+ #{marks\ 991}#
+ #{symnames\ 992}#
+ #{ribcage\ 993}#)
+ (letrec ((#{f\ 994}# (lambda (#{symnames\ 995}#
+ #{i\ 996}#)
+ (if (null? #{symnames\ 995}#)
+ (#{search\ 973}#
+ #{sym\ 989}#
+ (cdr #{subst\ 990}#)
+ #{marks\ 991}#)
+ (if (if (eq? (car #{symnames\ 995}#)
+ #{sym\ 989}#)
+ (#{same-marks?\ 152}#
+ #{marks\ 991}#
+ (list-ref
+ (#{ribcage-marks\ 141}#
+ #{ribcage\ 993}#)
+ #{i\ 996}#))
+ #f)
+ (values
+ (list-ref
+ (#{ribcage-labels\ 142}#
+ #{ribcage\ 993}#)
+ #{i\ 996}#)
+ #{marks\ 991}#)
+ (#{f\ 994}# (cdr #{symnames\ 995}#)
+ (#{fx+\ 86}#
+ #{i\ 996}#
+ 1)))))))
+ (#{f\ 994}# #{symnames\ 992}# 0))))
+ (#{search\ 973}#
+ (lambda (#{sym\ 997}# #{subst\ 998}# #{marks\ 999}#)
+ (if (null? #{subst\ 998}#)
+ (values #f #{marks\ 999}#)
+ (let ((#{fst\ 1000}# (car #{subst\ 998}#)))
+ (if (eq? #{fst\ 1000}# (quote shift))
+ (#{search\ 973}#
+ #{sym\ 997}#
+ (cdr #{subst\ 998}#)
+ (cdr #{marks\ 999}#))
+ (let ((#{symnames\ 1001}#
+ (#{ribcage-symnames\ 140}#
+ #{fst\ 1000}#)))
+ (if (vector? #{symnames\ 1001}#)
+ (#{search-vector-rib\ 975}#
+ #{sym\ 997}#
+ #{subst\ 998}#
+ #{marks\ 999}#
+ #{symnames\ 1001}#
+ #{fst\ 1000}#)
+ (#{search-list-rib\ 974}#
+ #{sym\ 997}#
+ #{subst\ 998}#
+ #{marks\ 999}#
+ #{symnames\ 1001}#
+ #{fst\ 1000}#)))))))))
+ (if (symbol? #{id\ 971}#)
+ (let ((#{t\ 1002}#
(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}#))))
+ (#{search\ 973}#
+ #{id\ 971}#
+ (#{wrap-subst\ 135}# #{w\ 972}#)
+ (#{wrap-marks\ 134}# #{w\ 972}#)))
+ (lambda (#{x\ 1003}# . #{ignore\ 1004}#)
+ #{x\ 1003}#))))
+ (if #{t\ 1002}# #{t\ 1002}# #{id\ 971}#))
+ (if (#{syntax-object?\ 115}# #{id\ 971}#)
+ (let ((#{id\ 1005}#
+ (#{syntax-object-expression\ 116}# #{id\ 971}#))
+ (#{w1\ 1006}#
+ (#{syntax-object-wrap\ 117}# #{id\ 971}#)))
+ (let ((#{marks\ 1007}#
+ (#{join-marks\ 151}#
+ (#{wrap-marks\ 134}# #{w\ 972}#)
+ (#{wrap-marks\ 134}# #{w1\ 1006}#))))
(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}#
+ (#{search\ 973}#
+ #{id\ 1005}#
+ (#{wrap-subst\ 135}# #{w\ 972}#)
+ #{marks\ 1007}#))
+ (lambda (#{new-id\ 1008}# #{marks\ 1009}#)
+ (let ((#{t\ 1010}# #{new-id\ 1008}#))
+ (if #{t\ 1010}#
+ #{t\ 1010}#
+ (let ((#{t\ 1011}#
(call-with-values
(lambda ()
- (#{search\ 1839}#
- #{id\ 1871}#
- (#{wrap-subst\ 1301}#
- #{w1\ 1872}#)
- #{marks\ 1875}#))
- (lambda (#{x\ 1879}#
+ (#{search\ 973}#
+ #{id\ 1005}#
+ (#{wrap-subst\ 135}#
+ #{w1\ 1006}#)
+ #{marks\ 1009}#))
+ (lambda (#{x\ 1012}#
.
- #{ignore\ 1878}#)
- #{x\ 1879}#))))
- (if #{t\ 1877}#
- #{t\ 1877}#
- #{id\ 1871}#))))))))
+ #{ignore\ 1013}#)
+ #{x\ 1012}#))))
+ (if #{t\ 1011}#
+ #{t\ 1011}#
+ #{id\ 1005}#))))))))
(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}#))
+ #{id\ 971}#))))))
+ (#{same-marks?\ 152}#
+ (lambda (#{x\ 1014}# #{y\ 1015}#)
+ (let ((#{t\ 1016}# (eq? #{x\ 1014}# #{y\ 1015}#)))
+ (if #{t\ 1016}#
+ #{t\ 1016}#
+ (if (not (null? #{x\ 1014}#))
+ (if (not (null? #{y\ 1015}#))
+ (if (eq? (car #{x\ 1014}#) (car #{y\ 1015}#))
+ (#{same-marks?\ 152}#
+ (cdr #{x\ 1014}#)
+ (cdr #{y\ 1015}#))
#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}#)))
+ (#{join-marks\ 151}#
+ (lambda (#{m1\ 1017}# #{m2\ 1018}#)
+ (#{smart-append\ 149}# #{m1\ 1017}# #{m2\ 1018}#)))
+ (#{join-wraps\ 150}#
+ (lambda (#{w1\ 1019}# #{w2\ 1020}#)
+ (let ((#{m1\ 1021}# (#{wrap-marks\ 134}# #{w1\ 1019}#))
+ (#{s1\ 1022}# (#{wrap-subst\ 135}# #{w1\ 1019}#)))
+ (if (null? #{m1\ 1021}#)
+ (if (null? #{s1\ 1022}#)
+ #{w2\ 1020}#
+ (#{make-wrap\ 133}#
+ (#{wrap-marks\ 134}# #{w2\ 1020}#)
+ (#{smart-append\ 149}#
+ #{s1\ 1022}#
+ (#{wrap-subst\ 135}# #{w2\ 1020}#))))
+ (#{make-wrap\ 133}#
+ (#{smart-append\ 149}#
+ #{m1\ 1021}#
+ (#{wrap-marks\ 134}# #{w2\ 1020}#))
+ (#{smart-append\ 149}#
+ #{s1\ 1022}#
+ (#{wrap-subst\ 135}# #{w2\ 1020}#)))))))
+ (#{smart-append\ 149}#
+ (lambda (#{m1\ 1023}# #{m2\ 1024}#)
+ (if (null? #{m2\ 1024}#)
+ #{m1\ 1023}#
+ (append #{m1\ 1023}# #{m2\ 1024}#))))
+ (#{make-binding-wrap\ 148}#
+ (lambda (#{ids\ 1025}# #{labels\ 1026}# #{w\ 1027}#)
+ (if (null? #{ids\ 1025}#)
+ #{w\ 1027}#
+ (#{make-wrap\ 133}#
+ (#{wrap-marks\ 134}# #{w\ 1027}#)
+ (cons (let ((#{labelvec\ 1028}#
+ (list->vector #{labels\ 1026}#)))
+ (let ((#{n\ 1029}#
+ (vector-length #{labelvec\ 1028}#)))
+ (let ((#{symnamevec\ 1030}#
+ (make-vector #{n\ 1029}#))
+ (#{marksvec\ 1031}#
+ (make-vector #{n\ 1029}#)))
(begin
- (letrec ((#{f\ 1898}#
- (lambda (#{ids\ 1899}# #{i\ 1900}#)
- (if (not (null? #{ids\ 1899}#))
+ (letrec ((#{f\ 1032}#
+ (lambda (#{ids\ 1033}# #{i\ 1034}#)
+ (if (not (null? #{ids\ 1033}#))
(call-with-values
(lambda ()
- (#{id-sym-name&marks\ 1298}#
- (car #{ids\ 1899}#)
- #{w\ 1893}#))
- (lambda (#{symname\ 1901}#
- #{marks\ 1902}#)
+ (#{id-sym-name&marks\ 132}#
+ (car #{ids\ 1033}#)
+ #{w\ 1027}#))
+ (lambda (#{symname\ 1035}#
+ #{marks\ 1036}#)
(begin
(vector-set!
- #{symnamevec\ 1896}#
- #{i\ 1900}#
- #{symname\ 1901}#)
+ #{symnamevec\ 1030}#
+ #{i\ 1034}#
+ #{symname\ 1035}#)
(vector-set!
- #{marksvec\ 1897}#
- #{i\ 1900}#
- #{marks\ 1902}#)
- (#{f\ 1898}#
- (cdr #{ids\ 1899}#)
- (#{fx+\ 1254}#
- #{i\ 1900}#
+ #{marksvec\ 1031}#
+ #{i\ 1034}#
+ #{marks\ 1036}#)
+ (#{f\ 1032}#
+ (cdr #{ids\ 1033}#)
+ (#{fx+\ 86}#
+ #{i\ 1034}#
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}#)
+ (#{f\ 1032}# #{ids\ 1025}# 0))
+ (#{make-ribcage\ 138}#
+ #{symnamevec\ 1030}#
+ #{marksvec\ 1031}#
+ #{labelvec\ 1028}#)))))
+ (#{wrap-subst\ 135}# #{w\ 1027}#))))))
+ (#{extend-ribcage!\ 147}#
+ (lambda (#{ribcage\ 1037}# #{id\ 1038}# #{label\ 1039}#)
(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}#))
+ (#{set-ribcage-symnames!\ 143}#
+ #{ribcage\ 1037}#
+ (cons (#{syntax-object-expression\ 116}# #{id\ 1038}#)
+ (#{ribcage-symnames\ 140}# #{ribcage\ 1037}#)))
+ (#{set-ribcage-marks!\ 144}#
+ #{ribcage\ 1037}#
+ (cons (#{wrap-marks\ 134}#
+ (#{syntax-object-wrap\ 117}# #{id\ 1038}#))
+ (#{ribcage-marks\ 141}# #{ribcage\ 1037}#)))
+ (#{set-ribcage-labels!\ 145}#
+ #{ribcage\ 1037}#
+ (cons #{label\ 1039}#
+ (#{ribcage-labels\ 142}# #{ribcage\ 1037}#))))))
+ (#{anti-mark\ 146}#
+ (lambda (#{w\ 1040}#)
+ (#{make-wrap\ 133}#
+ (cons #f (#{wrap-marks\ 134}# #{w\ 1040}#))
(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))
+ (#{wrap-subst\ 135}# #{w\ 1040}#)))))
+ (#{set-ribcage-labels!\ 145}#
+ (lambda (#{x\ 1041}# #{update\ 1042}#)
+ (vector-set! #{x\ 1041}# 3 #{update\ 1042}#)))
+ (#{set-ribcage-marks!\ 144}#
+ (lambda (#{x\ 1043}# #{update\ 1044}#)
+ (vector-set! #{x\ 1043}# 2 #{update\ 1044}#)))
+ (#{set-ribcage-symnames!\ 143}#
+ (lambda (#{x\ 1045}# #{update\ 1046}#)
+ (vector-set! #{x\ 1045}# 1 #{update\ 1046}#)))
+ (#{ribcage-labels\ 142}#
+ (lambda (#{x\ 1047}#) (vector-ref #{x\ 1047}# 3)))
+ (#{ribcage-marks\ 141}#
+ (lambda (#{x\ 1048}#) (vector-ref #{x\ 1048}# 2)))
+ (#{ribcage-symnames\ 140}#
+ (lambda (#{x\ 1049}#) (vector-ref #{x\ 1049}# 1)))
+ (#{ribcage?\ 139}#
+ (lambda (#{x\ 1050}#)
+ (if (vector? #{x\ 1050}#)
+ (if (= (vector-length #{x\ 1050}#) 4)
+ (eq? (vector-ref #{x\ 1050}# 0) (quote ribcage))
#f)
#f)))
- (#{make-ribcage\ 1304}#
- (lambda (#{symnames\ 1917}#
- #{marks\ 1918}#
- #{labels\ 1919}#)
+ (#{make-ribcage\ 138}#
+ (lambda (#{symnames\ 1051}#
+ #{marks\ 1052}#
+ #{labels\ 1053}#)
(vector
'ribcage
- #{symnames\ 1917}#
- #{marks\ 1918}#
- #{labels\ 1919}#)))
- (#{gen-labels\ 1303}#
- (lambda (#{ls\ 1920}#)
- (if (null? #{ls\ 1920}#)
+ #{symnames\ 1051}#
+ #{marks\ 1052}#
+ #{labels\ 1053}#)))
+ (#{gen-labels\ 137}#
+ (lambda (#{ls\ 1054}#)
+ (if (null? #{ls\ 1054}#)
'()
- (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}#)
+ (cons (#{gen-label\ 136}#)
+ (#{gen-labels\ 137}# (cdr #{ls\ 1054}#))))))
+ (#{gen-label\ 136}# (lambda () (string #\i)))
+ (#{wrap-subst\ 135}# cdr)
+ (#{wrap-marks\ 134}# car)
+ (#{make-wrap\ 133}# cons)
+ (#{id-sym-name&marks\ 132}#
+ (lambda (#{x\ 1055}# #{w\ 1056}#)
+ (if (#{syntax-object?\ 115}# #{x\ 1055}#)
(values
- (#{syntax-object-expression\ 1282}# #{x\ 1921}#)
- (#{join-marks\ 1317}#
- (#{wrap-marks\ 1300}# #{w\ 1922}#)
- (#{wrap-marks\ 1300}#
- (#{syntax-object-wrap\ 1283}# #{x\ 1921}#))))
+ (#{syntax-object-expression\ 116}# #{x\ 1055}#)
+ (#{join-marks\ 151}#
+ (#{wrap-marks\ 134}# #{w\ 1056}#)
+ (#{wrap-marks\ 134}#
+ (#{syntax-object-wrap\ 117}# #{x\ 1055}#))))
(values
- #{x\ 1921}#
- (#{wrap-marks\ 1300}# #{w\ 1922}#)))))
- (#{id?\ 1297}#
- (lambda (#{x\ 1923}#)
- (if (symbol? #{x\ 1923}#)
+ #{x\ 1055}#
+ (#{wrap-marks\ 134}# #{w\ 1056}#)))))
+ (#{id?\ 131}#
+ (lambda (#{x\ 1057}#)
+ (if (symbol? #{x\ 1057}#)
#t
- (if (#{syntax-object?\ 1281}# #{x\ 1923}#)
+ (if (#{syntax-object?\ 115}# #{x\ 1057}#)
(symbol?
- (#{syntax-object-expression\ 1282}# #{x\ 1923}#))
+ (#{syntax-object-expression\ 116}# #{x\ 1057}#))
#f))))
- (#{nonsymbol-id?\ 1296}#
- (lambda (#{x\ 1924}#)
- (if (#{syntax-object?\ 1281}# #{x\ 1924}#)
+ (#{nonsymbol-id?\ 130}#
+ (lambda (#{x\ 1058}#)
+ (if (#{syntax-object?\ 115}# #{x\ 1058}#)
(symbol?
- (#{syntax-object-expression\ 1282}# #{x\ 1924}#))
+ (#{syntax-object-expression\ 116}# #{x\ 1058}#))
#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))))
+ (#{global-extend\ 129}#
+ (lambda (#{type\ 1059}# #{sym\ 1060}# #{val\ 1061}#)
+ (#{put-global-definition-hook\ 92}#
+ #{sym\ 1060}#
+ #{type\ 1059}#
+ #{val\ 1061}#)))
+ (#{lookup\ 128}#
+ (lambda (#{x\ 1062}# #{r\ 1063}# #{mod\ 1064}#)
+ (let ((#{t\ 1065}# (assq #{x\ 1062}# #{r\ 1063}#)))
+ (if #{t\ 1065}#
+ (cdr #{t\ 1065}#)
+ (if (symbol? #{x\ 1062}#)
+ (let ((#{t\ 1066}#
+ (#{get-global-definition-hook\ 93}#
+ #{x\ 1062}#
+ #{mod\ 1064}#)))
+ (if #{t\ 1066}# #{t\ 1066}# (quote (global))))
'(displaced-lexical))))))
- (#{macros-only-env\ 1293}#
- (lambda (#{r\ 1933}#)
- (if (null? #{r\ 1933}#)
+ (#{macros-only-env\ 127}#
+ (lambda (#{r\ 1067}#)
+ (if (null? #{r\ 1067}#)
'()
- (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))
+ (let ((#{a\ 1068}# (car #{r\ 1067}#)))
+ (if (eq? (cadr #{a\ 1068}#) (quote macro))
+ (cons #{a\ 1068}#
+ (#{macros-only-env\ 127}# (cdr #{r\ 1067}#)))
+ (#{macros-only-env\ 127}# (cdr #{r\ 1067}#)))))))
+ (#{extend-var-env\ 126}#
+ (lambda (#{labels\ 1069}# #{vars\ 1070}# #{r\ 1071}#)
+ (if (null? #{labels\ 1069}#)
+ #{r\ 1071}#
+ (#{extend-var-env\ 126}#
+ (cdr #{labels\ 1069}#)
+ (cdr #{vars\ 1070}#)
+ (cons (cons (car #{labels\ 1069}#)
+ (cons (quote lexical) (car #{vars\ 1070}#)))
+ #{r\ 1071}#)))))
+ (#{extend-env\ 125}#
+ (lambda (#{labels\ 1072}# #{bindings\ 1073}# #{r\ 1074}#)
+ (if (null? #{labels\ 1072}#)
+ #{r\ 1074}#
+ (#{extend-env\ 125}#
+ (cdr #{labels\ 1072}#)
+ (cdr #{bindings\ 1073}#)
+ (cons (cons (car #{labels\ 1072}#)
+ (car #{bindings\ 1073}#))
+ #{r\ 1074}#)))))
+ (#{binding-value\ 124}# cdr)
+ (#{binding-type\ 123}# car)
+ (#{source-annotation\ 122}#
+ (lambda (#{x\ 1075}#)
+ (if (#{syntax-object?\ 115}# #{x\ 1075}#)
+ (#{source-annotation\ 122}#
+ (#{syntax-object-expression\ 116}# #{x\ 1075}#))
+ (if (pair? #{x\ 1075}#)
+ (let ((#{props\ 1076}# (source-properties #{x\ 1075}#)))
+ (if (pair? #{props\ 1076}#) #{props\ 1076}# #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)
+ (#{set-syntax-object-module!\ 121}#
+ (lambda (#{x\ 1077}# #{update\ 1078}#)
+ (vector-set! #{x\ 1077}# 3 #{update\ 1078}#)))
+ (#{set-syntax-object-wrap!\ 120}#
+ (lambda (#{x\ 1079}# #{update\ 1080}#)
+ (vector-set! #{x\ 1079}# 2 #{update\ 1080}#)))
+ (#{set-syntax-object-expression!\ 119}#
+ (lambda (#{x\ 1081}# #{update\ 1082}#)
+ (vector-set! #{x\ 1081}# 1 #{update\ 1082}#)))
+ (#{syntax-object-module\ 118}#
+ (lambda (#{x\ 1083}#) (vector-ref #{x\ 1083}# 3)))
+ (#{syntax-object-wrap\ 117}#
+ (lambda (#{x\ 1084}#) (vector-ref #{x\ 1084}# 2)))
+ (#{syntax-object-expression\ 116}#
+ (lambda (#{x\ 1085}#) (vector-ref #{x\ 1085}# 1)))
+ (#{syntax-object?\ 115}#
+ (lambda (#{x\ 1086}#)
+ (if (vector? #{x\ 1086}#)
+ (if (= (vector-length #{x\ 1086}#) 4)
+ (eq? (vector-ref #{x\ 1086}# 0)
'syntax-object)
#f)
#f)))
- (#{make-syntax-object\ 1280}#
- (lambda (#{expression\ 1953}#
- #{wrap\ 1954}#
- #{module\ 1955}#)
+ (#{make-syntax-object\ 114}#
+ (lambda (#{expression\ 1087}#
+ #{wrap\ 1088}#
+ #{module\ 1089}#)
(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)))
+ #{expression\ 1087}#
+ #{wrap\ 1088}#
+ #{module\ 1089}#)))
+ (#{build-letrec\ 113}#
+ (lambda (#{src\ 1090}#
+ #{ids\ 1091}#
+ #{vars\ 1092}#
+ #{val-exps\ 1093}#
+ #{body-exp\ 1094}#)
+ (if (null? #{vars\ 1092}#)
+ #{body-exp\ 1094}#
+ (let ((#{atom-key\ 1095}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1095}# (quote (c)))
(begin
(for-each
- #{maybe-name-value!\ 1271}#
- #{ids\ 1957}#
- #{val-exps\ 1959}#)
+ #{maybe-name-value!\ 103}#
+ #{ids\ 1091}#
+ #{val-exps\ 1093}#)
((@ (language tree-il) make-letrec)
- #{src\ 1956}#
- #{ids\ 1957}#
- #{vars\ 1958}#
- #{val-exps\ 1959}#
- #{body-exp\ 1960}#))
- (#{decorate-source\ 1262}#
+ #{src\ 1090}#
+ #{ids\ 1091}#
+ #{vars\ 1092}#
+ #{val-exps\ 1093}#
+ #{body-exp\ 1094}#))
+ (#{decorate-source\ 94}#
(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}#
+ (map list #{vars\ 1092}# #{val-exps\ 1093}#)
+ #{body-exp\ 1094}#)
+ #{src\ 1090}#))))))
+ (#{build-named-let\ 112}#
+ (lambda (#{src\ 1096}#
+ #{ids\ 1097}#
+ #{vars\ 1098}#
+ #{val-exps\ 1099}#
+ #{body-exp\ 1100}#)
+ (let ((#{f\ 1101}# (car #{vars\ 1098}#))
+ (#{f-name\ 1102}# (car #{ids\ 1097}#))
+ (#{vars\ 1103}# (cdr #{vars\ 1098}#))
+ (#{ids\ 1104}# (cdr #{ids\ 1097}#)))
+ (let ((#{atom-key\ 1105}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1105}# (quote (c)))
+ (let ((#{proc\ 1106}#
+ (#{build-simple-lambda\ 105}#
+ #{src\ 1096}#
+ #{ids\ 1104}#
#f
- #{body-exp\ 1966}#)))
+ #{vars\ 1103}#
+ #f
+ #{body-exp\ 1100}#)))
(begin
- (#{maybe-name-value!\ 1271}#
- #{f-name\ 1968}#
- #{proc\ 1972}#)
+ (#{maybe-name-value!\ 103}#
+ #{f-name\ 1102}#
+ #{proc\ 1106}#)
(for-each
- #{maybe-name-value!\ 1271}#
- #{ids\ 1970}#
- #{val-exps\ 1965}#)
+ #{maybe-name-value!\ 103}#
+ #{ids\ 1104}#
+ #{val-exps\ 1099}#)
((@ (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}#
+ #{src\ 1096}#
+ (list #{f-name\ 1102}#)
+ (list #{f\ 1101}#)
+ (list #{proc\ 1106}#)
+ (#{build-application\ 96}#
+ #{src\ 1096}#
+ (#{build-lexical-reference\ 98}#
'fun
- #{src\ 1962}#
- #{f-name\ 1968}#
- #{f\ 1967}#)
- #{val-exps\ 1965}#))))
- (#{decorate-source\ 1262}#
+ #{src\ 1096}#
+ #{f-name\ 1102}#
+ #{f\ 1101}#)
+ #{val-exps\ 1099}#))))
+ (#{decorate-source\ 94}#
(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)))
+ #{f\ 1101}#
+ (map list #{vars\ 1103}# #{val-exps\ 1099}#)
+ #{body-exp\ 1100}#)
+ #{src\ 1096}#))))))
+ (#{build-let\ 111}#
+ (lambda (#{src\ 1107}#
+ #{ids\ 1108}#
+ #{vars\ 1109}#
+ #{val-exps\ 1110}#
+ #{body-exp\ 1111}#)
+ (if (null? #{vars\ 1109}#)
+ #{body-exp\ 1111}#
+ (let ((#{atom-key\ 1112}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1112}# (quote (c)))
(begin
(for-each
- #{maybe-name-value!\ 1271}#
- #{ids\ 1974}#
- #{val-exps\ 1976}#)
+ #{maybe-name-value!\ 103}#
+ #{ids\ 1108}#
+ #{val-exps\ 1110}#)
((@ (language tree-il) make-let)
- #{src\ 1973}#
- #{ids\ 1974}#
- #{vars\ 1975}#
- #{val-exps\ 1976}#
- #{body-exp\ 1977}#))
- (#{decorate-source\ 1262}#
+ #{src\ 1107}#
+ #{ids\ 1108}#
+ #{vars\ 1109}#
+ #{val-exps\ 1110}#
+ #{body-exp\ 1111}#))
+ (#{decorate-source\ 94}#
(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)))
+ (map list #{vars\ 1109}# #{val-exps\ 1110}#)
+ #{body-exp\ 1111}#)
+ #{src\ 1107}#))))))
+ (#{build-sequence\ 110}#
+ (lambda (#{src\ 1113}# #{exps\ 1114}#)
+ (if (null? (cdr #{exps\ 1114}#))
+ (car #{exps\ 1114}#)
+ (let ((#{atom-key\ 1115}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1115}# (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)))
+ #{src\ 1113}#
+ #{exps\ 1114}#)
+ (#{decorate-source\ 94}#
+ (cons (quote begin) #{exps\ 1114}#)
+ #{src\ 1113}#))))))
+ (#{build-data\ 109}#
+ (lambda (#{src\ 1116}# #{exp\ 1117}#)
+ (let ((#{atom-key\ 1118}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1118}# (quote (c)))
((@ (language tree-il) make-const)
- #{src\ 1982}#
- #{exp\ 1983}#)
- (#{decorate-source\ 1262}#
- (if (if (self-evaluating? #{exp\ 1983}#)
- (not (vector? #{exp\ 1983}#))
+ #{src\ 1116}#
+ #{exp\ 1117}#)
+ (#{decorate-source\ 94}#
+ (if (if (self-evaluating? #{exp\ 1117}#)
+ (not (vector? #{exp\ 1117}#))
#f)
- #{exp\ 1983}#
- (list (quote quote) #{exp\ 1983}#))
- #{src\ 1982}#)))))
- (#{build-primref\ 1274}#
- (lambda (#{src\ 1985}# #{name\ 1986}#)
+ #{exp\ 1117}#
+ (list (quote quote) #{exp\ 1117}#))
+ #{src\ 1116}#)))))
+ (#{build-primref\ 108}#
+ (lambda (#{src\ 1119}# #{name\ 1120}#)
(if (equal?
(module-name (current-module))
'(guile))
- (let ((#{atom-key\ 1987}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 1987}# (quote (c)))
+ (let ((#{atom-key\ 1121}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1121}# (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)))
+ #{src\ 1119}#
+ #{name\ 1120}#)
+ (#{decorate-source\ 94}#
+ #{name\ 1120}#
+ #{src\ 1119}#)))
+ (let ((#{atom-key\ 1122}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1122}# (quote (c)))
((@ (language tree-il) make-module-ref)
- #{src\ 1985}#
+ #{src\ 1119}#
'(guile)
- #{name\ 1986}#
+ #{name\ 1120}#
#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)))
+ (#{decorate-source\ 94}#
+ (list (quote @@) (quote (guile)) #{name\ 1120}#)
+ #{src\ 1119}#))))))
+ (#{build-lambda-case\ 107}#
+ (lambda (#{src\ 1123}#
+ #{req\ 1124}#
+ #{opt\ 1125}#
+ #{rest\ 1126}#
+ #{kw\ 1127}#
+ #{inits\ 1128}#
+ #{vars\ 1129}#
+ #{predicate\ 1130}#
+ #{body\ 1131}#
+ #{else-case\ 1132}#)
+ (let ((#{atom-key\ 1133}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1133}# (quote (c)))
+ ((@ (language tree-il) make-lambda-case)
+ #{src\ 1123}#
+ #{req\ 1124}#
+ #{opt\ 1125}#
+ #{rest\ 1126}#
+ #{kw\ 1127}#
+ #{inits\ 1128}#
+ #{vars\ 1129}#
+ #{predicate\ 1130}#
+ #{body\ 1131}#
+ #{else-case\ 1132}#)
+ (let ((#{nreq\ 1134}# (length #{req\ 1124}#)))
+ (let ((#{nopt\ 1135}#
+ (if #{opt\ 1125}# (length #{opt\ 1125}#) 0)))
+ (let ((#{rest-idx\ 1136}#
+ (if #{rest\ 1126}#
+ (+ #{nreq\ 1134}# #{nopt\ 1135}#)
+ #f)))
+ (let ((#{allow-other-keys?\ 1137}#
+ (if #{kw\ 1127}# (car #{kw\ 1127}#) #f)))
+ (let ((#{kw-indices\ 1138}#
+ (map (lambda (#{x\ 1139}#)
+ (cons (car #{x\ 1139}#)
+ (list-index
+ #{vars\ 1129}#
+ (caddr #{x\ 1139}#))))
+ (if #{kw\ 1127}#
+ (cdr #{kw\ 1127}#)
+ '()))))
+ (let ((#{nargs\ 1140}#
+ (apply max
+ (+ #{nreq\ 1134}#
+ #{nopt\ 1135}#
+ (if #{rest\ 1126}# 1 0))
+ (map 1+
+ (map cdr
+ #{kw-indices\ 1138}#)))))
+ (begin
+ (let ((#{t\ 1141}#
+ (= #{nargs\ 1140}#
+ (length #{vars\ 1129}#)
+ (+ #{nreq\ 1134}#
+ (length #{inits\ 1128}#)
+ (if #{rest\ 1126}# 1 0)))))
+ (if #{t\ 1141}#
+ #{t\ 1141}#
+ (error "something went wrong"
+ #{req\ 1124}#
+ #{opt\ 1125}#
+ #{rest\ 1126}#
+ #{kw\ 1127}#
+ #{inits\ 1128}#
+ #{vars\ 1129}#
+ #{nreq\ 1134}#
+ #{nopt\ 1135}#
+ #{kw-indices\ 1138}#
+ #{nargs\ 1140}#)))
+ (#{decorate-source\ 94}#
+ (cons (list (cons '(@@ (ice-9 optargs)
+ parse-lambda-case)
+ (cons (list 'quote
+ (list #{nreq\ 1134}#
+ #{nopt\ 1135}#
+ #{rest-idx\ 1136}#
+ #{nargs\ 1140}#
+ #{allow-other-keys?\ 1137}#
+ #{kw-indices\ 1138}#))
+ (cons (cons 'list
+ (map (lambda (#{i\ 1142}#)
+ (list 'lambda
+ #{vars\ 1129}#
+ #{i\ 1142}#))
+ #{inits\ 1128}#))
+ (cons (if #{predicate\ 1130}#
+ (list 'lambda
+ #{vars\ 1129}#
+ #{predicate\ 1130}#)
+ #f)
+ '(%%args)))))
+ '=>
+ (list 'lambda
+ '(%%%args . _)
+ (cons 'apply
+ (cons (list 'lambda
+ #{vars\ 1129}#
+ #{body\ 1131}#)
+ '(%%%args)))))
+ (let ((#{t\ 1143}#
+ #{else-case\ 1132}#))
+ (if #{t\ 1143}#
+ #{t\ 1143}#
+ '((%%args
+ (error "wrong number of arguments"
+ %%args))))))
+ #{src\ 1123}#))))))))))))
+ (#{build-case-lambda\ 106}#
+ (lambda (#{src\ 1144}#
+ #{docstring\ 1145}#
+ #{body\ 1146}#)
+ (let ((#{atom-key\ 1147}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1147}# (quote (c)))
((@ (language tree-il) make-lambda)
- #{src\ 1989}#
- #{ids\ 1990}#
- #{vars\ 1991}#
- (if #{docstring\ 1992}#
- (list (cons (quote documentation) #{docstring\ 1992}#))
+ #{src\ 1144}#
+ (if #{docstring\ 1145}#
+ (list (cons (quote documentation) #{docstring\ 1145}#))
'())
- #{exp\ 1993}#)
- (#{decorate-source\ 1262}#
+ #{body\ 1146}#)
+ (#{decorate-source\ 94}#
(cons 'lambda
- (cons #{vars\ 1991}#
+ (cons '%%args
(append
- (if #{docstring\ 1992}#
- (list #{docstring\ 1992}#)
+ (if #{docstring\ 1145}#
+ (list #{docstring\ 1145}#)
'())
- (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)))
+ (list (cons (quote cond) #{body\ 1146}#)))))
+ #{src\ 1144}#)))))
+ (#{build-simple-lambda\ 105}#
+ (lambda (#{src\ 1148}#
+ #{req\ 1149}#
+ #{rest\ 1150}#
+ #{vars\ 1151}#
+ #{docstring\ 1152}#
+ #{exp\ 1153}#)
+ (let ((#{atom-key\ 1154}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1154}# (quote (c)))
+ ((@ (language tree-il) make-lambda)
+ #{src\ 1148}#
+ (if #{docstring\ 1152}#
+ (list (cons (quote documentation) #{docstring\ 1152}#))
+ '())
+ ((@ (language tree-il) make-lambda-case)
+ #{src\ 1148}#
+ #{req\ 1149}#
+ #f
+ #{rest\ 1150}#
+ #f
+ '()
+ #{vars\ 1151}#
+ #f
+ #{exp\ 1153}#
+ #f))
+ (#{decorate-source\ 94}#
+ (cons 'lambda
+ (cons (if #{rest\ 1150}#
+ (apply cons* #{vars\ 1151}#)
+ #{vars\ 1151}#)
+ (append
+ (if #{docstring\ 1152}#
+ (list #{docstring\ 1152}#)
+ '())
+ (list #{exp\ 1153}#))))
+ #{src\ 1148}#)))))
+ (#{build-global-definition\ 104}#
+ (lambda (#{source\ 1155}# #{var\ 1156}# #{exp\ 1157}#)
+ (let ((#{atom-key\ 1158}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1158}# (quote (c)))
(begin
- (#{maybe-name-value!\ 1271}#
- #{var\ 1996}#
- #{exp\ 1997}#)
+ (#{maybe-name-value!\ 103}#
+ #{var\ 1156}#
+ #{exp\ 1157}#)
((@ (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}#
+ #{source\ 1155}#
+ #{var\ 1156}#
+ #{exp\ 1157}#))
+ (#{decorate-source\ 94}#
+ (list (quote define) #{var\ 1156}# #{exp\ 1157}#)
+ #{source\ 1155}#)))))
+ (#{maybe-name-value!\ 103}#
+ (lambda (#{name\ 1159}# #{val\ 1160}#)
+ (if ((@ (language tree-il) lambda?) #{val\ 1160}#)
+ (let ((#{meta\ 1161}#
((@ (language tree-il) lambda-meta)
- #{val\ 2000}#)))
- (if (not (assq (quote name) #{meta\ 2001}#))
+ #{val\ 1160}#)))
+ (if (not (assq (quote name) #{meta\ 1161}#))
((setter (@ (language tree-il) lambda-meta))
- #{val\ 2000}#
+ #{val\ 1160}#
(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)))
+ #{name\ 1159}#
+ #{meta\ 1161}#)))))))
+ (#{build-global-assignment\ 102}#
+ (lambda (#{source\ 1162}#
+ #{var\ 1163}#
+ #{exp\ 1164}#
+ #{mod\ 1165}#)
+ (#{analyze-variable\ 100}#
+ #{mod\ 1165}#
+ #{var\ 1163}#
+ (lambda (#{mod\ 1166}# #{var\ 1167}# #{public?\ 1168}#)
+ (let ((#{atom-key\ 1169}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1169}# (quote (c)))
((@ (language tree-il) make-module-set)
- #{source\ 2002}#
- #{mod\ 2006}#
- #{var\ 2007}#
- #{public?\ 2008}#
- #{exp\ 2004}#)
- (#{decorate-source\ 1262}#
+ #{source\ 1162}#
+ #{mod\ 1166}#
+ #{var\ 1167}#
+ #{public?\ 1168}#
+ #{exp\ 1164}#)
+ (#{decorate-source\ 94}#
(list 'set!
- (list (if #{public?\ 2008}#
+ (list (if #{public?\ 1168}#
'@
'@@)
- #{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)))
+ #{mod\ 1166}#
+ #{var\ 1167}#)
+ #{exp\ 1164}#)
+ #{source\ 1162}#))))
+ (lambda (#{var\ 1170}#)
+ (let ((#{atom-key\ 1171}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1171}# (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)))
+ #{source\ 1162}#
+ #{var\ 1170}#
+ #{exp\ 1164}#)
+ (#{decorate-source\ 94}#
+ (list (quote set!) #{var\ 1170}# #{exp\ 1164}#)
+ #{source\ 1162}#)))))))
+ (#{build-global-reference\ 101}#
+ (lambda (#{source\ 1172}# #{var\ 1173}# #{mod\ 1174}#)
+ (#{analyze-variable\ 100}#
+ #{mod\ 1174}#
+ #{var\ 1173}#
+ (lambda (#{mod\ 1175}# #{var\ 1176}# #{public?\ 1177}#)
+ (let ((#{atom-key\ 1178}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1178}# (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)))
+ #{source\ 1172}#
+ #{mod\ 1175}#
+ #{var\ 1176}#
+ #{public?\ 1177}#)
+ (#{decorate-source\ 94}#
+ (list (if #{public?\ 1177}# (quote @) (quote @@))
+ #{mod\ 1175}#
+ #{var\ 1176}#)
+ #{source\ 1172}#))))
+ (lambda (#{var\ 1179}#)
+ (let ((#{atom-key\ 1180}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1180}# (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}#
+ #{source\ 1172}#
+ #{var\ 1179}#)
+ (#{decorate-source\ 94}#
+ #{var\ 1179}#
+ #{source\ 1172}#)))))))
+ (#{analyze-variable\ 100}#
+ (lambda (#{mod\ 1181}#
+ #{var\ 1182}#
+ #{modref-cont\ 1183}#
+ #{bare-cont\ 1184}#)
+ (if (not #{mod\ 1181}#)
+ (#{bare-cont\ 1184}# #{var\ 1182}#)
+ (let ((#{kind\ 1185}# (car #{mod\ 1181}#))
+ (#{mod\ 1186}# (cdr #{mod\ 1181}#)))
+ (if (memv #{kind\ 1185}# (quote (public)))
+ (#{modref-cont\ 1183}#
+ #{mod\ 1186}#
+ #{var\ 1182}#
#t)
- (if (memv #{kind\ 2025}# (quote (private)))
+ (if (memv #{kind\ 1185}# (quote (private)))
(if (not (equal?
- #{mod\ 2026}#
+ #{mod\ 1186}#
(module-name (current-module))))
- (#{modref-cont\ 2023}#
- #{mod\ 2026}#
- #{var\ 2022}#
+ (#{modref-cont\ 1183}#
+ #{mod\ 1186}#
+ #{var\ 1182}#
#f)
- (#{bare-cont\ 2024}# #{var\ 2022}#))
- (if (memv #{kind\ 2025}# (quote (bare)))
- (#{bare-cont\ 2024}# #{var\ 2022}#)
- (if (memv #{kind\ 2025}# (quote (hygiene)))
+ (#{bare-cont\ 1184}# #{var\ 1182}#))
+ (if (memv #{kind\ 1185}# (quote (bare)))
+ (#{bare-cont\ 1184}# #{var\ 1182}#)
+ (if (memv #{kind\ 1185}# (quote (hygiene)))
(if (if (not (equal?
- #{mod\ 2026}#
+ #{mod\ 1186}#
(module-name (current-module))))
(module-variable
- (resolve-module #{mod\ 2026}#)
- #{var\ 2022}#)
+ (resolve-module #{mod\ 1186}#)
+ #{var\ 1182}#)
#f)
- (#{modref-cont\ 2023}#
- #{mod\ 2026}#
- #{var\ 2022}#
+ (#{modref-cont\ 1183}#
+ #{mod\ 1186}#
+ #{var\ 1182}#
#f)
- (#{bare-cont\ 2024}# #{var\ 2022}#))
+ (#{bare-cont\ 1184}# #{var\ 1182}#))
(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)))
+ #{var\ 1182}#
+ #{mod\ 1186}#)))))))))
+ (#{build-lexical-assignment\ 99}#
+ (lambda (#{source\ 1187}#
+ #{name\ 1188}#
+ #{var\ 1189}#
+ #{exp\ 1190}#)
+ (let ((#{atom-key\ 1191}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1191}# (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)))
+ #{source\ 1187}#
+ #{name\ 1188}#
+ #{var\ 1189}#
+ #{exp\ 1190}#)
+ (#{decorate-source\ 94}#
+ (list (quote set!) #{var\ 1189}# #{exp\ 1190}#)
+ #{source\ 1187}#)))))
+ (#{build-lexical-reference\ 98}#
+ (lambda (#{type\ 1192}#
+ #{source\ 1193}#
+ #{name\ 1194}#
+ #{var\ 1195}#)
+ (let ((#{atom-key\ 1196}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1196}# (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)))
+ #{source\ 1193}#
+ #{name\ 1194}#
+ #{var\ 1195}#)
+ (#{decorate-source\ 94}#
+ #{var\ 1195}#
+ #{source\ 1193}#)))))
+ (#{build-conditional\ 97}#
+ (lambda (#{source\ 1197}#
+ #{test-exp\ 1198}#
+ #{then-exp\ 1199}#
+ #{else-exp\ 1200}#)
+ (let ((#{atom-key\ 1201}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1201}# (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)))
+ #{source\ 1197}#
+ #{test-exp\ 1198}#
+ #{then-exp\ 1199}#
+ #{else-exp\ 1200}#)
+ (#{decorate-source\ 94}#
+ (if (equal? #{else-exp\ 1200}# (quote (if #f #f)))
(list 'if
- #{test-exp\ 2038}#
- #{then-exp\ 2039}#)
+ #{test-exp\ 1198}#
+ #{then-exp\ 1199}#)
(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)))
+ #{test-exp\ 1198}#
+ #{then-exp\ 1199}#
+ #{else-exp\ 1200}#))
+ #{source\ 1197}#)))))
+ (#{build-application\ 96}#
+ (lambda (#{source\ 1202}#
+ #{fun-exp\ 1203}#
+ #{arg-exps\ 1204}#)
+ (let ((#{atom-key\ 1205}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1205}# (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)))
+ #{source\ 1202}#
+ #{fun-exp\ 1203}#
+ #{arg-exps\ 1204}#)
+ (#{decorate-source\ 94}#
+ (cons #{fun-exp\ 1203}# #{arg-exps\ 1204}#)
+ #{source\ 1202}#)))))
+ (#{build-void\ 95}#
+ (lambda (#{source\ 1206}#)
+ (let ((#{atom-key\ 1207}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1207}# (quote (c)))
((@ (language tree-il) make-void)
- #{source\ 2046}#)
- (#{decorate-source\ 1262}#
+ #{source\ 1206}#)
+ (#{decorate-source\ 94}#
'(if #f #f)
- #{source\ 2046}#)))))
- (#{decorate-source\ 1262}#
- (lambda (#{e\ 2048}# #{s\ 2049}#)
+ #{source\ 1206}#)))))
+ (#{decorate-source\ 94}#
+ (lambda (#{e\ 1208}# #{s\ 1209}#)
(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}#)
+ (if (if (pair? #{e\ 1208}#) #{s\ 1209}# #f)
+ (set-source-properties! #{e\ 1208}# #{s\ 1209}#))
+ #{e\ 1208}#)))
+ (#{get-global-definition-hook\ 93}#
+ (lambda (#{symbol\ 1210}# #{module\ 1211}#)
(begin
- (if (if (not #{module\ 2051}#) (current-module) #f)
+ (if (if (not #{module\ 1211}#) (current-module) #f)
(warn "module system is booted, we should have a module"
- #{symbol\ 2050}#))
- (let ((#{v\ 2052}#
+ #{symbol\ 1210}#))
+ (let ((#{v\ 1212}#
(module-variable
- (if #{module\ 2051}#
- (resolve-module (cdr #{module\ 2051}#))
+ (if #{module\ 1211}#
+ (resolve-module (cdr #{module\ 1211}#))
(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}#))
+ #{symbol\ 1210}#)))
+ (if #{v\ 1212}#
+ (if (variable-bound? #{v\ 1212}#)
+ (let ((#{val\ 1213}# (variable-ref #{v\ 1212}#)))
+ (if (macro? #{val\ 1213}#)
+ (if (syncase-macro-type #{val\ 1213}#)
+ (cons (syncase-macro-type #{val\ 1213}#)
+ (syncase-macro-binding #{val\ 1213}#))
#f)
#f))
#f)
#f)))))
- (#{put-global-definition-hook\ 1260}#
- (lambda (#{symbol\ 2054}# #{type\ 2055}# #{val\ 2056}#)
- (let ((#{existing\ 2057}#
- (let ((#{v\ 2058}#
+ (#{put-global-definition-hook\ 92}#
+ (lambda (#{symbol\ 1214}# #{type\ 1215}# #{val\ 1216}#)
+ (let ((#{existing\ 1217}#
+ (let ((#{v\ 1218}#
(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}#
+ #{symbol\ 1214}#)))
+ (if #{v\ 1218}#
+ (if (variable-bound? #{v\ 1218}#)
+ (let ((#{val\ 1219}# (variable-ref #{v\ 1218}#)))
+ (if (macro? #{val\ 1219}#)
+ (if (not (syncase-macro-type #{val\ 1219}#))
+ #{val\ 1219}#
#f)
#f))
#f)
#f))))
(module-define!
(current-module)
- #{symbol\ 2054}#
- (if #{existing\ 2057}#
+ #{symbol\ 1214}#
+ (if #{existing\ 1217}#
(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}#)
+ #{existing\ 1217}#
+ #{type\ 1215}#
+ #{val\ 1216}#)
+ (make-syncase-macro #{type\ 1215}# #{val\ 1216}#))))))
+ (#{local-eval-hook\ 91}#
+ (lambda (#{x\ 1220}# #{mod\ 1221}#)
(primitive-eval
- (list #{noexpand\ 1252}#
- (let ((#{atom-key\ 2062}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2062}# (quote (c)))
+ (list #{noexpand\ 84}#
+ (let ((#{atom-key\ 1222}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1222}# (quote (c)))
((@ (language tree-il) tree-il->scheme)
- #{x\ 2060}#)
- #{x\ 2060}#))))))
- (#{top-level-eval-hook\ 1258}#
- (lambda (#{x\ 2063}# #{mod\ 2064}#)
+ #{x\ 1220}#)
+ #{x\ 1220}#))))))
+ (#{top-level-eval-hook\ 90}#
+ (lambda (#{x\ 1223}# #{mod\ 1224}#)
(primitive-eval
- (list #{noexpand\ 1252}#
- (let ((#{atom-key\ 2065}# (fluid-ref #{*mode*\ 1253}#)))
- (if (memv #{atom-key\ 2065}# (quote (c)))
+ (list #{noexpand\ 84}#
+ (let ((#{atom-key\ 1225}# (fluid-ref #{*mode*\ 85}#)))
+ (if (memv #{atom-key\ 1225}# (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"))
+ #{x\ 1223}#)
+ #{x\ 1223}#))))))
+ (#{fx<\ 89}# <)
+ (#{fx=\ 88}# =)
+ (#{fx-\ 87}# -)
+ (#{fx+\ 86}# +)
+ (#{*mode*\ 85}# (make-fluid))
+ (#{noexpand\ 84}# "noexpand"))
(begin
- (#{global-extend\ 1295}#
+ (#{global-extend\ 129}#
'local-syntax
'letrec-syntax
#t)
- (#{global-extend\ 1295}#
+ (#{global-extend\ 129}#
'local-syntax
'let-syntax
#f)
- (#{global-extend\ 1295}#
+ (#{global-extend\ 129}#
'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}#)
+ (lambda (#{e\ 1226}#
+ #{r\ 1227}#
+ #{w\ 1228}#
+ #{s\ 1229}#
+ #{mod\ 1230}#)
+ ((lambda (#{tmp\ 1231}#)
+ ((lambda (#{tmp\ 1232}#)
+ (if (if #{tmp\ 1232}#
+ (apply (lambda (#{_\ 1233}#
+ #{var\ 1234}#
+ #{val\ 1235}#
+ #{e1\ 1236}#
+ #{e2\ 1237}#)
+ (#{valid-bound-ids?\ 156}# #{var\ 1234}#))
+ #{tmp\ 1232}#)
#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}#)))
+ (apply (lambda (#{_\ 1239}#
+ #{var\ 1240}#
+ #{val\ 1241}#
+ #{e1\ 1242}#
+ #{e2\ 1243}#)
+ (let ((#{names\ 1244}#
+ (map (lambda (#{x\ 1245}#)
+ (#{id-var-name\ 153}#
+ #{x\ 1245}#
+ #{w\ 1228}#))
+ #{var\ 1240}#)))
(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}#
+ (lambda (#{id\ 1247}# #{n\ 1248}#)
+ (let ((#{atom-key\ 1249}#
+ (#{binding-type\ 123}#
+ (#{lookup\ 128}#
+ #{n\ 1248}#
+ #{r\ 1227}#
+ #{mod\ 1230}#))))
+ (if (memv #{atom-key\ 1249}#
'(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}#)
+ #{e\ 1226}#
+ (#{source-wrap\ 160}#
+ #{id\ 1247}#
+ #{w\ 1228}#
+ #{s\ 1229}#
+ #{mod\ 1230}#)))))
+ #{var\ 1240}#
+ #{names\ 1244}#)
+ (#{chi-body\ 171}#
+ (cons #{e1\ 1242}# #{e2\ 1243}#)
+ (#{source-wrap\ 160}#
+ #{e\ 1226}#
+ #{w\ 1228}#
+ #{s\ 1229}#
+ #{mod\ 1230}#)
+ (#{extend-env\ 125}#
+ #{names\ 1244}#
+ (let ((#{trans-r\ 1252}#
+ (#{macros-only-env\ 127}#
+ #{r\ 1227}#)))
+ (map (lambda (#{x\ 1253}#)
(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}#)
+ (#{eval-local-transformer\ 173}#
+ (#{chi\ 167}#
+ #{x\ 1253}#
+ #{trans-r\ 1252}#
+ #{w\ 1228}#
+ #{mod\ 1230}#)
+ #{mod\ 1230}#)))
+ #{val\ 1241}#))
+ #{r\ 1227}#)
+ #{w\ 1228}#
+ #{mod\ 1230}#))))
+ #{tmp\ 1232}#)
+ ((lambda (#{_\ 1255}#)
(syntax-violation
'fluid-let-syntax
"bad syntax"
- (#{source-wrap\ 1326}#
- #{e\ 2066}#
- #{w\ 2068}#
- #{s\ 2069}#
- #{mod\ 2070}#)))
- #{tmp\ 2071}#)))
+ (#{source-wrap\ 160}#
+ #{e\ 1226}#
+ #{w\ 1228}#
+ #{s\ 1229}#
+ #{mod\ 1230}#)))
+ #{tmp\ 1231}#)))
($sc-dispatch
- #{tmp\ 2071}#
+ #{tmp\ 1231}#
'(any #(each (any any)) any . each-any))))
- #{e\ 2066}#)))
- (#{global-extend\ 1295}#
+ #{e\ 1226}#)))
+ (#{global-extend\ 129}#
'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}#)
+ (lambda (#{e\ 1256}#
+ #{r\ 1257}#
+ #{w\ 1258}#
+ #{s\ 1259}#
+ #{mod\ 1260}#)
+ ((lambda (#{tmp\ 1261}#)
+ ((lambda (#{tmp\ 1262}#)
+ (if #{tmp\ 1262}#
+ (apply (lambda (#{_\ 1263}# #{e\ 1264}#)
+ (#{build-data\ 109}#
+ #{s\ 1259}#
+ (#{strip\ 180}# #{e\ 1264}# #{w\ 1258}#)))
+ #{tmp\ 1262}#)
+ ((lambda (#{_\ 1265}#)
(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}#
+ (#{source-wrap\ 160}#
+ #{e\ 1256}#
+ #{w\ 1258}#
+ #{s\ 1259}#
+ #{mod\ 1260}#)))
+ #{tmp\ 1261}#)))
+ ($sc-dispatch #{tmp\ 1261}# (quote (any any)))))
+ #{e\ 1256}#)))
+ (#{global-extend\ 129}#
'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}#
+ (letrec ((#{regen\ 1273}#
+ (lambda (#{x\ 1274}#)
+ (let ((#{atom-key\ 1275}# (car #{x\ 1274}#)))
+ (if (memv #{atom-key\ 1275}# (quote (ref)))
+ (#{build-lexical-reference\ 98}#
'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}#
+ (cadr #{x\ 1274}#)
+ (cadr #{x\ 1274}#))
+ (if (memv #{atom-key\ 1275}# (quote (primitive)))
+ (#{build-primref\ 108}# #f (cadr #{x\ 1274}#))
+ (if (memv #{atom-key\ 1275}# (quote (quote)))
+ (#{build-data\ 109}# #f (cadr #{x\ 1274}#))
+ (if (memv #{atom-key\ 1275}# (quote (lambda)))
+ (if (list? (cadr #{x\ 1274}#))
+ (#{build-simple-lambda\ 105}#
+ #f
+ (cadr #{x\ 1274}#)
+ #f
+ (cadr #{x\ 1274}#)
+ #f
+ (#{regen\ 1273}# (caddr #{x\ 1274}#)))
+ (error "how did we get here" #{x\ 1274}#))
+ (#{build-application\ 96}#
#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))
+ (#{build-primref\ 108}# #f (car #{x\ 1274}#))
+ (map #{regen\ 1273}#
+ (cdr #{x\ 1274}#))))))))))
+ (#{gen-vector\ 1272}#
+ (lambda (#{x\ 1276}#)
+ (if (eq? (car #{x\ 1276}#) (quote list))
+ (cons (quote vector) (cdr #{x\ 1276}#))
+ (if (eq? (car #{x\ 1276}#) (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->vector (cadr #{x\ 1276}#)))
+ (list (quote list->vector) #{x\ 1276}#)))))
+ (#{gen-append\ 1271}#
+ (lambda (#{x\ 1277}# #{y\ 1278}#)
+ (if (equal? #{y\ 1278}# (quote (quote ())))
+ #{x\ 1277}#
+ (list (quote append) #{x\ 1277}# #{y\ 1278}#))))
+ (#{gen-cons\ 1270}#
+ (lambda (#{x\ 1279}# #{y\ 1280}#)
+ (let ((#{atom-key\ 1281}# (car #{y\ 1280}#)))
+ (if (memv #{atom-key\ 1281}# (quote (quote)))
+ (if (eq? (car #{x\ 1279}#) (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 (cadr #{x\ 1279}#) (cadr #{y\ 1280}#)))
+ (if (eq? (cadr #{y\ 1280}#) (quote ()))
+ (list (quote list) #{x\ 1279}#)
+ (list (quote cons) #{x\ 1279}# #{y\ 1280}#)))
+ (if (memv #{atom-key\ 1281}# (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}#)
+ (cons #{x\ 1279}# (cdr #{y\ 1280}#)))
+ (list (quote cons) #{x\ 1279}# #{y\ 1280}#))))))
+ (#{gen-map\ 1269}#
+ (lambda (#{e\ 1282}# #{map-env\ 1283}#)
+ (let ((#{formals\ 1284}# (map cdr #{map-env\ 1283}#))
+ (#{actuals\ 1285}#
+ (map (lambda (#{x\ 1286}#)
+ (list (quote ref) (car #{x\ 1286}#)))
+ #{map-env\ 1283}#)))
+ (if (eq? (car #{e\ 1282}#) (quote ref))
+ (car #{actuals\ 1285}#)
(if (and-map
- (lambda (#{x\ 2127}#)
- (if (eq? (car #{x\ 2127}#) (quote ref))
- (memq (cadr #{x\ 2127}#) #{formals\ 2124}#)
+ (lambda (#{x\ 1287}#)
+ (if (eq? (car #{x\ 1287}#) (quote ref))
+ (memq (cadr #{x\ 1287}#) #{formals\ 1284}#)
#f))
- (cdr #{e\ 2122}#))
+ (cdr #{e\ 1282}#))
(cons 'map
(cons (list 'primitive
- (car #{e\ 2122}#))
- (map (let ((#{r\ 2128}#
+ (car #{e\ 1282}#))
+ (map (let ((#{r\ 1288}#
(map cons
- #{formals\ 2124}#
- #{actuals\ 2125}#)))
- (lambda (#{x\ 2129}#)
- (cdr (assq (cadr #{x\ 2129}#)
- #{r\ 2128}#))))
- (cdr #{e\ 2122}#))))
+ #{formals\ 1284}#
+ #{actuals\ 1285}#)))
+ (lambda (#{x\ 1289}#)
+ (cdr (assq (cadr #{x\ 1289}#)
+ #{r\ 1288}#))))
+ (cdr #{e\ 1282}#))))
(cons 'map
(cons (list 'lambda
- #{formals\ 2124}#
- #{e\ 2122}#)
- #{actuals\ 2125}#)))))))
- (#{gen-mappend\ 2108}#
- (lambda (#{e\ 2130}# #{map-env\ 2131}#)
+ #{formals\ 1284}#
+ #{e\ 1282}#)
+ #{actuals\ 1285}#)))))))
+ (#{gen-mappend\ 1268}#
+ (lambda (#{e\ 1290}# #{map-env\ 1291}#)
(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}#)
+ (#{gen-map\ 1269}# #{e\ 1290}# #{map-env\ 1291}#))))
+ (#{gen-ref\ 1267}#
+ (lambda (#{src\ 1292}#
+ #{var\ 1293}#
+ #{level\ 1294}#
+ #{maps\ 1295}#)
+ (if (#{fx=\ 88}# #{level\ 1294}# 0)
+ (values #{var\ 1293}# #{maps\ 1295}#)
+ (if (null? #{maps\ 1295}#)
(syntax-violation
'syntax
"missing ellipsis"
- #{src\ 2132}#)
+ #{src\ 1292}#)
(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))))
+ (#{gen-ref\ 1267}#
+ #{src\ 1292}#
+ #{var\ 1293}#
+ (#{fx-\ 87}# #{level\ 1294}# 1)
+ (cdr #{maps\ 1295}#)))
+ (lambda (#{outer-var\ 1296}# #{outer-maps\ 1297}#)
+ (let ((#{b\ 1298}#
+ (assq #{outer-var\ 1296}#
+ (car #{maps\ 1295}#))))
+ (if #{b\ 1298}#
+ (values (cdr #{b\ 1298}#) #{maps\ 1295}#)
+ (let ((#{inner-var\ 1299}#
+ (#{gen-var\ 181}# (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}#
+ #{inner-var\ 1299}#
+ (cons (cons (cons #{outer-var\ 1296}#
+ #{inner-var\ 1299}#)
+ (car #{maps\ 1295}#))
+ #{outer-maps\ 1297}#)))))))))))
+ (#{gen-syntax\ 1266}#
+ (lambda (#{src\ 1300}#
+ #{e\ 1301}#
+ #{r\ 1302}#
+ #{maps\ 1303}#
+ #{ellipsis?\ 1304}#
+ #{mod\ 1305}#)
+ (if (#{id?\ 131}# #{e\ 1301}#)
+ (let ((#{label\ 1306}#
+ (#{id-var-name\ 153}#
+ #{e\ 1301}#
'(()))))
- (let ((#{b\ 2147}#
- (#{lookup\ 1294}#
- #{label\ 2146}#
- #{r\ 2142}#
- #{mod\ 2145}#)))
- (if (eq? (#{binding-type\ 1289}# #{b\ 2147}#)
+ (let ((#{b\ 1307}#
+ (#{lookup\ 128}#
+ #{label\ 1306}#
+ #{r\ 1302}#
+ #{mod\ 1305}#)))
+ (if (eq? (#{binding-type\ 123}# #{b\ 1307}#)
'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}#)
+ (let ((#{var.lev\ 1308}#
+ (#{binding-value\ 124}# #{b\ 1307}#)))
+ (#{gen-ref\ 1267}#
+ #{src\ 1300}#
+ (car #{var.lev\ 1308}#)
+ (cdr #{var.lev\ 1308}#)
+ #{maps\ 1303}#)))
+ (lambda (#{var\ 1309}# #{maps\ 1310}#)
(values
- (list (quote ref) #{var\ 2149}#)
- #{maps\ 2150}#)))
- (if (#{ellipsis?\ 2144}# #{e\ 2141}#)
+ (list (quote ref) #{var\ 1309}#)
+ #{maps\ 1310}#)))
+ (if (#{ellipsis?\ 1304}# #{e\ 1301}#)
(syntax-violation
'syntax
"misplaced ellipsis"
- #{src\ 2140}#)
+ #{src\ 1300}#)
(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}#)
+ (list (quote quote) #{e\ 1301}#)
+ #{maps\ 1303}#)))))
+ ((lambda (#{tmp\ 1311}#)
+ ((lambda (#{tmp\ 1312}#)
+ (if (if #{tmp\ 1312}#
+ (apply (lambda (#{dots\ 1313}# #{e\ 1314}#)
+ (#{ellipsis?\ 1304}#
+ #{dots\ 1313}#))
+ #{tmp\ 1312}#)
#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}#)
+ (apply (lambda (#{dots\ 1315}# #{e\ 1316}#)
+ (#{gen-syntax\ 1266}#
+ #{src\ 1300}#
+ #{e\ 1316}#
+ #{r\ 1302}#
+ #{maps\ 1303}#
+ (lambda (#{x\ 1317}#) #f)
+ #{mod\ 1305}#))
+ #{tmp\ 1312}#)
+ ((lambda (#{tmp\ 1318}#)
+ (if (if #{tmp\ 1318}#
+ (apply (lambda (#{x\ 1319}#
+ #{dots\ 1320}#
+ #{y\ 1321}#)
+ (#{ellipsis?\ 1304}#
+ #{dots\ 1320}#))
+ #{tmp\ 1318}#)
#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}#)
+ (apply (lambda (#{x\ 1322}#
+ #{dots\ 1323}#
+ #{y\ 1324}#)
+ (letrec ((#{f\ 1325}#
+ (lambda (#{y\ 1326}#
+ #{k\ 1327}#)
+ ((lambda (#{tmp\ 1331}#)
+ ((lambda (#{tmp\ 1332}#)
+ (if (if #{tmp\ 1332}#
+ (apply (lambda (#{dots\ 1333}#
+ #{y\ 1334}#)
+ (#{ellipsis?\ 1304}#
+ #{dots\ 1333}#))
+ #{tmp\ 1332}#)
#f)
- (apply (lambda (#{dots\ 2175}#
- #{y\ 2176}#)
- (#{f\ 2165}#
- #{y\ 2176}#
- (lambda (#{maps\ 2177}#)
+ (apply (lambda (#{dots\ 1335}#
+ #{y\ 1336}#)
+ (#{f\ 1325}#
+ #{y\ 1336}#
+ (lambda (#{maps\ 1337}#)
(call-with-values
(lambda ()
- (#{k\ 2167}#
+ (#{k\ 1327}#
(cons '()
- #{maps\ 2177}#)))
- (lambda (#{x\ 2178}#
- #{maps\ 2179}#)
- (if (null? (car #{maps\ 2179}#))
+ #{maps\ 1337}#)))
+ (lambda (#{x\ 1338}#
+ #{maps\ 1339}#)
+ (if (null? (car #{maps\ 1339}#))
(syntax-violation
'syntax
"extra ellipsis"
- #{src\ 2140}#)
+ #{src\ 1300}#)
(values
- (#{gen-mappend\ 2108}#
- #{x\ 2178}#
- (car #{maps\ 2179}#))
- (cdr #{maps\ 2179}#))))))))
- #{tmp\ 2172}#)
- ((lambda (#{_\ 2180}#)
+ (#{gen-mappend\ 1268}#
+ #{x\ 1338}#
+ (car #{maps\ 1339}#))
+ (cdr #{maps\ 1339}#))))))))
+ #{tmp\ 1332}#)
+ ((lambda (#{_\ 1340}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{src\ 2140}#
- #{y\ 2166}#
- #{r\ 2142}#
- #{maps\ 2143}#
- #{ellipsis?\ 2144}#
- #{mod\ 2145}#))
- (lambda (#{y\ 2181}#
- #{maps\ 2182}#)
+ (#{gen-syntax\ 1266}#
+ #{src\ 1300}#
+ #{y\ 1326}#
+ #{r\ 1302}#
+ #{maps\ 1303}#
+ #{ellipsis?\ 1304}#
+ #{mod\ 1305}#))
+ (lambda (#{y\ 1341}#
+ #{maps\ 1342}#)
(call-with-values
(lambda ()
- (#{k\ 2167}#
- #{maps\ 2182}#))
- (lambda (#{x\ 2183}#
- #{maps\ 2184}#)
+ (#{k\ 1327}#
+ #{maps\ 1342}#))
+ (lambda (#{x\ 1343}#
+ #{maps\ 1344}#)
(values
- (#{gen-append\ 2111}#
- #{x\ 2183}#
- #{y\ 2181}#)
- #{maps\ 2184}#))))))
- #{tmp\ 2171}#)))
+ (#{gen-append\ 1271}#
+ #{x\ 1343}#
+ #{y\ 1341}#)
+ #{maps\ 1344}#))))))
+ #{tmp\ 1331}#)))
($sc-dispatch
- #{tmp\ 2171}#
+ #{tmp\ 1331}#
'(any . any))))
- #{y\ 2166}#))))
- (#{f\ 2165}#
- #{y\ 2164}#
- (lambda (#{maps\ 2168}#)
+ #{y\ 1326}#))))
+ (#{f\ 1325}#
+ #{y\ 1324}#
+ (lambda (#{maps\ 1328}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{src\ 2140}#
- #{x\ 2162}#
- #{r\ 2142}#
+ (#{gen-syntax\ 1266}#
+ #{src\ 1300}#
+ #{x\ 1322}#
+ #{r\ 1302}#
(cons '()
- #{maps\ 2168}#)
- #{ellipsis?\ 2144}#
- #{mod\ 2145}#))
- (lambda (#{x\ 2169}#
- #{maps\ 2170}#)
- (if (null? (car #{maps\ 2170}#))
+ #{maps\ 1328}#)
+ #{ellipsis?\ 1304}#
+ #{mod\ 1305}#))
+ (lambda (#{x\ 1329}#
+ #{maps\ 1330}#)
+ (if (null? (car #{maps\ 1330}#))
(syntax-violation
'syntax
"extra ellipsis"
- #{src\ 2140}#)
+ #{src\ 1300}#)
(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}#)
+ (#{gen-map\ 1269}#
+ #{x\ 1329}#
+ (car #{maps\ 1330}#))
+ (cdr #{maps\ 1330}#)))))))))
+ #{tmp\ 1318}#)
+ ((lambda (#{tmp\ 1345}#)
+ (if #{tmp\ 1345}#
+ (apply (lambda (#{x\ 1346}#
+ #{y\ 1347}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{src\ 2140}#
- #{x\ 2186}#
- #{r\ 2142}#
- #{maps\ 2143}#
- #{ellipsis?\ 2144}#
- #{mod\ 2145}#))
- (lambda (#{x\ 2188}#
- #{maps\ 2189}#)
+ (#{gen-syntax\ 1266}#
+ #{src\ 1300}#
+ #{x\ 1346}#
+ #{r\ 1302}#
+ #{maps\ 1303}#
+ #{ellipsis?\ 1304}#
+ #{mod\ 1305}#))
+ (lambda (#{x\ 1348}#
+ #{maps\ 1349}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{src\ 2140}#
- #{y\ 2187}#
- #{r\ 2142}#
- #{maps\ 2189}#
- #{ellipsis?\ 2144}#
- #{mod\ 2145}#))
- (lambda (#{y\ 2190}#
- #{maps\ 2191}#)
+ (#{gen-syntax\ 1266}#
+ #{src\ 1300}#
+ #{y\ 1347}#
+ #{r\ 1302}#
+ #{maps\ 1349}#
+ #{ellipsis?\ 1304}#
+ #{mod\ 1305}#))
+ (lambda (#{y\ 1350}#
+ #{maps\ 1351}#)
(values
- (#{gen-cons\ 2110}#
- #{x\ 2188}#
- #{y\ 2190}#)
- #{maps\ 2191}#))))))
- #{tmp\ 2185}#)
- ((lambda (#{tmp\ 2192}#)
- (if #{tmp\ 2192}#
- (apply (lambda (#{e1\ 2193}#
- #{e2\ 2194}#)
+ (#{gen-cons\ 1270}#
+ #{x\ 1348}#
+ #{y\ 1350}#)
+ #{maps\ 1351}#))))))
+ #{tmp\ 1345}#)
+ ((lambda (#{tmp\ 1352}#)
+ (if #{tmp\ 1352}#
+ (apply (lambda (#{e1\ 1353}#
+ #{e2\ 1354}#)
(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}#)
+ (#{gen-syntax\ 1266}#
+ #{src\ 1300}#
+ (cons #{e1\ 1353}#
+ #{e2\ 1354}#)
+ #{r\ 1302}#
+ #{maps\ 1303}#
+ #{ellipsis?\ 1304}#
+ #{mod\ 1305}#))
+ (lambda (#{e\ 1356}#
+ #{maps\ 1357}#)
(values
- (#{gen-vector\ 2112}#
- #{e\ 2196}#)
- #{maps\ 2197}#))))
- #{tmp\ 2192}#)
- ((lambda (#{_\ 2198}#)
+ (#{gen-vector\ 1272}#
+ #{e\ 1356}#)
+ #{maps\ 1357}#))))
+ #{tmp\ 1352}#)
+ ((lambda (#{_\ 1358}#)
(values
(list 'quote
- #{e\ 2141}#)
- #{maps\ 2143}#))
- #{tmp\ 2151}#)))
+ #{e\ 1301}#)
+ #{maps\ 1303}#))
+ #{tmp\ 1311}#)))
($sc-dispatch
- #{tmp\ 2151}#
+ #{tmp\ 1311}#
'#(vector (any . each-any))))))
($sc-dispatch
- #{tmp\ 2151}#
+ #{tmp\ 1311}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 2151}#
+ #{tmp\ 1311}#
'(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}#)
+ ($sc-dispatch #{tmp\ 1311}# (quote (any any)))))
+ #{e\ 1301}#)))))
+ (lambda (#{e\ 1359}#
+ #{r\ 1360}#
+ #{w\ 1361}#
+ #{s\ 1362}#
+ #{mod\ 1363}#)
+ (let ((#{e\ 1364}#
+ (#{source-wrap\ 160}#
+ #{e\ 1359}#
+ #{w\ 1361}#
+ #{s\ 1362}#
+ #{mod\ 1363}#)))
+ ((lambda (#{tmp\ 1365}#)
+ ((lambda (#{tmp\ 1366}#)
+ (if #{tmp\ 1366}#
+ (apply (lambda (#{_\ 1367}# #{x\ 1368}#)
(call-with-values
(lambda ()
- (#{gen-syntax\ 2106}#
- #{e\ 2204}#
- #{x\ 2208}#
- #{r\ 2200}#
+ (#{gen-syntax\ 1266}#
+ #{e\ 1364}#
+ #{x\ 1368}#
+ #{r\ 1360}#
'()
- #{ellipsis?\ 1342}#
- #{mod\ 2203}#))
- (lambda (#{e\ 2209}# #{maps\ 2210}#)
- (#{regen\ 2113}# #{e\ 2209}#))))
- #{tmp\ 2206}#)
- ((lambda (#{_\ 2211}#)
+ #{ellipsis?\ 175}#
+ #{mod\ 1363}#))
+ (lambda (#{e\ 1369}# #{maps\ 1370}#)
+ (#{regen\ 1273}# #{e\ 1369}#))))
+ #{tmp\ 1366}#)
+ ((lambda (#{_\ 1371}#)
(syntax-violation
'syntax
"bad `syntax' form"
- #{e\ 2204}#))
- #{tmp\ 2205}#)))
- ($sc-dispatch #{tmp\ 2205}# (quote (any any)))))
- #{e\ 2204}#)))))
- (#{global-extend\ 1295}#
+ #{e\ 1364}#))
+ #{tmp\ 1365}#)))
+ ($sc-dispatch #{tmp\ 1365}# (quote (any any)))))
+ #{e\ 1364}#)))))
+ (#{global-extend\ 129}#
'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}#
+ (lambda (#{e\ 1372}#
+ #{r\ 1373}#
+ #{w\ 1374}#
+ #{s\ 1375}#
+ #{mod\ 1376}#)
+ ((lambda (#{tmp\ 1377}#)
+ ((lambda (#{tmp\ 1378}#)
+ (if (if #{tmp\ 1378}#
+ (apply (lambda (#{_\ 1379}#
+ #{args\ 1380}#
+ #{docstring\ 1381}#
+ #{e1\ 1382}#
+ #{e2\ 1383}#)
+ (string? (syntax->datum #{docstring\ 1381}#)))
+ #{tmp\ 1378}#)
+ #f)
+ (apply (lambda (#{_\ 1384}#
+ #{args\ 1385}#
+ #{docstring\ 1386}#
+ #{e1\ 1387}#
+ #{e2\ 1388}#)
+ (call-with-values
+ (lambda ()
+ (#{lambda-formals\ 176}# #{args\ 1385}#))
+ (lambda (#{req\ 1389}#
+ #{opt\ 1390}#
+ #{rest\ 1391}#
+ #{kw\ 1392}#
+ #{pred\ 1393}#)
+ (#{chi-simple-lambda\ 177}#
+ #{e\ 1372}#
+ #{r\ 1373}#
+ #{w\ 1374}#
+ #{s\ 1375}#
+ #{mod\ 1376}#
+ #{req\ 1389}#
+ #{rest\ 1391}#
+ (syntax->datum #{docstring\ 1386}#)
+ (cons #{e1\ 1387}# #{e2\ 1388}#)))))
+ #{tmp\ 1378}#)
+ ((lambda (#{tmp\ 1395}#)
+ (if #{tmp\ 1395}#
+ (apply (lambda (#{_\ 1396}#
+ #{args\ 1397}#
+ #{e1\ 1398}#
+ #{e2\ 1399}#)
+ (call-with-values
+ (lambda ()
+ (#{lambda-formals\ 176}# #{args\ 1397}#))
+ (lambda (#{req\ 1400}#
+ #{opt\ 1401}#
+ #{rest\ 1402}#
+ #{kw\ 1403}#
+ #{pred\ 1404}#)
+ (#{chi-simple-lambda\ 177}#
+ #{e\ 1372}#
+ #{r\ 1373}#
+ #{w\ 1374}#
+ #{s\ 1375}#
+ #{mod\ 1376}#
+ #{req\ 1400}#
+ #{rest\ 1402}#
+ #f
+ (cons #{e1\ 1398}# #{e2\ 1399}#)))))
+ #{tmp\ 1395}#)
+ ((lambda (#{_\ 1406}#)
+ (syntax-violation
+ 'lambda
+ "bad lambda"
+ #{e\ 1372}#))
+ #{tmp\ 1377}#)))
+ ($sc-dispatch
+ #{tmp\ 1377}#
+ '(any any any . each-any)))))
+ ($sc-dispatch
+ #{tmp\ 1377}#
+ '(any any any any . each-any))))
+ #{e\ 1372}#)))
+ (#{global-extend\ 129}#
+ 'core
+ 'lambda*
+ (lambda (#{e\ 1407}#
+ #{r\ 1408}#
+ #{w\ 1409}#
+ #{s\ 1410}#
+ #{mod\ 1411}#)
+ ((lambda (#{tmp\ 1412}#)
+ ((lambda (#{tmp\ 1413}#)
+ (if #{tmp\ 1413}#
+ (apply (lambda (#{_\ 1414}#
+ #{args\ 1415}#
+ #{e1\ 1416}#
+ #{e2\ 1417}#)
+ (call-with-values
+ (lambda ()
+ (#{chi-lambda-case\ 179}#
+ #{e\ 1407}#
+ #{r\ 1408}#
+ #{w\ 1409}#
+ #{s\ 1410}#
+ #{mod\ 1411}#
+ #{lambda*-formals\ 178}#
+ (list (cons #{args\ 1415}#
+ (cons #{e1\ 1416}#
+ #{e2\ 1417}#)))))
+ (lambda (#{docstring\ 1419}# #{lcase\ 1420}#)
+ (#{build-case-lambda\ 106}#
+ #{s\ 1410}#
+ #{docstring\ 1419}#
+ #{lcase\ 1420}#))))
+ #{tmp\ 1413}#)
+ ((lambda (#{_\ 1421}#)
+ (syntax-violation
+ 'lambda
+ "bad lambda*"
+ #{e\ 1407}#))
+ #{tmp\ 1412}#)))
+ ($sc-dispatch
+ #{tmp\ 1412}#
+ '(any any any . each-any))))
+ #{e\ 1407}#)))
+ (#{global-extend\ 129}#
+ 'core
+ 'case-lambda
+ (lambda (#{e\ 1422}#
+ #{r\ 1423}#
+ #{w\ 1424}#
+ #{s\ 1425}#
+ #{mod\ 1426}#)
+ ((lambda (#{tmp\ 1427}#)
+ ((lambda (#{tmp\ 1428}#)
+ (if #{tmp\ 1428}#
+ (apply (lambda (#{_\ 1429}#
+ #{args\ 1430}#
+ #{e1\ 1431}#
+ #{e2\ 1432}#
+ #{args*\ 1433}#
+ #{e1*\ 1434}#
+ #{e2*\ 1435}#)
+ (call-with-values
+ (lambda ()
+ (#{chi-lambda-case\ 179}#
+ #{e\ 1422}#
+ #{r\ 1423}#
+ #{w\ 1424}#
+ #{s\ 1425}#
+ #{mod\ 1426}#
+ #{lambda-formals\ 176}#
+ (cons (cons #{args\ 1430}#
+ (cons #{e1\ 1431}# #{e2\ 1432}#))
+ (map (lambda (#{tmp\ 1439}#
+ #{tmp\ 1438}#
+ #{tmp\ 1437}#)
+ (cons #{tmp\ 1437}#
+ (cons #{tmp\ 1438}#
+ #{tmp\ 1439}#)))
+ #{e2*\ 1435}#
+ #{e1*\ 1434}#
+ #{args*\ 1433}#))))
+ (lambda (#{docstring\ 1441}# #{lcase\ 1442}#)
+ (#{build-case-lambda\ 106}#
+ #{s\ 1425}#
+ #{docstring\ 1441}#
+ #{lcase\ 1442}#))))
+ #{tmp\ 1428}#)
+ ((lambda (#{_\ 1443}#)
+ (syntax-violation
+ 'case-lambda
+ "bad case-lambda"
+ #{e\ 1422}#))
+ #{tmp\ 1427}#)))
+ ($sc-dispatch
+ #{tmp\ 1427}#
+ '(any (any any . each-any)
+ .
+ #(each (any any . each-any))))))
+ #{e\ 1422}#)))
+ (#{global-extend\ 129}#
+ 'core
+ 'case-lambda*
+ (lambda (#{e\ 1444}#
+ #{r\ 1445}#
+ #{w\ 1446}#
+ #{s\ 1447}#
+ #{mod\ 1448}#)
+ ((lambda (#{tmp\ 1449}#)
+ ((lambda (#{tmp\ 1450}#)
+ (if #{tmp\ 1450}#
+ (apply (lambda (#{_\ 1451}#
+ #{args\ 1452}#
+ #{e1\ 1453}#
+ #{e2\ 1454}#
+ #{args*\ 1455}#
+ #{e1*\ 1456}#
+ #{e2*\ 1457}#)
+ (call-with-values
+ (lambda ()
+ (#{chi-lambda-case\ 179}#
+ #{e\ 1444}#
+ #{r\ 1445}#
+ #{w\ 1446}#
+ #{s\ 1447}#
+ #{mod\ 1448}#
+ #{lambda*-formals\ 178}#
+ (cons (cons #{args\ 1452}#
+ (cons #{e1\ 1453}# #{e2\ 1454}#))
+ (map (lambda (#{tmp\ 1461}#
+ #{tmp\ 1460}#
+ #{tmp\ 1459}#)
+ (cons #{tmp\ 1459}#
+ (cons #{tmp\ 1460}#
+ #{tmp\ 1461}#)))
+ #{e2*\ 1457}#
+ #{e1*\ 1456}#
+ #{args*\ 1455}#))))
+ (lambda (#{docstring\ 1463}# #{lcase\ 1464}#)
+ (#{build-case-lambda\ 106}#
+ #{s\ 1447}#
+ #{docstring\ 1463}#
+ #{lcase\ 1464}#))))
+ #{tmp\ 1450}#)
+ ((lambda (#{_\ 1465}#)
+ (syntax-violation
+ 'case-lambda
+ "bad case-lambda*"
+ #{e\ 1444}#))
+ #{tmp\ 1449}#)))
+ ($sc-dispatch
+ #{tmp\ 1449}#
+ '(any (any any . each-any)
+ .
+ #(each (any any . each-any))))))
+ #{e\ 1444}#)))
+ (#{global-extend\ 129}#
'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}#))
+ (letrec ((#{chi-let\ 1466}#
+ (lambda (#{e\ 1467}#
+ #{r\ 1468}#
+ #{w\ 1469}#
+ #{s\ 1470}#
+ #{mod\ 1471}#
+ #{constructor\ 1472}#
+ #{ids\ 1473}#
+ #{vals\ 1474}#
+ #{exps\ 1475}#)
+ (if (not (#{valid-bound-ids?\ 156}# #{ids\ 1473}#))
(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}#)
+ #{e\ 1467}#)
+ (let ((#{labels\ 1476}#
+ (#{gen-labels\ 137}# #{ids\ 1473}#))
+ (#{new-vars\ 1477}#
+ (map #{gen-var\ 181}# #{ids\ 1473}#)))
+ (let ((#{nw\ 1478}#
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 1473}#
+ #{labels\ 1476}#
+ #{w\ 1469}#))
+ (#{nr\ 1479}#
+ (#{extend-var-env\ 126}#
+ #{labels\ 1476}#
+ #{new-vars\ 1477}#
+ #{r\ 1468}#)))
+ (#{constructor\ 1472}#
+ #{s\ 1470}#
+ (map syntax->datum #{ids\ 1473}#)
+ #{new-vars\ 1477}#
+ (map (lambda (#{x\ 1480}#)
+ (#{chi\ 167}#
+ #{x\ 1480}#
+ #{r\ 1468}#
+ #{w\ 1469}#
+ #{mod\ 1471}#))
+ #{vals\ 1474}#)
+ (#{chi-body\ 171}#
+ #{exps\ 1475}#
+ (#{source-wrap\ 160}#
+ #{e\ 1467}#
+ #{nw\ 1478}#
+ #{s\ 1470}#
+ #{mod\ 1471}#)
+ #{nr\ 1479}#
+ #{nw\ 1478}#
+ #{mod\ 1471}#))))))))
+ (lambda (#{e\ 1481}#
+ #{r\ 1482}#
+ #{w\ 1483}#
+ #{s\ 1484}#
+ #{mod\ 1485}#)
+ ((lambda (#{tmp\ 1486}#)
+ ((lambda (#{tmp\ 1487}#)
+ (if (if #{tmp\ 1487}#
+ (apply (lambda (#{_\ 1488}#
+ #{id\ 1489}#
+ #{val\ 1490}#
+ #{e1\ 1491}#
+ #{e2\ 1492}#)
+ (and-map #{id?\ 131}# #{id\ 1489}#))
+ #{tmp\ 1487}#)
#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}#)
+ (apply (lambda (#{_\ 1494}#
+ #{id\ 1495}#
+ #{val\ 1496}#
+ #{e1\ 1497}#
+ #{e2\ 1498}#)
+ (#{chi-let\ 1466}#
+ #{e\ 1481}#
+ #{r\ 1482}#
+ #{w\ 1483}#
+ #{s\ 1484}#
+ #{mod\ 1485}#
+ #{build-let\ 111}#
+ #{id\ 1495}#
+ #{val\ 1496}#
+ (cons #{e1\ 1497}# #{e2\ 1498}#)))
+ #{tmp\ 1487}#)
+ ((lambda (#{tmp\ 1502}#)
+ (if (if #{tmp\ 1502}#
+ (apply (lambda (#{_\ 1503}#
+ #{f\ 1504}#
+ #{id\ 1505}#
+ #{val\ 1506}#
+ #{e1\ 1507}#
+ #{e2\ 1508}#)
+ (if (#{id?\ 131}# #{f\ 1504}#)
+ (and-map #{id?\ 131}# #{id\ 1505}#)
#f))
- #{tmp\ 2261}#)
+ #{tmp\ 1502}#)
#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}#)
+ (apply (lambda (#{_\ 1510}#
+ #{f\ 1511}#
+ #{id\ 1512}#
+ #{val\ 1513}#
+ #{e1\ 1514}#
+ #{e2\ 1515}#)
+ (#{chi-let\ 1466}#
+ #{e\ 1481}#
+ #{r\ 1482}#
+ #{w\ 1483}#
+ #{s\ 1484}#
+ #{mod\ 1485}#
+ #{build-named-let\ 112}#
+ (cons #{f\ 1511}# #{id\ 1512}#)
+ #{val\ 1513}#
+ (cons #{e1\ 1514}# #{e2\ 1515}#)))
+ #{tmp\ 1502}#)
+ ((lambda (#{_\ 1519}#)
(syntax-violation
'let
"bad let"
- (#{source-wrap\ 1326}#
- #{e\ 2240}#
- #{w\ 2242}#
- #{s\ 2243}#
- #{mod\ 2244}#)))
- #{tmp\ 2245}#)))
+ (#{source-wrap\ 160}#
+ #{e\ 1481}#
+ #{w\ 1483}#
+ #{s\ 1484}#
+ #{mod\ 1485}#)))
+ #{tmp\ 1486}#)))
($sc-dispatch
- #{tmp\ 2245}#
+ #{tmp\ 1486}#
'(any any #(each (any any)) any . each-any)))))
($sc-dispatch
- #{tmp\ 2245}#
+ #{tmp\ 1486}#
'(any #(each (any any)) any . each-any))))
- #{e\ 2240}#))))
- (#{global-extend\ 1295}#
+ #{e\ 1481}#))))
+ (#{global-extend\ 129}#
'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}#)
+ (lambda (#{e\ 1520}#
+ #{r\ 1521}#
+ #{w\ 1522}#
+ #{s\ 1523}#
+ #{mod\ 1524}#)
+ ((lambda (#{tmp\ 1525}#)
+ ((lambda (#{tmp\ 1526}#)
+ (if (if #{tmp\ 1526}#
+ (apply (lambda (#{_\ 1527}#
+ #{id\ 1528}#
+ #{val\ 1529}#
+ #{e1\ 1530}#
+ #{e2\ 1531}#)
+ (and-map #{id?\ 131}# #{id\ 1528}#))
+ #{tmp\ 1526}#)
#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}#))
+ (apply (lambda (#{_\ 1533}#
+ #{id\ 1534}#
+ #{val\ 1535}#
+ #{e1\ 1536}#
+ #{e2\ 1537}#)
+ (let ((#{ids\ 1538}# #{id\ 1534}#))
+ (if (not (#{valid-bound-ids?\ 156}#
+ #{ids\ 1538}#))
(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}#)
+ #{e\ 1520}#)
+ (let ((#{labels\ 1540}#
+ (#{gen-labels\ 137}# #{ids\ 1538}#))
+ (#{new-vars\ 1541}#
+ (map #{gen-var\ 181}# #{ids\ 1538}#)))
+ (let ((#{w\ 1542}#
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 1538}#
+ #{labels\ 1540}#
+ #{w\ 1522}#))
+ (#{r\ 1543}#
+ (#{extend-var-env\ 126}#
+ #{labels\ 1540}#
+ #{new-vars\ 1541}#
+ #{r\ 1521}#)))
+ (#{build-letrec\ 113}#
+ #{s\ 1523}#
+ (map syntax->datum #{ids\ 1538}#)
+ #{new-vars\ 1541}#
+ (map (lambda (#{x\ 1544}#)
+ (#{chi\ 167}#
+ #{x\ 1544}#
+ #{r\ 1543}#
+ #{w\ 1542}#
+ #{mod\ 1524}#))
+ #{val\ 1535}#)
+ (#{chi-body\ 171}#
+ (cons #{e1\ 1536}# #{e2\ 1537}#)
+ (#{source-wrap\ 160}#
+ #{e\ 1520}#
+ #{w\ 1542}#
+ #{s\ 1523}#
+ #{mod\ 1524}#)
+ #{r\ 1543}#
+ #{w\ 1542}#
+ #{mod\ 1524}#)))))))
+ #{tmp\ 1526}#)
+ ((lambda (#{_\ 1547}#)
(syntax-violation
'letrec
"bad letrec"
- (#{source-wrap\ 1326}#
- #{e\ 2279}#
- #{w\ 2281}#
- #{s\ 2282}#
- #{mod\ 2283}#)))
- #{tmp\ 2284}#)))
+ (#{source-wrap\ 160}#
+ #{e\ 1520}#
+ #{w\ 1522}#
+ #{s\ 1523}#
+ #{mod\ 1524}#)))
+ #{tmp\ 1525}#)))
($sc-dispatch
- #{tmp\ 2284}#
+ #{tmp\ 1525}#
'(any #(each (any any)) any . each-any))))
- #{e\ 2279}#)))
- (#{global-extend\ 1295}#
+ #{e\ 1520}#)))
+ (#{global-extend\ 129}#
'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}#)
+ (lambda (#{e\ 1548}#
+ #{r\ 1549}#
+ #{w\ 1550}#
+ #{s\ 1551}#
+ #{mod\ 1552}#)
+ ((lambda (#{tmp\ 1553}#)
+ ((lambda (#{tmp\ 1554}#)
+ (if (if #{tmp\ 1554}#
+ (apply (lambda (#{_\ 1555}# #{id\ 1556}# #{val\ 1557}#)
+ (#{id?\ 131}# #{id\ 1556}#))
+ #{tmp\ 1554}#)
#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}#
+ (apply (lambda (#{_\ 1558}# #{id\ 1559}# #{val\ 1560}#)
+ (let ((#{val\ 1561}#
+ (#{chi\ 167}#
+ #{val\ 1560}#
+ #{r\ 1549}#
+ #{w\ 1550}#
+ #{mod\ 1552}#))
+ (#{n\ 1562}#
+ (#{id-var-name\ 153}#
+ #{id\ 1559}#
+ #{w\ 1550}#)))
+ (let ((#{b\ 1563}#
+ (#{lookup\ 128}#
+ #{n\ 1562}#
+ #{r\ 1549}#
+ #{mod\ 1552}#)))
+ (let ((#{atom-key\ 1564}#
+ (#{binding-type\ 123}# #{b\ 1563}#)))
+ (if (memv #{atom-key\ 1564}#
'(lexical))
- (#{build-lexical-assignment\ 1267}#
- #{s\ 2310}#
- (syntax->datum #{id\ 2318}#)
- (#{binding-value\ 1290}# #{b\ 2322}#)
- #{val\ 2320}#)
- (if (memv #{atom-key\ 2323}#
+ (#{build-lexical-assignment\ 99}#
+ #{s\ 1551}#
+ (syntax->datum #{id\ 1559}#)
+ (#{binding-value\ 124}# #{b\ 1563}#)
+ #{val\ 1561}#)
+ (if (memv #{atom-key\ 1564}#
'(global))
- (#{build-global-assignment\ 1270}#
- #{s\ 2310}#
- #{n\ 2321}#
- #{val\ 2320}#
- #{mod\ 2311}#)
- (if (memv #{atom-key\ 2323}#
+ (#{build-global-assignment\ 102}#
+ #{s\ 1551}#
+ #{n\ 1562}#
+ #{val\ 1561}#
+ #{mod\ 1552}#)
+ (if (memv #{atom-key\ 1564}#
'(displaced-lexical))
(syntax-violation
'set!
"identifier out of context"
- (#{wrap\ 1325}#
- #{id\ 2318}#
- #{w\ 2309}#
- #{mod\ 2311}#))
+ (#{wrap\ 159}#
+ #{id\ 1559}#
+ #{w\ 1550}#
+ #{mod\ 1552}#))
(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}#)
+ (#{source-wrap\ 160}#
+ #{e\ 1548}#
+ #{w\ 1550}#
+ #{s\ 1551}#
+ #{mod\ 1552}#)))))))))
+ #{tmp\ 1554}#)
+ ((lambda (#{tmp\ 1565}#)
+ (if #{tmp\ 1565}#
+ (apply (lambda (#{_\ 1566}#
+ #{head\ 1567}#
+ #{tail\ 1568}#
+ #{val\ 1569}#)
(call-with-values
(lambda ()
- (#{syntax-type\ 1331}#
- #{head\ 2326}#
- #{r\ 2308}#
+ (#{syntax-type\ 165}#
+ #{head\ 1567}#
+ #{r\ 1549}#
'(())
#f
#f
- #{mod\ 2311}#
+ #{mod\ 1552}#
#t))
- (lambda (#{type\ 2329}#
- #{value\ 2330}#
- #{ee\ 2331}#
- #{ww\ 2332}#
- #{ss\ 2333}#
- #{modmod\ 2334}#)
- (if (memv #{type\ 2329}#
+ (lambda (#{type\ 1570}#
+ #{value\ 1571}#
+ #{ee\ 1572}#
+ #{ww\ 1573}#
+ #{ss\ 1574}#
+ #{modmod\ 1575}#)
+ (if (memv #{type\ 1570}#
'(module-ref))
- (let ((#{val\ 2335}#
- (#{chi\ 1333}#
- #{val\ 2328}#
- #{r\ 2308}#
- #{w\ 2309}#
- #{mod\ 2311}#)))
+ (let ((#{val\ 1576}#
+ (#{chi\ 167}#
+ #{val\ 1569}#
+ #{r\ 1549}#
+ #{w\ 1550}#
+ #{mod\ 1552}#)))
(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}#
+ (#{value\ 1571}#
+ (cons #{head\ 1567}#
+ #{tail\ 1568}#)))
+ (lambda (#{id\ 1578}# #{mod\ 1579}#)
+ (#{build-global-assignment\ 102}#
+ #{s\ 1551}#
+ #{id\ 1578}#
+ #{val\ 1576}#
+ #{mod\ 1579}#))))
+ (#{build-application\ 96}#
+ #{s\ 1551}#
+ (#{chi\ 167}#
(list '#(syntax-object
setter
((top)
@@ -6815,11 +9224,14 @@
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -6901,7 +9313,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -7035,6 +9449,11 @@
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
@@ -7147,6 +9566,11 @@
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -7154,53 +9578,53 @@
((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}#))
+ #{head\ 1567}#)
+ #{r\ 1549}#
+ #{w\ 1550}#
+ #{mod\ 1552}#)
+ (map (lambda (#{e\ 1580}#)
+ (#{chi\ 167}#
+ #{e\ 1580}#
+ #{r\ 1549}#
+ #{w\ 1550}#
+ #{mod\ 1552}#))
(append
- #{tail\ 2327}#
- (list #{val\ 2328}#))))))))
- #{tmp\ 2324}#)
- ((lambda (#{_\ 2341}#)
+ #{tail\ 1568}#
+ (list #{val\ 1569}#))))))))
+ #{tmp\ 1565}#)
+ ((lambda (#{_\ 1582}#)
(syntax-violation
'set!
"bad set!"
- (#{source-wrap\ 1326}#
- #{e\ 2307}#
- #{w\ 2309}#
- #{s\ 2310}#
- #{mod\ 2311}#)))
- #{tmp\ 2312}#)))
+ (#{source-wrap\ 160}#
+ #{e\ 1548}#
+ #{w\ 1550}#
+ #{s\ 1551}#
+ #{mod\ 1552}#)))
+ #{tmp\ 1553}#)))
($sc-dispatch
- #{tmp\ 2312}#
+ #{tmp\ 1553}#
'(any (any . each-any) any)))))
($sc-dispatch
- #{tmp\ 2312}#
+ #{tmp\ 1553}#
'(any any any))))
- #{e\ 2307}#)))
- (#{global-extend\ 1295}#
+ #{e\ 1548}#)))
+ (#{global-extend\ 129}#
'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}#)
+ (lambda (#{e\ 1583}#)
+ ((lambda (#{tmp\ 1584}#)
+ ((lambda (#{tmp\ 1585}#)
+ (if (if #{tmp\ 1585}#
+ (apply (lambda (#{_\ 1586}# #{mod\ 1587}# #{id\ 1588}#)
+ (if (and-map #{id?\ 131}# #{mod\ 1587}#)
+ (#{id?\ 131}# #{id\ 1588}#)
#f))
- #{tmp\ 2344}#)
+ #{tmp\ 1585}#)
#f)
- (apply (lambda (#{_\ 2349}# #{mod\ 2350}# #{id\ 2351}#)
+ (apply (lambda (#{_\ 1590}# #{mod\ 1591}# #{id\ 1592}#)
(values
- (syntax->datum #{id\ 2351}#)
+ (syntax->datum #{id\ 1592}#)
(syntax->datum
(cons '#(syntax-object
public
@@ -7215,11 +9639,14 @@
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -7301,7 +9728,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -7435,6 +9864,11 @@
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
@@ -7547,38 +9981,43 @@
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
((top) (top))
("i" "i")))
(hygiene guile))
- #{mod\ 2350}#))))
- #{tmp\ 2344}#)
+ #{mod\ 1591}#))))
+ #{tmp\ 1585}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2343}#)))
+ #{tmp\ 1584}#)))
($sc-dispatch
- #{tmp\ 2343}#
+ #{tmp\ 1584}#
'(any each-any any))))
- #{e\ 2342}#)))
- (#{global-extend\ 1295}#
+ #{e\ 1583}#)))
+ (#{global-extend\ 129}#
'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}#)
+ (lambda (#{e\ 1594}#)
+ ((lambda (#{tmp\ 1595}#)
+ ((lambda (#{tmp\ 1596}#)
+ (if (if #{tmp\ 1596}#
+ (apply (lambda (#{_\ 1597}# #{mod\ 1598}# #{id\ 1599}#)
+ (if (and-map #{id?\ 131}# #{mod\ 1598}#)
+ (#{id?\ 131}# #{id\ 1599}#)
#f))
- #{tmp\ 2355}#)
+ #{tmp\ 1596}#)
#f)
- (apply (lambda (#{_\ 2360}# #{mod\ 2361}# #{id\ 2362}#)
+ (apply (lambda (#{_\ 1601}# #{mod\ 1602}# #{id\ 1603}#)
(values
- (syntax->datum #{id\ 2362}#)
+ (syntax->datum #{id\ 1603}#)
(syntax->datum
(cons '#(syntax-object
private
@@ -7593,11 +10032,14 @@
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -7679,7 +10121,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -7813,6 +10257,11 @@
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
@@ -7925,129 +10374,134 @@
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure and-map*)
((top) (top))
("i" "i")))
(hygiene guile))
- #{mod\ 2361}#))))
- #{tmp\ 2355}#)
+ #{mod\ 1602}#))))
+ #{tmp\ 1596}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2354}#)))
+ #{tmp\ 1595}#)))
($sc-dispatch
- #{tmp\ 2354}#
+ #{tmp\ 1595}#
'(any each-any any))))
- #{e\ 2353}#)))
- (#{global-extend\ 1295}#
+ #{e\ 1594}#)))
+ (#{global-extend\ 129}#
'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}#)
+ (lambda (#{e\ 1605}#
+ #{r\ 1606}#
+ #{w\ 1607}#
+ #{s\ 1608}#
+ #{mod\ 1609}#)
+ ((lambda (#{tmp\ 1610}#)
+ ((lambda (#{tmp\ 1611}#)
+ (if #{tmp\ 1611}#
+ (apply (lambda (#{_\ 1612}# #{test\ 1613}# #{then\ 1614}#)
+ (#{build-conditional\ 97}#
+ #{s\ 1608}#
+ (#{chi\ 167}#
+ #{test\ 1613}#
+ #{r\ 1606}#
+ #{w\ 1607}#
+ #{mod\ 1609}#)
+ (#{chi\ 167}#
+ #{then\ 1614}#
+ #{r\ 1606}#
+ #{w\ 1607}#
+ #{mod\ 1609}#)
+ (#{build-void\ 95}# #f)))
+ #{tmp\ 1611}#)
+ ((lambda (#{tmp\ 1615}#)
+ (if #{tmp\ 1615}#
+ (apply (lambda (#{_\ 1616}#
+ #{test\ 1617}#
+ #{then\ 1618}#
+ #{else\ 1619}#)
+ (#{build-conditional\ 97}#
+ #{s\ 1608}#
+ (#{chi\ 167}#
+ #{test\ 1617}#
+ #{r\ 1606}#
+ #{w\ 1607}#
+ #{mod\ 1609}#)
+ (#{chi\ 167}#
+ #{then\ 1618}#
+ #{r\ 1606}#
+ #{w\ 1607}#
+ #{mod\ 1609}#)
+ (#{chi\ 167}#
+ #{else\ 1619}#
+ #{r\ 1606}#
+ #{w\ 1607}#
+ #{mod\ 1609}#)))
+ #{tmp\ 1615}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2369}#)))
+ #{tmp\ 1610}#)))
($sc-dispatch
- #{tmp\ 2369}#
+ #{tmp\ 1610}#
'(any any any any)))))
($sc-dispatch
- #{tmp\ 2369}#
+ #{tmp\ 1610}#
'(any any any))))
- #{e\ 2364}#)))
- (#{global-extend\ 1295}#
+ #{e\ 1605}#)))
+ (#{global-extend\ 129}#
'begin
'begin
'())
- (#{global-extend\ 1295}#
+ (#{global-extend\ 129}#
'define
'define
'())
- (#{global-extend\ 1295}#
+ (#{global-extend\ 129}#
'define-syntax
'define-syntax
'())
- (#{global-extend\ 1295}#
+ (#{global-extend\ 129}#
'eval-when
'eval-when
'())
- (#{global-extend\ 1295}#
+ (#{global-extend\ 129}#
'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}#
+ (letrec ((#{gen-syntax-case\ 1623}#
+ (lambda (#{x\ 1624}#
+ #{keys\ 1625}#
+ #{clauses\ 1626}#
+ #{r\ 1627}#
+ #{mod\ 1628}#)
+ (if (null? #{clauses\ 1626}#)
+ (#{build-application\ 96}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 108}#
#f
'syntax-violation)
- (list (#{build-data\ 1275}# #f #f)
- (#{build-data\ 1275}#
+ (list (#{build-data\ 109}# #f #f)
+ (#{build-data\ 109}#
#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}#)
+ #{x\ 1624}#))
+ ((lambda (#{tmp\ 1629}#)
+ ((lambda (#{tmp\ 1630}#)
+ (if #{tmp\ 1630}#
+ (apply (lambda (#{pat\ 1631}# #{exp\ 1632}#)
+ (if (if (#{id?\ 131}# #{pat\ 1631}#)
(and-map
- (lambda (#{x\ 2392}#)
- (not (#{free-id=?\ 1320}#
- #{pat\ 2390}#
- #{x\ 2392}#)))
+ (lambda (#{x\ 1633}#)
+ (not (#{free-id=?\ 154}#
+ #{pat\ 1631}#
+ #{x\ 1633}#)))
(cons '#(syntax-object
...
((top)
@@ -8086,11 +10540,14 @@
(lambda-var-list
gen-var
strip
+ chi-lambda-case
+ lambda*-formals
+ chi-simple-lambda
+ lambda-formals
ellipsis?
chi-void
eval-local-transformer
chi-local-syntax
- chi-lambda-clause
chi-body
chi-macro
chi-application
@@ -8172,7 +10629,9 @@
build-sequence
build-data
build-primref
- build-lambda
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
build-global-definition
maybe-name-value!
build-global-assignment
@@ -8306,6 +10765,11 @@
(top)
(top)
(top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
(top))
("i"
"i"
@@ -8418,6 +10882,11 @@
"i"
"i"
"i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
"i"))
#(ribcage
(define-structure
@@ -8425,731 +10894,734 @@
((top) (top))
("i" "i")))
(hygiene guile))
- #{keys\ 2384}#))
+ #{keys\ 1625}#))
#f)
- (let ((#{labels\ 2393}#
- (list (#{gen-label\ 1302}#)))
- (#{var\ 2394}#
- (#{gen-var\ 1344}#
- #{pat\ 2390}#)))
- (#{build-application\ 1264}#
+ (let ((#{labels\ 1634}#
+ (list (#{gen-label\ 136}#)))
+ (#{var\ 1635}#
+ (#{gen-var\ 181}#
+ #{pat\ 1631}#)))
+ (#{build-application\ 96}#
#f
- (#{build-lambda\ 1273}#
+ (#{build-simple-lambda\ 105}#
#f
(list (syntax->datum
- #{pat\ 2390}#))
- (list #{var\ 2394}#)
+ #{pat\ 1631}#))
+ #f
+ (list #{var\ 1635}#)
#f
- (#{chi\ 1333}#
- #{exp\ 2391}#
- (#{extend-env\ 1291}#
- #{labels\ 2393}#
+ (#{chi\ 167}#
+ #{exp\ 1632}#
+ (#{extend-env\ 125}#
+ #{labels\ 1634}#
(list (cons 'syntax
- (cons #{var\ 2394}#
+ (cons #{var\ 1635}#
0)))
- #{r\ 2386}#)
- (#{make-binding-wrap\ 1314}#
- (list #{pat\ 2390}#)
- #{labels\ 2393}#
+ #{r\ 1627}#)
+ (#{make-binding-wrap\ 148}#
+ (list #{pat\ 1631}#)
+ #{labels\ 1634}#
'(()))
- #{mod\ 2387}#))
- (list #{x\ 2383}#)))
- (#{gen-clause\ 2381}#
- #{x\ 2383}#
- #{keys\ 2384}#
- (cdr #{clauses\ 2385}#)
- #{r\ 2386}#
- #{pat\ 2390}#
+ #{mod\ 1628}#))
+ (list #{x\ 1624}#)))
+ (#{gen-clause\ 1622}#
+ #{x\ 1624}#
+ #{keys\ 1625}#
+ (cdr #{clauses\ 1626}#)
+ #{r\ 1627}#
+ #{pat\ 1631}#
#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}#)
+ #{exp\ 1632}#
+ #{mod\ 1628}#)))
+ #{tmp\ 1630}#)
+ ((lambda (#{tmp\ 1636}#)
+ (if #{tmp\ 1636}#
+ (apply (lambda (#{pat\ 1637}#
+ #{fender\ 1638}#
+ #{exp\ 1639}#)
+ (#{gen-clause\ 1622}#
+ #{x\ 1624}#
+ #{keys\ 1625}#
+ (cdr #{clauses\ 1626}#)
+ #{r\ 1627}#
+ #{pat\ 1637}#
+ #{fender\ 1638}#
+ #{exp\ 1639}#
+ #{mod\ 1628}#))
+ #{tmp\ 1636}#)
+ ((lambda (#{_\ 1640}#)
(syntax-violation
'syntax-case
"invalid clause"
- (car #{clauses\ 2385}#)))
- #{tmp\ 2388}#)))
+ (car #{clauses\ 1626}#)))
+ #{tmp\ 1629}#)))
($sc-dispatch
- #{tmp\ 2388}#
+ #{tmp\ 1629}#
'(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}#)
+ ($sc-dispatch #{tmp\ 1629}# (quote (any any)))))
+ (car #{clauses\ 1626}#)))))
+ (#{gen-clause\ 1622}#
+ (lambda (#{x\ 1641}#
+ #{keys\ 1642}#
+ #{clauses\ 1643}#
+ #{r\ 1644}#
+ #{pat\ 1645}#
+ #{fender\ 1646}#
+ #{exp\ 1647}#
+ #{mod\ 1648}#)
(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}#)))
+ (#{convert-pattern\ 1620}#
+ #{pat\ 1645}#
+ #{keys\ 1642}#))
+ (lambda (#{p\ 1649}# #{pvars\ 1650}#)
+ (if (not (#{distinct-bound-ids?\ 157}#
+ (map car #{pvars\ 1650}#)))
(syntax-violation
'syntax-case
"duplicate pattern variable"
- #{pat\ 2404}#)
+ #{pat\ 1645}#)
(if (not (and-map
- (lambda (#{x\ 2410}#)
- (not (#{ellipsis?\ 1342}#
- (car #{x\ 2410}#))))
- #{pvars\ 2409}#))
+ (lambda (#{x\ 1651}#)
+ (not (#{ellipsis?\ 175}#
+ (car #{x\ 1651}#))))
+ #{pvars\ 1650}#))
(syntax-violation
'syntax-case
"misplaced ellipsis"
- #{pat\ 2404}#)
- (let ((#{y\ 2411}#
- (#{gen-var\ 1344}# (quote tmp))))
- (#{build-application\ 1264}#
+ #{pat\ 1645}#)
+ (let ((#{y\ 1652}#
+ (#{gen-var\ 181}# (quote tmp))))
+ (#{build-application\ 96}#
#f
- (#{build-lambda\ 1273}#
+ (#{build-simple-lambda\ 105}#
#f
(list (quote tmp))
- (list #{y\ 2411}#)
#f
- (let ((#{y\ 2412}#
- (#{build-lexical-reference\ 1266}#
+ (list #{y\ 1652}#)
+ #f
+ (let ((#{y\ 1653}#
+ (#{build-lexical-reference\ 98}#
'value
#f
'tmp
- #{y\ 2411}#)))
- (#{build-conditional\ 1265}#
+ #{y\ 1652}#)))
+ (#{build-conditional\ 97}#
#f
- ((lambda (#{tmp\ 2413}#)
- ((lambda (#{tmp\ 2414}#)
- (if #{tmp\ 2414}#
- (apply (lambda () #{y\ 2412}#)
- #{tmp\ 2414}#)
- ((lambda (#{_\ 2415}#)
- (#{build-conditional\ 1265}#
+ ((lambda (#{tmp\ 1654}#)
+ ((lambda (#{tmp\ 1655}#)
+ (if #{tmp\ 1655}#
+ (apply (lambda () #{y\ 1653}#)
+ #{tmp\ 1655}#)
+ ((lambda (#{_\ 1656}#)
+ (#{build-conditional\ 97}#
#f
- #{y\ 2412}#
- (#{build-dispatch-call\ 2380}#
- #{pvars\ 2409}#
- #{fender\ 2405}#
- #{y\ 2412}#
- #{r\ 2403}#
- #{mod\ 2407}#)
- (#{build-data\ 1275}#
+ #{y\ 1653}#
+ (#{build-dispatch-call\ 1621}#
+ #{pvars\ 1650}#
+ #{fender\ 1646}#
+ #{y\ 1653}#
+ #{r\ 1644}#
+ #{mod\ 1648}#)
+ (#{build-data\ 109}#
#f
#f)))
- #{tmp\ 2413}#)))
+ #{tmp\ 1654}#)))
($sc-dispatch
- #{tmp\ 2413}#
+ #{tmp\ 1654}#
'#(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}#
+ #{fender\ 1646}#)
+ (#{build-dispatch-call\ 1621}#
+ #{pvars\ 1650}#
+ #{exp\ 1647}#
+ #{y\ 1653}#
+ #{r\ 1644}#
+ #{mod\ 1648}#)
+ (#{gen-syntax-case\ 1623}#
+ #{x\ 1641}#
+ #{keys\ 1642}#
+ #{clauses\ 1643}#
+ #{r\ 1644}#
+ #{mod\ 1648}#))))
+ (list (if (eq? #{p\ 1649}# (quote any))
+ (#{build-application\ 96}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 108}#
#f
'list)
- (list #{x\ 2400}#))
- (#{build-application\ 1264}#
+ (list #{x\ 1641}#))
+ (#{build-application\ 96}#
#f
- (#{build-primref\ 1274}#
+ (#{build-primref\ 108}#
#f
'$sc-dispatch)
- (list #{x\ 2400}#
- (#{build-data\ 1275}#
+ (list #{x\ 1641}#
+ (#{build-data\ 109}#
#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}#
+ #{p\ 1649}#)))))))))))))
+ (#{build-dispatch-call\ 1621}#
+ (lambda (#{pvars\ 1657}#
+ #{exp\ 1658}#
+ #{y\ 1659}#
+ #{r\ 1660}#
+ #{mod\ 1661}#)
+ (let ((#{ids\ 1662}# (map car #{pvars\ 1657}#))
+ (#{levels\ 1663}# (map cdr #{pvars\ 1657}#)))
+ (let ((#{labels\ 1664}#
+ (#{gen-labels\ 137}# #{ids\ 1662}#))
+ (#{new-vars\ 1665}#
+ (map #{gen-var\ 181}# #{ids\ 1662}#)))
+ (#{build-application\ 96}#
#f
- (#{build-primref\ 1274}# #f (quote apply))
- (list (#{build-lambda\ 1273}#
+ (#{build-primref\ 108}# #f (quote apply))
+ (list (#{build-simple-lambda\ 105}#
#f
- (map syntax->datum #{ids\ 2421}#)
- #{new-vars\ 2424}#
+ (map syntax->datum #{ids\ 1662}#)
#f
- (#{chi\ 1333}#
- #{exp\ 2417}#
- (#{extend-env\ 1291}#
- #{labels\ 2423}#
- (map (lambda (#{var\ 2425}#
- #{level\ 2426}#)
+ #{new-vars\ 1665}#
+ #f
+ (#{chi\ 167}#
+ #{exp\ 1658}#
+ (#{extend-env\ 125}#
+ #{labels\ 1664}#
+ (map (lambda (#{var\ 1666}#
+ #{level\ 1667}#)
(cons 'syntax
- (cons #{var\ 2425}#
- #{level\ 2426}#)))
- #{new-vars\ 2424}#
- (map cdr #{pvars\ 2416}#))
- #{r\ 2419}#)
- (#{make-binding-wrap\ 1314}#
- #{ids\ 2421}#
- #{labels\ 2423}#
+ (cons #{var\ 1666}#
+ #{level\ 1667}#)))
+ #{new-vars\ 1665}#
+ (map cdr #{pvars\ 1657}#))
+ #{r\ 1660}#)
+ (#{make-binding-wrap\ 148}#
+ #{ids\ 1662}#
+ #{labels\ 1664}#
'(()))
- #{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}#)
+ #{mod\ 1661}#))
+ #{y\ 1659}#))))))
+ (#{convert-pattern\ 1620}#
+ (lambda (#{pattern\ 1668}# #{keys\ 1669}#)
+ (letrec ((#{cvt\ 1670}#
+ (lambda (#{p\ 1671}# #{n\ 1672}# #{ids\ 1673}#)
+ (if (#{id?\ 131}# #{p\ 1671}#)
+ (if (#{bound-id-member?\ 158}#
+ #{p\ 1671}#
+ #{keys\ 1669}#)
(values
- (vector (quote free-id) #{p\ 2430}#)
- #{ids\ 2432}#)
+ (vector (quote free-id) #{p\ 1671}#)
+ #{ids\ 1673}#)
(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}#)
+ (cons (cons #{p\ 1671}# #{n\ 1672}#)
+ #{ids\ 1673}#)))
+ ((lambda (#{tmp\ 1674}#)
+ ((lambda (#{tmp\ 1675}#)
+ (if (if #{tmp\ 1675}#
+ (apply (lambda (#{x\ 1676}#
+ #{dots\ 1677}#)
+ (#{ellipsis?\ 175}#
+ #{dots\ 1677}#))
+ #{tmp\ 1675}#)
#f)
- (apply (lambda (#{x\ 2437}#
- #{dots\ 2438}#)
+ (apply (lambda (#{x\ 1678}#
+ #{dots\ 1679}#)
(call-with-values
(lambda ()
- (#{cvt\ 2429}#
- #{x\ 2437}#
- (#{fx+\ 1254}#
- #{n\ 2431}#
+ (#{cvt\ 1670}#
+ #{x\ 1678}#
+ (#{fx+\ 86}#
+ #{n\ 1672}#
1)
- #{ids\ 2432}#))
- (lambda (#{p\ 2439}#
- #{ids\ 2440}#)
+ #{ids\ 1673}#))
+ (lambda (#{p\ 1680}#
+ #{ids\ 1681}#)
(values
- (if (eq? #{p\ 2439}#
+ (if (eq? #{p\ 1680}#
'any)
'each-any
(vector
'each
- #{p\ 2439}#))
- #{ids\ 2440}#))))
- #{tmp\ 2434}#)
- ((lambda (#{tmp\ 2441}#)
- (if #{tmp\ 2441}#
- (apply (lambda (#{x\ 2442}#
- #{y\ 2443}#)
+ #{p\ 1680}#))
+ #{ids\ 1681}#))))
+ #{tmp\ 1675}#)
+ ((lambda (#{tmp\ 1682}#)
+ (if #{tmp\ 1682}#
+ (apply (lambda (#{x\ 1683}#
+ #{y\ 1684}#)
(call-with-values
(lambda ()
- (#{cvt\ 2429}#
- #{y\ 2443}#
- #{n\ 2431}#
- #{ids\ 2432}#))
- (lambda (#{y\ 2444}#
- #{ids\ 2445}#)
+ (#{cvt\ 1670}#
+ #{y\ 1684}#
+ #{n\ 1672}#
+ #{ids\ 1673}#))
+ (lambda (#{y\ 1685}#
+ #{ids\ 1686}#)
(call-with-values
(lambda ()
- (#{cvt\ 2429}#
- #{x\ 2442}#
- #{n\ 2431}#
- #{ids\ 2445}#))
- (lambda (#{x\ 2446}#
- #{ids\ 2447}#)
+ (#{cvt\ 1670}#
+ #{x\ 1683}#
+ #{n\ 1672}#
+ #{ids\ 1686}#))
+ (lambda (#{x\ 1687}#
+ #{ids\ 1688}#)
(values
- (cons #{x\ 2446}#
- #{y\ 2444}#)
- #{ids\ 2447}#))))))
- #{tmp\ 2441}#)
- ((lambda (#{tmp\ 2448}#)
- (if #{tmp\ 2448}#
+ (cons #{x\ 1687}#
+ #{y\ 1685}#)
+ #{ids\ 1688}#))))))
+ #{tmp\ 1682}#)
+ ((lambda (#{tmp\ 1689}#)
+ (if #{tmp\ 1689}#
(apply (lambda ()
(values
'()
- #{ids\ 2432}#))
- #{tmp\ 2448}#)
- ((lambda (#{tmp\ 2449}#)
- (if #{tmp\ 2449}#
- (apply (lambda (#{x\ 2450}#)
+ #{ids\ 1673}#))
+ #{tmp\ 1689}#)
+ ((lambda (#{tmp\ 1690}#)
+ (if #{tmp\ 1690}#
+ (apply (lambda (#{x\ 1691}#)
(call-with-values
(lambda ()
- (#{cvt\ 2429}#
- #{x\ 2450}#
- #{n\ 2431}#
- #{ids\ 2432}#))
- (lambda (#{p\ 2452}#
- #{ids\ 2453}#)
+ (#{cvt\ 1670}#
+ #{x\ 1691}#
+ #{n\ 1672}#
+ #{ids\ 1673}#))
+ (lambda (#{p\ 1693}#
+ #{ids\ 1694}#)
(values
(vector
'vector
- #{p\ 2452}#)
- #{ids\ 2453}#))))
- #{tmp\ 2449}#)
- ((lambda (#{x\ 2454}#)
+ #{p\ 1693}#)
+ #{ids\ 1694}#))))
+ #{tmp\ 1690}#)
+ ((lambda (#{x\ 1695}#)
(values
(vector
'atom
- (#{strip\ 1343}#
- #{p\ 2430}#
+ (#{strip\ 180}#
+ #{p\ 1671}#
'(())))
- #{ids\ 2432}#))
- #{tmp\ 2433}#)))
+ #{ids\ 1673}#))
+ #{tmp\ 1674}#)))
($sc-dispatch
- #{tmp\ 2433}#
+ #{tmp\ 1674}#
'#(vector
each-any)))))
($sc-dispatch
- #{tmp\ 2433}#
+ #{tmp\ 1674}#
'()))))
($sc-dispatch
- #{tmp\ 2433}#
+ #{tmp\ 1674}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 2433}#
+ #{tmp\ 1674}#
'(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}#)
+ #{p\ 1671}#)))))
+ (#{cvt\ 1670}# #{pattern\ 1668}# 0 (quote ()))))))
+ (lambda (#{e\ 1696}#
+ #{r\ 1697}#
+ #{w\ 1698}#
+ #{s\ 1699}#
+ #{mod\ 1700}#)
+ (let ((#{e\ 1701}#
+ (#{source-wrap\ 160}#
+ #{e\ 1696}#
+ #{w\ 1698}#
+ #{s\ 1699}#
+ #{mod\ 1700}#)))
+ ((lambda (#{tmp\ 1702}#)
+ ((lambda (#{tmp\ 1703}#)
+ (if #{tmp\ 1703}#
+ (apply (lambda (#{_\ 1704}#
+ #{val\ 1705}#
+ #{key\ 1706}#
+ #{m\ 1707}#)
(if (and-map
- (lambda (#{x\ 2467}#)
- (if (#{id?\ 1297}# #{x\ 2467}#)
- (not (#{ellipsis?\ 1342}#
- #{x\ 2467}#))
+ (lambda (#{x\ 1708}#)
+ (if (#{id?\ 131}# #{x\ 1708}#)
+ (not (#{ellipsis?\ 175}# #{x\ 1708}#))
#f))
- #{key\ 2465}#)
- (let ((#{x\ 2469}#
- (#{gen-var\ 1344}# (quote tmp))))
- (#{build-application\ 1264}#
- #{s\ 2458}#
- (#{build-lambda\ 1273}#
+ #{key\ 1706}#)
+ (let ((#{x\ 1710}#
+ (#{gen-var\ 181}# (quote tmp))))
+ (#{build-application\ 96}#
+ #{s\ 1699}#
+ (#{build-simple-lambda\ 105}#
#f
(list (quote tmp))
- (list #{x\ 2469}#)
#f
- (#{gen-syntax-case\ 2382}#
- (#{build-lexical-reference\ 1266}#
+ (list #{x\ 1710}#)
+ #f
+ (#{gen-syntax-case\ 1623}#
+ (#{build-lexical-reference\ 98}#
'value
#f
'tmp
- #{x\ 2469}#)
- #{key\ 2465}#
- #{m\ 2466}#
- #{r\ 2456}#
- #{mod\ 2459}#))
- (list (#{chi\ 1333}#
- #{val\ 2464}#
- #{r\ 2456}#
+ #{x\ 1710}#)
+ #{key\ 1706}#
+ #{m\ 1707}#
+ #{r\ 1697}#
+ #{mod\ 1700}#))
+ (list (#{chi\ 167}#
+ #{val\ 1705}#
+ #{r\ 1697}#
'(())
- #{mod\ 2459}#))))
+ #{mod\ 1700}#))))
(syntax-violation
'syntax-case
"invalid literals list"
- #{e\ 2460}#)))
- #{tmp\ 2462}#)
+ #{e\ 1701}#)))
+ #{tmp\ 1703}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2461}#)))
+ #{tmp\ 1702}#)))
($sc-dispatch
- #{tmp\ 2461}#
+ #{tmp\ 1702}#
'(any any each-any . each-any))))
- #{e\ 2460}#)))))
+ #{e\ 1701}#)))))
(set! sc-expand
- (lambda (#{x\ 2473}# . #{rest\ 2472}#)
- (if (if (pair? #{x\ 2473}#)
- (equal? (car #{x\ 2473}#) #{noexpand\ 1252}#)
+ (lambda (#{x\ 1713}# . #{rest\ 1714}#)
+ (if (if (pair? #{x\ 1713}#)
+ (equal? (car #{x\ 1713}#) #{noexpand\ 84}#)
#f)
- (cadr #{x\ 2473}#)
- (let ((#{m\ 2474}#
- (if (null? #{rest\ 2472}#)
+ (cadr #{x\ 1713}#)
+ (let ((#{m\ 1715}#
+ (if (null? #{rest\ 1714}#)
'e
- (car #{rest\ 2472}#)))
- (#{esew\ 2475}#
- (if (let ((#{t\ 2476}# (null? #{rest\ 2472}#)))
- (if #{t\ 2476}#
- #{t\ 2476}#
- (null? (cdr #{rest\ 2472}#))))
+ (car #{rest\ 1714}#)))
+ (#{esew\ 1716}#
+ (if (let ((#{t\ 1717}# (null? #{rest\ 1714}#)))
+ (if #{t\ 1717}#
+ #{t\ 1717}#
+ (null? (cdr #{rest\ 1714}#))))
'(eval)
- (cadr #{rest\ 2472}#))))
+ (cadr #{rest\ 1714}#))))
(with-fluid*
- #{*mode*\ 1253}#
- #{m\ 2474}#
+ #{*mode*\ 85}#
+ #{m\ 1715}#
(lambda ()
- (#{chi-top\ 1332}#
- #{x\ 2473}#
+ (#{chi-top\ 166}#
+ #{x\ 1713}#
'()
'((top))
- #{m\ 2474}#
- #{esew\ 2475}#
+ #{m\ 1715}#
+ #{esew\ 1716}#
(cons 'hygiene
(module-name (current-module))))))))))
(set! identifier?
- (lambda (#{x\ 2477}#)
- (#{nonsymbol-id?\ 1296}# #{x\ 2477}#)))
+ (lambda (#{x\ 1718}#)
+ (#{nonsymbol-id?\ 130}# #{x\ 1718}#)))
(set! datum->syntax
- (lambda (#{id\ 2478}# #{datum\ 2479}#)
- (#{make-syntax-object\ 1280}#
- #{datum\ 2479}#
- (#{syntax-object-wrap\ 1283}# #{id\ 2478}#)
+ (lambda (#{id\ 1719}# #{datum\ 1720}#)
+ (#{make-syntax-object\ 114}#
+ #{datum\ 1720}#
+ (#{syntax-object-wrap\ 117}# #{id\ 1719}#)
#f)))
(set! syntax->datum
- (lambda (#{x\ 2480}#)
- (#{strip\ 1343}# #{x\ 2480}# (quote (())))))
+ (lambda (#{x\ 1721}#)
+ (#{strip\ 180}# #{x\ 1721}# (quote (())))))
(set! generate-temporaries
- (lambda (#{ls\ 2481}#)
+ (lambda (#{ls\ 1722}#)
(begin
- (let ((#{x\ 2482}# #{ls\ 2481}#))
- (if (not (list? #{x\ 2482}#))
+ (let ((#{x\ 1723}# #{ls\ 1722}#))
+ (if (not (list? #{x\ 1723}#))
(syntax-violation
'generate-temporaries
"invalid argument"
- #{x\ 2482}#)))
- (map (lambda (#{x\ 2483}#)
- (#{wrap\ 1325}# (gensym) (quote ((top))) #f))
- #{ls\ 2481}#))))
+ #{x\ 1723}#)))
+ (map (lambda (#{x\ 1724}#)
+ (#{wrap\ 159}# (gensym) (quote ((top))) #f))
+ #{ls\ 1722}#))))
(set! free-identifier=?
- (lambda (#{x\ 2484}# #{y\ 2485}#)
+ (lambda (#{x\ 1725}# #{y\ 1726}#)
(begin
- (let ((#{x\ 2486}# #{x\ 2484}#))
- (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2486}#))
+ (let ((#{x\ 1727}# #{x\ 1725}#))
+ (if (not (#{nonsymbol-id?\ 130}# #{x\ 1727}#))
(syntax-violation
'free-identifier=?
"invalid argument"
- #{x\ 2486}#)))
- (let ((#{x\ 2487}# #{y\ 2485}#))
- (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2487}#))
+ #{x\ 1727}#)))
+ (let ((#{x\ 1728}# #{y\ 1726}#))
+ (if (not (#{nonsymbol-id?\ 130}# #{x\ 1728}#))
(syntax-violation
'free-identifier=?
"invalid argument"
- #{x\ 2487}#)))
- (#{free-id=?\ 1320}# #{x\ 2484}# #{y\ 2485}#))))
+ #{x\ 1728}#)))
+ (#{free-id=?\ 154}# #{x\ 1725}# #{y\ 1726}#))))
(set! bound-identifier=?
- (lambda (#{x\ 2488}# #{y\ 2489}#)
+ (lambda (#{x\ 1729}# #{y\ 1730}#)
(begin
- (let ((#{x\ 2490}# #{x\ 2488}#))
- (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2490}#))
+ (let ((#{x\ 1731}# #{x\ 1729}#))
+ (if (not (#{nonsymbol-id?\ 130}# #{x\ 1731}#))
(syntax-violation
'bound-identifier=?
"invalid argument"
- #{x\ 2490}#)))
- (let ((#{x\ 2491}# #{y\ 2489}#))
- (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2491}#))
+ #{x\ 1731}#)))
+ (let ((#{x\ 1732}# #{y\ 1730}#))
+ (if (not (#{nonsymbol-id?\ 130}# #{x\ 1732}#))
(syntax-violation
'bound-identifier=?
"invalid argument"
- #{x\ 2491}#)))
- (#{bound-id=?\ 1321}# #{x\ 2488}# #{y\ 2489}#))))
+ #{x\ 1732}#)))
+ (#{bound-id=?\ 155}# #{x\ 1729}# #{y\ 1730}#))))
(set! syntax-violation
- (lambda (#{who\ 2495}#
- #{message\ 2494}#
- #{form\ 2493}#
+ (lambda (#{who\ 1733}#
+ #{message\ 1734}#
+ #{form\ 1735}#
.
- #{subform\ 2492}#)
+ #{subform\ 1736}#)
(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}#))
+ (let ((#{x\ 1737}# #{who\ 1733}#))
+ (if (not ((lambda (#{x\ 1738}#)
+ (let ((#{t\ 1739}# (not #{x\ 1738}#)))
+ (if #{t\ 1739}#
+ #{t\ 1739}#
+ (let ((#{t\ 1740}# (string? #{x\ 1738}#)))
+ (if #{t\ 1740}#
+ #{t\ 1740}#
+ (symbol? #{x\ 1738}#))))))
+ #{x\ 1737}#))
(syntax-violation
'syntax-violation
"invalid argument"
- #{x\ 2496}#)))
- (let ((#{x\ 2500}# #{message\ 2494}#))
- (if (not (string? #{x\ 2500}#))
+ #{x\ 1737}#)))
+ (let ((#{x\ 1741}# #{message\ 1734}#))
+ (if (not (string? #{x\ 1741}#))
(syntax-violation
'syntax-violation
"invalid argument"
- #{x\ 2500}#)))
+ #{x\ 1741}#)))
(scm-error
'syntax-error
'sc-expand
(string-append
- (if #{who\ 2495}# "~a: " "")
+ (if #{who\ 1733}# "~a: " "")
"~a "
- (if (null? #{subform\ 2492}#)
+ (if (null? #{subform\ 1736}#)
"in ~a"
"in subform `~s' of `~s'"))
- (let ((#{tail\ 2501}#
- (cons #{message\ 2494}#
- (map (lambda (#{x\ 2502}#)
- (#{strip\ 1343}# #{x\ 2502}# (quote (()))))
+ (let ((#{tail\ 1742}#
+ (cons #{message\ 1734}#
+ (map (lambda (#{x\ 1743}#)
+ (#{strip\ 180}# #{x\ 1743}# (quote (()))))
(append
- #{subform\ 2492}#
- (list #{form\ 2493}#))))))
- (if #{who\ 2495}#
- (cons #{who\ 2495}# #{tail\ 2501}#)
- #{tail\ 2501}#))
+ #{subform\ 1736}#
+ (list #{form\ 1735}#))))))
+ (if #{who\ 1733}#
+ (cons #{who\ 1733}# #{tail\ 1742}#)
+ #{tail\ 1742}#))
#f))))
- (letrec ((#{match\ 2507}#
- (lambda (#{e\ 2508}#
- #{p\ 2509}#
- #{w\ 2510}#
- #{r\ 2511}#
- #{mod\ 2512}#)
- (if (not #{r\ 2511}#)
+ (letrec ((#{match\ 1748}#
+ (lambda (#{e\ 1749}#
+ #{p\ 1750}#
+ #{w\ 1751}#
+ #{r\ 1752}#
+ #{mod\ 1753}#)
+ (if (not #{r\ 1752}#)
#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}#)
+ (if (eq? #{p\ 1750}# (quote any))
+ (cons (#{wrap\ 159}#
+ #{e\ 1749}#
+ #{w\ 1751}#
+ #{mod\ 1753}#)
+ #{r\ 1752}#)
+ (if (#{syntax-object?\ 115}# #{e\ 1749}#)
+ (#{match*\ 1747}#
+ (#{syntax-object-expression\ 116}# #{e\ 1749}#)
+ #{p\ 1750}#
+ (#{join-wraps\ 150}#
+ #{w\ 1751}#
+ (#{syntax-object-wrap\ 117}# #{e\ 1749}#))
+ #{r\ 1752}#
+ (#{syntax-object-module\ 118}# #{e\ 1749}#))
+ (#{match*\ 1747}#
+ #{e\ 1749}#
+ #{p\ 1750}#
+ #{w\ 1751}#
+ #{r\ 1752}#
+ #{mod\ 1753}#))))))
+ (#{match*\ 1747}#
+ (lambda (#{e\ 1754}#
+ #{p\ 1755}#
+ #{w\ 1756}#
+ #{r\ 1757}#
+ #{mod\ 1758}#)
+ (if (null? #{p\ 1755}#)
+ (if (null? #{e\ 1754}#) #{r\ 1757}# #f)
+ (if (pair? #{p\ 1755}#)
+ (if (pair? #{e\ 1754}#)
+ (#{match\ 1748}#
+ (car #{e\ 1754}#)
+ (car #{p\ 1755}#)
+ #{w\ 1756}#
+ (#{match\ 1748}#
+ (cdr #{e\ 1754}#)
+ (cdr #{p\ 1755}#)
+ #{w\ 1756}#
+ #{r\ 1757}#
+ #{mod\ 1758}#)
+ #{mod\ 1758}#)
#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}#)
+ (if (eq? #{p\ 1755}# (quote each-any))
+ (let ((#{l\ 1759}#
+ (#{match-each-any\ 1745}#
+ #{e\ 1754}#
+ #{w\ 1756}#
+ #{mod\ 1758}#)))
+ (if #{l\ 1759}#
+ (cons #{l\ 1759}# #{r\ 1757}#)
#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}#
+ (let ((#{atom-key\ 1760}# (vector-ref #{p\ 1755}# 0)))
+ (if (memv #{atom-key\ 1760}# (quote (each)))
+ (if (null? #{e\ 1754}#)
+ (#{match-empty\ 1746}#
+ (vector-ref #{p\ 1755}# 1)
+ #{r\ 1757}#)
+ (let ((#{l\ 1761}#
+ (#{match-each\ 1744}#
+ #{e\ 1754}#
+ (vector-ref #{p\ 1755}# 1)
+ #{w\ 1756}#
+ #{mod\ 1758}#)))
+ (if #{l\ 1761}#
+ (letrec ((#{collect\ 1762}#
+ (lambda (#{l\ 1763}#)
+ (if (null? (car #{l\ 1763}#))
+ #{r\ 1757}#
+ (cons (map car #{l\ 1763}#)
+ (#{collect\ 1762}#
(map cdr
- #{l\ 2522}#)))))))
- (#{collect\ 2521}# #{l\ 2520}#))
+ #{l\ 1763}#)))))))
+ (#{collect\ 1762}# #{l\ 1761}#))
#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}#
+ (if (memv #{atom-key\ 1760}# (quote (free-id)))
+ (if (#{id?\ 131}# #{e\ 1754}#)
+ (if (#{free-id=?\ 154}#
+ (#{wrap\ 159}#
+ #{e\ 1754}#
+ #{w\ 1756}#
+ #{mod\ 1758}#)
+ (vector-ref #{p\ 1755}# 1))
+ #{r\ 1757}#
#f)
#f)
- (if (memv #{atom-key\ 2519}# (quote (atom)))
+ (if (memv #{atom-key\ 1760}# (quote (atom)))
(if (equal?
- (vector-ref #{p\ 2514}# 1)
- (#{strip\ 1343}#
- #{e\ 2513}#
- #{w\ 2515}#))
- #{r\ 2516}#
+ (vector-ref #{p\ 1755}# 1)
+ (#{strip\ 180}#
+ #{e\ 1754}#
+ #{w\ 1756}#))
+ #{r\ 1757}#
#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}#)
+ (if (memv #{atom-key\ 1760}# (quote (vector)))
+ (if (vector? #{e\ 1754}#)
+ (#{match\ 1748}#
+ (vector->list #{e\ 1754}#)
+ (vector-ref #{p\ 1755}# 1)
+ #{w\ 1756}#
+ #{r\ 1757}#
+ #{mod\ 1758}#)
#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}#
+ (#{match-empty\ 1746}#
+ (lambda (#{p\ 1764}# #{r\ 1765}#)
+ (if (null? #{p\ 1764}#)
+ #{r\ 1765}#
+ (if (eq? #{p\ 1764}# (quote any))
+ (cons (quote ()) #{r\ 1765}#)
+ (if (pair? #{p\ 1764}#)
+ (#{match-empty\ 1746}#
+ (car #{p\ 1764}#)
+ (#{match-empty\ 1746}#
+ (cdr #{p\ 1764}#)
+ #{r\ 1765}#))
+ (if (eq? #{p\ 1764}# (quote each-any))
+ (cons (quote ()) #{r\ 1765}#)
+ (let ((#{atom-key\ 1766}#
+ (vector-ref #{p\ 1764}# 0)))
+ (if (memv #{atom-key\ 1766}# (quote (each)))
+ (#{match-empty\ 1746}#
+ (vector-ref #{p\ 1764}# 1)
+ #{r\ 1765}#)
+ (if (memv #{atom-key\ 1766}#
'(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}#)
+ #{r\ 1765}#
+ (if (memv #{atom-key\ 1766}# (quote (vector)))
+ (#{match-empty\ 1746}#
+ (vector-ref #{p\ 1764}# 1)
+ #{r\ 1765}#)))))))))))
+ (#{match-each-any\ 1745}#
+ (lambda (#{e\ 1767}# #{w\ 1768}# #{mod\ 1769}#)
+ (if (pair? #{e\ 1767}#)
+ (let ((#{l\ 1770}#
+ (#{match-each-any\ 1745}#
+ (cdr #{e\ 1767}#)
+ #{w\ 1768}#
+ #{mod\ 1769}#)))
+ (if #{l\ 1770}#
+ (cons (#{wrap\ 159}#
+ (car #{e\ 1767}#)
+ #{w\ 1768}#
+ #{mod\ 1769}#)
+ #{l\ 1770}#)
#f))
- (if (null? #{e\ 2526}#)
+ (if (null? #{e\ 1767}#)
'()
- (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}#)
+ (if (#{syntax-object?\ 115}# #{e\ 1767}#)
+ (#{match-each-any\ 1745}#
+ (#{syntax-object-expression\ 116}# #{e\ 1767}#)
+ (#{join-wraps\ 150}#
+ #{w\ 1768}#
+ (#{syntax-object-wrap\ 117}# #{e\ 1767}#))
+ #{mod\ 1769}#)
#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}#
+ (#{match-each\ 1744}#
+ (lambda (#{e\ 1771}#
+ #{p\ 1772}#
+ #{w\ 1773}#
+ #{mod\ 1774}#)
+ (if (pair? #{e\ 1771}#)
+ (let ((#{first\ 1775}#
+ (#{match\ 1748}#
+ (car #{e\ 1771}#)
+ #{p\ 1772}#
+ #{w\ 1773}#
'()
- #{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}#)
+ #{mod\ 1774}#)))
+ (if #{first\ 1775}#
+ (let ((#{rest\ 1776}#
+ (#{match-each\ 1744}#
+ (cdr #{e\ 1771}#)
+ #{p\ 1772}#
+ #{w\ 1773}#
+ #{mod\ 1774}#)))
+ (if #{rest\ 1776}#
+ (cons #{first\ 1775}# #{rest\ 1776}#)
#f))
#f))
- (if (null? #{e\ 2530}#)
+ (if (null? #{e\ 1771}#)
'()
- (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}#))
+ (if (#{syntax-object?\ 115}# #{e\ 1771}#)
+ (#{match-each\ 1744}#
+ (#{syntax-object-expression\ 116}# #{e\ 1771}#)
+ #{p\ 1772}#
+ (#{join-wraps\ 150}#
+ #{w\ 1773}#
+ (#{syntax-object-wrap\ 117}# #{e\ 1771}#))
+ (#{syntax-object-module\ 118}# #{e\ 1771}#))
#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}#)
+ (lambda (#{e\ 1777}# #{p\ 1778}#)
+ (if (eq? #{p\ 1778}# (quote any))
+ (list #{e\ 1777}#)
+ (if (#{syntax-object?\ 115}# #{e\ 1777}#)
+ (#{match*\ 1747}#
+ (#{syntax-object-expression\ 116}# #{e\ 1777}#)
+ #{p\ 1778}#
+ (#{syntax-object-wrap\ 117}# #{e\ 1777}#)
'()
- (#{syntax-object-module\ 1284}# #{e\ 2536}#))
- (#{match*\ 2506}#
- #{e\ 2536}#
- #{p\ 2537}#
+ (#{syntax-object-module\ 118}# #{e\ 1777}#))
+ (#{match*\ 1747}#
+ #{e\ 1777}#
+ #{p\ 1778}#
'(())
'()
#f)))))))))
@@ -9157,11 +11629,11 @@
(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}#)
+ (lambda (#{x\ 1779}#)
+ ((lambda (#{tmp\ 1780}#)
+ ((lambda (#{tmp\ 1781}#)
+ (if #{tmp\ 1781}#
+ (apply (lambda (#{_\ 1782}# #{e1\ 1783}# #{e2\ 1784}#)
(cons '#(syntax-object
begin
((top)
@@ -9172,15 +11644,15 @@
#(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}#)
+ (cons #{e1\ 1783}# #{e2\ 1784}#)))
+ #{tmp\ 1781}#)
+ ((lambda (#{tmp\ 1786}#)
+ (if #{tmp\ 1786}#
+ (apply (lambda (#{_\ 1787}#
+ #{out\ 1788}#
+ #{in\ 1789}#
+ #{e1\ 1790}#
+ #{e2\ 1791}#)
(list '#(syntax-object
syntax-case
((top)
@@ -9191,9 +11663,9 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- #{in\ 2548}#
+ #{in\ 1789}#
'()
- (list #{out\ 2547}#
+ (list #{out\ 1788}#
(cons '#(syntax-object
begin
((top)
@@ -9211,16 +11683,16 @@
#((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}#)
+ (cons #{e1\ 1790}#
+ #{e2\ 1791}#)))))
+ #{tmp\ 1786}#)
+ ((lambda (#{tmp\ 1793}#)
+ (if #{tmp\ 1793}#
+ (apply (lambda (#{_\ 1794}#
+ #{out\ 1795}#
+ #{in\ 1796}#
+ #{e1\ 1797}#
+ #{e2\ 1798}#)
(list '#(syntax-object
syntax-case
((top)
@@ -9248,9 +11720,9 @@
#((top))
#("i")))
(hygiene guile))
- #{in\ 2555}#)
+ #{in\ 1796}#)
'()
- (list #{out\ 2554}#
+ (list #{out\ 1795}#
(cons '#(syntax-object
begin
((top)
@@ -9272,36 +11744,36 @@
#((top))
#("i")))
(hygiene guile))
- (cons #{e1\ 2556}#
- #{e2\ 2557}#)))))
- #{tmp\ 2552}#)
+ (cons #{e1\ 1797}#
+ #{e2\ 1798}#)))))
+ #{tmp\ 1793}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2539}#)))
+ #{tmp\ 1780}#)))
($sc-dispatch
- #{tmp\ 2539}#
+ #{tmp\ 1780}#
'(any #(each (any any)) any . each-any)))))
($sc-dispatch
- #{tmp\ 2539}#
+ #{tmp\ 1780}#
'(any ((any any)) any . each-any)))))
($sc-dispatch
- #{tmp\ 2539}#
+ #{tmp\ 1780}#
'(any () any . each-any))))
- #{x\ 2538}#))))
+ #{x\ 1779}#))))
(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}#)
+ (lambda (#{x\ 1802}#)
+ ((lambda (#{tmp\ 1803}#)
+ ((lambda (#{tmp\ 1804}#)
+ (if #{tmp\ 1804}#
+ (apply (lambda (#{_\ 1805}#
+ #{k\ 1806}#
+ #{keyword\ 1807}#
+ #{pattern\ 1808}#
+ #{template\ 1809}#)
(list '#(syntax-object
lambda
((top)
@@ -9342,9 +11814,9 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- (cons #{k\ 2565}#
- (map (lambda (#{tmp\ 2571}#
- #{tmp\ 2570}#)
+ (cons #{k\ 1806}#
+ (map (lambda (#{tmp\ 1812}#
+ #{tmp\ 1811}#)
(list (cons '#(syntax-object
dummy
((top)
@@ -9374,7 +11846,7 @@
#("i")))
(hygiene
guile))
- #{tmp\ 2570}#)
+ #{tmp\ 1811}#)
(list '#(syntax-object
syntax
((top)
@@ -9404,43 +11876,43 @@
#("i")))
(hygiene
guile))
- #{tmp\ 2571}#)))
- #{template\ 2568}#
- #{pattern\ 2567}#))))))
- #{tmp\ 2563}#)
+ #{tmp\ 1812}#)))
+ #{template\ 1809}#
+ #{pattern\ 1808}#))))))
+ #{tmp\ 1804}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2562}#)))
+ #{tmp\ 1803}#)))
($sc-dispatch
- #{tmp\ 2562}#
+ #{tmp\ 1803}#
'(any each-any . #(each ((any . any) any))))))
- #{x\ 2561}#))))
+ #{x\ 1802}#))))
(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}#)
+ (lambda (#{x\ 1813}#)
+ ((lambda (#{tmp\ 1814}#)
+ ((lambda (#{tmp\ 1815}#)
+ (if (if #{tmp\ 1815}#
+ (apply (lambda (#{let*\ 1816}#
+ #{x\ 1817}#
+ #{v\ 1818}#
+ #{e1\ 1819}#
+ #{e2\ 1820}#)
+ (and-map identifier? #{x\ 1817}#))
+ #{tmp\ 1815}#)
#f)
- (apply (lambda (#{let*\ 2581}#
- #{x\ 2582}#
- #{v\ 2583}#
- #{e1\ 2584}#
- #{e2\ 2585}#)
- (letrec ((#{f\ 2586}#
- (lambda (#{bindings\ 2587}#)
- (if (null? #{bindings\ 2587}#)
+ (apply (lambda (#{let*\ 1822}#
+ #{x\ 1823}#
+ #{v\ 1824}#
+ #{e1\ 1825}#
+ #{e2\ 1826}#)
+ (letrec ((#{f\ 1827}#
+ (lambda (#{bindings\ 1828}#)
+ (if (null? #{bindings\ 1828}#)
(cons '#(syntax-object
let
((top)
@@ -9464,13 +11936,13 @@
#("i")))
(hygiene guile))
(cons '()
- (cons #{e1\ 2584}#
- #{e2\ 2585}#)))
- ((lambda (#{tmp\ 2591}#)
- ((lambda (#{tmp\ 2592}#)
- (if #{tmp\ 2592}#
- (apply (lambda (#{body\ 2593}#
- #{binding\ 2594}#)
+ (cons #{e1\ 1825}#
+ #{e2\ 1826}#)))
+ ((lambda (#{tmp\ 1832}#)
+ ((lambda (#{tmp\ 1833}#)
+ (if #{tmp\ 1833}#
+ (apply (lambda (#{body\ 1834}#
+ #{binding\ 1835}#)
(list '#(syntax-object
let
((top)
@@ -9516,52 +11988,52 @@
#("i")))
(hygiene
guile))
- (list #{binding\ 2594}#)
- #{body\ 2593}#))
- #{tmp\ 2592}#)
+ (list #{binding\ 1835}#)
+ #{body\ 1834}#))
+ #{tmp\ 1833}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2591}#)))
+ #{tmp\ 1832}#)))
($sc-dispatch
- #{tmp\ 2591}#
+ #{tmp\ 1832}#
'(any any))))
- (list (#{f\ 2586}#
- (cdr #{bindings\ 2587}#))
- (car #{bindings\ 2587}#)))))))
- (#{f\ 2586}# (map list #{x\ 2582}# #{v\ 2583}#))))
- #{tmp\ 2574}#)
+ (list (#{f\ 1827}#
+ (cdr #{bindings\ 1828}#))
+ (car #{bindings\ 1828}#)))))))
+ (#{f\ 1827}# (map list #{x\ 1823}# #{v\ 1824}#))))
+ #{tmp\ 1815}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2573}#)))
+ #{tmp\ 1814}#)))
($sc-dispatch
- #{tmp\ 2573}#
+ #{tmp\ 1814}#
'(any #(each (any any)) any . each-any))))
- #{x\ 2572}#))))
+ #{x\ 1813}#))))
(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}#
+ (lambda (#{orig-x\ 1836}#)
+ ((lambda (#{tmp\ 1837}#)
+ ((lambda (#{tmp\ 1838}#)
+ (if #{tmp\ 1838}#
+ (apply (lambda (#{_\ 1839}#
+ #{var\ 1840}#
+ #{init\ 1841}#
+ #{step\ 1842}#
+ #{e0\ 1843}#
+ #{e1\ 1844}#
+ #{c\ 1845}#)
+ ((lambda (#{tmp\ 1846}#)
+ ((lambda (#{tmp\ 1847}#)
+ (if #{tmp\ 1847}#
+ (apply (lambda (#{step\ 1848}#)
+ ((lambda (#{tmp\ 1849}#)
+ ((lambda (#{tmp\ 1850}#)
+ (if #{tmp\ 1850}#
(apply (lambda ()
(list '#(syntax-object
let
@@ -9642,8 +12114,8 @@
(hygiene
guile))
(map list
- #{var\ 2599}#
- #{init\ 2600}#)
+ #{var\ 1840}#
+ #{init\ 1841}#)
(list '#(syntax-object
if
((top)
@@ -9722,7 +12194,7 @@
#("i")))
(hygiene
guile))
- #{e0\ 2602}#)
+ #{e0\ 1843}#)
(cons '#(syntax-object
begin
((top)
@@ -9763,7 +12235,7 @@
(hygiene
guile))
(append
- #{c\ 2604}#
+ #{c\ 1845}#
(list (cons '#(syntax-object
doloop
((top)
@@ -9803,12 +12275,12 @@
#("i")))
(hygiene
guile))
- #{step\ 2607}#)))))))
- #{tmp\ 2609}#)
- ((lambda (#{tmp\ 2614}#)
- (if #{tmp\ 2614}#
- (apply (lambda (#{e1\ 2615}#
- #{e2\ 2616}#)
+ #{step\ 1848}#)))))))
+ #{tmp\ 1850}#)
+ ((lambda (#{tmp\ 1855}#)
+ (if #{tmp\ 1855}#
+ (apply (lambda (#{e1\ 1856}#
+ #{e2\ 1857}#)
(list '#(syntax-object
let
((top)
@@ -9902,8 +12374,8 @@
(hygiene
guile))
(map list
- #{var\ 2599}#
- #{init\ 2600}#)
+ #{var\ 1840}#
+ #{init\ 1841}#)
(list '#(syntax-object
if
((top)
@@ -9950,7 +12422,7 @@
#("i")))
(hygiene
guile))
- #{e0\ 2602}#
+ #{e0\ 1843}#
(cons '#(syntax-object
begin
((top)
@@ -9997,8 +12469,8 @@
#("i")))
(hygiene
guile))
- (cons #{e1\ 2615}#
- #{e2\ 2616}#))
+ (cons #{e1\ 1856}#
+ #{e2\ 1857}#))
(cons '#(syntax-object
begin
((top)
@@ -10046,7 +12518,7 @@
(hygiene
guile))
(append
- #{c\ 2604}#
+ #{c\ 1845}#
(list (cons '#(syntax-object
doloop
((top)
@@ -10093,81 +12565,81 @@
#("i")))
(hygiene
guile))
- #{step\ 2607}#)))))))
- #{tmp\ 2614}#)
+ #{step\ 1848}#)))))))
+ #{tmp\ 1855}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2608}#)))
+ #{tmp\ 1849}#)))
($sc-dispatch
- #{tmp\ 2608}#
+ #{tmp\ 1849}#
'(any . each-any)))))
($sc-dispatch
- #{tmp\ 2608}#
+ #{tmp\ 1849}#
'())))
- #{e1\ 2603}#))
- #{tmp\ 2606}#)
+ #{e1\ 1844}#))
+ #{tmp\ 1847}#)
(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}#)
+ #{tmp\ 1846}#)))
+ ($sc-dispatch #{tmp\ 1846}# (quote each-any))))
+ (map (lambda (#{v\ 1864}# #{s\ 1865}#)
+ ((lambda (#{tmp\ 1866}#)
+ ((lambda (#{tmp\ 1867}#)
+ (if #{tmp\ 1867}#
+ (apply (lambda () #{v\ 1864}#)
+ #{tmp\ 1867}#)
+ ((lambda (#{tmp\ 1868}#)
+ (if #{tmp\ 1868}#
+ (apply (lambda (#{e\ 1869}#)
+ #{e\ 1869}#)
+ #{tmp\ 1868}#)
+ ((lambda (#{_\ 1870}#)
(syntax-violation
'do
"bad step expression"
- #{orig-x\ 2595}#
- #{s\ 2624}#))
- #{tmp\ 2625}#)))
+ #{orig-x\ 1836}#
+ #{s\ 1865}#))
+ #{tmp\ 1866}#)))
($sc-dispatch
- #{tmp\ 2625}#
+ #{tmp\ 1866}#
'(any)))))
- ($sc-dispatch #{tmp\ 2625}# (quote ()))))
- #{s\ 2624}#))
- #{var\ 2599}#
- #{step\ 2601}#)))
- #{tmp\ 2597}#)
+ ($sc-dispatch #{tmp\ 1866}# (quote ()))))
+ #{s\ 1865}#))
+ #{var\ 1840}#
+ #{step\ 1842}#)))
+ #{tmp\ 1838}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2596}#)))
+ #{tmp\ 1837}#)))
($sc-dispatch
- #{tmp\ 2596}#
+ #{tmp\ 1837}#
'(any #(each (any any . any))
(any . each-any)
.
each-any))))
- #{orig-x\ 2595}#))))
+ #{orig-x\ 1836}#))))
(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}#)
+ (letrec ((#{quasicons\ 1873}#
+ (lambda (#{x\ 1877}# #{y\ 1878}#)
+ ((lambda (#{tmp\ 1879}#)
+ ((lambda (#{tmp\ 1880}#)
+ (if #{tmp\ 1880}#
+ (apply (lambda (#{x\ 1881}# #{y\ 1882}#)
+ ((lambda (#{tmp\ 1883}#)
+ ((lambda (#{tmp\ 1884}#)
+ (if #{tmp\ 1884}#
+ (apply (lambda (#{dy\ 1885}#)
+ ((lambda (#{tmp\ 1886}#)
+ ((lambda (#{tmp\ 1887}#)
+ (if #{tmp\ 1887}#
+ (apply (lambda (#{dx\ 1888}#)
(list '#(syntax-object
quote
((top)
@@ -10216,11 +12688,11 @@
"i")))
(hygiene
guile))
- (cons #{dx\ 2647}#
- #{dy\ 2644}#)))
- #{tmp\ 2646}#)
- ((lambda (#{_\ 2648}#)
- (if (null? #{dy\ 2644}#)
+ (cons #{dx\ 1888}#
+ #{dy\ 1885}#)))
+ #{tmp\ 1887}#)
+ ((lambda (#{_\ 1889}#)
+ (if (null? #{dy\ 1885}#)
(list '#(syntax-object
list
((top)
@@ -10269,7 +12741,7 @@
"i")))
(hygiene
guile))
- #{x\ 2640}#)
+ #{x\ 1881}#)
(list '#(syntax-object
cons
((top)
@@ -10318,11 +12790,11 @@
"i")))
(hygiene
guile))
- #{x\ 2640}#
- #{y\ 2641}#)))
- #{tmp\ 2645}#)))
+ #{x\ 1881}#
+ #{y\ 1882}#)))
+ #{tmp\ 1886}#)))
($sc-dispatch
- #{tmp\ 2645}#
+ #{tmp\ 1886}#
'(#(free-id
#(syntax-object
quote
@@ -10365,11 +12837,11 @@
(hygiene
guile)))
any))))
- #{x\ 2640}#))
- #{tmp\ 2643}#)
- ((lambda (#{tmp\ 2649}#)
- (if #{tmp\ 2649}#
- (apply (lambda (#{stuff\ 2650}#)
+ #{x\ 1881}#))
+ #{tmp\ 1884}#)
+ ((lambda (#{tmp\ 1890}#)
+ (if #{tmp\ 1890}#
+ (apply (lambda (#{stuff\ 1891}#)
(cons '#(syntax-object
list
((top)
@@ -10410,10 +12882,10 @@
"i")))
(hygiene
guile))
- (cons #{x\ 2640}#
- #{stuff\ 2650}#)))
- #{tmp\ 2649}#)
- ((lambda (#{else\ 2651}#)
+ (cons #{x\ 1881}#
+ #{stuff\ 1891}#)))
+ #{tmp\ 1890}#)
+ ((lambda (#{else\ 1892}#)
(list '#(syntax-object
cons
((top)
@@ -10445,11 +12917,11 @@
"i"
"i")))
(hygiene guile))
- #{x\ 2640}#
- #{y\ 2641}#))
- #{tmp\ 2642}#)))
+ #{x\ 1881}#
+ #{y\ 1882}#))
+ #{tmp\ 1883}#)))
($sc-dispatch
- #{tmp\ 2642}#
+ #{tmp\ 1883}#
'(#(free-id
#(syntax-object
list
@@ -10478,7 +12950,7 @@
.
any)))))
($sc-dispatch
- #{tmp\ 2642}#
+ #{tmp\ 1883}#
'(#(free-id
#(syntax-object
quote
@@ -10502,26 +12974,26 @@
#("i" "i" "i" "i")))
(hygiene guile)))
any))))
- #{y\ 2641}#))
- #{tmp\ 2639}#)
+ #{y\ 1882}#))
+ #{tmp\ 1880}#)
(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}#)
+ #{tmp\ 1879}#)))
+ ($sc-dispatch #{tmp\ 1879}# (quote (any any)))))
+ (list #{x\ 1877}# #{y\ 1878}#))))
+ (#{quasiappend\ 1874}#
+ (lambda (#{x\ 1893}# #{y\ 1894}#)
+ ((lambda (#{tmp\ 1895}#)
+ ((lambda (#{tmp\ 1896}#)
+ (if #{tmp\ 1896}#
+ (apply (lambda (#{x\ 1897}# #{y\ 1898}#)
+ ((lambda (#{tmp\ 1899}#)
+ ((lambda (#{tmp\ 1900}#)
+ (if #{tmp\ 1900}#
+ (apply (lambda () #{x\ 1897}#)
+ #{tmp\ 1900}#)
+ ((lambda (#{_\ 1901}#)
(list '#(syntax-object
append
((top)
@@ -10550,11 +13022,11 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile))
- #{x\ 2656}#
- #{y\ 2657}#))
- #{tmp\ 2658}#)))
+ #{x\ 1897}#
+ #{y\ 1898}#))
+ #{tmp\ 1899}#)))
($sc-dispatch
- #{tmp\ 2658}#
+ #{tmp\ 1899}#
'(#(free-id
#(syntax-object
quote
@@ -10578,22 +13050,22 @@
#("i" "i" "i" "i")))
(hygiene guile)))
()))))
- #{y\ 2657}#))
- #{tmp\ 2655}#)
+ #{y\ 1898}#))
+ #{tmp\ 1896}#)
(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}#)
+ #{tmp\ 1895}#)))
+ ($sc-dispatch #{tmp\ 1895}# (quote (any any)))))
+ (list #{x\ 1893}# #{y\ 1894}#))))
+ (#{quasivector\ 1875}#
+ (lambda (#{x\ 1902}#)
+ ((lambda (#{tmp\ 1903}#)
+ ((lambda (#{x\ 1904}#)
+ ((lambda (#{tmp\ 1905}#)
+ ((lambda (#{tmp\ 1906}#)
+ (if #{tmp\ 1906}#
+ (apply (lambda (#{x\ 1907}#)
(list '#(syntax-object
quote
((top)
@@ -10619,11 +13091,11 @@
#((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}#)
+ (list->vector #{x\ 1907}#)))
+ #{tmp\ 1906}#)
+ ((lambda (#{tmp\ 1909}#)
+ (if #{tmp\ 1909}#
+ (apply (lambda (#{x\ 1910}#)
(cons '#(syntax-object
vector
((top)
@@ -10652,9 +13124,9 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile))
- #{x\ 2669}#))
- #{tmp\ 2668}#)
- ((lambda (#{_\ 2671}#)
+ #{x\ 1910}#))
+ #{tmp\ 1909}#)
+ ((lambda (#{_\ 1912}#)
(list '#(syntax-object
list->vector
((top)
@@ -10680,10 +13152,10 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile))
- #{x\ 2663}#))
- #{tmp\ 2664}#)))
+ #{x\ 1904}#))
+ #{tmp\ 1905}#)))
($sc-dispatch
- #{tmp\ 2664}#
+ #{tmp\ 1905}#
'(#(free-id
#(syntax-object
list
@@ -10703,7 +13175,7 @@
.
each-any)))))
($sc-dispatch
- #{tmp\ 2664}#
+ #{tmp\ 1905}#
'(#(free-id
#(syntax-object
quote
@@ -10721,18 +13193,18 @@
#("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}#
+ #{x\ 1904}#))
+ #{tmp\ 1903}#))
+ #{x\ 1902}#)))
+ (#{quasi\ 1876}#
+ (lambda (#{p\ 1913}# #{lev\ 1914}#)
+ ((lambda (#{tmp\ 1915}#)
+ ((lambda (#{tmp\ 1916}#)
+ (if #{tmp\ 1916}#
+ (apply (lambda (#{p\ 1917}#)
+ (if (= #{lev\ 1914}# 0)
+ #{p\ 1917}#
+ (#{quasicons\ 1873}#
'(#(syntax-object
quote
((top)
@@ -10767,21 +13239,21 @@
#((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}#)
+ (#{quasi\ 1876}#
+ (list #{p\ 1917}#)
+ (- #{lev\ 1914}# 1)))))
+ #{tmp\ 1916}#)
+ ((lambda (#{tmp\ 1918}#)
+ (if (if #{tmp\ 1918}#
+ (apply (lambda (#{args\ 1919}#)
+ (= #{lev\ 1914}# 0))
+ #{tmp\ 1918}#)
#f)
- (apply (lambda (#{args\ 2679}#)
+ (apply (lambda (#{args\ 1920}#)
(syntax-violation
'unquote
"unquote takes exactly one argument"
- #{p\ 2672}#
+ #{p\ 1913}#
(cons '#(syntax-object
unquote
((top)
@@ -10802,19 +13274,19 @@
#((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}#
+ #{args\ 1920}#)))
+ #{tmp\ 1918}#)
+ ((lambda (#{tmp\ 1921}#)
+ (if #{tmp\ 1921}#
+ (apply (lambda (#{p\ 1922}# #{q\ 1923}#)
+ (if (= #{lev\ 1914}# 0)
+ (#{quasiappend\ 1874}#
+ #{p\ 1922}#
+ (#{quasi\ 1876}#
+ #{q\ 1923}#
+ #{lev\ 1914}#))
+ (#{quasicons\ 1873}#
+ (#{quasicons\ 1873}#
'(#(syntax-object
quote
((top)
@@ -10861,26 +13333,26 @@
(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}#)
+ (#{quasi\ 1876}#
+ (list #{p\ 1922}#)
+ (- #{lev\ 1914}# 1)))
+ (#{quasi\ 1876}#
+ #{q\ 1923}#
+ #{lev\ 1914}#))))
+ #{tmp\ 1921}#)
+ ((lambda (#{tmp\ 1924}#)
+ (if (if #{tmp\ 1924}#
+ (apply (lambda (#{args\ 1925}#
+ #{q\ 1926}#)
+ (= #{lev\ 1914}# 0))
+ #{tmp\ 1924}#)
#f)
- (apply (lambda (#{args\ 2686}#
- #{q\ 2687}#)
+ (apply (lambda (#{args\ 1927}#
+ #{q\ 1928}#)
(syntax-violation
'unquote-splicing
"unquote-splicing takes exactly one argument"
- #{p\ 2672}#
+ #{p\ 1913}#
(cons '#(syntax-object
unquote-splicing
((top)
@@ -10910,12 +13382,12 @@
"i"
"i")))
(hygiene guile))
- #{args\ 2686}#)))
- #{tmp\ 2683}#)
- ((lambda (#{tmp\ 2688}#)
- (if #{tmp\ 2688}#
- (apply (lambda (#{p\ 2689}#)
- (#{quasicons\ 2632}#
+ #{args\ 1927}#)))
+ #{tmp\ 1924}#)
+ ((lambda (#{tmp\ 1929}#)
+ (if #{tmp\ 1929}#
+ (apply (lambda (#{p\ 1930}#)
+ (#{quasicons\ 1873}#
'(#(syntax-object
quote
((top)
@@ -10974,32 +13446,32 @@
"i"
"i")))
(hygiene guile)))
- (#{quasi\ 2635}#
- (list #{p\ 2689}#)
- (+ #{lev\ 2673}#
+ (#{quasi\ 1876}#
+ (list #{p\ 1930}#)
+ (+ #{lev\ 1914}#
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}#)
+ #{tmp\ 1929}#)
+ ((lambda (#{tmp\ 1931}#)
+ (if #{tmp\ 1931}#
+ (apply (lambda (#{p\ 1932}#
+ #{q\ 1933}#)
+ (#{quasicons\ 1873}#
+ (#{quasi\ 1876}#
+ #{p\ 1932}#
+ #{lev\ 1914}#)
+ (#{quasi\ 1876}#
+ #{q\ 1933}#
+ #{lev\ 1914}#)))
+ #{tmp\ 1931}#)
+ ((lambda (#{tmp\ 1934}#)
+ (if #{tmp\ 1934}#
+ (apply (lambda (#{x\ 1935}#)
+ (#{quasivector\ 1875}#
+ (#{quasi\ 1876}#
+ #{x\ 1935}#
+ #{lev\ 1914}#)))
+ #{tmp\ 1934}#)
+ ((lambda (#{p\ 1937}#)
(list '#(syntax-object
quote
((top)
@@ -11032,16 +13504,16 @@
"i")))
(hygiene
guile))
- #{p\ 2696}#))
- #{tmp\ 2674}#)))
+ #{p\ 1937}#))
+ #{tmp\ 1915}#)))
($sc-dispatch
- #{tmp\ 2674}#
+ #{tmp\ 1915}#
'#(vector each-any)))))
($sc-dispatch
- #{tmp\ 2674}#
+ #{tmp\ 1915}#
'(any . any)))))
($sc-dispatch
- #{tmp\ 2674}#
+ #{tmp\ 1915}#
'(#(free-id
#(syntax-object
quasiquote
@@ -11061,7 +13533,7 @@
(hygiene guile)))
any)))))
($sc-dispatch
- #{tmp\ 2674}#
+ #{tmp\ 1915}#
'((#(free-id
#(syntax-object
unquote-splicing
@@ -11084,7 +13556,7 @@
.
any)))))
($sc-dispatch
- #{tmp\ 2674}#
+ #{tmp\ 1915}#
'((#(free-id
#(syntax-object
unquote-splicing
@@ -11106,7 +13578,7 @@
.
any)))))
($sc-dispatch
- #{tmp\ 2674}#
+ #{tmp\ 1915}#
'(#(free-id
#(syntax-object
unquote
@@ -11124,7 +13596,7 @@
.
any)))))
($sc-dispatch
- #{tmp\ 2674}#
+ #{tmp\ 1915}#
'(#(free-id
#(syntax-object
unquote
@@ -11137,49 +13609,49 @@
#("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}#)
+ #{p\ 1913}#))))
+ (lambda (#{x\ 1938}#)
+ ((lambda (#{tmp\ 1939}#)
+ ((lambda (#{tmp\ 1940}#)
+ (if #{tmp\ 1940}#
+ (apply (lambda (#{_\ 1941}# #{e\ 1942}#)
+ (#{quasi\ 1876}# #{e\ 1942}# 0))
+ #{tmp\ 1940}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2698}#)))
- ($sc-dispatch #{tmp\ 2698}# (quote (any any)))))
- #{x\ 2697}#)))))
+ #{tmp\ 1939}#)))
+ ($sc-dispatch #{tmp\ 1939}# (quote (any any)))))
+ #{x\ 1938}#)))))
(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}#)
+ (lambda (#{x\ 1943}#)
+ (letrec ((#{read-file\ 1944}#
+ (lambda (#{fn\ 1945}# #{k\ 1946}#)
+ (let ((#{p\ 1947}# (open-input-file #{fn\ 1945}#)))
+ (letrec ((#{f\ 1948}#
+ (lambda (#{x\ 1949}#)
+ (if (eof-object? #{x\ 1949}#)
(begin
- (close-input-port #{p\ 2706}#)
+ (close-input-port #{p\ 1947}#)
'())
(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}#)
+ #{k\ 1946}#
+ #{x\ 1949}#)
+ (#{f\ 1948}# (read #{p\ 1947}#)))))))
+ (#{f\ 1948}# (read #{p\ 1947}#)))))))
+ ((lambda (#{tmp\ 1950}#)
+ ((lambda (#{tmp\ 1951}#)
+ (if #{tmp\ 1951}#
+ (apply (lambda (#{k\ 1952}# #{filename\ 1953}#)
+ (let ((#{fn\ 1954}#
+ (syntax->datum #{filename\ 1953}#)))
+ ((lambda (#{tmp\ 1955}#)
+ ((lambda (#{tmp\ 1956}#)
+ (if #{tmp\ 1956}#
+ (apply (lambda (#{exp\ 1957}#)
(cons '#(syntax-object
begin
((top)
@@ -11206,76 +13678,76 @@
#((top))
#("i")))
(hygiene guile))
- #{exp\ 2716}#))
- #{tmp\ 2715}#)
+ #{exp\ 1957}#))
+ #{tmp\ 1956}#)
(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}#)
+ #{tmp\ 1955}#)))
+ ($sc-dispatch #{tmp\ 1955}# (quote each-any))))
+ (#{read-file\ 1944}# #{fn\ 1954}# #{k\ 1952}#))))
+ #{tmp\ 1951}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2709}#)))
- ($sc-dispatch #{tmp\ 2709}# (quote (any any)))))
- #{x\ 2702}#)))))
+ #{tmp\ 1950}#)))
+ ($sc-dispatch #{tmp\ 1950}# (quote (any any)))))
+ #{x\ 1943}#)))))
(define unquote
(make-syncase-macro
'macro
- (lambda (#{x\ 2718}#)
- ((lambda (#{tmp\ 2719}#)
- ((lambda (#{tmp\ 2720}#)
- (if #{tmp\ 2720}#
- (apply (lambda (#{_\ 2721}# #{e\ 2722}#)
+ (lambda (#{x\ 1959}#)
+ ((lambda (#{tmp\ 1960}#)
+ ((lambda (#{tmp\ 1961}#)
+ (if #{tmp\ 1961}#
+ (apply (lambda (#{_\ 1962}# #{e\ 1963}#)
(syntax-violation
'unquote
"expression not valid outside of quasiquote"
- #{x\ 2718}#))
- #{tmp\ 2720}#)
+ #{x\ 1959}#))
+ #{tmp\ 1961}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2719}#)))
- ($sc-dispatch #{tmp\ 2719}# (quote (any any)))))
- #{x\ 2718}#))))
+ #{tmp\ 1960}#)))
+ ($sc-dispatch #{tmp\ 1960}# (quote (any any)))))
+ #{x\ 1959}#))))
(define unquote-splicing
(make-syncase-macro
'macro
- (lambda (#{x\ 2723}#)
- ((lambda (#{tmp\ 2724}#)
- ((lambda (#{tmp\ 2725}#)
- (if #{tmp\ 2725}#
- (apply (lambda (#{_\ 2726}# #{e\ 2727}#)
+ (lambda (#{x\ 1964}#)
+ ((lambda (#{tmp\ 1965}#)
+ ((lambda (#{tmp\ 1966}#)
+ (if #{tmp\ 1966}#
+ (apply (lambda (#{_\ 1967}# #{e\ 1968}#)
(syntax-violation
'unquote-splicing
"expression not valid outside of quasiquote"
- #{x\ 2723}#))
- #{tmp\ 2725}#)
+ #{x\ 1964}#))
+ #{tmp\ 1966}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2724}#)))
- ($sc-dispatch #{tmp\ 2724}# (quote (any any)))))
- #{x\ 2723}#))))
+ #{tmp\ 1965}#)))
+ ($sc-dispatch #{tmp\ 1965}# (quote (any any)))))
+ #{x\ 1964}#))))
(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}#)
+ (lambda (#{x\ 1969}#)
+ ((lambda (#{tmp\ 1970}#)
+ ((lambda (#{tmp\ 1971}#)
+ (if #{tmp\ 1971}#
+ (apply (lambda (#{_\ 1972}#
+ #{e\ 1973}#
+ #{m1\ 1974}#
+ #{m2\ 1975}#)
+ ((lambda (#{tmp\ 1976}#)
+ ((lambda (#{body\ 1977}#)
(list '#(syntax-object
let
((top)
@@ -11304,17 +13776,17 @@
#((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}#)
+ #{e\ 1973}#))
+ #{body\ 1977}#))
+ #{tmp\ 1976}#))
+ (letrec ((#{f\ 1978}#
+ (lambda (#{clause\ 1979}# #{clauses\ 1980}#)
+ (if (null? #{clauses\ 1980}#)
+ ((lambda (#{tmp\ 1982}#)
+ ((lambda (#{tmp\ 1983}#)
+ (if #{tmp\ 1983}#
+ (apply (lambda (#{e1\ 1984}#
+ #{e2\ 1985}#)
(cons '#(syntax-object
begin
((top)
@@ -11360,14 +13832,14 @@
#("i")))
(hygiene
guile))
- (cons #{e1\ 2743}#
- #{e2\ 2744}#)))
- #{tmp\ 2742}#)
- ((lambda (#{tmp\ 2746}#)
- (if #{tmp\ 2746}#
- (apply (lambda (#{k\ 2747}#
- #{e1\ 2748}#
- #{e2\ 2749}#)
+ (cons #{e1\ 1984}#
+ #{e2\ 1985}#)))
+ #{tmp\ 1983}#)
+ ((lambda (#{tmp\ 1987}#)
+ (if #{tmp\ 1987}#
+ (apply (lambda (#{k\ 1988}#
+ #{e1\ 1989}#
+ #{e2\ 1990}#)
(list '#(syntax-object
if
((top)
@@ -11568,7 +14040,7 @@
#("i")))
(hygiene
guile))
- #{k\ 2747}#))
+ #{k\ 1988}#))
(cons '#(syntax-object
begin
((top)
@@ -11619,24 +14091,24 @@
#("i")))
(hygiene
guile))
- (cons #{e1\ 2748}#
- #{e2\ 2749}#))))
- #{tmp\ 2746}#)
- ((lambda (#{_\ 2752}#)
+ (cons #{e1\ 1989}#
+ #{e2\ 1990}#))))
+ #{tmp\ 1987}#)
+ ((lambda (#{_\ 1993}#)
(syntax-violation
'case
"bad clause"
- #{x\ 2728}#
- #{clause\ 2738}#))
- #{tmp\ 2741}#)))
+ #{x\ 1969}#
+ #{clause\ 1979}#))
+ #{tmp\ 1982}#)))
($sc-dispatch
- #{tmp\ 2741}#
+ #{tmp\ 1982}#
'(each-any
any
.
each-any)))))
($sc-dispatch
- #{tmp\ 2741}#
+ #{tmp\ 1982}#
'(#(free-id
#(syntax-object
else
@@ -11662,15 +14134,15 @@
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}#)
+ #{clause\ 1979}#)
+ ((lambda (#{tmp\ 1994}#)
+ ((lambda (#{rest\ 1995}#)
+ ((lambda (#{tmp\ 1996}#)
+ ((lambda (#{tmp\ 1997}#)
+ (if #{tmp\ 1997}#
+ (apply (lambda (#{k\ 1998}#
+ #{e1\ 1999}#
+ #{e2\ 2000}#)
(list '#(syntax-object
if
((top)
@@ -11887,7 +14359,7 @@
#("i")))
(hygiene
guile))
- #{k\ 2757}#))
+ #{k\ 1998}#))
(cons '#(syntax-object
begin
((top)
@@ -11942,47 +14414,47 @@
#("i")))
(hygiene
guile))
- (cons #{e1\ 2758}#
- #{e2\ 2759}#))
- #{rest\ 2754}#))
- #{tmp\ 2756}#)
- ((lambda (#{_\ 2762}#)
+ (cons #{e1\ 1999}#
+ #{e2\ 2000}#))
+ #{rest\ 1995}#))
+ #{tmp\ 1997}#)
+ ((lambda (#{_\ 2003}#)
(syntax-violation
'case
"bad clause"
- #{x\ 2728}#
- #{clause\ 2738}#))
- #{tmp\ 2755}#)))
+ #{x\ 1969}#
+ #{clause\ 1979}#))
+ #{tmp\ 1996}#)))
($sc-dispatch
- #{tmp\ 2755}#
+ #{tmp\ 1996}#
'(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}#)
+ #{clause\ 1979}#))
+ #{tmp\ 1994}#))
+ (#{f\ 1978}#
+ (car #{clauses\ 1980}#)
+ (cdr #{clauses\ 1980}#)))))))
+ (#{f\ 1978}# #{m1\ 1974}# #{m2\ 1975}#))))
+ #{tmp\ 1971}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2729}#)))
+ #{tmp\ 1970}#)))
($sc-dispatch
- #{tmp\ 2729}#
+ #{tmp\ 1970}#
'(any any any . each-any))))
- #{x\ 2728}#))))
+ #{x\ 1969}#))))
(define identifier-syntax
(make-syncase-macro
'macro
- (lambda (#{x\ 2763}#)
- ((lambda (#{tmp\ 2764}#)
- ((lambda (#{tmp\ 2765}#)
- (if #{tmp\ 2765}#
- (apply (lambda (#{_\ 2766}# #{e\ 2767}#)
+ (lambda (#{x\ 2004}#)
+ ((lambda (#{tmp\ 2005}#)
+ ((lambda (#{tmp\ 2006}#)
+ (if #{tmp\ 2006}#
+ (apply (lambda (#{_\ 2007}# #{e\ 2008}#)
(list '#(syntax-object
lambda
((top)
@@ -12071,8 +14543,8 @@
#((top))
#("i")))
(hygiene guile))
- #{e\ 2767}#))
- (list (cons #{_\ 2766}#
+ #{e\ 2008}#))
+ (list (cons #{_\ 2007}#
'(#(syntax-object
x
((top)
@@ -12112,7 +14584,7 @@
#((top))
#("i")))
(hygiene guile))
- (cons #{e\ 2767}#
+ (cons #{e\ 2008}#
'(#(syntax-object
x
((top)
@@ -12140,11 +14612,56 @@
#("i")))
(hygiene
guile)))))))))
- #{tmp\ 2765}#)
+ #{tmp\ 2006}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2005}#)))
+ ($sc-dispatch #{tmp\ 2005}# (quote (any any)))))
+ #{x\ 2004}#))))
+
+(define define*
+ (make-syncase-macro
+ 'macro
+ (lambda (#{x\ 2009}#)
+ ((lambda (#{tmp\ 2010}#)
+ ((lambda (#{tmp\ 2011}#)
+ (if #{tmp\ 2011}#
+ (apply (lambda (#{dummy\ 2012}#
+ #{id\ 2013}#
+ #{args\ 2014}#
+ #{b0\ 2015}#
+ #{b1\ 2016}#)
+ (list '#(syntax-object
+ define
+ ((top)
+ #(ribcage
+ #(dummy id args b0 b1)
+ #(("m" top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #(("m" top)) #("i")))
+ (hygiene guile))
+ #{id\ 2013}#
+ (cons '#(syntax-object
+ lambda*
+ ((top)
+ #(ribcage
+ #(dummy id args b0 b1)
+ #(("m" top) (top) (top) (top) (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage #(x) #(("m" top)) #("i")))
+ (hygiene guile))
+ (cons #{args\ 2014}#
+ (cons #{b0\ 2015}# #{b1\ 2016}#)))))
+ #{tmp\ 2011}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp\ 2764}#)))
- ($sc-dispatch #{tmp\ 2764}# (quote (any any)))))
- #{x\ 2763}#))))
+ #{tmp\ 2010}#)))
+ ($sc-dispatch
+ #{tmp\ 2010}#
+ '(any (any . any) any . each-any))))
+ #{x\ 2009}#))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index cb90fcc17..6fcc9b064 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -448,17 +448,89 @@
((@ (language tree-il) make-toplevel-define) source var exp))
(else (decorate-source `(define ,var ,exp) source)))))
-(define build-lambda
- (lambda (src ids vars docstring exp)
+;; Ideally we would have all lambdas be case lambdas, but that would
+;; need special support in the interpreter for the full capabilities of
+;; case-lambda, with optional and keyword args, predicates, and else
+;; clauses. This will come with the new interpreter, but for now we
+;; separate the cases.
+(define build-simple-lambda
+ (lambda (src req rest vars docstring exp)
(case (fluid-ref *mode*)
- ((c) ((@ (language tree-il) make-lambda) src ids vars
+ ((c) ((@ (language tree-il) make-lambda) src
(if docstring `((documentation . ,docstring)) '())
- exp))
+ ;; hah, a case in which kwargs would be nice.
+ ((@ (language tree-il) make-lambda-case)
+ ;; src req opt rest kw inits vars predicate body else
+ src req #f rest #f '() vars #f exp #f)))
(else (decorate-source
- `(lambda ,vars ,@(if docstring (list docstring) '())
- ,exp)
+ `(lambda ,(if rest (apply cons* vars) vars)
+ ,@(if docstring (list docstring) '())
+ ,exp)
src)))))
+(define build-case-lambda
+ (lambda (src docstring body)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src
+ (if docstring `((documentation . ,docstring)) '())
+ body))
+ (else (decorate-source
+ ;; really gross hack
+ `(lambda %%args
+ ,@(if docstring (list docstring) '())
+ (cond ,@body))
+ src)))))
+
+(define build-lambda-case
+ ;; req := (name ...)
+ ;; opt := (name ...) | #f
+ ;; rest := name | #f
+ ;; kw := (allow-other-keys? (keyword name var [init]) ...) | #f
+ ;; inits: (init ...)
+ ;; vars: (sym ...)
+ ;; vars map to named arguments in the following order:
+ ;; required, optional (positional), rest, keyword.
+ ;; predicate: something you can stuff in a (lambda ,vars ,pred), already expanded
+ ;; the body of a lambda: anything, already expanded
+ ;; else: lambda-case | #f
+ (lambda (src req opt rest kw inits vars predicate body else-case)
+ (case (fluid-ref *mode*)
+ ((c)
+ ((@ (language tree-il) make-lambda-case)
+ src req opt rest kw inits vars predicate body else-case))
+ (else
+ ;; Very much like the logic of (language tree-il compile-glil).
+ (let* ((nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (rest-idx (and rest (+ nreq nopt)))
+ (allow-other-keys? (if kw (car kw) #f))
+ (kw-indices (map (lambda (x)
+ ;; (,key ,name ,var)
+ (cons (car x) (list-index vars (caddr x))))
+ (if kw (cdr kw) '())))
+ (nargs (apply max (+ nreq nopt (if rest 1 0))
+ (map 1+ (map cdr kw-indices)))))
+ (or (= nargs
+ (length vars)
+ (+ nreq (length inits) (if rest 1 0)))
+ (error "something went wrong"
+ req opt rest kw inits vars nreq nopt kw-indices nargs))
+ (decorate-source
+ `((((@@ (ice-9 optargs) parse-lambda-case)
+ '(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
+ (list ,@(map (lambda (i) `(lambda ,vars ,i)) inits))
+ ,(if predicate `(lambda ,vars ,predicate) #f)
+ %%args)
+ ;; FIXME: This _ is here to work around a bug in the
+ ;; memoizer. The %%% makes it different from %%, also a
+ ;; memoizer workaround. See the "interesting bug" mail from
+ ;; 23 oct 2009. As soon as we change the evaluator, this
+ ;; can be removed.
+ => (lambda (%%%args . _) (apply (lambda ,vars ,body) %%%args)))
+ ,@(or else-case
+ `((%%args (error "wrong number of arguments" %%args)))))
+ src))))))
+
(define build-primref
(lambda (src name)
(if (equal? (module-name (current-module)) '(guile))
@@ -506,7 +578,7 @@
(ids (cdr ids)))
(case (fluid-ref *mode*)
((c)
- (let ((proc (build-lambda src ids vars #f body-exp)))
+ (let ((proc (build-simple-lambda src ids #f vars #f body-exp)))
(maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps)
((@ (language tree-il) make-letrec) src
@@ -1323,7 +1395,7 @@
(rebuild-macro-output (vector-ref x i) m)))))
((symbol? x)
(syntax-violation #f "encountered raw symbol in macro output"
- (source-wrap e w s mod) x))
+ (source-wrap e w (wrap-subst w) mod) x))
(else x))))
(rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
@@ -1455,48 +1527,6 @@
(cons (cons er (source-wrap e w s mod))
(cdr body)))))))))))))))))
-(define chi-lambda-clause
- (lambda (e docstring c r w mod k)
- (syntax-case c ()
- ((args doc e1 e2 ...)
- (and (string? (syntax->datum (syntax doc))) (not docstring))
- (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
- (((id ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (syntax-violation 'lambda "invalid parameter list" e)
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (k (map syntax->datum ids)
- new-vars
- (and docstring (syntax->datum docstring))
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env labels new-vars r)
- (make-binding-wrap ids labels w)
- mod))))))
- ((ids e1 e2 ...)
- (let ((old-ids (lambda-var-list (syntax ids))))
- (if (not (valid-bound-ids? old-ids))
- (syntax-violation 'lambda "invalid parameter list" e)
- (let ((labels (gen-labels old-ids))
- (new-vars (map gen-var old-ids)))
- (k (let f ((ls1 (cdr old-ids)) (ls2 (car old-ids)))
- (if (null? ls1)
- (syntax->datum ls2)
- (f (cdr ls1) (cons (syntax->datum (car ls1)) ls2))))
- (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
- (if (null? ls1)
- ls2
- (f (cdr ls1) (cons (car ls1) ls2))))
- (and docstring (syntax->datum docstring))
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env labels new-vars r)
- (make-binding-wrap old-ids labels w)
- mod))))))
- (_ (syntax-violation 'lambda "bad lambda" e)))))
-
(define chi-local-syntax
(lambda (rec? e r w s mod k)
(syntax-case e ()
@@ -1540,6 +1570,231 @@
(and (nonsymbol-id? x)
(free-id=? x (syntax (... ...))))))
+(define lambda-formals
+ (lambda (orig-args)
+ (define (req args rreq)
+ (syntax-case args ()
+ (()
+ (check (reverse rreq) #f))
+ ((a . b) (id? #'a)
+ (req #'b (cons #'a rreq)))
+ (r (id? #'r)
+ (check (reverse rreq) #'r))
+ (else
+ (syntax-violation 'lambda "invalid argument list" orig-args args))))
+ (define (check req rest)
+ (cond
+ ((distinct-bound-ids? (if rest (cons rest req) req))
+ (values req #f rest #f #f))
+ (else
+ (syntax-violation 'lambda "duplicate identifier in argument list"
+ orig-args))))
+ (req orig-args '())))
+
+(define chi-simple-lambda
+ (lambda (e r w s mod req rest docstring body)
+ (let* ((ids (if rest (append req (list rest)) req))
+ (vars (map gen-var ids))
+ (labels (gen-labels ids)))
+ (build-simple-lambda
+ s
+ (map syntax->datum req) (and rest (syntax->datum rest)) vars
+ docstring
+ (chi-body body (source-wrap e w s mod)
+ (extend-var-env labels vars r)
+ (make-binding-wrap ids labels w)
+ mod)))))
+
+(define lambda*-formals
+ (lambda (orig-args)
+ (define (req args rreq)
+ (syntax-case args ()
+ (()
+ (check (reverse rreq) '() #f '() #f))
+ ((a . b) (id? #'a)
+ (req #'b (cons #'a rreq)))
+ ((a . b) (eq? (syntax->datum #'a) #:optional)
+ (opt #'b (reverse rreq) '()))
+ ((a . b) (eq? (syntax->datum #'a) #:key)
+ (key #'b (reverse rreq) '() '()))
+ ((a . b) (eq? (syntax->datum #'a) #:predicate)
+ (pred #'b (reverse rreq) '() '()))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b (reverse rreq) '() '() #f))
+ (r (id? #'r)
+ (rest #'r (reverse rreq) '() '() #f))
+ (else
+ (syntax-violation 'lambda* "invalid argument list" orig-args args))))
+ (define (opt args req ropt)
+ (syntax-case args ()
+ (()
+ (check req (reverse ropt) #f '() #f))
+ ((a . b) (id? #'a)
+ (opt #'b req (cons #'(a #f) ropt)))
+ (((a init) . b) (id? #'a)
+ (opt #'b req (cons #'(a init) ropt)))
+ ((a . b) (eq? (syntax->datum #'a) #:key)
+ (key #'b req (reverse ropt) '()))
+ ((a . b) (eq? (syntax->datum #'a) #:predicate)
+ (pred #'b req (reverse ropt) '()))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b req (reverse ropt) '() #f))
+ (r (id? #'r)
+ (rest #'r req (reverse ropt) '() #f))
+ (else
+ (syntax-violation 'lambda* "invalid optional argument list"
+ orig-args args))))
+ (define (key args req opt rkey)
+ (syntax-case args ()
+ (()
+ (check req opt #f (cons #f (reverse rkey)) #f))
+ ((a . b) (id? #'a)
+ (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+ (key #'b req opt (cons #'(k a #f) rkey))))
+ (((a init) . b) (id? #'a)
+ (with-syntax ((k (symbol->keyword (syntax->datum #'a))))
+ (key #'b req opt (cons #'(k a init) rkey))))
+ (((a init k) . b) (and (id? #'a)
+ (keyword? (syntax->datum #'k)))
+ (key #'b req opt (cons #'(k a init) rkey)))
+ ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (check req opt #f (cons #t (reverse rkey)) #f))
+ ((aok a . b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (eq? (syntax->datum #'a) #:predicate))
+ (pred #'b req opt (cons #t (reverse rkey))))
+ ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (eq? (syntax->datum #'a) #:rest))
+ (rest #'b req opt (cons #t (reverse rkey))))
+ ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys)
+ (id? #'r))
+ (rest #'r req opt (cons #t (reverse rkey))))
+ ((a . b) (eq? (syntax->datum #'a) #:predicate)
+ (pred #'b req opt (cons #f (reverse rkey))))
+ ((a b) (eq? (syntax->datum #'a) #:rest)
+ (rest #'b req opt (cons #f (reverse rkey)) #f))
+ (r (id? #'r)
+ (rest #'r req opt (cons #f (reverse rkey)) #f))
+ (else
+ (syntax-violation 'lambda* "invalid keyword argument list"
+ orig-args args))))
+ (define (pred args req opt kw)
+ (syntax-case args ()
+ ((x) (check req opt #f kw #'x))
+ ((x a b) (eq? (syntax->datum #'a #:rest))
+ (rest #'b req opt #f kw #'x))
+ ((x . b) (id? #'b)
+ (rest #'b req opt #f kw #'x))
+ (else
+ (syntax-violation 'lambda* "invalid argument list following #:predicate"
+ orig-args args))))
+ (define (rest args req opt kw pred)
+ (syntax-case args ()
+ (r (id? #'r)
+ (check req opt #'r kw pred))
+ (else
+ (syntax-violation 'lambda* "invalid rest argument"
+ orig-args args))))
+ (define (check req opt rest kw pred)
+ (cond
+ ((distinct-bound-ids?
+ (append req (map car opt) (if rest (list rest) '())
+ (if (pair? kw) (map cadr (cdr kw)) '())))
+ (values req opt rest kw pred))
+ (else
+ (syntax-violation 'lambda* "duplicate identifier in argument list"
+ orig-args))))
+ (req orig-args '())))
+
+(define chi-lambda-case
+ (lambda (e r w s mod get-formals clauses)
+ (define (expand-req req opt rest kw pred body)
+ (let ((vars (map gen-var req))
+ (labels (gen-labels req)))
+ (let ((r* (extend-var-env labels vars r))
+ (w* (make-binding-wrap req labels w)))
+ (expand-opt (map syntax->datum req)
+ opt rest kw pred body (reverse vars) r* w* '() '()))))
+ (define (expand-opt req opt rest kw pred body vars r* w* out inits)
+ (cond
+ ((pair? opt)
+ (syntax-case (car opt) ()
+ ((id i)
+ (let* ((v (gen-var #'id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list #'id) l w*)))
+ (expand-opt req (cdr opt) rest kw pred body (cons v vars)
+ r** w** (cons (syntax->datum #'id) out)
+ (cons (chi #'i r* w* mod) inits))))))
+ (rest
+ (let* ((v (gen-var rest))
+ (l (gen-labels (list v)))
+ (r* (extend-var-env l (list v) r*))
+ (w* (make-binding-wrap (list rest) l w*)))
+ (expand-kw req (if (pair? out) (reverse out) #f)
+ (syntax->datum rest)
+ (if (pair? kw) (cdr kw) kw)
+ pred body (cons v vars) r* w*
+ (if (pair? kw) (car kw) #f)
+ '() inits)))
+ (else
+ (expand-kw req (if (pair? out) (reverse out) #f) #f
+ (if (pair? kw) (cdr kw) kw)
+ pred body vars r* w*
+ (if (pair? kw) (car kw) #f)
+ '() inits))))
+ (define (expand-kw req opt rest kw pred body vars r* w* aok out inits)
+ (cond
+ ((pair? kw)
+ (syntax-case (car kw) ()
+ ((k id i)
+ (let* ((v (gen-var #'id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list #'id) l w*)))
+ (expand-kw req opt rest (cdr kw) pred body (cons v vars)
+ r** w** aok
+ (cons (list (syntax->datum #'k)
+ (syntax->datum #'id)
+ v)
+ out)
+ (cons (chi #'i r* w* mod) inits))))))
+ (else
+ (expand-pred req opt rest
+ (if (or aok (pair? out)) (cons aok (reverse out)) #f)
+ pred body (reverse vars) r* w* (reverse inits)))))
+ (define (expand-pred req opt rest kw pred body vars r* w* inits)
+ (expand-body req opt rest kw (and pred (chi pred r* w* mod))
+ body vars r* w* inits))
+ (define (expand-body req opt rest kw pred body vars r* w* inits)
+ (syntax-case body ()
+ ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
+ (values (syntax->datum #'docstring) req opt rest kw inits vars pred
+ (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
+ r* w* mod)))
+ ((e1 e2 ...)
+ (values #f req opt rest kw inits vars pred
+ (chi-body #'(e1 e2 ...) (source-wrap e w s mod)
+ r* w* mod)))))
+
+ (syntax-case clauses ()
+ (() (values #f #f))
+ (((args e1 e2 ...) (args* e1* e2* ...) ...)
+ (call-with-values (lambda () (get-formals #'args))
+ (lambda (req opt rest kw pred)
+ (call-with-values (lambda ()
+ (expand-req req opt rest kw pred #'(e1 e2 ...)))
+ (lambda (docstring req opt rest kw inits vars pred body)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod get-formals
+ #'((args* e1* e2* ...) ...)))
+ (lambda (docstring* else*)
+ (values
+ (or docstring docstring*)
+ (build-lambda-case s req opt rest kw inits vars
+ pred body else*))))))))))))
+
;;; data
;;; strips syntax-objects down to top-wrap
@@ -1574,6 +1829,7 @@
(let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
(build-lexical-var no-source id))))
+;; appears to return a reversed list
(define lambda-var-list
(lambda (vars)
(let lvl ((vars vars) (ls '()) (w empty-wrap))
@@ -1777,7 +2033,10 @@
((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
- ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr x))))
+ ((lambda)
+ (if (list? (cadr x))
+ (build-simple-lambda no-source (cadr x) #f (cadr x) #f (regen (caddr x)))
+ (error "how did we get here" x)))
(else (build-application no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
@@ -1791,15 +2050,57 @@
(lambda (e maps) (regen e))))
(_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
-
(global-extend 'core 'lambda
(lambda (e r w s mod)
- (syntax-case e ()
- ((_ . c)
- (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
- (lambda (names vars docstring body)
- (build-lambda s names vars docstring body)))))))
-
+ (syntax-case e ()
+ ((_ args docstring e1 e2 ...) (string? (syntax->datum #'docstring))
+ (call-with-values (lambda () (lambda-formals #'args))
+ (lambda (req opt rest kw pred)
+ (chi-simple-lambda e r w s mod req rest (syntax->datum #'docstring)
+ #'(e1 e2 ...)))))
+ ((_ args e1 e2 ...)
+ (call-with-values (lambda () (lambda-formals #'args))
+ (lambda (req opt rest kw pred)
+ (chi-simple-lambda e r w s mod req rest #f #'(e1 e2 ...)))))
+ (_ (syntax-violation 'lambda "bad lambda" e)))))
+
+(global-extend 'core 'lambda*
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ args e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod
+ lambda*-formals #'((args e1 e2 ...))))
+ (lambda (docstring lcase)
+ (build-case-lambda s docstring lcase))))
+ (_ (syntax-violation 'lambda "bad lambda*" e)))))
+
+(global-extend 'core 'case-lambda
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod
+ lambda-formals
+ #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
+ (lambda (docstring lcase)
+ (build-case-lambda s docstring lcase))))
+ (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
+
+(global-extend 'core 'case-lambda*
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
+ (call-with-values
+ (lambda ()
+ (chi-lambda-case e r w s mod
+ lambda*-formals
+ #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
+ (lambda (docstring lcase)
+ (build-case-lambda s docstring lcase))))
+ (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
(global-extend 'core 'let
(let ()
@@ -1975,7 +2276,7 @@
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source
(build-primref no-source 'apply)
- (list (build-lambda no-source (map syntax->datum ids) new-vars #f
+ (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars #f
(chi exp
(extend-env
labels
@@ -2002,7 +2303,7 @@
(let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y
(build-application no-source
- (build-lambda no-source (list 'tmp) (list y) #f
+ (build-simple-lambda no-source (list 'tmp) #f (list y) #f
(let ((y (build-lexical-reference 'value no-source
'tmp y)))
(build-conditional no-source
@@ -2039,16 +2340,16 @@
(let ((labels (list (gen-label)))
(var (gen-var (syntax pat))))
(build-application no-source
- (build-lambda no-source
- (list (syntax->datum (syntax pat))) (list var)
- #f
- (chi (syntax exp)
- (extend-env labels
- (list (make-binding 'syntax `(,var . 0)))
- r)
- (make-binding-wrap (syntax (pat))
- labels empty-wrap)
- mod))
+ (build-simple-lambda
+ no-source (list (syntax->datum (syntax pat))) #f (list var)
+ #f
+ (chi (syntax exp)
+ (extend-env labels
+ (list (make-binding 'syntax `(,var . 0)))
+ r)
+ (make-binding-wrap (syntax (pat))
+ labels empty-wrap)
+ mod))
(list x)))
(gen-clause x keys (cdr clauses) r
(syntax pat) #t (syntax exp) mod)))
@@ -2067,7 +2368,7 @@
(let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x
(build-application s
- (build-lambda no-source (list 'tmp) (list x) #f
+ (build-simple-lambda no-source (list 'tmp) #f (list x) #f
(gen-syntax-case (build-lexical-reference 'value no-source
'tmp x)
(syntax (key ...)) (syntax (m ...))
@@ -2448,3 +2749,8 @@
(syntax e))
((_ x (... ...))
(syntax (e x (... ...)))))))))))
+
+(define-syntax define*
+ (syntax-rules ()
+ ((_ (id . args) b0 b1 ...)
+ (define id (lambda* args b0 b1 ...)))))
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index 1f3ec2795..70708c310 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 2000, 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
@@ -112,7 +112,8 @@ You don't seem to have regular expressions installed.\n")
(= (length name) 2)
(eq? (car name) 'unquote))
(let ((doc (try-value-help (cadr name)
- (local-eval (cadr name) env))))
+ (module-ref (current-module)
+ (cadr name)))))
(cond ((not doc) (not-found 'documentation (cadr name)))
((eq? doc #t)) ;; pass
(else (write-line doc)))))
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 683da6cc1..a7c47492e 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -28,8 +28,8 @@
assembly-pack assembly-unpack
object->assembly assembly->object))
-;; nargs, nrest, nlocs, len, metalen, padding
-(define *program-header-len* (+ 1 1 2 4 4 4))
+;; len, metalen
+(define *program-header-len* (+ 4 4))
;; lengths are encoded in 3 bytes
(define *len-len* 3)
@@ -49,7 +49,7 @@
(+ 1 *len-len* (string-length str)))
((load-array ,bv)
(+ 1 *len-len* (bytevector-length bv)))
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
+ ((load-program ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
@@ -72,7 +72,7 @@
'(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)
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 688cb6b31..e6fc5bc2a 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -55,6 +55,10 @@
(define (write-uint16-le x)
(write-byte (logand x 255))
(write-byte (logand (ash x -8) 255)))
+ (define (write-uint24-be x)
+ (write-byte (logand (ash x -16) 255))
+ (write-byte (logand (ash x -8) 255))
+ (write-byte (logand x 255)))
(define (write-uint32-be x)
(write-byte (logand (ash x -24) 255))
(write-byte (logand (ash x -16) 255))
@@ -80,25 +84,15 @@
(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-bytes-per-char 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)
- (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 ((offset (- (assq-ref labels label) (+ (get-addr) 3))))
+ (cond ((>= offset (ash 1 23)) (error "jump too far forward" offset))
+ ((< offset (- (ash 1 23))) (error "jump too far backwards" offset))
+ (else (write-uint24-be offset)))))
(let ((inst (car asm))
(args (cdr asm))
@@ -110,13 +104,9 @@
(len (instruction-length inst)))
(write-byte opcode)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
- (write-byte nargs)
- (write-byte nrest)
- (write-uint16 nlocs)
+ ((load-program ,labels ,length ,meta . ,code)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
- (write-uint32 0) ; padding
(letrec ((i 0)
(write (lambda (x) (set! i (1+ i)) (write-byte x)))
(get-addr (lambda () i)))
@@ -147,6 +137,9 @@
((br-if-not-eq ,l) (write-break l))
((br-if-null ,l) (write-break l))
((br-if-not-null ,l) (write-break l))
+ ((br-if-nargs-ne ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
+ ((br-if-nargs-lt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
+ ((br-if-nargs-gt ,hi ,lo ,l) (write-byte hi) (write-byte lo) (write-break l))
((mv-call ,n ,l) (write-byte n) (write-break l))
(else
(cond
diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm
index 8cdebcfd0..6d41da2cb 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -42,28 +42,25 @@
(define (br-instruction? x)
(memq x '(br br-if br-if-not br-if-eq br-if-not-eq br-if-null br-if-not-null)))
+(define (br-nargs-instruction? x)
+ (memq x '(br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)))
-(define (bytes->s16 a b)
- (let ((x (+ (ash a 8) b)))
- (if (zero? (logand (ash 1 15) x))
+(define (bytes->s24 a b c)
+ (let ((x (+ (ash a 16) (ash b 8) c)))
+ (if (zero? (logand (ash 1 23) x))
x
- (- x (ash 1 16)))))
+ (- x (ash 1 24)))))
;; FIXME: this is a little-endian disassembly!!!
(define (decode-load-program pop)
- (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop))
- (nlocs (+ nlocs0 (ash nlocs1 8)))
- (a (pop)) (b (pop)) (c (pop)) (d (pop))
+ (let* ((a (pop)) (b (pop)) (c (pop)) (d (pop))
(e (pop)) (f (pop)) (g (pop)) (h (pop))
(len (+ a (ash b 8) (ash c 16) (ash d 24)))
(metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
- (totlen (+ len metalen))
- (pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop))
(labels '())
(i 0))
- (define (ensure-label rel1 rel2)
- (let ((where (+ (logand i (lognot #x7))
- (* (bytes->s16 rel1 rel2) 8))))
+ (define (ensure-label rel1 rel2 rel3)
+ (let ((where (+ i (bytes->s24 rel1 rel2 rel3))))
(or (assv-ref labels where)
(begin
(let ((l (gensym ":L")))
@@ -79,8 +76,7 @@
(cond ((> i len)
(error "error decoding program -- read too many bytes" out))
((= i len)
- `(load-program ,nargs ,nrest ,nlocs
- ,(map (lambda (x) (cons (cdr x) (car x)))
+ `(load-program ,(map (lambda (x) (cons (cdr x) (car x)))
(reverse labels))
,len
,(if (zero? metalen) #f (decode-load-program pop))
@@ -88,10 +84,12 @@
(else
(let ((exp (decode-bytecode sub-pop)))
(pmatch exp
- ((,br ,rel1 ,rel2) (guard (br-instruction? br))
- (lp (cons `(,br ,(ensure-label rel1 rel2)) out)))
- ((mv-call ,n ,rel1 ,rel2)
- (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2)) out)))
+ ((,br ,rel1 ,rel2 ,rel3) (guard (br-instruction? br))
+ (lp (cons `(,br ,(ensure-label rel1 rel2 rel3)) out)))
+ ((,br ,hi ,lo ,rel1 ,rel2 ,rel3) (guard (br-nargs-instruction? br))
+ (lp (cons `(,br ,hi ,lo ,(ensure-label rel1 rel2 rel3)) out)))
+ ((mv-call ,n ,rel1 ,rel2 ,rel3)
+ (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2 rel3)) out)))
(else
(lp (cons exp out))))))))))
@@ -121,7 +119,7 @@
(let lp ((i 0))
(if (= i len)
`(,inst ,(if (eq? inst 'load-wide-string)
- (utf32->string seq)
+ (utf32->string seq (native-endianness))
seq))
(begin
(sequence-set! seq i (pop))
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index 492acb7e5..2c0ad4fcb 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -35,7 +35,7 @@
(define (disassemble-load-program asm env)
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
+ ((load-program ,labels ,len ,meta . ,code)
(let ((objs (and env (assq-ref env 'objects)))
(free-vars (and env (assq-ref env 'free-vars)))
(meta (and env (assq-ref env 'meta)))
@@ -64,7 +64,9 @@
(lp (+ pos (byte-length asm)) (cdr code) programs))
(else
(print-info pos asm
- (code-annotation end asm objs nargs blocs
+ ;; FIXME: code-annotation for whether it's
+ ;; an arg or not, currently passing nargs=-1
+ (code-annotation end asm objs -1 blocs
labels)
(and=> (and srcs (assq end srcs)) source->string))
(lp (+ pos (byte-length asm)) (cdr code) programs)))))))
@@ -95,7 +97,7 @@
(define (disassemble-free-vars free-vars)
(display "Free variables:\n\n")
- (let ((i 0))
+ (let lp ((i 0))
(cond ((< i (vector-length free-vars))
(print-info i (vector-ref free-vars i) #f #f)
(lp (1+ i))))))
@@ -106,8 +108,7 @@
(define *uninteresting-props* '(name))
(define (disassemble-meta meta)
- (let ((sources (cadr meta))
- (props (filter (lambda (x)
+ (let ((props (filter (lambda (x)
(not (memq (car x) *uninteresting-props*)))
(cddr meta))))
(unless (null? props)
@@ -131,6 +132,8 @@
(list "~a element~:p" (apply make-int16 args)))
((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
(list "-> ~A" (assq-ref labels (car args))))
+ ((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
+ (list "-> ~A" (assq-ref labels (caddr args))))
((object-ref)
(and objs (list "~s" (vector-ref objs (car args)))))
((local-ref local-boxed-ref local-set local-boxed-set)
diff --git a/module/language/assembly/spec.scm b/module/language/assembly/spec.scm
index 286c80511..9e34c4def 100644
--- a/module/language/assembly/spec.scm
+++ b/module/language/assembly/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Virtual Machine Assembly
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; 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
@@ -27,7 +27,7 @@
(define-language assembly
#:title "Guile Virtual Machine Assembly Language"
#:version "2.0"
- #:reader read
+ #:reader (lambda (port env) (read port))
#:printer write
#:parser read ;; fixme: make a verifier?
#:compilers `((bytecode . ,compile-bytecode))
diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm
index 0aaa11274..4cd63167e 100644
--- a/module/language/brainfuck/compile-tree-il.scm
+++ b/module/language/brainfuck/compile-tree-il.scm
@@ -168,14 +168,17 @@
((<bf-loop> . ,body)
(let ((iterate (gensym)))
(emit `(letrec (iterate) (,iterate)
- ((lambda () ()
- (if (apply (primitive =)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const 0))
- (void)
- (begin ,(compile-body body)
- (apply (lexical ,iterate))))))
+ ((lambda ()
+ (lambda-case
+ ((() #f #f #f () () #f)
+ (if (apply (primitive =)
+ (apply (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const 0))
+ (void)
+ (begin ,(compile-body body)
+ (apply (lexical ,iterate)))))
+ #f)))
(apply (lexical ,iterate))))))
(else (error "unknown brainfuck instruction" (car in))))))))
diff --git a/module/language/brainfuck/parse.scm b/module/language/brainfuck/parse.scm
index 0a71638d8..81dbdd94a 100644
--- a/module/language/brainfuck/parse.scm
+++ b/module/language/brainfuck/parse.scm
@@ -66,9 +66,16 @@
(define (read-brainfuck p)
(let iterate ((parsed '()))
(let ((chr (read-char p)))
- (if (or (eof-object? chr) (eq? #\] chr))
- (reverse-without-nops parsed)
- (iterate (cons (process-input-char chr p) parsed))))))
+ (cond
+ ((eof-object? chr)
+ (let ((parsed (reverse-without-nops parsed)))
+ (if (null? parsed)
+ chr ;; pass on the EOF object
+ parsed)))
+ ((eqv? chr #\])
+ (reverse-without-nops parsed))
+ (else
+ (iterate (cons (process-input-char chr p) parsed)))))))
; This routine processes a single character of input and builds the
diff --git a/module/language/brainfuck/spec.scm b/module/language/brainfuck/spec.scm
index a4ba60f82..9c4d0a880 100644
--- a/module/language/brainfuck/spec.scm
+++ b/module/language/brainfuck/spec.scm
@@ -37,7 +37,7 @@
(define-language brainfuck
#:title "Guile Brainfuck"
#:version "1.0"
- #:reader (lambda () (read-brainfuck (current-input-port)))
+ #:reader (lambda (port env) (read-brainfuck 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 184565b04..b38b0911f 100644
--- a/module/language/bytecode/spec.scm
+++ b/module/language/bytecode/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; 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
@@ -32,7 +32,7 @@
(define-language bytecode
#:title "Guile Bytecode Vectors"
#:version "0.3"
- #:reader read
+ #:reader (lambda (port env) (read port))
#:printer write
#:compilers `((objcode . ,compile-objcode))
#:decompilers `((objcode . ,decompile-objcode))
diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm
index 1d031fcde..b244bec01 100644
--- a/module/language/ecmascript/base.scm
+++ b/module/language/ecmascript/base.scm
@@ -149,17 +149,15 @@
o))))
(define (object->value/string o)
- (let ((v (object->string o #f)))
- (if (is-a? x <js-object>)
- (object->number o #t)
- x)))
-
+ (if (is-a? o <js-object>)
+ (object->number o #t)
+ o))
+
(define (object->value/number o)
- (let ((v (object->number o #f)))
- (if (is-a? x <js-object>)
- (object->string o #t)
- x)))
-
+ (if (is-a? o <js-object>)
+ (object->string o #t)
+ o))
+
(define (object->value o)
;; FIXME: if it's a date, we should try numbers first
(object->value/string o))
@@ -178,7 +176,7 @@
((boolean? x) (if x 1 0))
((null? x) 0)
((eq? x *undefined*) +nan.0)
- ((is-a? x <js-object>) (object->number o))
+ ((is-a? x <js-object>) (object->number x))
((string? x) (string->number x))
(else (throw 'TypeError o '->number))))
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
index 88f3db76f..a820baf1f 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -326,14 +326,20 @@
((begin . ,forms)
`(begin ,@(map (lambda (x) (comp x e)) forms)))
((lambda ,formals ,body)
- (let ((%args (gensym "%args ")))
- (-> (lambda '%args %args '()
- (comp-body (econs '%args %args e) body formals '%args)))))
+ (let ((syms (map (lambda (x)
+ (gensym (string-append (symbol->string x) " ")))
+ formals)))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() ,formals #f #f () ,syms #f)
+ ,(comp-body e body formals syms))))))))
((call/this ,obj ,prop . ,args)
(@impl call/this*
obj
- (-> (lambda '() '() '()
- `(apply ,(@impl pget obj prop) ,@args)))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ (apply ,(@impl pget obj prop) ,@args))))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
@@ -433,40 +439,46 @@
(%continue (gensym "%continue ")))
(let ((e (econs '%loop %loop (econs '%continue %continue e))))
(-> (letrec '(%loop %continue) (list %loop %continue)
- (list (-> (lambda '() '() '()
- (-> (begin
- (comp statement e)
- (-> (apply (-> (lexical '%continue %continue)))
- )))))
-
- (-> (lambda '() '() '()
- (-> (if (@impl ->boolean (comp test e))
- (-> (apply (-> (lexical '%loop %loop))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ ,(-> (begin
+ (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ ,(-> (if (@impl ->boolean (comp test e))
+ (-> (apply (-> (lexical '%loop %loop))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%loop %loop)))))))))
((while ,test ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
(-> (letrec '(%continue) (list %continue)
- (list (-> (lambda '() '() '()
- (-> (if (@impl ->boolean (comp test e))
- (-> (begin (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ ,(-> (if (@impl ->boolean (comp test e))
+ (-> (begin (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
(-> (letrec '(%continue) (list %continue)
- (list (-> (lambda '() '() '()
- (-> (if (if test
- (@impl ->boolean (comp test e))
- (comp 'true e))
- (-> (begin (comp statement e)
- (comp (or inc '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ ,(-> (if (if test
+ (@impl ->boolean (comp test e))
+ (comp 'true e))
+ (-> (begin (comp statement e)
+ (comp (or inc '(begin)) e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e)
(-> (apply (-> (lexical '%continue %continue)))))))))))
@@ -476,18 +488,20 @@
(let ((e (econs '%enum %enum (econs '%continue %continue e))))
(-> (letrec '(%enum %continue) (list %enum %continue)
(list (@impl make-enumerator (comp object e))
- (-> (lambda '() '() '()
- (-> (if (@impl ->boolean
- (@impl pget
- (-> (lexical '%enum %enum))
- (-> (const 'length))))
- (-> (begin
- (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
- ,(-> (const 'pop))))
- e)
- (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () () #f)
+ (-> (if (@impl ->boolean
+ (@impl pget
+ (-> (lexical '%enum %enum))
+ (-> (const 'length))))
+ (-> (begin
+ (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
+ ,(-> (const 'pop))))
+ e)
+ (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%continue %continue)))))))))
((block ,x)
@@ -495,18 +509,22 @@
(else
(error "compilation not yet implemented:" x)))))
-(define (comp-body e body formals %args)
+(define (comp-body e body formals formal-syms)
(define (process)
- (let lp ((in body) (out '()) (rvars (reverse formals)))
+ (let lp ((in body) (out '()) (rvars '()))
(pmatch in
(((var (,x) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
out
- (if (memq x rvars) rvars (cons x rvars))))
+ (if (or (memq x rvars) (memq x formals))
+ rvars
+ (cons x rvars))))
(((var (,x ,y) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
`((= (ref ,x) ,y) . ,out)
- (if (memq x rvars) rvars (cons x rvars))))
+ (if (or (memq x rvars) (memq x formals))
+ rvars
+ (cons x rvars))))
(((var) . ,rest)
(lp rest out rvars))
((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
@@ -532,18 +550,6 @@
(syms (map (lambda (x)
(gensym (string-append (symbol->string x) " ")))
names))
- (e (fold acons e names syms)))
- (let ((%argv (lookup %args e)))
- (let lp ((names names) (syms syms))
- (if (null? names)
- ;; fixme: here check for too many args
- (comp out e)
- (-> (let (list (car names)) (list (car syms))
- (list (-> (if (-> (apply (-> (primitive 'null?)) %argv))
- (-> (@implv *undefined*))
- (-> (let1 (-> (apply (-> (primitive 'car)) %argv))
- (lambda (v)
- (-> (set! %argv
- (-> (apply (-> (primitive 'cdr)) %argv))))
- (-> (lexical v v))))))))
- (lp (cdr names) (cdr syms))))))))))
+ (e (fold econs (fold econs e formals formal-syms) names syms)))
+ (-> (let names syms (map (lambda (x) (->@implv *undefined*)) names)
+ (comp out e))))))
diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm
index 7a1ea465c..dd4dc3c0f 100644
--- a/module/language/ecmascript/spec.scm
+++ b/module/language/ecmascript/spec.scm
@@ -31,7 +31,7 @@
(define-language ecmascript
#:title "Guile ECMAScript"
#:version "3.0"
- #:reader (lambda () (read-ecmascript/1 (current-input-port)))
+ #:reader (lambda (port env) (read-ecmascript/1 port))
#: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 1b6a7eeaf..2ab8045cc 100644
--- a/module/language/ecmascript/tokenize.scm
+++ b/module/language/ecmascript/tokenize.scm
@@ -50,8 +50,9 @@
(+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))
(define (read-slash port div?)
- (let* ((c0 (read-char port))
- (c1 (peek-char port)))
+ (let ((c1 (begin
+ (read-char port)
+ (peek-char port))))
(cond
((eof-object? c1)
;; hmm. error if we're not looking for a div? ?
diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm
deleted file mode 100644
index 617e4e3c5..000000000
--- a/module/language/elisp/spec.scm
+++ /dev/null
@@ -1,62 +0,0 @@
-;;; Guile Emac Lisp
-
-;; 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 (lang elisp spec)
- #:use-module (system lang language)
- #:export (elisp))
-
-
-;;;
-;;; Translator
-;;;
-
-(define (translate x)
- (if (pair? x)
- (translate-pair x)
- x))
-
-(define (translate-pair x)
- (let ((name (car x)) (args (cdr x)))
- (case name
- ((quote) `(@quote ,@args))
- ((defvar) `(@define ,@(map translate args)))
- ((setq) `(@set! ,@(map translate args)))
- ((if) `(@if ,(translate (car args))
- (@begin ,@(map translate (cdr args)))))
- ((and) `(@and ,@(map translate args)))
- ((or) `(@or ,@(map translate args)))
- ((progn) `(@begin ,@(map translate args)))
- ((defun) `(@define ,(car args)
- (@lambda ,(cadr args) ,@(map translate (cddr args)))))
- ((lambda) `(@lambda ,(car args) ,@(map translate (cdr args))))
- (else x))))
-
-
-;;;
-;;; Language definition
-;;;
-
-(define-language elisp
- #:title "Emacs Lisp"
- #:version "0.0"
- #:reader read
- #:expander id
- #:translator translate
- )
diff --git a/module/language/ghil.scm b/module/language/ghil.scm
deleted file mode 100644
index 84cc83de5..000000000
--- a/module/language/ghil.scm
+++ /dev/null
@@ -1,478 +0,0 @@
-;;; Guile High Intermediate Language
-
-;; 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 ghil)
- #:use-module (system base syntax)
- #:use-module (system base pmatch)
- #:use-module (ice-9 regex)
- #:export
- (ghil-env ghil-loc
-
- <ghil-void> make-ghil-void ghil-void?
- ghil-void-env ghil-void-loc
-
- <ghil-quote> make-ghil-quote ghil-quote?
- ghil-quote-env ghil-quote-loc ghil-quote-obj
-
- <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
- ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
-
- <ghil-unquote> make-ghil-unquote ghil-unquote?
- ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
-
- <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
- ghil-unquote-splicing-env ghil-unquote-splicing-loc ghil-unquote-splicing-exp
-
- <ghil-ref> make-ghil-ref ghil-ref?
- ghil-ref-env ghil-ref-loc ghil-ref-var
-
- <ghil-set> make-ghil-set ghil-set?
- ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
-
- <ghil-define> make-ghil-define ghil-define?
- ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
-
- <ghil-if> make-ghil-if ghil-if?
- ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
-
- <ghil-and> make-ghil-and ghil-and?
- ghil-and-env ghil-and-loc ghil-and-exps
-
- <ghil-or> make-ghil-or ghil-or?
- ghil-or-env ghil-or-loc ghil-or-exps
-
- <ghil-begin> make-ghil-begin ghil-begin?
- ghil-begin-env ghil-begin-loc ghil-begin-exps
-
- <ghil-bind> make-ghil-bind ghil-bind?
- ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
-
- <ghil-mv-bind> make-ghil-mv-bind ghil-mv-bind?
- ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars ghil-mv-bind-rest ghil-mv-bind-body
-
- <ghil-lambda> make-ghil-lambda ghil-lambda?
- ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
- ghil-lambda-meta ghil-lambda-body
-
- <ghil-inline> make-ghil-inline ghil-inline?
- ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
-
- <ghil-call> make-ghil-call ghil-call?
- ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
-
- <ghil-mv-call> make-ghil-mv-call ghil-mv-call?
- ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer
-
- <ghil-values> make-ghil-values ghil-values?
- ghil-values-env ghil-values-loc ghil-values-values
-
- <ghil-values*> make-ghil-values* ghil-values*?
- ghil-values*-env ghil-values*-loc ghil-values*-values
-
- <ghil-var> make-ghil-var ghil-var?
- ghil-var-env ghil-var-name ghil-var-kind ghil-var-index
-
- <ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env?
- ghil-toplevel-env-table
-
- <ghil-env> make-ghil-env ghil-env?
- ghil-env-parent ghil-env-table ghil-env-variables
-
- <ghil-reified-env> make-ghil-reified-env ghil-reified-env?
- ghil-reified-env-env ghil-reified-env-loc
-
- ghil-env-add!
- ghil-env-reify ghil-env-dereify
- ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
- ghil-var-at-module!
- call-with-ghil-environment call-with-ghil-bindings
-
- parse-ghil unparse-ghil))
-
-
-;;;
-;;; Parse tree
-;;;
-
-(define (print-ghil x port)
- (format port "#<ghil ~s>" (unparse-ghil x)))
-
-(define-type (<ghil> #:printer print-ghil
- #:common-slots (env loc))
- ;; Objects
- (<ghil-void>)
- (<ghil-quote> obj)
- (<ghil-quasiquote> exp)
- (<ghil-unquote> exp)
- (<ghil-unquote-splicing> exp)
- ;; Variables
- (<ghil-ref> var)
- (<ghil-set> var val)
- (<ghil-define> var val)
- ;; Controls
- (<ghil-if> test then else)
- (<ghil-and> exps)
- (<ghil-or> exps)
- (<ghil-begin> exps)
- (<ghil-bind> vars vals body)
- (<ghil-mv-bind> producer vars rest body)
- (<ghil-lambda> vars rest meta body)
- (<ghil-call> proc args)
- (<ghil-mv-call> producer consumer)
- (<ghil-inline> inline args)
- (<ghil-values> values)
- (<ghil-values*> values)
- (<ghil-reified-env>))
-
-
-
-;;;
-;;; Variables
-;;;
-
-(define-record <ghil-var> env name kind (index #f))
-
-
-;;;
-;;; Modules
-;;;
-
-
-;;;
-;;; Environments
-;;;
-
-(define-record <ghil-env> parent (table '()) (variables '()))
-(define-record <ghil-toplevel-env> (table '()))
-
-(define (ghil-env-ref env sym)
- (assq-ref (ghil-env-table env) sym))
-
-(define-macro (push! item loc)
- `(set! ,loc (cons ,item ,loc)))
-(define-macro (apush! k v loc)
- `(set! ,loc (acons ,k ,v ,loc)))
-(define-macro (apopq! k loc)
- `(set! ,loc (assq-remove! ,loc ,k)))
-
-(define (ghil-env-add! env var)
- (apush! (ghil-var-name var) var (ghil-env-table env))
- (push! var (ghil-env-variables env)))
-
-(define (ghil-env-remove! env var)
- (apopq! (ghil-var-name var) (ghil-env-table env)))
-
-(define (force-heap-allocation! var)
- (set! (ghil-var-kind var) 'external))
-
-
-
-;;;
-;;; Public interface
-;;;
-
-;; The following four functions used to be one, in ghil-lookup. Now they
-;; are four, to reflect the different intents. A bit of duplication, but
-;; that's OK. The common current is to find out where a variable will be
-;; stored at runtime.
-;;
-;; These functions first search the lexical environments. If the
-;; variable is not in the innermost environment, make sure the variable
-;; is marked as being "external" so that it goes on the heap. If the
-;; variable is being modified (via a set!), also make sure it's on the
-;; heap, so that other continuations see the changes to the var.
-;;
-;; If the variable is not found lexically, it is a toplevel variable,
-;; which will be looked up at runtime with respect to the module that
-;; was current when the lambda was bound, at runtime. The variable will
-;; be resolved when it is first used.
-(define (ghil-var-is-bound? env sym)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (cons (module-name (current-module)) sym)))
- (assoc-ref table key)))
- ((<ghil-env> parent table variables)
- (and (not (assq-ref table sym))
- (loop parent))))))
-
-(define (ghil-var-for-ref! env sym)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (cons (module-name (current-module)) sym)))
- (or (assoc-ref table key)
- (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
- (apush! key var (ghil-toplevel-env-table e))
- var))))
- ((<ghil-env> parent table variables)
- (cond
- ((assq-ref table sym)
- => (lambda (var)
- (or (eq? e env)
- (force-heap-allocation! var))
- var))
- (else
- (loop parent)))))))
-
-(define (ghil-var-for-set! env sym)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (cons (module-name (current-module)) sym)))
- (or (assoc-ref table key)
- (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
- (apush! key var (ghil-toplevel-env-table e))
- var))))
- ((<ghil-env> parent table variables)
- (cond
- ((assq-ref table sym)
- => (lambda (var)
- (force-heap-allocation! var)
- var))
- (else
- (loop parent)))))))
-
-(define (ghil-var-at-module! env modname sym interface?)
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((key (list modname sym interface?)))
- (or (assoc-ref table key)
- (let ((var (make-ghil-var modname sym
- (if interface? 'public 'private))))
- (apush! key var (ghil-toplevel-env-table e))
- var))))
- ((<ghil-env> parent table variables)
- (loop parent)))))
-
-(define (ghil-var-define! toplevel sym)
- (let ((key (cons (module-name (current-module)) sym)))
- (or (assoc-ref (ghil-toplevel-env-table toplevel) key)
- (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
- (apush! key var (ghil-toplevel-env-table toplevel))
- var))))
-
-(define (call-with-ghil-environment e syms func)
- (let* ((e (make-ghil-env e))
- (vars (map (lambda (s)
- (let ((v (make-ghil-var e s 'argument)))
- (ghil-env-add! e v) v))
- syms)))
- (func e vars)))
-
-(define (call-with-ghil-bindings e syms func)
- (let* ((vars (map (lambda (s)
- (let ((v (make-ghil-var e s 'local)))
- (ghil-env-add! e v) v))
- syms))
- (ret (func vars)))
- (for-each (lambda (v) (ghil-env-remove! e v)) vars)
- ret))
-
-(define (ghil-env-reify env)
- (let loop ((e env) (out '()))
- (record-case e
- ((<ghil-toplevel-env> table)
- (map (lambda (v)
- (cons (ghil-var-name v)
- (or (ghil-var-index v)
- (error "reify called before indices finalized"))))
- out))
- ((<ghil-env> parent table variables)
- (loop parent
- (append out
- (filter (lambda (v) (eq? (ghil-var-kind v) 'external))
- variables)))))))
-
-(define (ghil-env-dereify name-index-alist)
- (let* ((e (make-ghil-env (make-ghil-toplevel-env)))
- (vars (map (lambda (pair)
- (make-ghil-var e (car pair) 'external (cdr pair)))
- name-index-alist)))
- (set! (ghil-env-table e)
- (map (lambda (v) (cons (ghil-var-name v) v)) vars))
- (set! (ghil-env-variables e) vars)
- e))
-
-
-;;;
-;;; Parser
-;;;
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- (vector (assq-ref props 'line)
- (assq-ref props 'column)
- (assq-ref props 'filename))))))
-
-(define (parse-quasiquote e x level)
- (cond ((not (pair? x)) x)
- ((memq (car x) '(unquote unquote-splicing))
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj)
- (cond
- ((zero? level)
- (if (eq? (car x) 'unquote)
- (make-ghil-unquote e l (parse-ghil e obj))
- (make-ghil-unquote-splicing e l (parse-ghil e obj))))
- (else
- (list (car x) (parse-quasiquote e obj (1- level))))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- ((eq? (car x) 'quasiquote)
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj) (list 'quasiquote (parse-quasiquote e obj (1+ level))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- (else (cons (parse-quasiquote e (car x) level)
- (parse-quasiquote e (cdr x) level)))))
-
-(define (parse-ghil env exp)
- (let ((loc (location exp))
- (retrans (lambda (x) (parse-ghil env x))))
- (pmatch exp
- ((ref ,sym) (guard (symbol? sym))
- (make-ghil-ref env #f (ghil-var-for-ref! env sym)))
-
- (('quote ,exp) (make-ghil-quote env loc exp))
-
- ((void) (make-ghil-void env loc))
-
- ((lambda ,syms ,rest ,meta . ,body)
- (call-with-ghil-environment env syms
- (lambda (env vars)
- (make-ghil-lambda env loc vars rest meta
- (parse-ghil env `(begin ,@body))))))
-
- ((begin . ,body)
- (make-ghil-begin env loc (map retrans body)))
-
- ((bind ,syms ,exprs . ,body)
- (let ((vals (map retrans exprs)))
- (call-with-ghil-bindings env syms
- (lambda (vars)
- (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
-
- ((bindrec ,syms ,exprs . ,body)
- (call-with-ghil-bindings env syms
- (lambda (vars)
- (let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
- (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
-
- ((set ,sym ,val)
- (make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
-
- ((define ,sym ,val)
- (make-ghil-define env loc (ghil-var-define! env sym) (retrans val)))
-
- ((if ,test ,then ,else)
- (make-ghil-if env loc (retrans test) (retrans then) (retrans else)))
-
- ((and . ,exps)
- (make-ghil-and env loc (map retrans exps)))
-
- ((or . ,exps)
- (make-ghil-or env loc (map retrans exps)))
-
- ((mv-bind ,syms ,rest ,producer . ,body)
- (call-with-ghil-bindings env syms
- (lambda (vars)
- (make-ghil-mv-bind env loc (retrans producer) vars rest
- (map retrans body)))))
-
- ((call ,proc . ,args)
- (make-ghil-call env loc (retrans proc) (map retrans args)))
-
- ((mv-call ,producer ,consumer)
- (make-ghil-mv-call env loc (retrans producer) (retrans consumer)))
-
- ((inline ,op . ,args)
- (make-ghil-inline env loc op (map retrans args)))
-
- ((values . ,values)
- (make-ghil-values env loc (map retrans values)))
-
- ((values* . ,values)
- (make-ghil-values* env loc (map retrans values)))
-
- ((compile-time-environment)
- (make-ghil-reified-env env loc))
-
- ((quasiquote ,exp)
- (make-ghil-quasiquote env loc (parse-quasiquote env exp 0)))
-
- (else
- (error "unrecognized GHIL" exp)))))
-
-(define (unparse-ghil ghil)
- (record-case ghil
- ((<ghil-void> env loc)
- '(void))
- ((<ghil-quote> env loc obj)
- `(,'quote ,obj))
- ((<ghil-quasiquote> env loc exp)
- `(,'quasiquote ,(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)
- `(,'unquote-splicing ,(unparse-ghil exp)))
- ;; Variables
- ((<ghil-ref> env loc var)
- `(ref ,(ghil-var-name var)))
- ((<ghil-set> env loc var val)
- `(set ,(ghil-var-name var) ,(unparse-ghil val)))
- ((<ghil-define> env loc var val)
- `(define ,(ghil-var-name var) ,(unparse-ghil val)))
- ;; Controls
- ((<ghil-if> env loc test then else)
- `(if ,(unparse-ghil test) ,(unparse-ghil then) ,(unparse-ghil else)))
- ((<ghil-and> env loc exps)
- `(and ,@(map unparse-ghil exps)))
- ((<ghil-or> env loc exps)
- `(or ,@(map unparse-ghil exps)))
- ((<ghil-begin> env loc exps)
- `(begin ,@(map unparse-ghil exps)))
- ((<ghil-bind> env loc vars vals body)
- `(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
- ,(unparse-ghil body)))
- ((<ghil-mv-bind> env loc producer vars rest body)
- `(mv-bind ,(map ghil-var-name vars) ,rest
- ,(unparse-ghil producer) ,(unparse-ghil body)))
- ((<ghil-lambda> env loc vars rest meta body)
- `(lambda ,(map ghil-var-name vars) ,rest ,meta
- ,(unparse-ghil body)))
- ((<ghil-call> env loc proc args)
- `(call ,(unparse-ghil proc) ,@(map unparse-ghil args)))
- ((<ghil-mv-call> env loc producer consumer)
- `(mv-call ,(unparse-ghil producer) ,(unparse-ghil consumer)))
- ((<ghil-inline> env loc inline args)
- `(inline ,inline ,@(map unparse-ghil args)))
- ((<ghil-values> env loc values)
- `(values ,@(map unparse-ghil values)))
- ((<ghil-values*> env loc values)
- `(values* ,@(map unparse-ghil values)))
- ((<ghil-reified-env> env loc)
- `(compile-time-environment))))
diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm
deleted file mode 100644
index 47e15c797..000000000
--- a/module/language/ghil/compile-glil.scm
+++ /dev/null
@@ -1,592 +0,0 @@
-;;; GHIL -> GLIL compiler
-
-;; 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 ghil compile-glil)
- #:use-module (system base syntax)
- #:use-module (language glil)
- #:use-module (language ghil)
- #:use-module (ice-9 common-list)
- #:export (compile-glil))
-
-(define (compile-glil x e opts)
- (if (memq #:O opts) (set! x (optimize x)))
- (values (codegen x)
- (and e (cons (car e) (cddr e)))
- e))
-
-
-;;;
-;;; Stage 2: Optimization
-;;;
-
-(define (lift-variables! env)
- (let ((parent-env (ghil-env-parent env)))
- (for-each (lambda (v)
- (case (ghil-var-kind v)
- ((argument) (set! (ghil-var-kind v) 'local)))
- (set! (ghil-var-env v) parent-env)
- (ghil-env-add! parent-env v))
- (ghil-env-variables env))))
-
-;; The premise of this, unused, approach to optimization is that you can
-;; determine the environment of a variable lexically, because they have
-;; been alpha-renamed. It makes the transformations *much* easier.
-;; Unfortunately it doesn't work yet.
-(define (optimize* x)
- (transform-record (<ghil> env loc) x
- ((quasiquote exp)
- (define (optimize-qq x)
- (cond ((list? x) (map optimize-qq x))
- ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x))))
- ((record? x) (optimize x))
- (else x)))
- (-> (quasiquote (optimize-qq x))))
-
- ((unquote exp)
- (-> (unquote (optimize exp))))
-
- ((unquote-splicing exp)
- (-> (unquote-splicing (optimize exp))))
-
- ((set var val)
- (-> (set var (optimize val))))
-
- ((define var val)
- (-> (define var (optimize val))))
-
- ((if test then else)
- (-> (if (optimize test) (optimize then) (optimize else))))
-
- ((and exps)
- (-> (and (map optimize exps))))
-
- ((or exps)
- (-> (or (map optimize exps))))
-
- ((begin exps)
- (-> (begin (map optimize exps))))
-
- ((bind vars vals body)
- (-> (bind vars (map optimize vals) (optimize body))))
-
- ((mv-bind producer vars rest body)
- (-> (mv-bind (optimize producer) vars rest (optimize body))))
-
- ((inline inst args)
- (-> (inline inst (map optimize args))))
-
- ((call (proc (lambda vars (rest #f) meta body)) args)
- (-> (bind vars (optimize args) (optimize body))))
-
- ((call proc args)
- (-> (call (optimize proc) (map optimize args))))
-
- ((lambda vars rest meta body)
- (-> (lambda vars rest meta (optimize body))))
-
- ((mv-call producer (consumer (lambda vars rest meta body)))
- (-> (mv-bind (optimize producer) vars rest (optimize body))))
-
- ((mv-call producer consumer)
- (-> (mv-call (optimize producer) (optimize consumer))))
-
- ((values values)
- (-> (values (map optimize values))))
-
- ((values* values)
- (-> (values* (map optimize values))))
-
- (else
- (error "unrecognized GHIL" x))))
-
-(define (optimize x)
- (record-case x
- ((<ghil-set> env loc var val)
- (make-ghil-set env var (optimize val)))
-
- ((<ghil-define> env loc var val)
- (make-ghil-define env var (optimize val)))
-
- ((<ghil-if> env loc test then else)
- (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
-
- ((<ghil-and> env loc exps)
- (make-ghil-and env loc (map optimize exps)))
-
- ((<ghil-or> env loc exps)
- (make-ghil-or env loc (map optimize exps)))
-
- ((<ghil-begin> env loc exps)
- (make-ghil-begin env loc (map optimize exps)))
-
- ((<ghil-bind> env loc vars vals body)
- (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
-
- ((<ghil-lambda> env loc vars rest meta body)
- (make-ghil-lambda env loc vars rest meta (optimize body)))
-
- ((<ghil-inline> env loc instruction args)
- (make-ghil-inline env loc instruction (map optimize args)))
-
- ((<ghil-call> env loc proc args)
- (let ((parent-env env))
- (record-case proc
- ;; ((@lambda (VAR...) BODY...) ARG...) =>
- ;; (@let ((VAR ARG) ...) BODY...)
- ((<ghil-lambda> env loc vars rest meta body)
- (cond
- ((not rest)
- (lift-variables! env)
- (make-ghil-bind parent-env loc (map optimize args)))
- (else
- (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
- (else
- (make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
-
- ((<ghil-mv-call> env loc producer consumer)
- (record-case consumer
- ;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
- ;; (mv-let PRODUCER ARGS BODY...)
- ((<ghil-lambda> env loc vars rest meta body)
- (lift-variables! env)
- (make-ghil-mv-bind producer vars rest body))
- (else
- (make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
-
- (else x)))
-
-
-;;;
-;;; Stage 3: Code generation
-;;;
-
-(define *ia-void* (make-glil-void))
-(define *ia-drop* (make-glil-call 'drop 1))
-(define *ia-return* (make-glil-call 'return 1))
-
-(define (make-label) (gensym ":L"))
-
-(define (make-glil-var op env var)
- (case (ghil-var-kind var)
- ((argument)
- (make-glil-local op (ghil-var-index var)))
- ((local)
- (make-glil-local op (ghil-var-index var)))
- ((external)
- (do ((depth 0 (1+ depth))
- (e env (ghil-env-parent e)))
- ((eq? e (ghil-var-env var))
- (make-glil-external op depth (ghil-var-index var)))))
- ((toplevel)
- (make-glil-toplevel op (ghil-var-name var)))
- ((public private)
- (make-glil-module op (ghil-var-env var) (ghil-var-name var)
- (eq? (ghil-var-kind var) 'public)))
- (else (error "Unknown kind of variable:" var))))
-
-(define (constant? x)
- (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t)
- ((pair? x) (and (constant? (car x))
- (constant? (cdr x))))
- ((vector? x) (let lp ((i (vector-length x)))
- (or (zero? i)
- (and (constant? (vector-ref x (1- i)))
- (lp (1- i))))))))
-
-(define (codegen ghil)
- (let ((stack '()))
- (define (push-code! loc code)
- (set! stack (cons code stack))
- (if loc (set! stack (cons (make-glil-source loc) stack))))
- (define (var->binding var)
- (list (ghil-var-name var) (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)))))
- (define (comp tree tail drop)
- (define (push-label! label)
- (push-code! #f (make-glil-label label)))
- (define (push-branch! loc inst label)
- (push-code! loc (make-glil-branch inst label)))
- (define (push-call! loc inst args)
- (for-each comp-push args)
- (push-code! loc (make-glil-call inst (length args))))
- ;; possible tail position
- (define (comp-tail tree) (comp tree tail drop))
- ;; push the result
- (define (comp-push tree) (comp tree #f #f))
- ;; drop the result
- (define (comp-drop tree) (comp tree #f #t))
- ;; drop the result if unnecessary
- (define (maybe-drop)
- (if drop (push-code! #f *ia-drop*)))
- ;; return here if necessary
- (define (maybe-return)
- (if tail (push-code! #f *ia-return*)))
- ;; return this code if necessary
- (define (return-code! loc code)
- (if (not drop) (push-code! loc code))
- (maybe-return))
- ;; return void if necessary
- (define (return-void!)
- (return-code! #f *ia-void*))
- ;; return object if necessary
- (define (return-object! loc obj)
- (return-code! loc (make-glil-const obj)))
- ;;
- ;; dispatch
- (record-case tree
- ((<ghil-void>)
- (return-void!))
-
- ((<ghil-quote> env loc obj)
- (return-object! loc obj))
-
- ((<ghil-quasiquote> env loc exp)
- (let loop ((x exp) (in-car? #f))
- (cond
- ((list? x)
- (push-call! #f 'mark '())
- (for-each (lambda (x) (loop x #t)) x)
- (push-call! #f 'list-mark '()))
- ((pair? x)
- (push-call! #f 'mark '())
- (loop (car x) #t)
- (loop (cdr x) #f)
- (push-call! #f 'cons-mark '()))
- ((record? x)
- (record-case x
- ((<ghil-unquote> env loc exp)
- (comp-push exp))
- ((<ghil-unquote-splicing> env loc exp)
- (if (not in-car?)
- (error "unquote-splicing in the cdr of a pair" exp))
- (comp-push exp)
- (push-call! #f 'list-break '()))))
- ((constant? x)
- (push-code! #f (make-glil-const x)))
- (else
- (error "element of quasiquote can't be compiled" x))))
- (maybe-drop)
- (maybe-return))
-
- ((<ghil-unquote> env loc exp)
- (error "unquote outside of quasiquote" exp))
-
- ((<ghil-unquote-splicing> env loc exp)
- (error "unquote-splicing outside of quasiquote" exp))
-
- ((<ghil-ref> env loc var)
- (return-code! loc (make-glil-var 'ref env var)))
-
- ((<ghil-set> env loc var val)
- (comp-push val)
- (push-code! loc (make-glil-var 'set env var))
- (return-void!))
-
- ((<ghil-define> env loc var val)
- (comp-push val)
- (push-code! loc (make-glil-var 'define env var))
- (return-void!))
-
- ((<ghil-if> env loc test then else)
- ;; TEST
- ;; (br-if-not L1)
- ;; THEN
- ;; (br L2)
- ;; L1: ELSE
- ;; L2:
- (let ((L1 (make-label)) (L2 (make-label)))
- (comp-push test)
- (push-branch! loc 'br-if-not L1)
- (comp-tail then)
- (if (not tail) (push-branch! #f 'br L2))
- (push-label! L1)
- (comp-tail else)
- (if (not tail) (push-label! L2))))
-
- ((<ghil-and> env loc exps)
- ;; EXP
- ;; (br-if-not L1)
- ;; ...
- ;; TAIL
- ;; (br L2)
- ;; L1: (const #f)
- ;; L2:
- (cond ((null? exps) (return-object! loc #t))
- ((null? (cdr exps)) (comp-tail (car exps)))
- (else
- (let ((L1 (make-label)) (L2 (make-label)))
- (let lp ((exps exps))
- (cond ((null? (cdr exps))
- (comp-tail (car exps))
- (push-branch! #f 'br L2)
- (push-label! L1)
- (return-object! #f #f)
- (push-label! L2)
- (maybe-return))
- (else
- (comp-push (car exps))
- (push-branch! #f 'br-if-not L1)
- (lp (cdr exps)))))))))
-
- ((<ghil-or> env loc exps)
- ;; EXP
- ;; (dup)
- ;; (br-if L1)
- ;; (drop)
- ;; ...
- ;; TAIL
- ;; L1:
- (cond ((null? exps) (return-object! loc #f))
- ((null? (cdr exps)) (comp-tail (car exps)))
- (else
- (let ((L1 (make-label)))
- (let lp ((exps exps))
- (cond ((null? (cdr exps))
- (comp-tail (car exps))
- (push-label! L1)
- (maybe-return))
- (else
- (comp-push (car exps))
- (if (not drop)
- (push-call! #f 'dup '()))
- (push-branch! #f 'br-if L1)
- (if (not drop)
- (push-code! loc (make-glil-call 'drop 1)))
- (lp (cdr exps)))))))))
-
- ((<ghil-begin> env loc exps)
- ;; EXPS...
- ;; TAIL
- (if (null? exps)
- (return-void!)
- (do ((exps exps (cdr exps)))
- ((null? (cdr exps))
- (comp-tail (car exps)))
- (comp-drop (car exps)))))
-
- ((<ghil-bind> env loc vars vals body)
- ;; VALS...
- ;; (set VARS)...
- ;; BODY
- (for-each comp-push vals)
- (push-bindings! loc vars)
- (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
- (reverse vars))
- (comp-tail body)
- (push-code! #f (make-glil-unbind)))
-
- ((<ghil-mv-bind> env loc producer vars rest body)
- ;; VALS...
- ;; (set VARS)...
- ;; BODY
- (let ((MV (make-label)))
- (comp-push producer)
- (push-code! loc (make-glil-mv-call 0 MV))
- (push-code! #f (make-glil-const 1))
- (push-label! MV)
- (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
- (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
- (reverse vars)))
- (comp-tail body)
- (push-code! #f (make-glil-unbind)))
-
- ((<ghil-lambda> env loc vars rest meta body)
- (return-code! loc (codegen tree)))
-
- ((<ghil-inline> env loc inline args)
- ;; ARGS...
- ;; (INST NARGS)
- (let ((tail-table '((call . goto/args)
- (apply . goto/apply)
- (call/cc . goto/cc))))
- (cond ((and tail (assq-ref tail-table inline))
- => (lambda (tail-inst)
- (push-call! loc tail-inst args)))
- (else
- (push-call! loc inline args)
- (maybe-drop)
- (maybe-return)))))
-
- ((<ghil-values> env loc values)
- (cond (tail ;; (lambda () (values 1 2))
- (push-call! loc 'return/values values))
- (drop ;; (lambda () (values 1 2) 3)
- (for-each comp-drop values))
- (else ;; (lambda () (list (values 10 12) 1))
- (push-code! #f (make-glil-const 'values))
- (push-code! #f (make-glil-call 'link-now 1))
- (push-code! #f (make-glil-call 'variable-ref 0))
- (push-call! loc 'call values))))
-
- ((<ghil-values*> env loc values)
- (cond (tail ;; (lambda () (apply values '(1 2)))
- (push-call! loc 'return/values* values))
- (drop ;; (lambda () (apply values '(1 2)) 3)
- (for-each comp-drop values))
- (else ;; (lambda () (list (apply values '(10 12)) 1))
- (push-code! #f (make-glil-const 'values))
- (push-code! #f (make-glil-call 'link-now 1))
- (push-code! #f (make-glil-call 'variable-ref 0))
- (push-call! loc 'apply values))))
-
- ((<ghil-call> env loc proc args)
- ;; PROC
- ;; ARGS...
- ;; ([tail-]call NARGS)
- (comp-push proc)
- (let ((nargs (length args)))
- (cond ((< nargs 255)
- (push-call! loc (if tail 'goto/args 'call) args))
- (else
- (push-call! loc 'mark '())
- (for-each comp-push args)
- (push-call! loc 'list-mark '())
- (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2)))))
- (maybe-drop))
-
- ((<ghil-mv-call> env loc producer consumer)
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (let ((MV (make-label)) (POST (make-label)))
- (comp-push consumer)
- (comp-push producer)
- (push-code! loc (make-glil-mv-call 0 MV))
- (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
- (cond ((not tail)
- (push-branch! #f 'br POST)))
- (push-label! MV)
- (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
- (cond ((not tail)
- (push-label! POST)
- (maybe-drop)))))
-
- ((<ghil-reified-env> env loc)
- (return-object! loc (ghil-env-reify env)))))
-
- ;;
- ;; main
- (record-case ghil
- ((<ghil-lambda> env loc vars rest meta body)
- (let* ((evars (ghil-env-variables env))
- (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
- (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
- (nargs (allocate-indices-linearly! vars))
- (nlocs (allocate-locals! locs body nargs))
- (nexts (allocate-indices-linearly! exts)))
- ;; meta bindings
- (push-bindings! #f vars)
- ;; push on definition source location
- (if loc (set! stack (cons (make-glil-source loc) stack)))
- ;; copy args to the heap if they're marked as external
- (do ((n 0 (1+ n))
- (l vars (cdr l)))
- ((null? l))
- (let ((v (car l)))
- (case (ghil-var-kind v)
- ((external)
- (push-code! #f (make-glil-local 'ref n))
- (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
- ;; compile body
- (comp body #t #f)
- ;; create GLIL
- (make-glil-program nargs (if rest 1 0) nlocs nexts meta
- (reverse! stack)))))))
-
-(define (allocate-indices-linearly! vars)
- (do ((n 0 (1+ n))
- (l vars (cdr l)))
- ((null? l) n)
- (let ((v (car l))) (set! (ghil-var-index v) n))))
-
-(define (allocate-locals! vars body nargs)
- (let ((free '()) (nlocs nargs))
- (define (allocate! var)
- (cond
- ((pair? free)
- (set! (ghil-var-index var) (car free))
- (set! free (cdr free)))
- (else
- (set! (ghil-var-index var) nlocs)
- (set! nlocs (1+ nlocs)))))
- (define (deallocate! var)
- (set! free (cons (ghil-var-index var) free)))
- (let lp ((x body))
- (record-case x
- ((<ghil-void>))
- ((<ghil-quote>))
- ((<ghil-quasiquote> exp)
- (let qlp ((x exp))
- (cond ((list? x) (for-each qlp x))
- ((pair? x) (qlp (car x)) (qlp (cdr x)))
- ((record? x)
- (record-case x
- ((<ghil-unquote> exp) (lp exp))
- ((<ghil-unquote-splicing> exp) (lp exp)))))))
- ((<ghil-unquote> exp)
- (lp exp))
- ((<ghil-unquote-splicing> exp)
- (lp exp))
- ((<ghil-reified-env>))
- ((<ghil-set> val)
- (lp val))
- ((<ghil-ref>))
- ((<ghil-define> val)
- (lp val))
- ((<ghil-if> test then else)
- (lp test) (lp then) (lp else))
- ((<ghil-and> exps)
- (for-each lp exps))
- ((<ghil-or> exps)
- (for-each lp exps))
- ((<ghil-begin> exps)
- (for-each lp exps))
- ((<ghil-bind> vars vals body)
- (for-each allocate! vars)
- (for-each lp vals)
- (lp body)
- (for-each deallocate! vars))
- ((<ghil-mv-bind> vars producer body)
- (lp producer)
- (for-each allocate! vars)
- (lp body)
- (for-each deallocate! vars))
- ((<ghil-inline> args)
- (for-each lp args))
- ((<ghil-call> proc args)
- (lp proc)
- (for-each lp args))
- ((<ghil-lambda>))
- ((<ghil-mv-call> producer consumer)
- (lp producer)
- (lp consumer))
- ((<ghil-values> values)
- (for-each lp values))
- ((<ghil-values*> values)
- (for-each lp values))))
- nlocs))
diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm
deleted file mode 100644
index f2bc19b61..000000000
--- a/module/language/ghil/spec.scm
+++ /dev/null
@@ -1,62 +0,0 @@
-;;; Guile High Intermediate Language
-
-;; 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 ghil spec)
- #:use-module (system base language)
- #:use-module (language glil)
- #:use-module (language ghil)
- #:use-module (language ghil compile-glil)
- #:export (ghil))
-
-(define (write-ghil exp . port)
- (apply write (unparse-ghil exp) port))
-
-(define (parse x)
- (call-with-ghil-environment (make-ghil-toplevel-env (current-module)) '()
- (lambda (env vars)
- (make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
-
-(define (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 0777073f6..1c465415f 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -24,9 +24,20 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:export
(<glil-program> make-glil-program glil-program?
- glil-program-nargs glil-program-nrest glil-program-nlocs
glil-program-meta glil-program-body
+ <glil-std-prelude> make-glil-std-prelude glil-std-prelude?
+ glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label
+
+ <glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
+ glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest
+ glil-opt-prelude-nlocs glil-opt-prelude-else-label
+
+ <glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
+ glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
+ glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest
+ glil-kw-prelude-nlocs glil-kw-prelude-else-label
+
<glil-bind> make-glil-bind glil-bind?
glil-bind-vars
@@ -71,7 +82,10 @@
(define-type (<glil> #:printer print-glil)
;; Meta operations
- (<glil-program> nargs nrest nlocs meta body)
+ (<glil-program> meta body)
+ (<glil-std-prelude> nreq nlocs else-label)
+ (<glil-opt-prelude> nreq nopt rest nlocs else-label)
+ (<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
(<glil-unbind>)
@@ -93,8 +107,14 @@
(define (parse-glil x)
(pmatch x
- ((program ,nargs ,nrest ,nlocs ,meta . ,body)
- (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
+ ((program ,meta . ,body)
+ (make-glil-program meta (map parse-glil body)))
+ ((std-prelude ,nreq ,nlocs ,else-label)
+ (make-glil-std-prelude nreq nlocs else-label))
+ ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)
+ (make-glil-opt-prelude nreq nopt rest nlocs else-label))
+ ((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)
+ (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs else-label))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind))
@@ -105,7 +125,7 @@
((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-glil-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))
@@ -114,8 +134,14 @@
(define (unparse-glil glil)
(record-case glil
;; meta
- ((<glil-program> nargs nrest nlocs meta body)
- `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
+ ((<glil-program> meta body)
+ `(program ,meta ,@(map unparse-glil body)))
+ ((<glil-std-prelude> nreq nlocs else-label)
+ `(std-prelude ,nreq ,nlocs ,else-label))
+ ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
+ `(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label))
+ ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
+ `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind))
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index 121d9db9f..490d1a4a5 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -68,13 +68,13 @@
(else
(lp (cdr in) out filename)))))))
-(define (make-meta bindings sources tail)
+(define (make-meta bindings sources arities tail)
(if (and (null? bindings) (null? sources) (null? tail))
#f
(compile-assembly
- (make-glil-program 0 0 0 '()
+ (make-glil-program '()
(list
- (make-glil-const `(,bindings ,sources ,@tail))
+ (make-glil-const `(,bindings ,sources ,arities ,@tail))
(make-glil-call 'return 1))))))
;; A functional stack of names of live variables.
@@ -125,27 +125,51 @@
(assoc-ref-or-acons alist x
(lambda (x alist)
(+ (length alist) *module*))))
+(define (make-object-table objects)
+ (and (not (null? objects))
+ (list->vector (cons #f objects))))
+
+;; A functional arities thingamajiggy.
+;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
+(define (open-arity addr nreq nopt rest kw arities)
+ (cons
+ (cond
+ (kw (list addr nreq nopt rest kw))
+ (rest (list addr nreq nopt rest))
+ (nopt (list addr nreq nopt))
+ (nreq (list addr nreq))
+ (else (list addr)))
+ arities))
+(define (close-arity addr arities)
+ (pmatch arities
+ (() '())
+ (((,start . ,tail) . ,rest)
+ `((,start ,addr . ,tail) . ,rest))
+ (else (error "bad arities" arities))))
+(define (begin-arity end start nreq nopt rest kw arities)
+ (open-arity start nreq nopt rest kw (close-arity end arities)))
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil #t '(()) '() '() #f -1)
+ (glil->assembly glil #t '(()) '() '() #f '() -1)
(car code)))
-(define (make-object-table objects)
- (and (not (null? objects))
- (list->vector (cons #f objects))))
(define (glil->assembly glil toplevel? bindings
- source-alist label-alist object-alist addr)
+ source-alist label-alist object-alist arities addr)
(define (emit-code x)
- (values x bindings source-alist label-alist object-alist))
+ (values x bindings source-alist label-alist object-alist arities))
(define (emit-code/object x object-alist)
- (values x bindings source-alist label-alist object-alist))
-
+ (values x bindings source-alist label-alist object-alist arities))
+ (define (emit-code/arity x nreq nopt rest kw)
+ (values x bindings source-alist label-alist object-alist
+ (begin-arity addr (addr+ addr x) nreq nopt rest kw arities)))
+
(record-case glil
- ((<glil-program> nargs nrest nlocs meta body)
+ ((<glil-program> meta body)
(define (process-body)
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
- (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+ (label-alist '()) (object-alist (if toplevel? #f '()))
+ (arities '()) (addr 0))
(cond
((null? body)
(values (reverse code)
@@ -153,20 +177,23 @@
(limn-sources (reverse! source-alist))
(reverse label-alist)
(and object-alist (map car (reverse object-alist)))
+ (reverse (close-arity addr arities))
addr))
(else
- (receive (subcode bindings source-alist label-alist object-alist)
+ (receive (subcode bindings source-alist label-alist object-alist
+ arities)
(glil->assembly (car body) #f bindings
- source-alist label-alist object-alist addr)
+ source-alist label-alist object-alist
+ arities addr)
(lp (cdr body) (append (reverse subcode) code)
- bindings source-alist label-alist object-alist
+ bindings source-alist label-alist object-alist arities
(addr+ addr subcode)))))))
- (receive (code bindings sources labels objects len)
+ (receive (code bindings sources labels objects arities len)
(process-body)
- (let* ((meta (make-meta bindings sources meta))
+ (let* ((meta (make-meta bindings sources arities meta))
(meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
- (prog `(load-program ,nargs ,nrest ,nlocs ,labels
+ (prog `(load-program ,labels
,(+ len meta-pad)
,meta
,@code
@@ -200,33 +227,132 @@
`(,@table-code
,@(align-program prog (addr+ addr table-code)))))))))))))
+ ((<glil-std-prelude> nreq nlocs else-label)
+ (emit-code/arity
+ `(,(if else-label
+ `(br-if-nargs-ne ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,else-label)
+ `(assert-nargs-ee ,(quotient nreq 256)
+ ,(modulo nreq 256)))
+ (reserve-locals ,(quotient nlocs 256)
+ ,(modulo nlocs 256)))
+ nreq #f #f #f))
+
+ ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
+ (let ((bind-required
+ (if else-label
+ `((br-if-nargs-lt ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,else-label))
+ `((assert-nargs-ge ,(quotient nreq 256)
+ ,(modulo nreq 256)))))
+ (bind-optionals
+ (if (zero? nopt)
+ '()
+ `((bind-optionals ,(quotient (+ nopt nreq) 256)
+ ,(modulo (+ nreq nopt) 256)))))
+ (bind-rest
+ (cond
+ (rest
+ `((push-rest ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256))))
+ (else
+ (if else-label
+ `((br-if-nargs-gt ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256)
+ ,else-label))
+ `((assert-nargs-ee ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256))))))))
+ (emit-code/arity
+ `(,@bind-required
+ ,@bind-optionals
+ ,@bind-rest
+ (reserve-locals ,(quotient nlocs 256)
+ ,(modulo nlocs 256)))
+ nreq nopt rest #f)))
+
+ ((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
+ (receive (kw-idx object-alist)
+ (object-index-and-alist kw object-alist)
+ (let* ((bind-required
+ (if else-label
+ `((br-if-nargs-lt ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,else-label))
+ `((assert-nargs-ge ,(quotient nreq 256)
+ ,(modulo nreq 256)))))
+ (ntotal (apply max (+ nreq nopt) (map 1+ (map cdr kw))))
+ (bind-optionals-and-shuffle
+ `((bind-optionals/shuffle
+ ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,(quotient (+ nreq nopt) 256)
+ ,(modulo (+ nreq nopt) 256)
+ ,(quotient ntotal 256)
+ ,(modulo ntotal 256))))
+ (bind-kw
+ ;; when this code gets called, all optionals are filled
+ ;; in, space has been made for kwargs, and the kwargs
+ ;; themselves have been shuffled above the slots for all
+ ;; req/opt/kwargs locals.
+ `((bind-kwargs
+ ,(quotient kw-idx 256)
+ ,(modulo kw-idx 256)
+ ,(quotient ntotal 256)
+ ,(modulo ntotal 256)
+ ,(logior (if rest 2 0)
+ (if allow-other-keys? 1 0)))))
+ (bind-rest
+ (if rest
+ `((bind-rest ,(quotient ntotal 256)
+ ,(modulo ntotal 256)
+ ,(quotient rest 256)
+ ,(modulo rest 256)))
+ '())))
+
+ (let ((code `(,@bind-required
+ ,@bind-optionals-and-shuffle
+ ,@bind-kw
+ ,@bind-rest
+ (reserve-locals ,(quotient nlocs 256)
+ ,(modulo nlocs 256)))))
+ (values code bindings source-alist label-alist object-alist
+ (begin-arity addr (addr+ addr code) nreq nopt rest
+ (and kw (cons allow-other-keys? kw))
+ arities))))))
+
((<glil-bind> vars)
(values '()
(open-binding bindings vars addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
(open-binding bindings vars addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-unbind>)
(values '()
(close-binding bindings addr)
source-alist
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-source> props)
(values '()
bindings
(acons addr props source-alist)
label-alist
- object-alist))
+ object-alist
+ arities))
((<glil-void>)
(emit-code '((void))))
@@ -261,9 +387,13 @@
((box) `((box ,index)))
((empty-box) `((empty-box ,index)))
((fix) `((fix-closure 0 ,index)))
+ ((bound?) (if boxed?
+ `((local-ref ,index)
+ (variable-bound?))
+ `((local-bound? ,index))))
(else (error "what" op)))
- (let ((a (quotient i 256))
- (b (modulo i 256)))
+ (let ((a (quotient index 256))
+ (b (modulo index 256)))
`((,(case op
((ref)
(if boxed?
@@ -284,6 +414,11 @@
(long-local-set ,a ,b)))
((fix)
`((fix-closure ,a ,b)))
+ ((bound?)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-bound?))
+ `((long-local-bound? ,a ,b))))
(else (error "what" op)))
,index))))
`((,(case op
@@ -351,7 +486,8 @@
bindings
source-alist
(acons label (addr+ addr code) label-alist)
- object-alist)))
+ object-alist
+ arities)))
((<glil-branch> inst label)
(emit-code `((,inst ,label))))
diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm
index 3cb887d44..937a67858 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -31,9 +31,8 @@
(define (decompile-toplevel x)
(pmatch x
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
- (decompile-load-program nargs nrest nlocs
- (decompile-meta meta)
+ ((load-program ,labels ,len ,meta . ,body)
+ (decompile-load-program (decompile-meta meta)
body labels #f))
(else
(error "invalid assembly" x))))
@@ -56,7 +55,7 @@
((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
(else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
-(define (decompile-load-program nargs nrest nlocs meta body labels
+(define (decompile-load-program meta body labels
objects)
(let ((glil-labels (sort (map (lambda (x)
(cons (cdr x) (make-glil-label (car x))))
@@ -100,7 +99,7 @@
(cond
((null? in)
(or (null? stack) (error "leftover stack insts" stack body))
- (make-glil-program nargs nrest nlocs props (reverse out) #f))
+ (make-glil-program props (reverse out)))
((pop-bindings! pos)
=> (lambda (bindings)
(lp in stack
@@ -123,9 +122,9 @@
(lp (cdr in) stack out (1+ pos)))
((make-false)
(lp (cdr in) (cons #f stack) out (1+ pos)))
- ((load-program ,a ,b ,c ,d ,labels ,sublen ,meta . ,body)
+ ((load-program ,labels ,sublen ,meta . ,body)
(lp (cdr in)
- (cons (decompile-load-program a b c d (decompile-meta meta)
+ (cons (decompile-load-program (decompile-meta meta)
body labels (car stack))
(cdr stack))
out
diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm
index d5291a211..7733d7bbe 100644
--- a/module/language/glil/spec.scm
+++ b/module/language/glil/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; 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
@@ -34,7 +34,7 @@
(define-language glil
#:title "Guile Lowlevel Intermediate Language (GLIL)"
#:version "0.3"
- #:reader read
+ #:reader (lambda (port env) (read port))
#:printer write-glil
#:parser parse-glil
#:compilers `((assembly . ,compile-asm))
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index 4cb600f1d..9837c5c1c 100644
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -22,25 +22,17 @@
#:use-module (system base language)
#:use-module (system vm objcode)
#:use-module (system vm program)
- #:export (objcode make-objcode-env))
-
-(define (make-objcode-env module externals)
- (cons module externals))
-
-(define (objcode-env-module env)
- (if env (car env) (current-module)))
-
-(define (objcode-env-externals env)
- (and env (vector? (cdr env)) (cdr env)))
+ #:export (objcode))
(define (objcode->value x e opts)
- (let ((thunk (make-program x #f (objcode-env-externals e))))
- (if e
+ (let ((thunk (make-program x #f #f)))
+ (if (eq? e (current-module))
+ ;; save a cons in this case
+ (values (thunk) e e)
(save-module-excursion
(lambda ()
- (set-current-module (objcode-env-module e))
- (values (thunk) #f e)))
- (values (thunk) #f e))))
+ (set-current-module e)
+ (values (thunk) e 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
@@ -68,8 +60,7 @@
(meta (program-meta x))
(free-vars (program-free-variables x))
(binds (program-bindings x))
- (srcs (program-sources x))
- (nargs (arity:nargs (program-arity x))))
+ (srcs (program-sources x)))
(let ((blocs (and binds (collapse-locals binds))))
(values (program-objcode x)
`((objects . ,objs)
diff --git a/module/language/r5rs/core.il b/module/language/r5rs/core.il
deleted file mode 100644
index c614a6fe2..000000000
--- a/module/language/r5rs/core.il
+++ /dev/null
@@ -1,324 +0,0 @@
-;;; R5RS core environment
-
-;; 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:
-
-;; Non standard procedures
-
-(@define void (@lambda () (@void)))
-
-;; 6. Standard procedures
-
-;;; 6.1 Equivalence predicates
-
-(@define eq? (@lambda (x y) (@eq? x y)))
-(@define eqv? (@ Core::eqv?))
-(@define equal? (@ Core::equal?))
-
-;;; 6.2 Numbers
-
-(@define number? (@ Core::number?))
-(@define complex? (@ Core::complex?))
-(@define real? (@ Core::real?))
-(@define rational? (@ Core::rational?))
-(@define integer? (@ Core::integer?))
-
-(@define exact? (@ Core::exact?))
-(@define inexact? (@ Core::inexact?))
-
-(@define = (@ Core::=))
-(@define < (@ Core::<))
-(@define > (@ Core::>))
-(@define <= (@ Core::<=))
-(@define >= (@ Core::>=))
-
-(@define zero? (@ Core::zero?))
-(@define positive? (@ Core::positive?))
-(@define negative? (@ Core::negative?))
-(@define odd? (@ Core::odd?))
-(@define even? (@ Core::even?))
-
-(@define max (@ Core::max))
-(@define min (@ Core::min))
-
-(@define + (@ Core::+))
-(@define * (@ Core::*))
-(@define - (@ Core::-))
-(@define / (@ Core::/))
-
-(@define abs (@ Core::abs))
-
-(@define quotient (@ Core::quotient))
-(@define remainder (@ Core::remainder))
-(@define modulo (@ Core::modulo))
-
-(@define gcd (@ Core::gcd))
-(@define lcm (@ Core::lcm))
-
-;; (@define numerator (@ Core::numerator))
-;; (@define denominator (@ Core::denominator))
-
-(@define floor (@ Core::floor))
-(@define ceiling (@ Core::ceiling))
-(@define truncate (@ Core::truncate))
-(@define round (@ Core::round))
-
-;; (@define rationalize (@ Core::rationalize))
-
-(@define exp (@ Core::exp))
-(@define log (@ Core::log))
-(@define sin (@ Core::sin))
-(@define cos (@ Core::cos))
-(@define tan (@ Core::tan))
-(@define asin (@ Core::asin))
-(@define acos (@ Core::acos))
-(@define atan (@ Core::atan))
-
-(@define sqrt (@ Core::sqrt))
-(@define expt (@ Core::expt))
-
-(@define make-rectangular (@ Core::make-rectangular))
-(@define make-polar (@ Core::make-polar))
-(@define real-part (@ Core::real-part))
-(@define imag-part (@ Core::imag-part))
-(@define magnitude (@ Core::magnitude))
-(@define angle (@ Core::angle))
-
-(@define exact->inexact (@ Core::exact->inexact))
-(@define inexact->exact (@ Core::inexact->exact))
-
-(@define number->string (@ Core::number->string))
-(@define string->number (@ Core::string->number))
-
-;;; 6.3 Other data types
-
-;;;; 6.3.1 Booleans
-
-(@define not (@lambda (x) (@not x)))
-(@define boolean? (@ Core::boolean?))
-
-;;;; 6.3.2 Pairs and lists
-
-(@define pair? (@lambda (x) (@pair? x)))
-(@define cons (@lambda (x y) (@cons x y)))
-
-(@define car (@lambda (x) (@car x)))
-(@define cdr (@lambda (x) (@cdr x)))
-(@define set-car! (@ Core::set-car!))
-(@define set-cdr! (@ Core::set-cdr!))
-
-(@define caar (@lambda (x) (@caar x)))
-(@define cadr (@lambda (x) (@cadr x)))
-(@define cdar (@lambda (x) (@cdar x)))
-(@define cddr (@lambda (x) (@cddr x)))
-(@define caaar (@lambda (x) (@caaar x)))
-(@define caadr (@lambda (x) (@caadr x)))
-(@define cadar (@lambda (x) (@cadar x)))
-(@define caddr (@lambda (x) (@caddr x)))
-(@define cdaar (@lambda (x) (@cdaar x)))
-(@define cdadr (@lambda (x) (@cdadr x)))
-(@define cddar (@lambda (x) (@cddar x)))
-(@define cdddr (@lambda (x) (@cdddr x)))
-(@define caaaar (@lambda (x) (@caaaar x)))
-(@define caaadr (@lambda (x) (@caaadr x)))
-(@define caadar (@lambda (x) (@caadar x)))
-(@define caaddr (@lambda (x) (@caaddr x)))
-(@define cadaar (@lambda (x) (@cadaar x)))
-(@define cadadr (@lambda (x) (@cadadr x)))
-(@define caddar (@lambda (x) (@caddar x)))
-(@define cadddr (@lambda (x) (@cadddr x)))
-(@define cdaaar (@lambda (x) (@cdaaar x)))
-(@define cdaadr (@lambda (x) (@cdaadr x)))
-(@define cdadar (@lambda (x) (@cdadar x)))
-(@define cdaddr (@lambda (x) (@cdaddr x)))
-(@define cddaar (@lambda (x) (@cddaar x)))
-(@define cddadr (@lambda (x) (@cddadr x)))
-(@define cdddar (@lambda (x) (@cdddar x)))
-(@define cddddr (@lambda (x) (@cddddr x)))
-
-(@define null? (@lambda (x) (@null? x)))
-(@define list? (@lambda (x) (@list? x)))
-
-(@define list (@lambda x x))
-
-(@define length (@ Core::length))
-(@define append (@ Core::append))
-(@define reverse (@ Core::reverse))
-(@define list-tail (@ Core::list-tail))
-(@define list-ref (@ Core::list-ref))
-
-(@define memq (@ Core::memq))
-(@define memv (@ Core::memv))
-(@define member (@ Core::member))
-
-(@define assq (@ Core::assq))
-(@define assv (@ Core::assv))
-(@define assoc (@ Core::assoc))
-
-;;;; 6.3.3 Symbols
-
-(@define symbol? (@ Core::symbol?))
-(@define symbol->string (@ Core::symbol->string))
-(@define string->symbol (@ Core::string->symbol))
-
-;;;; 6.3.4 Characters
-
-(@define char? (@ Core::char?))
-(@define char=? (@ Core::char=?))
-(@define char<? (@ Core::char<?))
-(@define char>? (@ Core::char>?))
-(@define char<=? (@ Core::char<=?))
-(@define char>=? (@ Core::char>=?))
-(@define char-ci=? (@ Core::char-ci=?))
-(@define char-ci<? (@ Core::char-ci<?))
-(@define char-ci>? (@ Core::char-ci>?))
-(@define char-ci<=? (@ Core::char-ci<=?))
-(@define char-ci>=? (@ Core::char-ci>=?))
-(@define char-alphabetic? (@ Core::char-alphabetic?))
-(@define char-numeric? (@ Core::char-numeric?))
-(@define char-whitespace? (@ Core::char-whitespace?))
-(@define char-upper-case? (@ Core::char-upper-case?))
-(@define char-lower-case? (@ Core::char-lower-case?))
-(@define char->integer (@ Core::char->integer))
-(@define integer->char (@ Core::integer->char))
-(@define char-upcase (@ Core::char-upcase))
-(@define char-downcase (@ Core::char-downcase))
-
-;;;; 6.3.5 Strings
-
-(@define string? (@ Core::string?))
-(@define make-string (@ Core::make-string))
-(@define string (@ Core::string))
-(@define string-length (@ Core::string-length))
-(@define string-ref (@ Core::string-ref))
-(@define string-set! (@ Core::string-set!))
-
-(@define string=? (@ Core::string=?))
-(@define string-ci=? (@ Core::string-ci=?))
-(@define string<? (@ Core::string<?))
-(@define string>? (@ Core::string>?))
-(@define string<=? (@ Core::string<=?))
-(@define string>=? (@ Core::string>=?))
-(@define string-ci<? (@ Core::string-ci<?))
-(@define string-ci>? (@ Core::string-ci>?))
-(@define string-ci<=? (@ Core::string-ci<=?))
-(@define string-ci>=? (@ Core::string-ci>=?))
-
-(@define substring (@ Core::substring))
-(@define string-append (@ Core::string-append))
-(@define string->list (@ Core::string->list))
-(@define list->string (@ Core::list->string))
-(@define string-copy (@ Core::string-copy))
-(@define string-fill! (@ Core::string-fill!))
-
-;;;; 6.3.6 Vectors
-
-(@define vector? (@ Core::vector?))
-(@define make-vector (@ Core::make-vector))
-(@define vector (@ Core::vector))
-(@define vector-length (@ Core::vector-length))
-(@define vector-ref (@ Core::vector-ref))
-(@define vector-set! (@ Core::vector-set!))
-(@define vector->list (@ Core::vector->list))
-(@define list->vector (@ Core::list->vector))
-(@define vector-fill! (@ Core::vector-fill!))
-
-;;; 6.4 Control features
-
-(@define procedure? (@ Core::procedure?))
-(@define apply (@ Core::apply))
-(@define map (@ Core::map))
-(@define for-each (@ Core::for-each))
-(@define force (@ Core::force))
-
-(@define call-with-current-continuation (@ Core::call-with-current-continuation))
-(@define values (@ Core::values))
-(@define call-with-values (@ Core::call-with-values))
-(@define dynamic-wind (@ Core::dynamic-wind))
-
-;;; 6.5 Eval
-
-(@define eval
- (@let ((l (@ Language::r5rs::spec::r5rs)))
- (@lambda (x e)
- (((@ System::Base::language::compile-in) x e l)))))
-
-;; (@define scheme-report-environment
-;; (@lambda (version)
-;; (@if (@= version 5)
-;; (@ Language::R5RS::Core)
-;; (@error "Unsupported environment version" version))))
-;;
-;; (@define null-environment
-;; (@lambda (version)
-;; (@if (@= version 5)
-;; (@ Language::R5RS::Null)
-;; (@error "Unsupported environment version" version))))
-
-(@define interaction-environment (@lambda () (@current-module)))
-
-;;; 6.6 Input and output
-
-;;;; 6.6.1 Ports
-
-(@define call-with-input-file (@ Core::call-with-input-file))
-(@define call-with-output-file (@ Core::call-with-output-file))
-
-(@define input-port? (@ Core::input-port?))
-(@define output-port? (@ Core::output-port?))
-(@define current-input-port (@ Core::current-input-port))
-(@define current-output-port (@ Core::current-output-port))
-
-(@define with-input-from-file (@ Core::with-input-from-file))
-(@define with-output-to-file (@ Core::with-output-to-file))
-
-(@define open-input-file (@ Core::open-input-file))
-(@define open-output-file (@ Core::open-output-file))
-(@define close-input-port (@ Core::close-input-port))
-(@define close-output-port (@ Core::close-output-port))
-
-;;;; 6.6.2 Input
-
-(@define read (@ Core::read))
-(@define read-char (@ Core::read-char))
-(@define peek-char (@ Core::peek-char))
-(@define eof-object? (@ Core::eof-object?))
-(@define char-ready? (@ Core::char-ready?))
-
-;;;; 6.6.3 Output
-
-(@define write (@ Core::write))
-(@define display (@ Core::display))
-(@define newline (@ Core::newline))
-(@define write-char (@ Core::write-char))
-
-;;;; 6.6.4 System interface
-
-(@define load
- (@lambda (file)
- (call-with-input-file file
- (@lambda (port)
- (@let ((loop (@lambda (x)
- (@if (@not (eof-object? x))
- (@begin
- (eval x (interaction-environment))
- (loop (read port)))))))
- (loop (read port)))))))
-
-;; transcript-on
-;; transcript-off
diff --git a/module/language/r5rs/expand.scm b/module/language/r5rs/expand.scm
deleted file mode 100644
index e8910ae1b..000000000
--- a/module/language/r5rs/expand.scm
+++ /dev/null
@@ -1,80 +0,0 @@
-;;; R5RS syntax expander
-
-;; 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 r5rs expand)
- #:export (expand void
- identifier? free-identifier=? bound-identifier=?
- generate-temporaries datum->syntax-object syntax-object->datum))
-
-(define sc-expand #f)
-(define $sc-put-cte #f)
-(define $syntax-dispatch #f)
-(define syntax-rules #f)
-(define syntax-error #f)
-(define identifier? #f)
-(define free-identifier=? #f)
-(define bound-identifier=? #f)
-(define generate-temporaries #f)
-(define datum->syntax-object #f)
-(define syntax-object->datum #f)
-
-(define void (lambda () (if #f #f)))
-
-(define andmap
- (lambda (f first . rest)
- (or (null? first)
- (if (null? rest)
- (let andmap ((first first))
- (let ((x (car first)) (first (cdr first)))
- (if (null? first)
- (f x)
- (and (f x) (andmap first)))))
- (let andmap ((first first) (rest rest))
- (let ((x (car first))
- (xr (map car rest))
- (first (cdr first))
- (rest (map cdr rest)))
- (if (null? first)
- (apply f (cons x xr))
- (and (apply f (cons x xr)) (andmap first rest)))))))))
-
-(define ormap
- (lambda (proc list1)
- (and (not (null? list1))
- (or (proc (car list1)) (ormap proc (cdr list1))))))
-
-(define putprop set-symbol-property!)
-(define getprop symbol-property)
-(define remprop symbol-property-remove!)
-
-(define syncase-module (current-module))
-(define guile-eval eval)
-(define (eval x)
- (if (and (pair? x) (equal? (car x) "noexpand"))
- (cdr x)
- (guile-eval x syncase-module)))
-
-(define guile-error error)
-(define (error who format-string why what)
- (guile-error why what))
-
-(load "psyntax.pp")
-
-(define expand sc-expand)
diff --git a/module/language/r5rs/psyntax.pp b/module/language/r5rs/psyntax.pp
deleted file mode 100644
index ef9ca0aa9..000000000
--- a/module/language/r5rs/psyntax.pp
+++ /dev/null
@@ -1,14552 +0,0 @@
-;;; psyntax.pp
-;;; automatically generated from psyntax.ss
-;;; Wed Aug 30 12:24:52 EST 2000
-;;; see copyright notice in psyntax.ss
-
-((lambda ()
- (letrec ((g452
- (lambda (g1823)
- ((letrec ((g1824
- (lambda (g1827 g1825 g1826)
- (if (pair? g1827)
- (g1824
- (cdr g1827)
- (cons (g393 (car g1827) g1826) g1825)
- g1826)
- (if (g256 g1827)
- (cons (g393 g1827 g1826) g1825)
- (if (null? g1827)
- g1825
- (if (g204 g1827)
- (g1824
- (g205 g1827)
- g1825
- (g371 g1826 (g206 g1827)))
- (if (g90 g1827)
- (g1824
- (annotation-expression
- g1827)
- g1825
- g1826)
- (cons g1827 g1825)))))))))
- g1824)
- g1823
- '()
- '(()))))
- (g451
- (lambda (g833)
- ((lambda (g834) (if (g90 g834) (gensym) (gensym)))
- (if (g204 g833) (g205 g833) g833))))
- (g450
- (lambda (g1820 g1819)
- (g449 g1820
- g1819
- (lambda (g1821)
- (if ((lambda (g1822)
- (if g1822
- g1822
- (if (pair? g1821)
- (g90 (car g1821))
- '#f)))
- (g90 g1821))
- (g448 g1821 '#f)
- g1821)))))
- (g449
- (lambda (g837 g835 g836)
- (if (memq 'top (g264 g835))
- (g836 g837)
- ((letrec ((g838
- (lambda (g839)
- (if (g204 g839)
- (g449 (g205 g839) (g206 g839) g836)
- (if (pair? g839)
- ((lambda (g841 g840)
- (if (if (eq? g841 (car g839))
- (eq? g840 (cdr g839))
- '#f)
- g839
- (cons g841 g840)))
- (g838 (car g839))
- (g838 (cdr g839)))
- (if (vector? g839)
- ((lambda (g842)
- ((lambda (g843)
- (if (andmap
- eq?
- g842
- g843)
- g839
- (list->vector g843)))
- (map g838 g842)))
- (vector->list g839))
- g839))))))
- g838)
- g837))))
- (g448
- (lambda (g1813 g1812)
- (if (pair? g1813)
- ((lambda (g1814)
- (begin (if g1812
- (set-annotation-stripped! g1812 g1814)
- (void))
- (set-car! g1814 (g448 (car g1813) '#f))
- (set-cdr! g1814 (g448 (cdr g1813) '#f))
- g1814))
- (cons '#f '#f))
- (if (g90 g1813)
- ((lambda (g1815)
- (if g1815
- g1815
- (g448 (annotation-expression g1813) g1813)))
- (annotation-stripped g1813))
- (if (vector? g1813)
- ((lambda (g1816)
- (begin (if g1812
- (set-annotation-stripped!
- g1812
- g1816)
- (void))
- ((letrec ((g1817
- (lambda (g1818)
- (if (not (< g1818 '0))
- (begin (vector-set!
- g1816
- g1818
- (g448 (vector-ref
- g1813
- g1818)
- '#f))
- (g1817
- (- g1818
- '1)))
- (void)))))
- g1817)
- (- (vector-length g1813) '1))
- g1816))
- (make-vector (vector-length g1813)))
- g1813)))))
- (g447
- (lambda (g844)
- (if (g255 g844)
- (g378 g844
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage ((import-token . *top*)) () ())
- #(ribcage ((import-token . *top*)) () ()))))
- '#f)))
- (g446 (lambda () (list 'void)))
- (g445
- (lambda (g850 g845 g849 g846 g848 g847)
- ((lambda (g851)
- ((lambda (g852)
- (if g852
- (apply
- (lambda (g857 g853 g856 g854 g855)
- ((lambda (g858)
- (if (not (g389 g858))
- (g391 (map (lambda (g859)
- (g393 g859 g846))
- g858)
- (g394 g845 g846 g848)
- '"keyword")
- ((lambda (g860)
- ((lambda (g861)
- (g847 (cons g854 g855)
- (g247 g860
- ((lambda (g863 g862)
- (map (lambda (g865)
- (g231 'deferred
- (g432 g865
- g862
- g863)))
- g856))
- (if g850 g861 g846)
- (g249 g849))
- g849)
- g861
- g848))
- (g368 g858 g860 g846)))
- (g299 g858))))
- g853))
- g852)
- ((lambda (g868)
- (syntax-error (g394 g845 g846 g848)))
- g851)))
- ($syntax-dispatch
- g851
- '(any #(each (any any)) any . each-any))))
- g845)))
- (g444
- (lambda (g1789 g1785 g1788 g1786 g1787)
- ((lambda (g1790)
- ((lambda (g1791)
- (if g1791
- (apply
- (lambda (g1794 g1792 g1793)
- ((lambda (g1795)
- (if (not (g389 g1795))
- (syntax-error
- g1789
- '"invalid parameter list in")
- ((lambda (g1797 g1796)
- (g1787
- g1796
- (g437 (cons g1792 g1793)
- g1789
- (g248 g1797 g1796 g1788)
- (g368 g1795 g1797 g1786))))
- (g299 g1795)
- (map g451 g1795))))
- g1794))
- g1791)
- ((lambda (g1800)
- (if g1800
- (apply
- (lambda (g1803 g1801 g1802)
- ((lambda (g1804)
- (if (not (g389 g1804))
- (syntax-error
- g1789
- '"invalid parameter list in")
- ((lambda (g1806 g1805)
- (g1787
- ((letrec ((g1808
- (lambda (g1810
- g1809)
- (if (null?
- g1810)
- g1809
- (g1808
- (cdr g1810)
- (cons (car g1810)
- g1809))))))
- g1808)
- (cdr g1805)
- (car g1805))
- (g437 (cons g1801 g1802)
- g1789
- (g248 g1806
- g1805
- g1788)
- (g368 g1804
- g1806
- g1786))))
- (g299 g1804)
- (map g451 g1804))))
- (g452 g1803)))
- g1800)
- ((lambda (g1811) (syntax-error g1789))
- g1790)))
- ($syntax-dispatch g1790 '(any any . each-any)))))
- ($syntax-dispatch g1790 '(each-any any . each-any))))
- g1785)))
- (g443
- (lambda (g872 g869 g871 g870)
- ((lambda (g873)
- ((lambda (g874)
- (if (if g874
- (apply
- (lambda (g877 g875 g876) (g256 g875))
- g874)
- '#f)
- (apply
- (lambda (g880 g878 g879) (g870 g878 g879 g869))
- g874)
- ((lambda (g881)
- (syntax-error (g394 g872 g869 g871)))
- g873)))
- ($syntax-dispatch g873 '(any any any))))
- g872)))
- (g442
- (lambda (g1758 g1755 g1757 g1756)
- ((lambda (g1759)
- ((lambda (g1760)
- (if (if g1760
- (apply
- (lambda (g1763 g1761 g1762) (g256 g1761))
- g1760)
- '#f)
- (apply
- (lambda (g1766 g1764 g1765)
- (g1756 g1764 g1765 g1755))
- g1760)
- ((lambda (g1767)
- (if (if g1767
- (apply
- (lambda (g1772
- g1768
- g1771
- g1769
- g1770)
- (if (g256 g1768)
- (g389 (g452 g1771))
- '#f))
- g1767)
- '#f)
- (apply
- (lambda (g1777 g1773 g1776 g1774 g1775)
- (g1756
- (g393 g1773 g1755)
- (cons '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_ name args e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(e w s k)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (g393 (cons g1776
- (cons g1774 g1775))
- g1755))
- '(())))
- g1767)
- ((lambda (g1779)
- (if (if g1779
- (apply
- (lambda (g1781 g1780)
- (g256 g1780))
- g1779)
- '#f)
- (apply
- (lambda (g1783 g1782)
- (g1756
- (g393 g1782 g1755)
- '(#(syntax-object
- void
- ((top)
- #(ribcage
- #(_ name)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(e w s k)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- '(())))
- g1779)
- ((lambda (g1784)
- (syntax-error
- (g394 g1758 g1755 g1757)))
- g1759)))
- ($syntax-dispatch g1759 '(any any)))))
- ($syntax-dispatch
- g1759
- '(any (any . any) any . each-any)))))
- ($syntax-dispatch g1759 '(any any any))))
- g1758)))
- (g441
- (lambda (g885 g882 g884 g883)
- ((lambda (g886)
- ((lambda (g887)
- (if (if g887
- (apply (lambda (g889 g888) (g256 g888)) g887)
- '#f)
- (apply
- (lambda (g891 g890) (g883 (g393 g890 g882)))
- g887)
- ((lambda (g892)
- (syntax-error (g394 g885 g882 g884)))
- g886)))
- ($syntax-dispatch g886 '(any any))))
- g885)))
- (g440
- (lambda (g1723 g1719 g1722 g1720 g1721)
- (letrec ((g1725
- (lambda (g1753 g1751 g1752)
- (g1721
- g1753
- (g1724 g1751)
- (map (lambda (g1754) (g393 g1754 g1720))
- g1752))))
- (g1724
- (lambda (g1745)
- (if (null? g1745)
- '()
- (cons ((lambda (g1746)
- ((lambda (g1747)
- (if g1747
- (apply
- (lambda (g1748)
- (g1724 g1748))
- g1747)
- ((lambda (g1750)
- (if (g256 g1750)
- (g393 g1750 g1720)
- (syntax-error
- (g394 g1723
- g1719
- g1722)
- '"invalid exports list in")))
- g1746)))
- ($syntax-dispatch
- g1746
- 'each-any)))
- (car g1745))
- (g1724 (cdr g1745)))))))
- ((lambda (g1726)
- ((lambda (g1727)
- (if g1727
- (apply
- (lambda (g1730 g1728 g1729)
- (g1725 '#f g1728 g1729))
- g1727)
- ((lambda (g1733)
- (if (if g1733
- (apply
- (lambda (g1737 g1734 g1736 g1735)
- (g256 g1734))
- g1733)
- '#f)
- (apply
- (lambda (g1741 g1738 g1740 g1739)
- (g1725
- (g393 g1738 g1719)
- g1740
- g1739))
- g1733)
- ((lambda (g1744)
- (syntax-error
- (g394 g1723 g1719 g1722)))
- g1726)))
- ($syntax-dispatch
- g1726
- '(any any each-any . each-any)))))
- ($syntax-dispatch g1726 '(any each-any . each-any))))
- g1723))))
- (g439
- (lambda (g894 g893)
- ((lambda (g895)
- (if g895
- (g366 g893 g895)
- (g429 (lambda (g896)
- ((lambda (g897)
- (begin (if (not g897)
- (syntax-error
- g896
- '"exported identifier not visible")
- (void))
- (g363 g893 g896 g897)))
- (g376 g896 '(()))))
- (g404 g894))))
- (g405 g894))))
- (g438
- (lambda (g1652 g1648 g1651 g1649 g1650)
- (letrec ((g1653
- (lambda (g1718 g1714 g1717 g1715 g1716)
- (begin (g426 g1648 g1714)
- (g1650 g1718 g1714 g1717 g1715 g1716)))))
- ((letrec ((g1654
- (lambda (g1659 g1655 g1658 g1656 g1657)
- (if (null? g1659)
- (g1653 g1659 g1655 g1658 g1656 g1657)
- ((lambda (g1661 g1660)
- (call-with-values
- (lambda ()
- (g398 g1661
- g1660
- '(())
- '#f
- g1652))
- (lambda (g1666
- g1662
- g1665
- g1663
- g1664)
- ((lambda (g1667)
- (if (memv g1667 '(define-form))
- (g442 g1665
- g1663
- g1664
- (lambda (g1670
- g1668
- g1669)
- ((lambda (g1672
- g1671)
- ((lambda (g1673)
- (begin (g363 g1652
- g1672
- g1671)
- (g424 g1649
- g1671
- (g231 'lexical
- g1673))
- (g1654
- (cdr g1659)
- (cons g1672
- g1655)
- (cons g1673
- g1658)
- (cons (cons g1660
- (g393 g1668
- g1669))
- g1656)
- g1657)))
- (g451 g1672)))
- (g393 g1670 g1669)
- (g297))))
- (if (memv g1667
- '(define-syntax-form))
- (g443 g1665
- g1663
- g1664
- (lambda (g1676
- g1674
- g1675)
- ((lambda (g1679
- g1677
- g1678)
- (begin (g363 g1652
- g1679
- g1677)
- (g424 g1649
- g1677
- (g231 'deferred
- g1678))
- (g1654
- (cdr g1659)
- (cons g1679
- g1655)
- g1658
- g1656
- g1657)))
- (g393 g1676
- g1675)
- (g297)
- (g432 g1674
- (g249 g1660)
- g1675))))
- (if (memv g1667
- '(module-form))
- ((lambda (g1680)
- ((lambda (g1681)
- ((lambda ()
- (g440 g1665
- g1663
- g1664
- g1681
- (lambda (g1684
- g1682
- g1683)
- (g438 g1680
- (g394 g1665
- g1663
- g1664)
- (map (lambda (g1695)
- (cons g1660
- g1695))
- g1683)
- g1649
- (lambda (g1689
- g1685
- g1688
- g1686
- g1687)
- (begin (g425 g1648
- (g401 g1682)
- g1685)
- ((lambda (g1693
- g1690
- g1692
- g1691)
- (if g1684
- ((lambda (g1694)
- (begin (g363 g1652
- g1684
- g1694)
- (g424 g1649
- g1694
- (g231 'module
- g1693))
- (g1654
- (cdr g1659)
- (cons g1684
- g1655)
- g1690
- g1692
- g1691)))
- (g297))
- ((lambda ()
- (begin (g439 g1693
- g1652)
- (g1654
- (cdr g1659)
- (cons g1693
- g1655)
- g1690
- g1692
- g1691))))))
- (g408 g1682)
- (append
- g1688
- g1658)
- (append
- g1686
- g1656)
- (append
- g1657
- g1687
- g1689))))))))))
- (g263 (g264 g1663)
- (cons g1680
- (g265 g1663)))))
- (g304 '()
- '()
- '()))
- (if (memv g1667
- '(import-form))
- (g441 g1665
- g1663
- g1664
- (lambda (g1696)
- ((lambda (g1697)
- ((lambda (g1698)
- ((lambda (g1699)
- (if (memv g1699
- '(module))
- ((lambda (g1700)
- (begin (if g1662
- (g364 g1652
- g1662)
- (void))
- (g439 g1700
- g1652)
- (g1654
- (cdr g1659)
- (cons g1700
- g1655)
- g1658
- g1656
- g1657)))
- (cdr g1698))
- (if (memv g1699
- '(displaced-lexical))
- (g250 g1696)
- (syntax-error
- g1696
- '"import from unknown module"))))
- (car g1698)))
- (g253 g1697
- g1649)))
- (g377 g1696
- '(())))))
- (if (memv g1667
- '(begin-form))
- ((lambda (g1701)
- ((lambda (g1702)
- (if g1702
- (apply
- (lambda (g1704
- g1703)
- (g1654
- ((letrec ((g1705
- (lambda (g1706)
- (if (null?
- g1706)
- (cdr g1659)
- (cons (cons g1660
- (g393 (car g1706)
- g1663))
- (g1705
- (cdr g1706)))))))
- g1705)
- g1703)
- g1655
- g1658
- g1656
- g1657))
- g1702)
- (syntax-error
- g1701)))
- ($syntax-dispatch
- g1701
- '(any .
- each-any))))
- g1665)
- (if (memv g1667
- '(local-syntax-form))
- (g445 g1662
- g1665
- g1660
- g1663
- g1664
- (lambda (g1711
- g1708
- g1710
- g1709)
- (g1654
- ((letrec ((g1712
- (lambda (g1713)
- (if (null?
- g1713)
- (cdr g1659)
- (cons (cons g1708
- (g393 (car g1713)
- g1710))
- (g1712
- (cdr g1713)))))))
- g1712)
- g1711)
- g1655
- g1658
- g1656
- g1657)))
- (g1653
- (cons (cons g1660
- (g394 g1665
- g1663
- g1664))
- (cdr g1659))
- g1655
- g1658
- g1656
- g1657))))))))
- g1666))))
- (cdar g1659)
- (caar g1659))))))
- g1654)
- g1651
- '()
- '()
- '()
- '()))))
- (g437
- (lambda (g901 g898 g900 g899)
- ((lambda (g902)
- ((lambda (g903)
- ((lambda (g904)
- ((lambda (g905)
- ((lambda ()
- (g438 g903
- g898
- g905
- g902
- (lambda (g910 g906 g909 g907 g908)
- (begin (if (null? g910)
- (syntax-error
- g898
- '"no expressions in body")
- (void))
- (g191 '#f
- g909
- (map (lambda (g912)
- (g432 (cdr g912)
- (car g912)
- '(())))
- g907)
- (g190 '#f
- (map (lambda (g911)
- (g432 (cdr g911)
- (car g911)
- '(())))
- (append
- g908
- g910))))))))))
- (map (lambda (g913) (cons g902 (g393 g913 g904)))
- g901)))
- (g263 (g264 g899) (cons g903 (g265 g899)))))
- (g304 '() '() '())))
- (cons '("placeholder" placeholder) g900))))
- (g436
- (lambda (g1635 g1630 g1634 g1631 g1633 g1632)
- (letrec ((g1636
- (lambda (g1640 g1639)
- (if (pair? g1640)
- (cons (g1636 (car g1640) g1639)
- (g1636 (cdr g1640) g1639))
- (if (g204 g1640)
- ((lambda (g1641)
- ((lambda (g1643 g1642)
- (g203 (g205 g1640)
- (if (if (pair? g1643)
- (eq? (car g1643)
- '#f)
- '#f)
- (g263 (cdr g1643)
- (if g1632
- (cons g1632
- (cdr g1642))
- (cdr g1642)))
- (g263 (cons g1639 g1643)
- (if g1632
- (cons g1632
- (cons 'shift
- g1642))
- (cons 'shift
- g1642))))))
- (g264 g1641)
- (g265 g1641)))
- (g206 g1640))
- (if (vector? g1640)
- ((lambda (g1644)
- ((lambda (g1645)
- ((lambda ()
- ((letrec ((g1646
- (lambda (g1647)
- (if (= g1647
- g1644)
- g1645
- (begin (vector-set!
- g1645
- g1647
- (g1636
- (vector-ref
- g1640
- g1647)
- g1639))
- (g1646
- (+ g1647
- '1)))))))
- g1646)
- '0))))
- (make-vector g1644)))
- (vector-length g1640))
- (if (symbol? g1640)
- (syntax-error
- (g394 g1630 g1631 g1633)
- '"encountered raw symbol "
- (format '"~s" g1640)
- '" in output of macro")
- g1640)))))))
- (g1636
- ((lambda (g1637)
- (if (procedure? g1637)
- (g1637
- (lambda (g1638)
- (begin (if (not (identifier? g1638))
- (syntax-error
- g1638
- '"environment argument is not an identifier")
- (void))
- (g253 (g377 g1638 '(())) g1634))))
- g1637))
- (g1635 (g394 g1630 (g349 g1631) g1633)))
- (string '#\m)))))
- (g435
- (lambda (g918 g914 g917 g915 g916)
- ((lambda (g919)
- ((lambda (g920)
- (if (if g920
- (apply
- (lambda (g923 g921 g922) (g256 g921))
- g920)
- '#f)
- (apply
- (lambda (g926 g924 g925)
- ((lambda (g927)
- ((lambda (g928)
- ((lambda (g929)
- (if (memv g929 '(macro!))
- ((lambda (g931 g930)
- (g398 (g436 (g233 g928)
- (list '#(syntax-object
- set!
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(id
- val)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(t)
- #(("m" top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(b)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(n)
- #((top))
- #("i"))
- #(ribcage
- #(_
- id
- val)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e
- r
- w
- s
- rib)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g931
- g930)
- g914
- '(())
- g915
- g916)
- g914
- '(())
- g915
- g916))
- (g393 g924 g917)
- (g393 g925 g917))
- (values
- 'core
- (lambda (g935 g932 g934 g933)
- ((lambda (g937 g936)
- ((lambda (g938)
- ((lambda (g939)
- (if (memv g939
- '(lexical))
- (list 'set!
- (g233 g938)
- g937)
- (if (memv g939
- '(global))
- (list 'set!
- (g233 g938)
- g937)
- (if (memv g939
- '(displaced-lexical))
- (syntax-error
- (g393 g924
- g934)
- '"identifier out of context")
- (syntax-error
- (g394 g935
- g934
- g933))))))
- (g232 g938)))
- (g253 g936 g932)))
- (g432 g925 g932 g934)
- (g377 g924 g934)))
- g918
- g917
- g915)))
- (g232 g928)))
- (g253 g927 g914)))
- (g377 g924 g917)))
- g920)
- ((lambda (g940)
- (syntax-error (g394 g918 g917 g915)))
- g919)))
- ($syntax-dispatch g919 '(any any any))))
- g918)))
- (g434
- (lambda (g1622 g1618 g1621 g1619 g1620)
- ((lambda (g1623)
- ((lambda (g1624)
- (if g1624
- (apply
- (lambda (g1626 g1625)
- (cons g1622
- (map (lambda (g1628)
- (g432 g1628 g1621 g1619))
- g1625)))
- g1624)
- ((lambda (g1629)
- (syntax-error (g394 g1618 g1619 g1620)))
- g1623)))
- ($syntax-dispatch g1623 '(any . each-any))))
- g1618)))
- (g433
- (lambda (g946 g941 g945 g942 g944 g943)
- ((lambda (g947)
- (if (memv g947 '(lexical))
- g941
- (if (memv g947 '(core))
- (g941 g945 g942 g944 g943)
- (if (memv g947 '(lexical-call))
- (g434 g941 g945 g942 g944 g943)
- (if (memv g947 '(constant))
- (list 'quote
- (g450 (g394 g945 g944 g943) '(())))
- (if (memv g947 '(global))
- g941
- (if (memv g947 '(call))
- (g434 (g432 (car g945) g942 g944)
- g945
- g942
- g944
- g943)
- (if (memv g947 '(begin-form))
- ((lambda (g948)
- ((lambda (g949)
- (if g949
- (apply
- (lambda (g952
- g950
- g951)
- (g395 (cons g950
- g951)
- g942
- g944
- g943))
- g949)
- (syntax-error
- g948)))
- ($syntax-dispatch
- g948
- '(any any
- .
- each-any))))
- g945)
- (if (memv g947
- '(local-syntax-form))
- (g445 g941
- g945
- g942
- g944
- g943
- g395)
- (if (memv g947
- '(eval-when-form))
- ((lambda (g954)
- ((lambda (g955)
- (if g955
- (apply
- (lambda (g959
- g956
- g958
- g957)
- ((lambda (g960)
- (if (memq 'eval
- g960)
- (g395 (cons g958
- g957)
- g942
- g944
- g943)
- (g446)))
- (g397 g945
- g956
- g944)))
- g955)
- (syntax-error
- g954)))
- ($syntax-dispatch
- g954
- '(any each-any
- any
- .
- each-any))))
- g945)
- (if (memv g947
- '(define-form
- define-syntax-form
- module-form
- import-form))
- (syntax-error
- (g394 g945
- g944
- g943)
- '"invalid context for definition")
- (if (memv g947
- '(syntax))
- (syntax-error
- (g394 g945
- g944
- g943)
- '"reference to pattern variable outside syntax form")
- (if (memv g947
- '(displaced-lexical))
- (g250 (g394 g945
- g944
- g943))
- (syntax-error
- (g394 g945
- g944
- g943)))))))))))))))
- g946)))
- (g432
- (lambda (g1612 g1610 g1611)
- (call-with-values
- (lambda () (g398 g1612 g1610 g1611 '#f '#f))
- (lambda (g1617 g1613 g1616 g1614 g1615)
- (g433 g1617 g1613 g1616 g1610 g1614 g1615)))))
- (g431
- (lambda (g965 g963 g964)
- ((lambda (g966)
- (if (memv g966 '(c))
- (if (memq 'compile g963)
- ((lambda (g967)
- (begin (g91 g967)
- (if (memq 'load g963) g967 (g446))))
- (g964))
- (if (memq 'load g963) (g964) (g446)))
- (if (memv g966 '(c&e))
- ((lambda (g968) (begin (g91 g968) g968)) (g964))
- (begin (if (memq 'eval g963) (g91 (g964)) (void))
- (g446)))))
- g965)))
- (g430
- (lambda (g1609 g1608)
- (list '$sc-put-cte
- (list 'quote g1609)
- (list 'quote (g231 'do-import g1608)))))
- (g429
- (lambda (g970 g969)
- ((lambda (g971)
- ((letrec ((g972
- (lambda (g973)
- (if (not (= g973 g971))
- (begin (g970 (vector-ref g969 g973))
- (g972 (+ g973 '1)))
- (void)))))
- g972)
- '0))
- (vector-length g969))))
- (g428
- (lambda (g1604 g1603)
- ((letrec ((g1605
- (lambda (g1607 g1606)
- (if (< g1607 '0)
- g1606
- (g1605
- (- g1607 '1)
- (cons (g1604 (vector-ref g1603 g1607))
- g1606))))))
- g1605)
- (- (vector-length g1603) '1)
- '())))
- (g427
- (lambda (g982 g974 g981 g975 g980 g976 g979 g977 g978)
- (letrec ((g985
- (lambda (g1050 g1049)
- ((lambda (g1051)
- (map (lambda (g1052)
- ((lambda (g1053)
- (if (not (g392 g1053 g1051))
- g1052
- (g410 (g412 g1052)
- g1053
- (g414 g1052)
- (append
- (g984 g1053)
- (g415 g1052))
- (g416 g1052))))
- (g413 g1052)))
- g1050))
- (map (lambda (g1054)
- (if (pair? g1054) (car g1054) g1054))
- g1049))))
- (g984
- (lambda (g1043)
- ((letrec ((g1044
- (lambda (g1045)
- (if (null? g1045)
- '()
- (if (if (pair? (car g1045))
- (g388 g1043
- (caar g1045))
- '#f)
- (g401 (cdar g1045))
- (g1044 (cdr g1045)))))))
- g1044)
- g980)))
- (g983
- (lambda (g1048 g1046 g1047)
- (begin (g426 g974 g1046)
- (g425 g974 g976 g1046)
- (g978 g1048 g1047)))))
- ((letrec ((g986
- (lambda (g990 g987 g989 g988)
- (if (null? g990)
- (g983 g989 g987 g988)
- ((lambda (g992 g991)
- (call-with-values
- (lambda ()
- (g398 g992 g991 '(()) '#f g982))
- (lambda (g997 g993 g996 g994 g995)
- ((lambda (g998)
- (if (memv g998 '(define-form))
- (g442 g996
- g994
- g995
- (lambda (g1001
- g999
- g1000)
- ((lambda (g1002)
- ((lambda (g1003)
- ((lambda (g1004)
- ((lambda ()
- (begin (g363 g982
- g1002
- g1003)
- (g986 (cdr g990)
- (cons g1002
- g987)
- (cons (g410 g997
- g1002
- g1003
- g1004
- (cons g991
- (g393 g999
- g1000)))
- g989)
- g988)))))
- (g984 g1002)))
- (g300)))
- (g393 g1001
- g1000))))
- (if (memv g998
- '(define-syntax-form))
- (g443 g996
- g994
- g995
- (lambda (g1007
- g1005
- g1006)
- ((lambda (g1008)
- ((lambda (g1009)
- ((lambda (g1010)
- ((lambda (g1011)
- ((lambda ()
- (begin (g424 g975
- (g302 g1009)
- (cons 'deferred
- g1011))
- (g363 g982
- g1008
- g1009)
- (g986 (cdr g990)
- (cons g1008
- g987)
- (cons (g410 g997
- g1008
- g1009
- g1010
- g1011)
- g989)
- g988)))))
- (g432 g1005
- (g249 g991)
- g1006)))
- (g984 g1008)))
- (g300)))
- (g393 g1007
- g1006))))
- (if (memv g998
- '(module-form))
- ((lambda (g1012)
- ((lambda (g1013)
- ((lambda ()
- (g440 g996
- g994
- g995
- g1013
- (lambda (g1016
- g1014
- g1015)
- (g427 g1012
- (g394 g996
- g994
- g995)
- (map (lambda (g1024)
- (cons g991
- g1024))
- g1015)
- g975
- g1014
- (g401 g1014)
- g979
- g977
- (lambda (g1018
- g1017)
- ((lambda (g1019)
- ((lambda (g1020)
- ((lambda (g1021)
- ((lambda ()
- (if g1016
- ((lambda (g1023
- g1022)
- (begin (g424 g975
- (g302 g1023)
- (g231 'module
- g1019))
- (g363 g982
- g1016
- g1023)
- (g986 (cdr g990)
- (cons g1016
- g987)
- (cons (g410 g997
- g1016
- g1023
- g1022
- g1014)
- g1020)
- g1021)))
- (g300)
- (g984 g1016))
- ((lambda ()
- (begin (g439 g1019
- g982)
- (g986 (cdr g990)
- (cons g1019
- g987)
- g1020
- g1021))))))))
- (append
- g988
- g1017)))
- (append
- (if g1016
- g1018
- (g985 g1018
- g1014))
- g989)))
- (g408 g1014)))))))))
- (g263 (g264 g994)
- (cons g1012
- (g265 g994)))))
- (g304 '()
- '()
- '()))
- (if (memv g998
- '(import-form))
- (g441 g996
- g994
- g995
- (lambda (g1025)
- ((lambda (g1026)
- ((lambda (g1027)
- ((lambda (g1028)
- (if (memv g1028
- '(module))
- ((lambda (g1029)
- (begin (if g993
- (g364 g982
- g993)
- (void))
- (g439 g1029
- g982)
- (g986 (cdr g990)
- (cons g1029
- g987)
- (g985 g989
- (vector->list
- (g404 g1029)))
- g988)))
- (g233 g1027))
- (if (memv g1028
- '(displaced-lexical))
- (g250 g1025)
- (syntax-error
- g1025
- '"import from unknown module"))))
- (g232 g1027)))
- (g253 g1026
- g975)))
- (g377 g1025
- '(())))))
- (if (memv g998
- '(begin-form))
- ((lambda (g1030)
- ((lambda (g1031)
- (if g1031
- (apply
- (lambda (g1033
- g1032)
- (g986 ((letrec ((g1034
- (lambda (g1035)
- (if (null?
- g1035)
- (cdr g990)
- (cons (cons g991
- (g393 (car g1035)
- g994))
- (g1034
- (cdr g1035)))))))
- g1034)
- g1032)
- g987
- g989
- g988))
- g1031)
- (syntax-error
- g1030)))
- ($syntax-dispatch
- g1030
- '(any .
- each-any))))
- g996)
- (if (memv g998
- '(local-syntax-form))
- (g445 g993
- g996
- g991
- g994
- g995
- (lambda (g1040
- g1037
- g1039
- g1038)
- (g986 ((letrec ((g1041
- (lambda (g1042)
- (if (null?
- g1042)
- (cdr g990)
- (cons (cons g1037
- (g393 (car g1042)
- g1039))
- (g1041
- (cdr g1042)))))))
- g1041)
- g1040)
- g987
- g989
- g988)))
- (g983 g989
- g987
- (append
- g988
- (cons (cons g991
- (g394 g996
- g994
- g995))
- (cdr g990)))))))))))
- g997))))
- (cdar g990)
- (caar g990))))))
- g986)
- g981
- '()
- '()
- '()))))
- (g426
- (lambda (g1560 g1559)
- (letrec ((g1564
- (lambda (g1597 g1595 g1596)
- ((lambda (g1598)
- (if g1598
- (if (g367 ((lambda (g1599)
- ((lambda (g1600)
- (if (g90 g1600)
- (annotation-expression
- g1600)
- g1600))
- (if (g204 g1599)
- (g205 g1599)
- g1599)))
- g1597)
- g1598
- (if (symbol? g1597)
- (g264 '((top)))
- (g264 (g206 g1597))))
- (cons g1597 g1596)
- g1596)
- (g1562
- (g404 g1595)
- (lambda (g1602 g1601)
- (if (g1561 g1602 g1597)
- (cons g1602 g1601)
- g1601))
- g1596)))
- (g405 g1595))))
- (g1563
- (lambda (g1575 g1573 g1574)
- (if (g403 g1575)
- (if (g403 g1573)
- (call-with-values
- (lambda ()
- ((lambda (g1581 g1580)
- (if (fx> (vector-length g1581)
- (vector-length g1580))
- (values g1575 g1580)
- (values g1573 g1581)))
- (g404 g1575)
- (g404 g1573)))
- (lambda (g1577 g1576)
- (g1562
- g1576
- (lambda (g1579 g1578)
- (g1564 g1579 g1577 g1578))
- g1574)))
- (g1564 g1573 g1575 g1574))
- (if (g403 g1573)
- (g1564 g1575 g1573 g1574)
- (if (g1561 g1575 g1573)
- (cons g1575 g1574)
- g1574)))))
- (g1562
- (lambda (g1590 g1588 g1589)
- ((lambda (g1591)
- ((letrec ((g1592
- (lambda (g1594 g1593)
- (if (= g1594 g1591)
- g1593
- (g1592
- (+ g1594 '1)
- (g1588
- (vector-ref g1590 g1594)
- g1593))))))
- g1592)
- '0
- g1589))
- (vector-length g1590))))
- (g1561
- (lambda (g1583 g1582)
- (if (symbol? g1583)
- (if (symbol? g1582)
- (eq? g1583 g1582)
- (if (eq? g1583
- ((lambda (g1584)
- ((lambda (g1585)
- (if (g90 g1585)
- (annotation-expression
- g1585)
- g1585))
- (if (g204 g1584)
- (g205 g1584)
- g1584)))
- g1582))
- (g373 (g264 (g206 g1582))
- (g264 '((top))))
- '#f))
- (if (symbol? g1582)
- (if (eq? g1582
- ((lambda (g1586)
- ((lambda (g1587)
- (if (g90 g1587)
- (annotation-expression
- g1587)
- g1587))
- (if (g204 g1586)
- (g205 g1586)
- g1586)))
- g1583))
- (g373 (g264 (g206 g1583))
- (g264 '((top))))
- '#f)
- (g388 g1583 g1582))))))
- (if (not (null? g1559))
- ((letrec ((g1565
- (lambda (g1568 g1566 g1567)
- (if (null? g1566)
- (if (not (null? g1567))
- ((lambda (g1569)
- (syntax-error
- g1560
- '"duplicate definition for "
- (symbol->string (car g1569))
- '" in"))
- (syntax-object->datum g1567))
- (void))
- ((letrec ((g1570
- (lambda (g1572 g1571)
- (if (null? g1572)
- (g1565
- (car g1566)
- (cdr g1566)
- g1571)
- (g1570
- (cdr g1572)
- (g1563
- g1568
- (car g1572)
- g1571))))))
- g1570)
- g1566
- g1567)))))
- g1565)
- (car g1559)
- (cdr g1559)
- '())
- (void)))))
- (g425
- (lambda (g1057 g1055 g1056)
- (letrec ((g1058
- (lambda (g1065 g1064)
- (ormap
- (lambda (g1066)
- (if (g403 g1066)
- ((lambda (g1067)
- (if g1067
- (g367 ((lambda (g1068)
- ((lambda (g1069)
- (if (g90 g1069)
- (annotation-expression
- g1069)
- g1069))
- (if (g204 g1068)
- (g205 g1068)
- g1068)))
- g1065)
- g1067
- (g264 (g206 g1065)))
- ((lambda (g1070)
- ((letrec ((g1071
- (lambda (g1072)
- (if (fx>= g1072
- '0)
- ((lambda (g1073)
- (if g1073
- g1073
- (g1071
- (- g1072
- '1))))
- (g388 g1065
- (vector-ref
- g1070
- g1072)))
- '#f))))
- g1071)
- (- (vector-length g1070)
- '1)))
- (g404 g1066))))
- (g405 g1066))
- (g388 g1065 g1066)))
- g1064))))
- ((letrec ((g1059
- (lambda (g1061 g1060)
- (if (null? g1061)
- (if (not (null? g1060))
- (syntax-error
- g1060
- '"missing definition for export(s)")
- (void))
- ((lambda (g1063 g1062)
- (if (g1058 g1063 g1056)
- (g1059 g1062 g1060)
- (g1059 g1062 (cons g1063 g1060))))
- (car g1061)
- (cdr g1061))))))
- g1059)
- g1055
- '()))))
- (g424
- (lambda (g1558 g1556 g1557)
- (set-cdr! g1558 (g246 g1556 g1557 (cdr g1558)))))
- (g423
- (lambda (g1075 g1074)
- (if (null? g1075)
- '()
- (if (g392 (car g1075) g1074)
- (g423 (cdr g1075) g1074)
- (cons (car g1075) (g423 (cdr g1075) g1074))))))
- (g422
- (lambda (g1491
- g1482
- g1490
- g1483
- g1489
- g1484
- g1488
- g1485
- g1487
- g1486)
- ((lambda (g1492)
- (g427 g1490
- (g394 g1491 g1483 g1489)
- (map (lambda (g1555) (cons g1482 g1555)) g1486)
- g1482
- g1487
- g1492
- g1484
- g1488
- (lambda (g1494 g1493)
- ((letrec ((g1495
- (lambda (g1500
- g1496
- g1499
- g1497
- g1498)
- (if (null? g1500)
- ((letrec ((g1501
- (lambda (g1504
- g1502
- g1503)
- (if (null? g1504)
- ((lambda (g1507
- g1505
- g1506)
- (begin (for-each
- (lambda (g1523)
- (apply
- (lambda (g1527
- g1524
- g1526
- g1525)
- (if g1524
- (g303 g1524
- g1526)
- (void)))
- g1523))
- g1498)
- (g190 '#f
- (list (g431 g1484
- g1488
- (lambda ()
- (if (null?
- g1498)
- (g446)
- (g190 '#f
- (map (lambda (g1518)
- (apply
- (lambda (g1522
- g1519
- g1521
- g1520)
- (list '$sc-put-cte
- (list 'quote
- g1521)
- (if (eq? g1522
- 'define-syntax-form)
- g1520
- (list 'quote
- (g231 'module
- (g409 g1520
- g1521))))))
- g1518))
- g1498)))))
- (g431 g1484
- g1488
- (lambda ()
- ((lambda (g1508)
- ((lambda (g1509)
- ((lambda (g1510)
- ((lambda ()
- (if g1508
- (list '$sc-put-cte
- (list 'quote
- (if (g373 (g264 (g206 g1485))
- (g264 '((top))))
- g1508
- ((lambda (g1511)
- (g203 g1508
- (g263 g1511
- (list (g304 (vector
- g1508)
- (vector
- g1511)
- (vector
- (g101 g1508)))))))
- (g264 (g206 g1485)))))
- g1510)
- ((lambda (g1512)
- (g190 '#f
- (list (list '$sc-put-cte
- (list 'quote
- g1512)
- g1510)
- (g430 g1512
- g1509))))
- (g101 'tmp))))))
- (list 'quote
- (g231 'module
- (g409 g1487
- g1509)))))
- (g101 g1508)))
- (if g1485
- ((lambda (g1513)
- ((lambda (g1514)
- (if (g90 g1514)
- (annotation-expression
- g1514)
- g1514))
- (if (g204 g1513)
- (g205 g1513)
- g1513)))
- g1485)
- '#f))))
- (g190 '#f
- (map (lambda (g1517)
- (list 'define
- g1517
- (g446)))
- g1499))
- (g191 '#f
- g1502
- g1505
- (g190 '#f
- (list (if (null?
- g1499)
- (g446)
- (g190 '#f
- (map (lambda (g1516
- g1515)
- (list 'set!
- g1516
- g1515))
- g1499
- g1507)))
- (if (null?
- g1506)
- (g446)
- (g190 '#f
- g1506)))))
- (g446)))))
- (map (lambda (g1530)
- (g432 (cdr g1530)
- (car g1530)
- '(())))
- g1497)
- (map (lambda (g1528)
- (g432 (cdr g1528)
- (car g1528)
- '(())))
- g1503)
- (map (lambda (g1529)
- (g432 (cdr g1529)
- (car g1529)
- '(())))
- g1493))
- ((lambda (g1531)
- ((lambda (g1532)
- (if (memv g1532
- '(define-form))
- ((lambda (g1533)
- (begin (g424 g1482
- (g302 (g414 g1531))
- (g231 'lexical
- g1533))
- (g1501
- (cdr g1504)
- (cons g1533
- g1502)
- (cons (g416 g1531)
- g1503))))
- (g451 (g413 g1531)))
- (if (memv g1532
- '(define-syntax-form
- module-form))
- (g1501
- (cdr g1504)
- g1502
- g1503)
- (error 'sc-expand-internal
- '"unexpected module binding type"))))
- (g412 g1531)))
- (car g1504))))))
- g1501)
- g1496
- '()
- '())
- ((lambda (g1535 g1534)
- (letrec ((g1536
- (lambda (g1551
- g1548
- g1550
- g1549)
- ((letrec ((g1552
- (lambda (g1554
- g1553)
- (if (null?
- g1554)
- (g1549)
- (if (g388 (g413 (car g1554))
- g1551)
- (g1550
- (car g1554)
- (g370 (reverse
- g1553)
- (cdr g1554)))
- (g1552
- (cdr g1554)
- (cons (car g1554)
- g1553)))))))
- g1552)
- g1548
- '()))))
- (g1536
- g1535
- g1496
- (lambda (g1538 g1537)
- ((lambda (g1541
- g1539
- g1540)
- ((lambda (g1543
- g1542)
- ((lambda (g1544)
- (if (memv g1544
- '(define-form))
- (begin (g303 g1539
- g1542)
- (g1495
- g1543
- g1537
- (cons g1542
- g1499)
- (cons (g416 g1538)
- g1497)
- g1498))
- (if (memv g1544
- '(define-syntax-form))
- (g1495
- g1543
- g1537
- g1499
- g1497
- (cons (list g1541
- g1539
- g1542
- (g416 g1538))
- g1498))
- (if (memv g1544
- '(module-form))
- ((lambda (g1545)
- (g1495
- (append
- (g401 g1545)
- g1543)
- g1537
- g1499
- g1497
- (cons (list g1541
- g1539
- g1542
- g1545)
- g1498)))
- (g416 g1538))
- (error 'sc-expand-internal
- '"unexpected module binding type")))))
- g1541))
- (append
- g1540
- g1534)
- (g101 ((lambda (g1546)
- ((lambda (g1547)
- (if (g90 g1547)
- (annotation-expression
- g1547)
- g1547))
- (if (g204 g1546)
- (g205 g1546)
- g1546)))
- g1535))))
- (g412 g1538)
- (g414 g1538)
- (g415 g1538)))
- (lambda ()
- (g1495
- g1534
- g1496
- g1499
- g1497
- g1498)))))
- (car g1500)
- (cdr g1500))))))
- g1495)
- g1492
- g1494
- '()
- '()
- '()))))
- (g401 g1487))))
- (g421 (lambda (g1077 g1076) (vector-set! g1077 '5 g1076)))
- (g420 (lambda (g1481 g1480) (vector-set! g1481 '4 g1480)))
- (g419 (lambda (g1079 g1078) (vector-set! g1079 '3 g1078)))
- (g418 (lambda (g1479 g1478) (vector-set! g1479 '2 g1478)))
- (g417 (lambda (g1081 g1080) (vector-set! g1081 '1 g1080)))
- (g416 (lambda (g1477) (vector-ref g1477 '5)))
- (g415 (lambda (g1082) (vector-ref g1082 '4)))
- (g414 (lambda (g1476) (vector-ref g1476 '3)))
- (g413 (lambda (g1083) (vector-ref g1083 '2)))
- (g412 (lambda (g1475) (vector-ref g1475 '1)))
- (g411
- (lambda (g1084)
- (if (vector? g1084)
- (if (= (vector-length g1084) '6)
- (eq? (vector-ref g1084 '0) 'module-binding)
- '#f)
- '#f)))
- (g410
- (lambda (g1474 g1470 g1473 g1471 g1472)
- (vector 'module-binding g1474 g1470 g1473 g1471 g1472)))
- (g409
- (lambda (g1086 g1085)
- (g402 (list->vector
- (map (lambda (g1087)
- (g369 (if (pair? g1087) (car g1087) g1087)))
- g1086))
- g1085)))
- (g408
- (lambda (g1468)
- (g402 (list->vector
- (map (lambda (g1469)
- (if (pair? g1469) (car g1469) g1469))
- g1468))
- '#f)))
- (g407 (lambda (g1089 g1088) (vector-set! g1089 '2 g1088)))
- (g406 (lambda (g1467 g1466) (vector-set! g1467 '1 g1466)))
- (g405 (lambda (g1090) (vector-ref g1090 '2)))
- (g404 (lambda (g1465) (vector-ref g1465 '1)))
- (g403
- (lambda (g1091)
- (if (vector? g1091)
- (if (= (vector-length g1091) '3)
- (eq? (vector-ref g1091 '0) 'interface)
- '#f)
- '#f)))
- (g402
- (lambda (g1464 g1463) (vector 'interface g1464 g1463)))
- (g401
- (lambda (g1092)
- ((letrec ((g1093
- (lambda (g1095 g1094)
- (if (null? g1095)
- g1094
- (g1093
- (cdr g1095)
- (if (pair? (car g1095))
- (g1093 (car g1095) g1094)
- (cons (car g1095) g1094)))))))
- g1093)
- g1092
- '())))
- (g400
- (lambda (g1390 g1385 g1389 g1386 g1388 g1387)
- (call-with-values
- (lambda () (g398 g1390 g1385 g1389 '#f g1387))
- (lambda (g1401 g1397 g1400 g1398 g1399)
- ((lambda (g1402)
- (if (memv g1402 '(begin-form))
- ((lambda (g1403)
- ((lambda (g1404)
- (if g1404
- (apply (lambda (g1405) (g446)) g1404)
- ((lambda (g1406)
- (if g1406
- (apply
- (lambda (g1409 g1407 g1408)
- (g396 (cons g1407 g1408)
- g1385
- g1398
- g1399
- g1386
- g1388
- g1387))
- g1406)
- (syntax-error g1403)))
- ($syntax-dispatch
- g1403
- '(any any . each-any)))))
- ($syntax-dispatch g1403 '(any))))
- g1400)
- (if (memv g1402 '(local-syntax-form))
- (g445 g1397
- g1400
- g1385
- g1398
- g1399
- (lambda (g1414 g1411 g1413 g1412)
- (g396 g1414
- g1411
- g1413
- g1412
- g1386
- g1388
- g1387)))
- (if (memv g1402 '(eval-when-form))
- ((lambda (g1415)
- ((lambda (g1416)
- (if g1416
- (apply
- (lambda (g1420
- g1417
- g1419
- g1418)
- ((lambda (g1422 g1421)
- (if (eq? g1386 'e)
- (if (memq 'eval
- g1422)
- (g396 g1421
- g1385
- g1398
- g1399
- 'e
- '(eval)
- g1387)
- (g446))
- (if (memq 'load
- g1422)
- (if ((lambda (g1423)
- (if g1423
- g1423
- (if (eq? g1386
- 'c&e)
- (memq 'eval
- g1422)
- '#f)))
- (memq 'compile
- g1422))
- (g396 g1421
- g1385
- g1398
- g1399
- 'c&e
- '(compile
- load)
- g1387)
- (if (memq g1386
- '(c c&e))
- (g396 g1421
- g1385
- g1398
- g1399
- 'c
- '(load)
- g1387)
- (g446)))
- (if ((lambda (g1424)
- (if g1424
- g1424
- (if (eq? g1386
- 'c&e)
- (memq 'eval
- g1422)
- '#f)))
- (memq 'compile
- g1422))
- (begin (g91 (g396 g1421
- g1385
- g1398
- g1399
- 'e
- '(eval)
- g1387))
- (g446))
- (g446)))))
- (g397 g1400 g1417 g1398)
- (cons g1419 g1418)))
- g1416)
- (syntax-error g1415)))
- ($syntax-dispatch
- g1415
- '(any each-any any . each-any))))
- g1400)
- (if (memv g1402 '(define-syntax-form))
- (g443 g1400
- g1398
- g1399
- (lambda (g1429 g1427 g1428)
- ((lambda (g1430)
- (begin ((lambda (g1435)
- ((lambda (g1436)
- ((lambda (g1437)
- (if (memv g1437
- '(displaced-lexical))
- (g250 g1430)
- (void)))
- (g232 g1436)))
- (g253 g1435
- g1385)))
- (g377 g1430
- '(())))
- (g431 g1386
- g1388
- (lambda ()
- (list '$sc-put-cte
- (list 'quote
- ((lambda (g1431)
- (if (g373 (g264 (g206 g1430))
- (g264 '((top))))
- g1431
- ((lambda (g1432)
- (g203 g1431
- (g263 g1432
- (list (g304 (vector
- g1431)
- (vector
- g1432)
- (vector
- (g101 g1431)))))))
- (g264 (g206 g1430)))))
- ((lambda (g1433)
- ((lambda (g1434)
- (if (g90 g1434)
- (annotation-expression
- g1434)
- g1434))
- (if (g204 g1433)
- (g205 g1433)
- g1433)))
- g1430)))
- (g432 g1427
- (g249 g1385)
- g1428))))))
- (g393 g1429 g1428))))
- (if (memv g1402 '(define-form))
- (g442 g1400
- g1398
- g1399
- (lambda (g1440 g1438 g1439)
- ((lambda (g1441)
- (begin ((lambda (g1448)
- ((lambda (g1449)
- ((lambda (g1450)
- (if (memv g1450
- '(displaced-lexical))
- (g250 g1441)
- (void)))
- (g232 g1449)))
- (g253 g1448
- g1385)))
- (g377 g1441
- '(())))
- ((lambda (g1442)
- ((lambda (g1443)
- (g190 '#f
- (list (g431 g1386
- g1388
- (lambda ()
- (list '$sc-put-cte
- (list 'quote
- (if (eq? g1442
- g1443)
- g1442
- ((lambda (g1445)
- (g203 g1442
- (g263 g1445
- (list (g304 (vector
- g1442)
- (vector
- g1445)
- (vector
- g1443))))))
- (g264 (g206 g1441)))))
- (list 'quote
- (g231 'global
- g1443)))))
- ((lambda (g1444)
- (begin (if (eq? g1386
- 'c&e)
- (g91 g1444)
- (void))
- g1444))
- (list 'define
- g1443
- (g432 g1438
- g1385
- g1439))))))
- (if (g373 (g264 (g206 g1441))
- (g264 '((top))))
- g1442
- (g101 g1442))))
- ((lambda (g1446)
- ((lambda (g1447)
- (if (g90 g1447)
- (annotation-expression
- g1447)
- g1447))
- (if (g204 g1446)
- (g205 g1446)
- g1446)))
- g1441))))
- (g393 g1440 g1439))))
- (if (memv g1402 '(module-form))
- ((lambda (g1452 g1451)
- (g440 g1400
- g1398
- g1399
- (g263 (g264 g1398)
- (cons g1451
- (g265 g1398)))
- (lambda (g1455
- g1453
- g1454)
- (if g1455
- (begin ((lambda (g1456)
- ((lambda (g1457)
- ((lambda (g1458)
- (if (memv g1458
- '(displaced-lexical))
- (g250 (g393 g1455
- g1398))
- (void)))
- (g232 g1457)))
- (g253 g1456
- g1452)))
- (g377 g1455
- '(())))
- (g422 g1400
- g1452
- g1451
- g1398
- g1399
- g1386
- g1388
- g1455
- g1453
- g1454))
- (g422 g1400
- g1452
- g1451
- g1398
- g1399
- g1386
- g1388
- '#f
- g1453
- g1454)))))
- (cons '("top-level module placeholder"
- placeholder)
- g1385)
- (g304 '() '() '()))
- (if (memv g1402
- '(import-form))
- (g441 g1400
- g1398
- g1399
- (lambda (g1459)
- (g431 g1386
- g1388
- (lambda ()
- (begin (if g1397
- (syntax-error
- (g394 g1400
- g1398
- g1399)
- '"not valid at top-level")
- (void))
- ((lambda (g1460)
- ((lambda (g1461)
- (if (memv g1461
- '(module))
- (g430 g1459
- (g405 (g233 g1460)))
- (if (memv g1461
- '(displaced-lexical))
- (g250 g1459)
- (syntax-error
- g1459
- '"import from unknown module"))))
- (g232 g1460)))
- (g253 (g377 g1459
- '(()))
- '())))))))
- ((lambda (g1462)
- (begin (if (eq? g1386
- 'c&e)
- (g91 g1462)
- (void))
- g1462))
- (g433 g1401
- g1397
- g1400
- g1385
- g1398
- g1399))))))))))
- g1401)))))
- (g399
- (lambda (g1099 g1096 g1098 g1097)
- (call-with-values
- (lambda () (g398 g1099 g1096 g1098 '#f g1097))
- (lambda (g1104 g1100 g1103 g1101 g1102)
- (g433 g1104 g1100 g1103 g1096 g1101 g1102)))))
- (g398
- (lambda (g1370 g1366 g1369 g1367 g1368)
- (if (symbol? g1370)
- ((lambda (g1371)
- ((lambda (g1372)
- ((lambda (g1373)
- ((lambda ()
- ((lambda (g1374)
- (if (memv g1374 '(lexical))
- (values
- g1373
- (g233 g1372)
- g1370
- g1369
- g1367)
- (if (memv g1374 '(global))
- (values
- g1373
- (g233 g1372)
- g1370
- g1369
- g1367)
- (if (memv g1374 '(macro macro!))
- (g398 (g436 (g233 g1372)
- g1370
- g1366
- g1369
- g1367
- g1368)
- g1366
- '(())
- '#f
- g1368)
- (values
- g1373
- (g233 g1372)
- g1370
- g1369
- g1367)))))
- g1373))))
- (g232 g1372)))
- (g253 g1371 g1366)))
- (g377 g1370 g1369))
- (if (pair? g1370)
- ((lambda (g1375)
- (if (g256 g1375)
- ((lambda (g1376)
- ((lambda (g1377)
- ((lambda (g1378)
- ((lambda ()
- ((lambda (g1379)
- (if (memv g1379 '(lexical))
- (values
- 'lexical-call
- (g233 g1377)
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(macro macro!))
- (g398 (g436 (g233 g1377)
- g1370
- g1366
- g1369
- g1367
- g1368)
- g1366
- '(())
- '#f
- g1368)
- (if (memv g1379
- '(core))
- (values
- g1378
- (g233 g1377)
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(local-syntax))
- (values
- 'local-syntax-form
- (g233 g1377)
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(begin))
- (values
- 'begin-form
- '#f
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(eval-when))
- (values
- 'eval-when-form
- '#f
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(define))
- (values
- 'define-form
- '#f
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(define-syntax))
- (values
- 'define-syntax-form
- '#f
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(module-key))
- (values
- 'module-form
- '#f
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(import))
- (values
- 'import-form
- (if (g233 g1377)
- (g393 g1375
- g1369)
- '#f)
- g1370
- g1369
- g1367)
- (if (memv g1379
- '(set!))
- (g435 g1370
- g1366
- g1369
- g1367
- g1368)
- (values
- 'call
- '#f
- g1370
- g1369
- g1367)))))))))))))
- g1378))))
- (g232 g1377)))
- (g253 g1376 g1366)))
- (g377 g1375 g1369))
- (values 'call '#f g1370 g1369 g1367)))
- (car g1370))
- (if (g204 g1370)
- (g398 (g205 g1370)
- g1366
- (g371 g1369 (g206 g1370))
- '#f
- g1368)
- (if (g90 g1370)
- (g398 (annotation-expression g1370)
- g1366
- g1369
- (annotation-source g1370)
- g1368)
- (if ((lambda (g1380)
- ((lambda (g1381)
- (if g1381
- g1381
- ((lambda (g1382)
- (if g1382
- g1382
- ((lambda (g1383)
- (if g1383
- g1383
- ((lambda (g1384)
- (if g1384
- g1384
- (null?
- g1380)))
- (char?
- g1380))))
- (string? g1380))))
- (number? g1380))))
- (boolean? g1380)))
- g1370)
- (values 'constant '#f g1370 g1369 g1367)
- (values
- 'other
- '#f
- g1370
- g1369
- g1367))))))))
- (g397
- (lambda (g1107 g1105 g1106)
- ((letrec ((g1108
- (lambda (g1110 g1109)
- (if (null? g1110)
- g1109
- (g1108
- (cdr g1110)
- (cons ((lambda (g1111)
- (if (g378 g1111
- '#(syntax-object
- compile
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(when-list
- situations)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e when-list w)
- #((top)
- (top)
- (top))
- #("i" "i" "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- 'compile
- (if (g378 g1111
- '#(syntax-object
- load
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(when-list
- situations)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e
- when-list
- w)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- 'load
- (if (g378 g1111
- '#(syntax-object
- eval
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(when-list
- situations)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e
- when-list
- w)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- strip*
- strip-annotation
- ellipsis?
- chi-void
- chi-local-syntax
- chi-lambda-clause
- parse-define-syntax
- parse-define
- parse-import
- parse-module
- do-import!
- chi-internal
- chi-body
- chi-macro
- chi-set!
- chi-application
- chi-expr
- chi
- ct-eval/residualize
- do-top-import
- vfor-each
- vmap
- chi-external
- check-defined-ids
- check-module-exports
- extend-store!
- id-set-diff
- chi-top-module
- set-module-binding-val!
- set-module-binding-imps!
- set-module-binding-label!
- set-module-binding-id!
- set-module-binding-type!
- module-binding-val
- module-binding-imps
- module-binding-label
- module-binding-id
- module-binding-type
- module-binding?
- make-module-binding
- make-resolved-interface
- make-trimmed-interface
- set-interface-token!
- set-interface-exports!
- interface-token
- interface-exports
- interface?
- make-interface
- flatten-exports
- chi-top
- chi-top-expr
- syntax-type
- chi-when-list
- chi-top-sequence
- chi-sequence
- source-wrap
- wrap
- bound-id-member?
- invalid-ids-error
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- literal-id=?
- free-id=?
- id-var-name
- id-var-name-loc
- id-var-name&marks
- id-var-name-loc&marks
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-trimmed-syntax-object
- make-binding-wrap
- lookup-import-binding-name
- extend-ribcage-subst!
- extend-ribcage-barrier-help!
- extend-ribcage-barrier!
- extend-ribcage!
- make-empty-ribcage
- import-token-key
- import-token?
- make-import-token
- barrier-marker
- new-mark
- anti-mark
- the-anti-mark
- only-top-marked?
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- set-indirect-label!
- get-indirect-label
- indirect-label?
- gen-indirect-label
- gen-labels
- label?
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- sanitize-binding
- lookup*
- displaced-lexical-error
- transformer-env
- extend-var-env*
- extend-env*
- extend-env
- null-env
- binding?
- set-binding-value!
- set-binding-type!
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- unannotate
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- self-evaluating?
- build-lexical-var
- build-letrec
- build-sequence
- build-data
- build-primref
- build-lambda
- build-cte-install
- build-module-definition
- build-global-definition
- build-global-assignment
- build-global-reference
- build-lexical-assignment
- build-lexical-reference
- build-conditional
- build-application
- generate-id
- get-import-binding
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- error-hook
- local-eval-hook
- top-level-eval-hook
- annotation?
- fx<
- fx=
- fx-
- fx+
- noexpand
- define-structure
- unless
- when)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i" "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- 'eval
- (syntax-error
- (g393 g1111 g1106)
- '"invalid eval-when situation")))))
- (car g1110))
- g1109))))))
- g1108)
- g1105
- '())))
- (g396
- (lambda (g1358 g1352 g1357 g1353 g1356 g1354 g1355)
- (g190 g1353
- ((letrec ((g1359
- (lambda (g1364 g1360 g1363 g1361 g1362)
- (if (null? g1364)
- '()
- ((lambda (g1365)
- (cons g1365
- (g1359
- (cdr g1364)
- g1360
- g1363
- g1361
- g1362)))
- (g400 (car g1364)
- g1360
- g1363
- g1361
- g1362
- g1355))))))
- g1359)
- g1358
- g1352
- g1357
- g1356
- g1354))))
- (g395
- (lambda (g1115 g1112 g1114 g1113)
- (g190 g1113
- ((letrec ((g1116
- (lambda (g1119 g1117 g1118)
- (if (null? g1119)
- '()
- ((lambda (g1120)
- (cons g1120
- (g1116
- (cdr g1119)
- g1117
- g1118)))
- (g432 (car g1119) g1117 g1118))))))
- g1116)
- g1115
- g1112
- g1114))))
- (g394
- (lambda (g1351 g1349 g1350)
- (g393 (if g1350 (make-annotation g1351 g1350 '#f) g1351)
- g1349)))
- (g393
- (lambda (g1122 g1121)
- (if (if (null? (g264 g1121)) (null? (g265 g1121)) '#f)
- g1122
- (if (g204 g1122)
- (g203 (g205 g1122) (g371 g1121 (g206 g1122)))
- (if (null? g1122) g1122 (g203 g1122 g1121))))))
- (g392
- (lambda (g1347 g1346)
- (if (not (null? g1346))
- ((lambda (g1348)
- (if g1348 g1348 (g392 g1347 (cdr g1346))))
- (g388 g1347 (car g1346)))
- '#f)))
- (g391
- (lambda (g1125 g1123 g1124)
- ((letrec ((g1126
- (lambda (g1128 g1127)
- (if (null? g1128)
- (syntax-error g1123)
- (if (g256 (car g1128))
- (if (g392 (car g1128) g1127)
- (syntax-error
- (car g1128)
- '"duplicate "
- g1124)
- (g1126
- (cdr g1128)
- (cons (car g1128) g1127)))
- (syntax-error
- (car g1128)
- '"invalid "
- g1124))))))
- g1126)
- g1125
- '())))
- (g390
- (lambda (g1342)
- ((letrec ((g1343
- (lambda (g1344)
- ((lambda (g1345)
- (if g1345
- g1345
- (if (not (g392 (car g1344) (cdr g1344)))
- (g1343 (cdr g1344))
- '#f)))
- (null? g1344)))))
- g1343)
- g1342)))
- (g389
- (lambda (g1129)
- (if ((letrec ((g1130
- (lambda (g1131)
- ((lambda (g1132)
- (if g1132
- g1132
- (if (g256 (car g1131))
- (g1130 (cdr g1131))
- '#f)))
- (null? g1131)))))
- g1130)
- g1129)
- (g390 g1129)
- '#f)))
- (g388
- (lambda (g1337 g1336)
- (if (if (g204 g1337) (g204 g1336) '#f)
- (if (eq? ((lambda (g1339)
- (if (g90 g1339)
- (annotation-expression g1339)
- g1339))
- (g205 g1337))
- ((lambda (g1338)
- (if (g90 g1338)
- (annotation-expression g1338)
- g1338))
- (g205 g1336)))
- (g373 (g264 (g206 g1337)) (g264 (g206 g1336)))
- '#f)
- (eq? ((lambda (g1341)
- (if (g90 g1341)
- (annotation-expression g1341)
- g1341))
- g1337)
- ((lambda (g1340)
- (if (g90 g1340)
- (annotation-expression g1340)
- g1340))
- g1336)))))
- (g378
- (lambda (g1134 g1133)
- (if (eq? ((lambda (g1137)
- ((lambda (g1138)
- (if (g90 g1138)
- (annotation-expression g1138)
- g1138))
- (if (g204 g1137) (g205 g1137) g1137)))
- g1134)
- ((lambda (g1135)
- ((lambda (g1136)
- (if (g90 g1136)
- (annotation-expression g1136)
- g1136))
- (if (g204 g1135) (g205 g1135) g1135)))
- g1133))
- (eq? (g377 g1134 '(())) (g377 g1133 '(())))
- '#f)))
- (g377
- (lambda (g1333 g1332)
- (call-with-values
- (lambda () (g374 g1333 g1332))
- (lambda (g1335 g1334)
- (if (g301 g1335) (g302 g1335) g1335)))))
- (g376
- (lambda (g1140 g1139)
- (call-with-values
- (lambda () (g374 g1140 g1139))
- (lambda (g1142 g1141) g1142))))
- (g375
- (lambda (g1329 g1328)
- (call-with-values
- (lambda () (g374 g1329 g1328))
- (lambda (g1331 g1330)
- (values (if (g301 g1331) (g302 g1331) g1331) g1330)))))
- (g374
- (lambda (g1144 g1143)
- (letrec ((g1147
- (lambda (g1174 g1170 g1173 g1171 g1172)
- ((lambda (g1175)
- ((letrec ((g1176
- (lambda (g1177)
- (if (= g1177 g1175)
- (g1145
- g1174
- (cdr g1170)
- g1173)
- (if (if (eq? (vector-ref
- g1171
- g1177)
- g1174)
- (g373 g1173
- (vector-ref
- (g307 g1172)
- g1177))
- '#f)
- (values
- (vector-ref
- (g308 g1172)
- g1177)
- g1173)
- (g1176 (+ g1177 '1)))))))
- g1176)
- '0))
- (vector-length g1171))))
- (g1146
- (lambda (g1159 g1155 g1158 g1156 g1157)
- ((letrec ((g1160
- (lambda (g1162 g1161)
- (if (null? g1162)
- (g1145 g1159 (cdr g1155) g1158)
- (if (if (eq? (car g1162) g1159)
- (g373 g1158
- (list-ref
- (g307 g1157)
- g1161))
- '#f)
- (values
- (list-ref
- (g308 g1157)
- g1161)
- g1158)
- (if (g357 (car g1162))
- ((lambda (g1163)
- (if g1163
- ((lambda (g1164)
- (if (symbol?
- g1164)
- (values
- g1164
- g1158)
- (g375 g1164
- '(()))))
- g1163)
- (g1160
- (cdr g1162)
- g1161)))
- (g367 g1159
- (g358 (car g1162))
- g1158))
- (if (if (eq? (car g1162)
- g354)
- (g373 g1158
- (list-ref
- (g307 g1157)
- g1161))
- '#f)
- (values '#f g1158)
- (g1160
- (cdr g1162)
- (+ g1161
- '1)))))))))
- g1160)
- g1156
- '0)))
- (g1145
- (lambda (g1167 g1165 g1166)
- (if (null? g1165)
- (values g1167 g1166)
- ((lambda (g1168)
- (if (eq? g1168 'shift)
- (g1145 g1167 (cdr g1165) (cdr g1166))
- ((lambda (g1169)
- (if (vector? g1169)
- (g1147
- g1167
- g1165
- g1166
- g1169
- g1168)
- (g1146
- g1167
- g1165
- g1166
- g1169
- g1168)))
- (g306 g1168))))
- (car g1165))))))
- (if (symbol? g1144)
- (g1145 g1144 (g265 g1143) (g264 g1143))
- (if (g204 g1144)
- ((lambda (g1149 g1148)
- ((lambda (g1150)
- (call-with-values
- (lambda ()
- (g1145 g1149 (g265 g1143) g1150))
- (lambda (g1152 g1151)
- (if (eq? g1152 g1149)
- (g1145 g1149 (g265 g1148) g1151)
- (values g1152 g1151)))))
- (g372 (g264 g1143) (g264 g1148))))
- ((lambda (g1153)
- (if (g90 g1153)
- (annotation-expression g1153)
- g1153))
- (g205 g1144))
- (g206 g1144))
- (if (g90 g1144)
- (g1145
- ((lambda (g1154)
- (if (g90 g1154)
- (annotation-expression g1154)
- g1154))
- g1144)
- (g265 g1143)
- (g264 g1143))
- (g93 'id-var-name '"invalid id" g1144)))))))
- (g373
- (lambda (g1326 g1325)
- ((lambda (g1327)
- (if g1327
- g1327
- (if (not (null? g1326))
- (if (not (null? g1325))
- (if (eq? (car g1326) (car g1325))
- (g373 (cdr g1326) (cdr g1325))
- '#f)
- '#f)
- '#f)))
- (eq? g1326 g1325))))
- (g372 (lambda (g1179 g1178) (g370 g1179 g1178)))
- (g371
- (lambda (g1322 g1321)
- ((lambda (g1324 g1323)
- (if (null? g1324)
- (if (null? g1323)
- g1321
- (g263 (g264 g1321) (g370 g1323 (g265 g1321))))
- (g263 (g370 g1324 (g264 g1321))
- (g370 g1323 (g265 g1321)))))
- (g264 g1322)
- (g265 g1322))))
- (g370
- (lambda (g1181 g1180)
- (if (null? g1180) g1181 (append g1181 g1180))))
- (g369
- (lambda (g1315)
- (call-with-values
- (lambda () (g375 g1315 '(())))
- (lambda (g1317 g1316)
- (begin (if (not g1317)
- (syntax-error
- g1315
- '"identifier not visible for export")
- (void))
- ((lambda (g1318)
- (g203 g1318
- (g263 g1316
- (list (g304 (vector g1318)
- (vector g1316)
- (vector g1317))))))
- ((lambda (g1319)
- ((lambda (g1320)
- (if (g90 g1320)
- (annotation-expression g1320)
- g1320))
- (if (g204 g1319) (g205 g1319) g1319)))
- g1315)))))))
- (g368
- (lambda (g1184 g1182 g1183)
- (if (null? g1184)
- g1183
- (g263 (g264 g1183)
- (cons ((lambda (g1185)
- ((lambda (g1186)
- ((lambda (g1188 g1187)
- (begin ((letrec ((g1189
- (lambda (g1191
- g1190)
- (if (not (null?
- g1191))
- (call-with-values
- (lambda ()
- (g262 (car g1191)
- g1183))
- (lambda (g1193
- g1192)
- (begin (vector-set!
- g1188
- g1190
- g1193)
- (vector-set!
- g1187
- g1190
- g1192)
- (g1189
- (cdr g1191)
- (+ g1190
- '1)))))
- (void)))))
- g1189)
- g1184
- '0)
- (g304 g1188 g1187 g1185)))
- (make-vector g1186)
- (make-vector g1186)))
- (vector-length g1185)))
- (list->vector g1182))
- (g265 g1183))))))
- (g367
- (lambda (g1310 g1308 g1309)
- ((lambda (g1311)
- (if g1311
- ((letrec ((g1312
- (lambda (g1313)
- (if (pair? g1313)
- ((lambda (g1314)
- (if g1314
- g1314
- (g1312 (cdr g1313))))
- (g1312 (car g1313)))
- (if (g373 g1309 (g264 (g206 g1313)))
- g1313
- '#f)))))
- g1312)
- g1311)
- '#f))
- (g100 g1310 g1308))))
- (g366
- (lambda (g1195 g1194)
- (g309 g1195 (cons (g356 g1194) (g306 g1195)))))
- (g365
- (lambda (g1307 g1306)
- (begin (g309 g1307 (cons g354 (g306 g1307)))
- (g310 g1307 (cons (g264 g1306) (g307 g1307))))))
- (g364 (lambda (g1197 g1196) (g365 g1197 (g206 g1196))))
- (g363
- (lambda (g1304 g1302 g1303)
- (begin (g309 g1304
- (cons ((lambda (g1305)
- (if (g90 g1305)
- (annotation-expression g1305)
- g1305))
- (g205 g1302))
- (g306 g1304)))
- (g310 g1304 (cons (g264 (g206 g1302)) (g307 g1304)))
- (g311 g1304 (cons g1303 (g308 g1304))))))
- (g358 cdr)
- (g357
- (lambda (g1301)
- (if (pair? g1301) (eq? (car g1301) g355) '#f)))
- (g356 (lambda (g1198) (cons g355 g1198)))
- (g355 'import-token)
- (g354 '#f)
- (g349
- (lambda (g1300)
- (g263 (cons '#f (g264 g1300)) (cons 'shift (g265 g1300)))))
- (g311 (lambda (g1200 g1199) (vector-set! g1200 '3 g1199)))
- (g310 (lambda (g1299 g1298) (vector-set! g1299 '2 g1298)))
- (g309 (lambda (g1202 g1201) (vector-set! g1202 '1 g1201)))
- (g308 (lambda (g1297) (vector-ref g1297 '3)))
- (g307 (lambda (g1203) (vector-ref g1203 '2)))
- (g306 (lambda (g1296) (vector-ref g1296 '1)))
- (g305
- (lambda (g1204)
- (if (vector? g1204)
- (if (= (vector-length g1204) '4)
- (eq? (vector-ref g1204 '0) 'ribcage)
- '#f)
- '#f)))
- (g304
- (lambda (g1295 g1293 g1294)
- (vector 'ribcage g1295 g1293 g1294)))
- (g303 set-car!)
- (g302 car)
- (g301 pair?)
- (g300 (lambda () (list (g297))))
- (g299
- (lambda (g1205)
- (if (null? g1205) '() (cons (g297) (g299 (cdr g1205))))))
- (g298
- (lambda (g1290)
- ((lambda (g1291)
- (if g1291
- g1291
- ((lambda (g1292) (if g1292 g1292 (g301 g1290)))
- (symbol? g1290))))
- (string? g1290))))
- (g297 (lambda () (string '#\i)))
- (g265 cdr)
- (g264 car)
- (g263 cons)
- (g262
- (lambda (g1207 g1206)
- (if (g204 g1207)
- (values
- ((lambda (g1208)
- (if (g90 g1208)
- (annotation-expression g1208)
- g1208))
- (g205 g1207))
- (g372 (g264 g1206) (g264 (g206 g1207))))
- (values
- ((lambda (g1209)
- (if (g90 g1209)
- (annotation-expression g1209)
- g1209))
- g1207)
- (g264 g1206)))))
- (g256
- (lambda (g1288)
- (if (symbol? g1288)
- '#t
- (if (g204 g1288)
- (symbol?
- ((lambda (g1289)
- (if (g90 g1289)
- (annotation-expression g1289)
- g1289))
- (g205 g1288)))
- (if (g90 g1288)
- (symbol? (annotation-expression g1288))
- '#f)))))
- (g255
- (lambda (g1210)
- (if (g204 g1210)
- (symbol?
- ((lambda (g1211)
- (if (g90 g1211)
- (annotation-expression g1211)
- g1211))
- (g205 g1210)))
- '#f)))
- (g254
- (lambda (g1287 g1285 g1286) (g98 g1285 (g231 g1287 g1286))))
- (g253
- (lambda (g1213 g1212)
- (letrec ((g1214
- (lambda (g1221 g1220)
- (begin (g234 g1221 (g232 g1220))
- (g235 g1221 (g233 g1220))))))
- ((lambda (g1215)
- ((lambda (g1216)
- (if (memv g1216 '(deferred))
- (begin (g1214
- g1215
- ((lambda (g1217)
- ((lambda (g1218)
- (if g1218
- g1218
- (syntax-error
- g1217
- '"invalid transformer")))
- (g252 g1217)))
- (g92 (g233 g1215))))
- ((lambda (g1219) g1215) (g232 g1215)))
- g1215))
- (g232 g1215)))
- (g251 g1213 g1212)))))
- (g252
- (lambda (g1283)
- (if (procedure? g1283)
- (g231 'macro g1283)
- (if (g236 g1283)
- ((lambda (g1284)
- (if (memv g1284 '(core macro macro!))
- (if (procedure? (g233 g1283)) g1283 '#f)
- (if (memv g1284 '(module))
- (if (g403 (g233 g1283)) g1283 '#f)
- g1283)))
- (g232 g1283))
- '#f))))
- (g251
- (lambda (g1223 g1222)
- ((lambda (g1224)
- (if g1224
- (cdr g1224)
- (if (symbol? g1223)
- ((lambda (g1225)
- (if g1225 g1225 (g231 'global g1223)))
- (g99 g1223))
- (g231 'displaced-lexical '#f))))
- (assq g1223 g1222))))
- (g250
- (lambda (g1282)
- (syntax-error
- g1282
- (if (g377 g1282 '(()))
- '"identifier out of context"
- '"identifier not visible"))))
- (g249
- (lambda (g1226)
- (if (null? g1226)
- '()
- ((lambda (g1227)
- (if (eq? (cadr g1227) 'lexical)
- (g249 (cdr g1226))
- (cons g1227 (g249 (cdr g1226)))))
- (car g1226)))))
- (g248
- (lambda (g1281 g1279 g1280)
- (if (null? g1281)
- g1280
- (g248 (cdr g1281)
- (cdr g1279)
- (g246 (car g1281)
- (g231 'lexical (car g1279))
- g1280)))))
- (g247
- (lambda (g1230 g1228 g1229)
- (if (null? g1230)
- g1229
- (g247 (cdr g1230)
- (cdr g1228)
- (g246 (car g1230) (car g1228) g1229)))))
- (g246
- (lambda (g1278 g1276 g1277)
- (cons (cons g1278 g1276) g1277)))
- (g236
- (lambda (g1231)
- (if (pair? g1231) (symbol? (car g1231)) '#f)))
- (g235 set-cdr!)
- (g234 set-car!)
- (g233 cdr)
- (g232 car)
- (g231 (lambda (g1275 g1274) (cons g1275 g1274)))
- (g223
- (lambda (g1232)
- (if (g90 g1232)
- (annotation-source g1232)
- (if (g204 g1232) (g223 (g205 g1232)) '#f))))
- (g208 (lambda (g1273 g1272) (vector-set! g1273 '2 g1272)))
- (g207 (lambda (g1234 g1233) (vector-set! g1234 '1 g1233)))
- (g206 (lambda (g1271) (vector-ref g1271 '2)))
- (g205 (lambda (g1235) (vector-ref g1235 '1)))
- (g204
- (lambda (g1270)
- (if (vector? g1270)
- (if (= (vector-length g1270) '3)
- (eq? (vector-ref g1270 '0) 'syntax-object)
- '#f)
- '#f)))
- (g203
- (lambda (g1237 g1236) (vector 'syntax-object g1237 g1236)))
- (g191
- (lambda (g1269 g1266 g1268 g1267)
- (if (null? g1266)
- g1267
- (list 'letrec (map list g1266 g1268) g1267))))
- (g190
- (lambda (g1239 g1238)
- (if (null? (cdr g1238)) (car g1238) (cons 'begin g1238))))
- (g101
- ((lambda (g1251)
- (letrec ((g1254
- (lambda (g1260)
- ((letrec ((g1261
- (lambda (g1263 g1262)
- (if (< g1263 g1251)
- (list->string
- (cons (g1253 g1263) g1262))
- ((lambda (g1265 g1264)
- (g1261
- g1264
- (cons (g1253 g1265)
- g1262)))
- (modulo g1263 g1251)
- (quotient g1263 g1251))))))
- g1261)
- g1260
- '())))
- (g1253
- (lambda (g1259) (integer->char (+ g1259 '33))))
- (g1252 (lambda () '0)))
- ((lambda (g1256 g1255)
- (lambda (g1257)
- (begin (set! g1255 (+ g1255 '1))
- ((lambda (g1258) g1258)
- (string->symbol
- (string-append
- '"#"
- g1256
- (g1254 g1255)))))))
- (g1254 (g1252))
- '-1)))
- (- '127 '32 '2)))
- (g100 (lambda (g1241 g1240) (getprop g1241 g1240)))
- (g99 (lambda (g1250) (getprop g1250 '*sc-expander*)))
- (g98 (lambda (g1243 g1242) ($sc-put-cte g1243 g1242)))
- (g93
- (lambda (g1249 g1247 g1248)
- (error g1249 '"~a ~s" g1247 g1248)))
- (g92 (lambda (g1244) (eval (list g53 g1244))))
- (g91 (lambda (g1246) (eval (list g53 g1246))))
- (g90 (lambda (g1245) '#f))
- (g53 '"noexpand"))
- (begin (set! $sc-put-cte
- (lambda (g802 g801)
- (letrec ((g805
- (lambda (g831 g830)
- ((lambda (g832)
- (putprop g832 '*sc-expander* g830))
- (if (symbol? g831) g831 (g377 g831 '(()))))))
- (g804
- (lambda (g815 g814)
- (g429 (lambda (g816) (g803 g816 g814)) g815)))
- (g803
- (lambda (g818 g817)
- (letrec ((g820
- (lambda (g828 g827)
- (if (pair? g827)
- (if (g388 (car g827) g828)
- (g820 g828 (cdr g827))
- (g819 (car g827)
- (g820 g828
- (cdr g827))))
- (if ((lambda (g829)
- (if g829
- g829
- (g388 g827 g828)))
- (not g827))
- '#f
- g827))))
- (g819
- (lambda (g826 g825)
- (if (not g825)
- g826
- (cons g826 g825)))))
- ((lambda (g821)
- ((lambda (g822)
- (if (if (not g822) (symbol? g818) '#f)
- (remprop g821 g817)
- (putprop
- g821
- g817
- (g819 g818 g822))))
- (g820 g818 (getprop g821 g817))))
- ((lambda (g823)
- ((lambda (g824)
- (if (g90 g824)
- (annotation-expression g824)
- g824))
- (if (g204 g823) (g205 g823) g823)))
- g818))))))
- ((lambda (g806)
- ((lambda (g807)
- (if (memv g807 '(module))
- (begin ((lambda (g808)
- (g804 (g404 g808) (g405 g808)))
- (g233 g806))
- (g805 g802 g806))
- (if (memv g807 '(do-import))
- ((lambda (g809)
- ((lambda (g810)
- ((lambda (g811)
- (if (memv g811 '(module))
- ((lambda (g812)
- (begin (if (not (eq? (g405 g812)
- g809))
- (syntax-error
- g802
- '"import mismatch for module")
- (void))
- (g804 (g404 g812)
- '*top*)))
- (g233 g810))
- (syntax-error
- g802
- '"import from unknown module")))
- (g232 g810)))
- (g253 (g377 g802 '(())) '())))
- (g233 g801))
- (g805 g802 g806))))
- (g232 g806)))
- ((lambda (g813)
- (if g813
- g813
- (error 'define-syntax
- '"invalid transformer ~s"
- g801)))
- (g252 g801))))))
- (g254 'local-syntax 'letrec-syntax '#t)
- (g254 'local-syntax 'let-syntax '#f)
- (g254 'core
- 'fluid-let-syntax
- (lambda (g456 g453 g455 g454)
- ((lambda (g457)
- ((lambda (g458)
- (if (if g458
- (apply
- (lambda (g463 g459 g462 g460 g461)
- (g389 g459))
- g458)
- '#f)
- (apply
- (lambda (g469 g465 g468 g466 g467)
- ((lambda (g470)
- (begin (for-each
- (lambda (g477 g476)
- ((lambda (g478)
- (if (memv g478
- '(displaced-lexical))
- (g250 (g393 g477
- g455))
- (void)))
- (g232 (g253 g476 g453))))
- g465
- g470)
- (g437 (cons g466 g467)
- (g394 g456 g455 g454)
- (g247 g470
- ((lambda (g471)
- (map (lambda (g473)
- (g231 'deferred
- (g432 g473
- g471
- g455)))
- g468))
- (g249 g453))
- g453)
- g455)))
- (map (lambda (g480) (g377 g480 g455))
- g465)))
- g458)
- ((lambda (g481)
- (syntax-error (g394 g456 g455 g454)))
- g457)))
- ($syntax-dispatch
- g457
- '(any #(each (any any)) any . each-any))))
- g456)))
- (g254 'core
- 'quote
- (lambda (g795 g792 g794 g793)
- ((lambda (g796)
- ((lambda (g797)
- (if g797
- (apply
- (lambda (g799 g798)
- (list 'quote (g450 g798 g794)))
- g797)
- ((lambda (g800)
- (syntax-error (g394 g795 g794 g793)))
- g796)))
- ($syntax-dispatch g796 '(any any))))
- g795)))
- (g254 'core
- 'syntax
- ((lambda ()
- (letrec ((g489
- (lambda (g584)
- ((lambda (g585)
- (if (memv g585 '(ref))
- (cadr g584)
- (if (memv g585 '(primitive))
- (cadr g584)
- (if (memv g585 '(quote))
- (list 'quote (cadr g584))
- (if (memv g585 '(lambda))
- (list 'lambda
- (cadr g584)
- (g489 (caddr
- g584)))
- (if (memv g585 '(map))
- ((lambda (g586)
- (cons (if (= (length
- g586)
- '2)
- 'map
- 'map)
- g586))
- (map g489
- (cdr g584)))
- (cons (car g584)
- (map g489
- (cdr g584)))))))))
- (car g584))))
- (g488
- (lambda (g502)
- (if (eq? (car g502) 'list)
- (cons 'vector (cdr g502))
- (if (eq? (car g502) 'quote)
- (list 'quote
- (list->vector (cadr g502)))
- (list 'list->vector g502)))))
- (g487
- (lambda (g583 g582)
- (if (equal? g582 ''())
- g583
- (list 'append g583 g582))))
- (g486
- (lambda (g504 g503)
- ((lambda (g505)
- (if (memv g505 '(quote))
- (if (eq? (car g504) 'quote)
- (list 'quote
- (cons (cadr g504)
- (cadr g503)))
- (if (eq? (cadr g503) '())
- (list 'list g504)
- (list 'cons g504 g503)))
- (if (memv g505 '(list))
- (cons 'list
- (cons g504 (cdr g503)))
- (list 'cons g504 g503))))
- (car g503))))
- (g485
- (lambda (g575 g574)
- ((lambda (g577 g576)
- (if (eq? (car g575) 'ref)
- (car g576)
- (if (andmap
- (lambda (g578)
- (if (eq? (car g578) 'ref)
- (memq (cadr g578) g577)
- '#f))
- (cdr g575))
- (cons 'map
- (cons (list 'primitive
- (car g575))
- (map ((lambda (g579)
- (lambda (g580)
- (cdr (assq (cadr g580)
- g579))))
- (map cons
- g577
- g576))
- (cdr g575))))
- (cons 'map
- (cons (list 'lambda
- g577
- g575)
- g576)))))
- (map cdr g574)
- (map (lambda (g581)
- (list 'ref (car g581)))
- g574))))
- (g484
- (lambda (g507 g506)
- (list 'apply
- '(primitive append)
- (g485 g507 g506))))
- (g483
- (lambda (g569 g566 g568 g567)
- (if (= g568 '0)
- (values g566 g567)
- (if (null? g567)
- (syntax-error
- g569
- '"missing ellipsis in syntax form")
- (call-with-values
- (lambda ()
- (g483 g569
- g566
- (- g568 '1)
- (cdr g567)))
- (lambda (g571 g570)
- ((lambda (g572)
- (if g572
- (values
- (cdr g572)
- g567)
- ((lambda (g573)
- (values
- g573
- (cons (cons (cons g571
- g573)
- (car g567))
- g570)))
- (g451 'tmp))))
- (assq g571 (car g567)))))))))
- (g482
- (lambda (g512 g508 g511 g509 g510)
- (if (g256 g508)
- ((lambda (g513)
- ((lambda (g514)
- (if (eq? (g232 g514) 'syntax)
- (call-with-values
- (lambda ()
- ((lambda (g517)
- (g483 g512
- (car g517)
- (cdr g517)
- g509))
- (g233 g514)))
- (lambda (g516 g515)
- (values
- (list 'ref g516)
- g515)))
- (if (g510 g508)
- (syntax-error
- g512
- '"misplaced ellipsis in syntax form")
- (values
- (list 'quote g508)
- g509))))
- (g253 g513 g511)))
- (g377 g508 '(())))
- ((lambda (g518)
- ((lambda (g519)
- (if (if g519
- (apply
- (lambda (g521 g520)
- (g510 g521))
- g519)
- '#f)
- (apply
- (lambda (g523 g522)
- (g482 g512
- g522
- g511
- g509
- (lambda (g524)
- '#f)))
- g519)
- ((lambda (g525)
- (if (if g525
- (apply
- (lambda (g528
- g526
- g527)
- (g510 g526))
- g525)
- '#f)
- (apply
- (lambda (g531
- g529
- g530)
- ((letrec ((g532
- (lambda (g534
- g533)
- ((lambda (g535)
- ((lambda (g536)
- (if (if g536
- (apply
- (lambda (g538
- g537)
- (g510 g538))
- g536)
- '#f)
- (apply
- (lambda (g540
- g539)
- (g532 g539
- (lambda (g541)
- (call-with-values
- (lambda ()
- (g533 (cons '()
- g541)))
- (lambda (g543
- g542)
- (if (null?
- (car g542))
- (syntax-error
- g512
- '"extra ellipsis in syntax form")
- (values
- (g484 g543
- (car g542))
- (cdr g542))))))))
- g536)
- ((lambda (g544)
- (call-with-values
- (lambda ()
- (g482 g512
- g534
- g511
- g509
- g510))
- (lambda (g546
- g545)
- (call-with-values
- (lambda ()
- (g533 g545))
- (lambda (g548
- g547)
- (values
- (g487 g548
- g546)
- g547))))))
- g535)))
- ($syntax-dispatch
- g535
- '(any .
- any))))
- g534))))
- g532)
- g530
- (lambda (g549)
- (call-with-values
- (lambda ()
- (g482 g512
- g531
- g511
- (cons '()
- g549)
- g510))
- (lambda (g551
- g550)
- (if (null?
- (car g550))
- (syntax-error
- g512
- '"extra ellipsis in syntax form")
- (values
- (g485 g551
- (car g550))
- (cdr g550))))))))
- g525)
- ((lambda (g552)
- (if g552
- (apply
- (lambda (g554
- g553)
- (call-with-values
- (lambda ()
- (g482 g512
- g554
- g511
- g509
- g510))
- (lambda (g556
- g555)
- (call-with-values
- (lambda ()
- (g482 g512
- g553
- g511
- g555
- g510))
- (lambda (g558
- g557)
- (values
- (g486 g556
- g558)
- g557))))))
- g552)
- ((lambda (g559)
- (if g559
- (apply
- (lambda (g561
- g560)
- (call-with-values
- (lambda ()
- (g482 g512
- (cons g561
- g560)
- g511
- g509
- g510))
- (lambda (g563
- g562)
- (values
- (g488 g563)
- g562))))
- g559)
- ((lambda (g565)
- (values
- (list 'quote
- g508)
- g509))
- g518)))
- ($syntax-dispatch
- g518
- '#(vector
- (any .
- each-any))))))
- ($syntax-dispatch
- g518
- '(any . any)))))
- ($syntax-dispatch
- g518
- '(any any . any)))))
- ($syntax-dispatch
- g518
- '(any any))))
- g508)))))
- (lambda (g493 g490 g492 g491)
- ((lambda (g494)
- ((lambda (g495)
- ((lambda (g496)
- (if g496
- (apply
- (lambda (g498 g497)
- (call-with-values
- (lambda ()
- (g482 g494
- g497
- g490
- '()
- g447))
- (lambda (g500 g499)
- (g489 g500))))
- g496)
- ((lambda (g501) (syntax-error g494))
- g495)))
- ($syntax-dispatch g495 '(any any))))
- g494))
- (g394 g493 g492 g491)))))))
- (g254 'core
- 'lambda
- (lambda (g785 g782 g784 g783)
- ((lambda (g786)
- ((lambda (g787)
- (if g787
- (apply
- (lambda (g789 g788)
- (g444 (g394 g785 g784 g783)
- g788
- g782
- g784
- (lambda (g791 g790)
- (list 'lambda g791 g790))))
- g787)
- (syntax-error g786)))
- ($syntax-dispatch g786 '(any . any))))
- g785)))
- (g254 'core
- 'letrec
- (lambda (g590 g587 g589 g588)
- ((lambda (g591)
- ((lambda (g592)
- (if g592
- (apply
- (lambda (g597 g593 g596 g594 g595)
- ((lambda (g598)
- (if (not (g389 g598))
- (g391 (map (lambda (g599)
- (g393 g599 g589))
- g598)
- (g394 g590 g589 g588)
- '"bound variable")
- ((lambda (g601 g600)
- ((lambda (g603 g602)
- (g191 g588
- g600
- (map (lambda (g606)
- (g432 g606
- g602
- g603))
- g596)
- (g437 (cons g594 g595)
- (g394 g590
- g603
- g588)
- g602
- g603)))
- (g368 g598 g601 g589)
- (g248 g601 g600 g587)))
- (g299 g598)
- (map g451 g598))))
- g593))
- g592)
- ((lambda (g608)
- (syntax-error (g394 g590 g589 g588)))
- g591)))
- ($syntax-dispatch
- g591
- '(any #(each (any any)) any . each-any))))
- g590)))
- (g254 'core
- 'if
- (lambda (g770 g767 g769 g768)
- ((lambda (g771)
- ((lambda (g772)
- (if g772
- (apply
- (lambda (g775 g773 g774)
- (list 'if
- (g432 g773 g767 g769)
- (g432 g774 g767 g769)
- (g446)))
- g772)
- ((lambda (g776)
- (if g776
- (apply
- (lambda (g780 g777 g779 g778)
- (list 'if
- (g432 g777 g767 g769)
- (g432 g779 g767 g769)
- (g432 g778 g767 g769)))
- g776)
- ((lambda (g781)
- (syntax-error
- (g394 g770 g769 g768)))
- g771)))
- ($syntax-dispatch
- g771
- '(any any any any)))))
- ($syntax-dispatch g771 '(any any any))))
- g770)))
- (g254 'set! 'set! '())
- (g254 'begin 'begin '())
- (g254 'module-key 'module '())
- (g254 'import 'import '#f)
- (g254 'import 'import-only '#t)
- (g254 'define 'define '())
- (g254 'define-syntax 'define-syntax '())
- (g254 'eval-when 'eval-when '())
- (g254 'core
- 'syntax-case
- ((lambda ()
- (letrec ((g612
- (lambda (g693 g690 g692 g691)
- (if (null? g692)
- (list 'syntax-error g693)
- ((lambda (g694)
- ((lambda (g695)
- (if g695
- (apply
- (lambda (g697 g696)
- (if (if (g256 g697)
- (if (not (g392 g697
- g690))
- (not (g447 g697))
- '#f)
- '#f)
- ((lambda (g699 g698)
- (list (list 'lambda
- (list g698)
- (g432 g696
- (g246 g699
- (g231 'syntax
- (cons g698
- '0))
- g691)
- (g368 (list g697)
- (list g699)
- '(()))))
- g693))
- (g297)
- (g451 g697))
- (g611 g693
- g690
- (cdr g692)
- g691
- g697
- '#t
- g696)))
- g695)
- ((lambda (g700)
- (if g700
- (apply
- (lambda (g703
- g701
- g702)
- (g611 g693
- g690
- (cdr g692)
- g691
- g703
- g701
- g702))
- g700)
- ((lambda (g704)
- (syntax-error
- (car g692)
- '"invalid syntax-case clause"))
- g694)))
- ($syntax-dispatch
- g694
- '(any any any)))))
- ($syntax-dispatch
- g694
- '(any any))))
- (car g692)))))
- (g611
- (lambda (g635 g629 g634 g630 g633 g631 g632)
- (call-with-values
- (lambda () (g609 g633 g629))
- (lambda (g637 g636)
- (if (not (g390 (map car g636)))
- (g391 (map car g636)
- g633
- '"pattern variable")
- (if (not (andmap
- (lambda (g638)
- (not (g447 (car g638))))
- g636))
- (syntax-error
- g633
- '"misplaced ellipsis in syntax-case pattern")
- ((lambda (g639)
- (list (list 'lambda
- (list g639)
- (list 'if
- ((lambda (g649)
- ((lambda (g650)
- (if g650
- (apply
- (lambda ()
- g639)
- g650)
- ((lambda (g651)
- (list 'if
- g639
- (g610 g636
- g631
- g639
- g630)
- (list 'quote
- '#f)))
- g649)))
- ($syntax-dispatch
- g649
- '#(atom
- #t))))
- g631)
- (g610 g636
- g632
- g639
- g630)
- (g612 g635
- g629
- g634
- g630)))
- (if (eq? g637 'any)
- (list 'list g635)
- (list '$syntax-dispatch
- g635
- (list 'quote
- g637)))))
- (g451 'tmp))))))))
- (g610
- (lambda (g683 g680 g682 g681)
- ((lambda (g685 g684)
- ((lambda (g687 g686)
- (list 'apply
- (list 'lambda
- g686
- (g432 g680
- (g247 g687
- (map (lambda (g689
- g688)
- (g231 'syntax
- (cons g689
- g688)))
- g686
- (map cdr
- g683))
- g681)
- (g368 g685
- g687
- '(()))))
- g682))
- (g299 g685)
- (map g451 g685)))
- (map car g683)
- (map cdr g683))))
- (g609
- (lambda (g653 g652)
- ((letrec ((g654
- (lambda (g657 g655 g656)
- (if (g256 g657)
- (if (g392 g657 g652)
- (values
- (vector
- 'free-id
- g657)
- g656)
- (values
- 'any
- (cons (cons g657
- g655)
- g656)))
- ((lambda (g658)
- ((lambda (g659)
- (if (if g659
- (apply
- (lambda (g661
- g660)
- (g447 g660))
- g659)
- '#f)
- (apply
- (lambda (g663
- g662)
- (call-with-values
- (lambda ()
- (g654 g663
- (+ g655
- '1)
- g656))
- (lambda (g665
- g664)
- (values
- (if (eq? g665
- 'any)
- 'each-any
- (vector
- 'each
- g665))
- g664))))
- g659)
- ((lambda (g666)
- (if g666
- (apply
- (lambda (g668
- g667)
- (call-with-values
- (lambda ()
- (g654 g667
- g655
- g656))
- (lambda (g670
- g669)
- (call-with-values
- (lambda ()
- (g654 g668
- g655
- g669))
- (lambda (g672
- g671)
- (values
- (cons g672
- g670)
- g671))))))
- g666)
- ((lambda (g673)
- (if g673
- (apply
- (lambda ()
- (values
- '()
- g656))
- g673)
- ((lambda (g674)
- (if g674
- (apply
- (lambda (g675)
- (call-with-values
- (lambda ()
- (g654 g675
- g655
- g656))
- (lambda (g677
- g676)
- (values
- (vector
- 'vector
- g677)
- g676))))
- g674)
- ((lambda (g679)
- (values
- (vector
- 'atom
- (g450 g657
- '(())))
- g656))
- g658)))
- ($syntax-dispatch
- g658
- '#(vector
- each-any)))))
- ($syntax-dispatch
- g658
- '()))))
- ($syntax-dispatch
- g658
- '(any .
- any)))))
- ($syntax-dispatch
- g658
- '(any any))))
- g657)))))
- g654)
- g653
- '0
- '()))))
- (lambda (g616 g613 g615 g614)
- ((lambda (g617)
- ((lambda (g618)
- ((lambda (g619)
- (if g619
- (apply
- (lambda (g623 g620 g622 g621)
- (if (andmap
- (lambda (g625)
- (if (g256 g625)
- (not (g447 g625))
- '#f))
- g622)
- ((lambda (g626)
- (list (list 'lambda
- (list g626)
- (g612 g626
- g622
- g621
- g613))
- (g432 g620
- g613
- '(()))))
- (g451 'tmp))
- (syntax-error
- g617
- '"invalid literals list in")))
- g619)
- (syntax-error g618)))
- ($syntax-dispatch
- g618
- '(any any each-any . each-any))))
- g617))
- (g394 g616 g615 g614)))))))
- (set! sc-expand
- ((lambda (g763 g761 g762)
- ((lambda (g764)
- (lambda (g765)
- (if (if (pair? g765) (equal? (car g765) g53) '#f)
- (cadr g765)
- (g400 g765 '() g764 g763 g761 g762))))
- (g263 (g264 '((top))) (cons g762 (g265 '((top)))))))
- 'e
- '(eval)
- ((lambda (g766) (begin (g366 g766 '*top*) g766))
- (g304 '() '() '()))))
- (set! identifier? (lambda (g705) (g255 g705)))
- (set! datum->syntax-object
- (lambda (g759 g758)
- (begin ((lambda (g760)
- (if (not (g255 g760))
- (g93 'datum->syntax-object
- '"invalid argument"
- g760)
- (void)))
- g759)
- (g203 g758 (g206 g759)))))
- (set! syntax-object->datum
- (lambda (g706) (g450 g706 '(()))))
- (set! generate-temporaries
- (lambda (g755)
- (begin ((lambda (g757)
- (if (not (list? g757))
- (g93 'generate-temporaries
- '"invalid argument"
- g757)
- (void)))
- g755)
- (map (lambda (g756) (g393 (gensym) '((top))))
- g755))))
- (set! free-identifier=?
- (lambda (g708 g707)
- (begin ((lambda (g710)
- (if (not (g255 g710))
- (g93 'free-identifier=?
- '"invalid argument"
- g710)
- (void)))
- g708)
- ((lambda (g709)
- (if (not (g255 g709))
- (g93 'free-identifier=?
- '"invalid argument"
- g709)
- (void)))
- g707)
- (g378 g708 g707))))
- (set! bound-identifier=?
- (lambda (g752 g751)
- (begin ((lambda (g754)
- (if (not (g255 g754))
- (g93 'bound-identifier=?
- '"invalid argument"
- g754)
- (void)))
- g752)
- ((lambda (g753)
- (if (not (g255 g753))
- (g93 'bound-identifier=?
- '"invalid argument"
- g753)
- (void)))
- g751)
- (g388 g752 g751))))
- (set! syntax-error
- (lambda (g711 . g712)
- (begin (for-each
- (lambda (g714)
- ((lambda (g715)
- (if (not (string? g715))
- (g93 'syntax-error
- '"invalid argument"
- g715)
- (void)))
- g714))
- g712)
- ((lambda (g713) (g93 '#f g713 (g450 g711 '(()))))
- (if (null? g712)
- '"invalid syntax"
- (apply string-append g712))))))
- ((lambda ()
- (letrec ((g720
- (lambda (g748 g745 g747 g746)
- (if (not g746)
- '#f
- (if (eq? g745 'any)
- (cons (g393 g748 g747) g746)
- (if (g204 g748)
- (g719 ((lambda (g749)
- (if (g90 g749)
- (annotation-expression
- g749)
- g749))
- (g205 g748))
- g745
- (g371 g747 (g206 g748))
- g746)
- (g719 ((lambda (g750)
- (if (g90 g750)
- (annotation-expression
- g750)
- g750))
- g748)
- g745
- g747
- g746))))))
- (g719
- (lambda (g728 g725 g727 g726)
- (if (null? g725)
- (if (null? g728) g726 '#f)
- (if (pair? g725)
- (if (pair? g728)
- (g720 (car g728)
- (car g725)
- g727
- (g720 (cdr g728)
- (cdr g725)
- g727
- g726))
- '#f)
- (if (eq? g725 'each-any)
- ((lambda (g729)
- (if g729 (cons g729 g726) '#f))
- (g717 g728 g727))
- ((lambda (g730)
- (if (memv g730 '(each))
- (if (null? g728)
- (g718 (vector-ref
- g725
- '1)
- g726)
- ((lambda (g731)
- (if g731
- ((letrec ((g732
- (lambda (g733)
- (if (null?
- (car g733))
- g726
- (cons (map car
- g733)
- (g732 (map cdr
- g733)))))))
- g732)
- g731)
- '#f))
- (g716 g728
- (vector-ref
- g725
- '1)
- g727)))
- (if (memv g730 '(free-id))
- (if (g256 g728)
- (if (g378 (g393 g728
- g727)
- (vector-ref
- g725
- '1))
- g726
- '#f)
- '#f)
- (if (memv g730 '(atom))
- (if (equal?
- (vector-ref
- g725
- '1)
- (g450 g728
- g727))
- g726
- '#f)
- (if (memv g730
- '(vector))
- (if (vector?
- g728)
- (g720 (vector->list
- g728)
- (vector-ref
- g725
- '1)
- g727
- g726)
- '#f)
- (void))))))
- (vector-ref g725 '0)))))))
- (g718
- (lambda (g743 g742)
- (if (null? g743)
- g742
- (if (eq? g743 'any)
- (cons '() g742)
- (if (pair? g743)
- (g718 (car g743)
- (g718 (cdr g743) g742))
- (if (eq? g743 'each-any)
- (cons '() g742)
- ((lambda (g744)
- (if (memv g744 '(each))
- (g718 (vector-ref
- g743
- '1)
- g742)
- (if (memv g744
- '(free-id
- atom))
- g742
- (if (memv g744
- '(vector))
- (g718 (vector-ref
- g743
- '1)
- g742)
- (void)))))
- (vector-ref g743 '0))))))))
- (g717
- (lambda (g735 g734)
- (if (g90 g735)
- (g717 (annotation-expression g735) g734)
- (if (pair? g735)
- ((lambda (g736)
- (if g736
- (cons (g393 (car g735) g734)
- g736)
- '#f))
- (g717 (cdr g735) g734))
- (if (null? g735)
- '()
- (if (g204 g735)
- (g717 (g205 g735)
- (g371 g734 (g206 g735)))
- '#f))))))
- (g716
- (lambda (g739 g737 g738)
- (if (g90 g739)
- (g716 (annotation-expression g739)
- g737
- g738)
- (if (pair? g739)
- ((lambda (g740)
- (if g740
- ((lambda (g741)
- (if g741
- (cons g740 g741)
- '#f))
- (g716 (cdr g739) g737 g738))
- '#f))
- (g720 (car g739) g737 g738 '()))
- (if (null? g739)
- '()
- (if (g204 g739)
- (g716 (g205 g739)
- g737
- (g371 g738 (g206 g739)))
- '#f)))))))
- (set! $syntax-dispatch
- (lambda (g722 g721)
- (if (eq? g721 'any)
- (list g722)
- (if (g204 g722)
- (g719 ((lambda (g723)
- (if (g90 g723)
- (annotation-expression g723)
- g723))
- (g205 g722))
- g721
- (g206 g722)
- '())
- (g719 ((lambda (g724)
- (if (g90 g724)
- (annotation-expression g724)
- g724))
- g722)
- g721
- '(())
- '()))))))))))))
-($sc-put-cte
- 'with-syntax
- (lambda (g1828)
- ((lambda (g1829)
- ((lambda (g1830)
- (if g1830
- (apply
- (lambda (g1833 g1831 g1832)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(_ e1 e2)
- #((top) (top) (top))
- #("i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ())))
- (cons g1831 g1832)))
- g1830)
- ((lambda (g1835)
- (if g1835
- (apply
- (lambda (g1840 g1836 g1839 g1837 g1838)
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g1839
- '()
- (list g1836
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons g1837 g1838)))))
- g1835)
- ((lambda (g1842)
- (if g1842
- (apply
- (lambda (g1847 g1843 g1846 g1844 g1845)
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons '#(syntax-object
- list
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g1846)
- '()
- (list g1843
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(_ out in e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1844 g1845)))))
- g1842)
- (syntax-error g1829)))
- ($syntax-dispatch
- g1829
- '(any #(each (any any)) any . each-any)))))
- ($syntax-dispatch
- g1829
- '(any ((any any)) any . each-any)))))
- ($syntax-dispatch g1829 '(any () any . each-any))))
- g1828)))
-($sc-put-cte
- 'syntax-rules
- (lambda (g1851)
- ((lambda (g1852)
- ((lambda (g1853)
- (if g1853
- (apply
- (lambda (g1858 g1854 g1857 g1855 g1856)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_ k keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ())))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ k keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ()))))
- (cons '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ k keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons '#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ k keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons g1854
- (map (lambda (g1861 g1860)
- (list (cons '#(syntax-object
- dummy
- ((top)
- #(ribcage
- #(_
- k
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1860)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- k
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1861)))
- g1856
- g1855))))))
- g1853)
- (syntax-error g1852)))
- ($syntax-dispatch
- g1852
- '(any each-any . #(each ((any . any) any))))))
- g1851)))
-($sc-put-cte
- 'or
- (lambda (g1862)
- ((lambda (g1863)
- ((lambda (g1864)
- (if g1864
- (apply
- (lambda (g1865)
- '#(syntax-object
- #f
- ((top)
- #(ribcage #(_) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ()))))
- g1864)
- ((lambda (g1866)
- (if g1866
- (apply (lambda (g1868 g1867) g1867) g1866)
- ((lambda (g1869)
- (if g1869
- (apply
- (lambda (g1873 g1870 g1872 g1871)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1870))
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons '#(syntax-object
- or
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1872 g1871)))))
- g1869)
- (syntax-error g1863)))
- ($syntax-dispatch g1863 '(any any any . each-any)))))
- ($syntax-dispatch g1863 '(any any)))))
- ($syntax-dispatch g1863 '(any))))
- g1862)))
-($sc-put-cte
- 'and
- (lambda (g1875)
- ((lambda (g1876)
- ((lambda (g1877)
- (if g1877
- (apply
- (lambda (g1881 g1878 g1880 g1879)
- (cons '#(syntax-object
- if
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ())))
- (cons g1878
- (cons (cons '#(syntax-object
- and
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons g1880 g1879))
- '(#(syntax-object
- #f
- ((top)
- #(ribcage
- #(_ e1 e2 e3)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))))))
- g1877)
- ((lambda (g1883)
- (if g1883
- (apply (lambda (g1885 g1884) g1884) g1883)
- ((lambda (g1886)
- (if g1886
- (apply
- (lambda (g1887)
- '#(syntax-object
- #t
- ((top)
- #(ribcage #(_) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- g1886)
- (syntax-error g1876)))
- ($syntax-dispatch g1876 '(any)))))
- ($syntax-dispatch g1876 '(any any)))))
- ($syntax-dispatch g1876 '(any any any . each-any))))
- g1875)))
-($sc-put-cte
- 'let
- (lambda (g1888)
- ((lambda (g1889)
- ((lambda (g1890)
- (if (if g1890
- (apply
- (lambda (g1895 g1891 g1894 g1892 g1893)
- (andmap identifier? g1891))
- g1890)
- '#f)
- (apply
- (lambda (g1901 g1897 g1900 g1898 g1899)
- (cons (cons '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_ x v e1 e2)
- #((top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons g1897 (cons g1898 g1899)))
- g1900))
- g1890)
- ((lambda (g1905)
- (if (if g1905
- (apply
- (lambda (g1911 g1906 g1910 g1907 g1909 g1908)
- (andmap identifier? (cons g1906 g1910)))
- g1905)
- '#f)
- (apply
- (lambda (g1918 g1913 g1917 g1914 g1916 g1915)
- (cons (list '#(syntax-object
- letrec
- ((top)
- #(ribcage
- #(_ f x v e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (list (list g1913
- (cons '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_
- f
- x
- v
- e1
- e2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1917
- (cons g1916
- g1915)))))
- g1913)
- g1914))
- g1905)
- (syntax-error g1889)))
- ($syntax-dispatch
- g1889
- '(any any #(each (any any)) any . each-any)))))
- ($syntax-dispatch
- g1889
- '(any #(each (any any)) any . each-any))))
- g1888)))
-($sc-put-cte
- 'let*
- (lambda (g1922)
- ((lambda (g1923)
- ((lambda (g1924)
- (if (if g1924
- (apply
- (lambda (g1929 g1925 g1928 g1926 g1927)
- (andmap identifier? g1925))
- g1924)
- '#f)
- (apply
- (lambda (g1935 g1931 g1934 g1932 g1933)
- ((letrec ((g1936
- (lambda (g1937)
- (if (null? g1937)
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(bindings)
- #((top))
- #("i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(let* x v e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons '() (cons g1932 g1933)))
- ((lambda (g1939)
- ((lambda (g1940)
- (if g1940
- (apply
- (lambda (g1942 g1941)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(body
- binding)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(bindings)
- #((top))
- #("i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(let*
- x
- v
- e1
- e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list g1941)
- g1942))
- g1940)
- (syntax-error g1939)))
- ($syntax-dispatch
- g1939
- '(any any))))
- (list (g1936 (cdr g1937))
- (car g1937)))))))
- g1936)
- (map list g1931 g1934)))
- g1924)
- (syntax-error g1923)))
- ($syntax-dispatch
- g1923
- '(any #(each (any any)) any . each-any))))
- g1922)))
-($sc-put-cte
- 'cond
- (lambda (g1945)
- ((lambda (g1946)
- ((lambda (g1947)
- (if g1947
- (apply
- (lambda (g1950 g1948 g1949)
- ((letrec ((g1951
- (lambda (g1953 g1952)
- (if (null? g1952)
- ((lambda (g1954)
- ((lambda (g1955)
- (if g1955
- (apply
- (lambda (g1957 g1956)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_ m1 m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1957 g1956)))
- g1955)
- ((lambda (g1959)
- (if g1959
- (apply
- (lambda (g1960)
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1960))
- '((#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))))))
- g1959)
- ((lambda (g1961)
- (if g1961
- (apply
- (lambda (g1963
- g1962)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1963))
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1962
- '(#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))))))
- g1961)
- ((lambda (g1964)
- (if g1964
- (apply
- (lambda (g1967
- g1965
- g1966)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1967
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e0
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1965
- g1966))))
- g1964)
- ((lambda (g1969)
- (syntax-error
- g1945))
- g1954)))
- ($syntax-dispatch
- g1954
- '(any any
- .
- each-any)))))
- ($syntax-dispatch
- g1954
- '(any #(free-id
- #(syntax-object
- =>
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- any)))))
- ($syntax-dispatch
- g1954
- '(any)))))
- ($syntax-dispatch
- g1954
- '(#(free-id
- #(syntax-object
- else
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(clause clauses)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_ m1 m2)
- #((top) (top) (top))
- #("i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- any
- .
- each-any))))
- g1953)
- ((lambda (g1970)
- ((lambda (g1971)
- ((lambda (g1972)
- ((lambda (g1973)
- (if g1973
- (apply
- (lambda (g1974)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1974))
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0)
- #((top))
- #("i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1971)))
- g1973)
- ((lambda (g1975)
- (if g1975
- (apply
- (lambda (g1977
- g1976)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1977))
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1976
- '(#(syntax-object
- t
- ((top)
- #(ribcage
- #(e0
- e1)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))))
- g1971)))
- g1975)
- ((lambda (g1978)
- (if g1978
- (apply
- (lambda (g1981
- g1979
- g1980)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e0
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1981
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e0
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g1979
- g1980))
- g1971))
- g1978)
- ((lambda (g1983)
- (syntax-error
- g1945))
- g1972)))
- ($syntax-dispatch
- g1972
- '(any any
- .
- each-any)))))
- ($syntax-dispatch
- g1972
- '(any #(free-id
- #(syntax-object
- =>
- ((top)
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- m1
- m2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- any)))))
- ($syntax-dispatch
- g1972
- '(any))))
- g1953))
- g1970))
- (g1951 (car g1952) (cdr g1952)))))))
- g1951)
- g1948
- g1949))
- g1947)
- (syntax-error g1946)))
- ($syntax-dispatch g1946 '(any any . each-any))))
- g1945)))
-($sc-put-cte
- 'do
- (lambda (g1985)
- ((lambda (g1986)
- ((lambda (g1987)
- (if g1987
- (apply
- (lambda (g1994 g1988 g1993 g1989 g1992 g1990 g1991)
- ((lambda (g1995)
- ((lambda (g2005)
- (if g2005
- (apply
- (lambda (g2006)
- ((lambda (g2007)
- ((lambda (g2009)
- (if g2009
- (apply
- (lambda ()
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (map list g1988 g1993)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- not
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1992)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (append
- g1991
- (list (cons '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2006)))))))
- g2009)
- ((lambda (g2014)
- (if g2014
- (apply
- (lambda (g2016 g2015)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e1 e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(e1 e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (map list
- g1988
- g1993)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g1992
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2016
- g2015))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (append
- g1991
- (list (cons '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(e1
- e2)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(step)
- #((top))
- #("i"))
- #(ribcage
- #(_
- var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2006)))))))
- g2014)
- (syntax-error g2007)))
- ($syntax-dispatch
- g2007
- '(any . each-any)))))
- ($syntax-dispatch g2007 '())))
- g1990))
- g2005)
- (syntax-error g1995)))
- ($syntax-dispatch g1995 'each-any)))
- (map (lambda (g1999 g1998)
- ((lambda (g2000)
- ((lambda (g2001)
- (if g2001
- (apply (lambda () g1999) g2001)
- ((lambda (g2002)
- (if g2002
- (apply
- (lambda (g2003) g2003)
- g2002)
- ((lambda (g2004)
- (syntax-error g1985))
- g2000)))
- ($syntax-dispatch g2000 '(any)))))
- ($syntax-dispatch g2000 '())))
- g1998))
- g1988
- g1989)))
- g1987)
- (syntax-error g1986)))
- ($syntax-dispatch
- g1986
- '(any #(each (any any . any))
- (any . each-any)
- .
- each-any))))
- g1985)))
-($sc-put-cte
- 'quasiquote
- (letrec ((g2030
- (lambda (g2142)
- (if (identifier? g2142)
- (free-identifier=?
- g2142
- '#(syntax-object
- quote
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
- #(ribcage ((import-token . *top*)) () ()))))
- '#f)))
- (g2022
- (lambda (g2036)
- (if (identifier? g2036)
- (free-identifier=?
- g2036
- '#(syntax-object
- list
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
- #(ribcage ((import-token . *top*)) () ()))))
- '#f)))
- (g2029
- (lambda (g2141)
- (if (identifier? g2141)
- (free-identifier=?
- g2141
- '#(syntax-object
- cons
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
- #(ribcage ((import-token . *top*)) () ()))))
- '#f)))
- (g2023
- (lambda (g2037)
- ((lambda (g2038)
- ((lambda (g2039)
- (if g2039
- (apply (lambda (g2040) (g2030 g2040)) g2039)
- ((lambda (g2041) '#f) g2038)))
- ($syntax-dispatch g2038 '(any ()))))
- g2037)))
- (g2028
- (lambda (g2138 g2137)
- ((letrec ((g2139
- (lambda (g2140)
- (if (null? g2140)
- g2137
- (g2024 (car g2140) (g2139 (cdr g2140)))))))
- g2139)
- g2138)))
- (g2024
- (lambda (g2043 g2042)
- ((lambda (g2044)
- ((lambda (g2045)
- (if g2045
- (apply
- (lambda (g2047 g2046)
- ((lambda (g2048)
- ((lambda (g2049)
- (if (if g2049
- (apply
- (lambda (g2051 g2050)
- (g2030 g2051))
- g2049)
- '#f)
- (apply
- (lambda (g2053 g2052)
- ((lambda (g2054)
- ((lambda (g2055)
- (if (if g2055
- (apply
- (lambda (g2057
- g2056)
- (g2030 g2057))
- g2055)
- '#f)
- (apply
- (lambda (g2059 g2058)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(quote?
- dx)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(quote?
- dy)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(x y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2058
- g2052)))
- g2055)
- ((lambda (g2060)
- (if (null? g2052)
- (list '#(syntax-object
- list
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(quote?
- dy)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2047)
- (list '#(syntax-object
- cons
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(quote?
- dy)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- y)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2047
- g2046)))
- g2054)))
- ($syntax-dispatch
- g2054
- '(any any))))
- g2047))
- g2049)
- ((lambda (g2061)
- (if (if g2061
- (apply
- (lambda (g2063 g2062)
- (g2022 g2063))
- g2061)
- '#f)
- (apply
- (lambda (g2065 g2064)
- (cons '#(syntax-object
- list
- ((top)
- #(ribcage
- #(listp stuff)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2047 g2064)))
- g2061)
- ((lambda (g2066)
- (list '#(syntax-object
- cons
- ((top)
- #(ribcage
- #(else)
- #((top))
- #("i"))
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2047
- g2046))
- g2048)))
- ($syntax-dispatch
- g2048
- '(any . any)))))
- ($syntax-dispatch g2048 '(any any))))
- g2046))
- g2045)
- (syntax-error g2044)))
- ($syntax-dispatch g2044 '(any any))))
- (list g2043 g2042))))
- (g2027
- (lambda (g2129 g2128)
- ((lambda (g2130)
- (if (null? g2130)
- '(#(syntax-object
- quote
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(ls) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x y) #((top) (top)) #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
- #(ribcage ((import-token . *top*)) () ())))
- ())
- (if (null? (cdr g2130))
- (car g2130)
- ((lambda (g2131)
- ((lambda (g2132)
- (if g2132
- (apply
- (lambda (g2133)
- (cons '#(syntax-object
- append
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ls)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g2133))
- g2132)
- (syntax-error g2131)))
- ($syntax-dispatch g2131 'each-any)))
- g2130))))
- ((letrec ((g2135
- (lambda (g2136)
- (if (null? g2136)
- (if (g2023 g2128) '() (list g2128))
- (if (g2023 (car g2136))
- (g2135 (cdr g2136))
- (cons (car g2136)
- (g2135 (cdr g2136))))))))
- g2135)
- g2129))))
- (g2025
- (lambda (g2067)
- ((lambda (g2068)
- ((lambda (g2069)
- ((lambda (g2070)
- ((lambda (g2071)
- (if (if g2071
- (apply
- (lambda (g2073 g2072) (g2030 g2073))
- g2071)
- '#f)
- (apply
- (lambda (g2075 g2074)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(quote? x)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(pat-x)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (list->vector g2074)))
- g2071)
- ((lambda (g2077)
- ((letrec ((g2078
- (lambda (g2080 g2079)
- ((lambda (g2081)
- ((lambda (g2082)
- (if (if g2082
- (apply
- (lambda (g2084
- g2083)
- (g2030
- g2084))
- g2082)
- '#f)
- (apply
- (lambda (g2086
- g2085)
- (g2079
- (map (lambda (g2087)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(quote?
- x)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- k)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(pat-x)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2087))
- g2085)))
- g2082)
- ((lambda (g2088)
- (if (if g2088
- (apply
- (lambda (g2090
- g2089)
- (g2022
- g2090))
- g2088)
- '#f)
- (apply
- (lambda (g2092
- g2091)
- (g2079
- g2091))
- g2088)
- ((lambda (g2094)
- (if (if g2094
- (apply
- (lambda (g2097
- g2095
- g2096)
- (g2029
- g2097))
- g2094)
- '#f)
- (apply
- (lambda (g2100
- g2098
- g2099)
- (g2078
- g2099
- (lambda (g2101)
- (g2079
- (cons g2098
- g2101)))))
- g2094)
- ((lambda (g2102)
- (list '#(syntax-object
- list->vector
- ((top)
- #(ribcage
- #(else)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x
- k)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(pat-x)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2069))
- g2081)))
- ($syntax-dispatch
- g2081
- '(any any
- any)))))
- ($syntax-dispatch
- g2081
- '(any .
- each-any)))))
- ($syntax-dispatch
- g2081
- '(any each-any))))
- g2080))))
- g2078)
- g2067
- (lambda (g2103)
- (cons '#(syntax-object
- vector
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ls)
- #((top))
- #("i"))
- #(ribcage
- #(_)
- #((top))
- #("i"))
- #(ribcage
- #(pat-x)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g2103))))
- g2070)))
- ($syntax-dispatch g2070 '(any each-any))))
- g2069))
- g2068))
- g2067)))
- (g2026
- (lambda (g2105 g2104)
- ((lambda (g2106)
- ((lambda (g2107)
- (if g2107
- (apply
- (lambda (g2108)
- (if (= g2104 '0)
- g2108
- (g2024
- '(#(syntax-object
- quote
- ((top)
- #(ribcage #(p) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- #(syntax-object
- unquote
- ((top)
- #(ribcage #(p) #((top)) #("i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- (g2026 (list g2108) (- g2104 '1)))))
- g2107)
- ((lambda (g2109)
- (if g2109
- (apply
- (lambda (g2111 g2110)
- (if (= g2104 '0)
- (g2028 g2111 (g2026 g2110 g2104))
- (g2024
- (g2024
- '(#(syntax-object
- quote
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- #(syntax-object
- unquote
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- (g2026 g2111 (- g2104 '1)))
- (g2026 g2110 g2104))))
- g2109)
- ((lambda (g2114)
- (if g2114
- (apply
- (lambda (g2116 g2115)
- (if (= g2104 '0)
- (g2027
- g2116
- (g2026 g2115 g2104))
- (g2024
- (g2024
- '(#(syntax-object
- quote
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- (g2026
- g2116
- (- g2104 '1)))
- (g2026 g2115 g2104))))
- g2114)
- ((lambda (g2119)
- (if g2119
- (apply
- (lambda (g2120)
- (g2024
- '(#(syntax-object
- quote
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- quasiquote
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))
- (g2026
- (list g2120)
- (+ g2104 '1))))
- g2119)
- ((lambda (g2121)
- (if g2121
- (apply
- (lambda (g2123 g2122)
- (g2024
- (g2026
- g2123
- g2104)
- (g2026
- g2122
- g2104)))
- g2121)
- ((lambda (g2124)
- (if g2124
- (apply
- (lambda (g2125)
- (g2025
- (g2026
- g2125
- g2104)))
- g2124)
- ((lambda (g2127)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(p
- lev)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2127))
- g2106)))
- ($syntax-dispatch
- g2106
- '#(vector
- each-any)))))
- ($syntax-dispatch
- g2106
- '(any . any)))))
- ($syntax-dispatch
- g2106
- '(#(free-id
- #(syntax-object
- quasiquote
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- any)))))
- ($syntax-dispatch
- g2106
- '((#(free-id
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- .
- each-any)
- .
- any)))))
- ($syntax-dispatch
- g2106
- '((#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- .
- each-any)
- .
- any)))))
- ($syntax-dispatch
- g2106
- '(#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage () () ())
- #(ribcage #(p lev) #((top) (top)) #("i" "i"))
- #(ribcage
- #(isquote?
- islist?
- iscons?
- quote-nil?
- quasilist*
- quasicons
- quasiappend
- quasivector
- quasi)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i" "i" "i" "i"))
- #(ribcage ((import-token . *top*)) () ()))))
- any))))
- g2105))))
- (lambda (g2031)
- ((lambda (g2032)
- ((lambda (g2033)
- (if g2033
- (apply (lambda (g2035 g2034) (g2026 g2034 '0)) g2033)
- (syntax-error g2032)))
- ($syntax-dispatch g2032 '(any any))))
- g2031))))
-($sc-put-cte
- 'include
- (lambda (g2143)
- (letrec ((g2144
- (lambda (g2155 g2154)
- ((lambda (g2156)
- ((letrec ((g2157
- (lambda ()
- ((lambda (g2158)
- (if (eof-object? g2158)
- (begin (close-input-port g2156) '())
- (cons (datum->syntax-object
- g2154
- g2158)
- (g2157))))
- (read g2156)))))
- g2157)))
- (open-input-file g2155)))))
- ((lambda (g2145)
- ((lambda (g2146)
- (if g2146
- (apply
- (lambda (g2148 g2147)
- ((lambda (g2149)
- ((lambda (g2150)
- ((lambda (g2151)
- (if g2151
- (apply
- (lambda (g2152)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(exp)
- #((top))
- #("i"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(fn)
- #((top))
- #("i"))
- #(ribcage
- #(k filename)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- (read-file)
- ((top))
- ("i"))
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g2152))
- g2151)
- (syntax-error g2150)))
- ($syntax-dispatch g2150 'each-any)))
- (g2144 g2149 g2148)))
- (syntax-object->datum g2147)))
- g2146)
- (syntax-error g2145)))
- ($syntax-dispatch g2145 '(any any))))
- g2143))))
-($sc-put-cte
- 'unquote
- (lambda (g2159)
- ((lambda (g2160)
- ((lambda (g2161)
- (if g2161
- (apply
- (lambda (g2163 g2162)
- (syntax-error
- g2159
- '"expression not valid outside of quasiquote"))
- g2161)
- (syntax-error g2160)))
- ($syntax-dispatch g2160 '(any . each-any))))
- g2159)))
-($sc-put-cte
- 'unquote-splicing
- (lambda (g2164)
- ((lambda (g2165)
- ((lambda (g2166)
- (if g2166
- (apply
- (lambda (g2168 g2167)
- (syntax-error
- g2164
- '"expression not valid outside of quasiquote"))
- g2166)
- (syntax-error g2165)))
- ($syntax-dispatch g2165 '(any . each-any))))
- g2164)))
-($sc-put-cte
- 'case
- (lambda (g2169)
- ((lambda (g2170)
- ((lambda (g2171)
- (if g2171
- (apply
- (lambda (g2175 g2172 g2174 g2173)
- ((lambda (g2176)
- ((lambda (g2203)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage #(body) #((top)) #("i"))
- #(ribcage
- #(_ e m1 m2)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage
- #(body)
- #((top))
- #("i"))
- #(ribcage
- #(_ e m1 m2)
- #((top) (top) (top) (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g2172))
- g2203))
- g2176))
- ((letrec ((g2177
- (lambda (g2179 g2178)
- (if (null? g2178)
- ((lambda (g2180)
- ((lambda (g2181)
- (if g2181
- (apply
- (lambda (g2183 g2182)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_ e m1 m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2183
- g2182)))
- g2181)
- ((lambda (g2185)
- (if g2185
- (apply
- (lambda (g2188
- g2186
- g2187)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2188))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2186
- g2187))))
- g2185)
- ((lambda (g2191)
- (syntax-error
- g2169))
- g2180)))
- ($syntax-dispatch
- g2180
- '(each-any
- any
- .
- each-any)))))
- ($syntax-dispatch
- g2180
- '(#(free-id
- #(syntax-object
- else
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(clause clauses)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_ e m1 m2)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- any
- .
- each-any))))
- g2179)
- ((lambda (g2192)
- ((lambda (g2193)
- ((lambda (g2194)
- ((lambda (g2195)
- (if g2195
- (apply
- (lambda (g2198
- g2196
- g2197)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2198))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(clause
- clauses)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(f)
- #((top))
- #("i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2196
- g2197))
- g2193))
- g2195)
- ((lambda (g2201)
- (syntax-error
- g2169))
- g2194)))
- ($syntax-dispatch
- g2194
- '(each-any
- any
- .
- each-any))))
- g2179))
- g2192))
- (g2177 (car g2178) (cdr g2178)))))))
- g2177)
- g2174
- g2173)))
- g2171)
- (syntax-error g2170)))
- ($syntax-dispatch g2170 '(any any any . each-any))))
- g2169)))
-($sc-put-cte
- 'identifier-syntax
- (lambda (g2204)
- ((lambda (g2205)
- ((lambda (g2206)
- (if g2206
- (apply
- (lambda (g2208 g2207)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage #(_ e) #((top) (top)) #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ())))
- '(#(syntax-object
- x
- ((top)
- #(ribcage #(_ e) #((top) (top)) #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ()))))
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '()
- (list '#(syntax-object
- id
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '(#(syntax-object
- identifier?
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- #(syntax-object
- id
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- g2207))
- (list (cons g2208
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- (cons g2207
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(_ e)
- #((top) (top))
- #("i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ()))))))))))
- g2206)
- ((lambda (g2209)
- (if (if g2209
- (apply
- (lambda (g2215 g2210 g2214 g2211 g2213 g2212)
- (if (identifier? g2210)
- (identifier? g2211)
- '#f))
- g2209)
- '#f)
- (apply
- (lambda (g2221 g2216 g2220 g2217 g2219 g2218)
- (list '#(syntax-object
- cons
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top) (top) (top) (top) (top) (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '(#(syntax-object
- quote
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- #(syntax-object
- macro!
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '#(syntax-object
- x
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ())))
- '(#(syntax-object
- set!
- ((top)
- #(ribcage
- #(_ id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token . *top*))
- ()
- ()))))
- (list (list '#(syntax-object
- set!
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2217
- g2219)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2218))
- (list (cons g2216
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (cons g2220
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))))))
- (list g2216
- (list '#(syntax-object
- identifier?
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2216))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(_
- id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i"))
- #(ribcage
- ((import-token
- .
- *top*))
- ()
- ())))
- g2220))))))
- g2209)
- (syntax-error g2205)))
- ($syntax-dispatch
- g2205
- '(any (any any)
- ((#(free-id
- #(syntax-object
- set!
- ((top)
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i"))
- #(ribcage ((import-token . *top*)) () ()))))
- any
- any)
- any))))))
- ($syntax-dispatch g2205 '(any any))))
- g2204)))
diff --git a/module/language/r5rs/psyntax.ss b/module/language/r5rs/psyntax.ss
deleted file mode 100644
index c8ac3e503..000000000
--- a/module/language/r5rs/psyntax.ss
+++ /dev/null
@@ -1,3202 +0,0 @@
-;;; Portable implementation of syntax-case
-;;; Extracted from Chez Scheme Version 6.3
-;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
-
-;;; Copyright (c) 1992-2000 Cadence Research Systems
-;;; Permission to copy this software, in whole or in part, to use this
-;;; software for any lawful purpose, and to redistribute this software
-;;; is granted subject to the restriction that all copies made of this
-;;; software must include this copyright notice in full. This software
-;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
-;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
-;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
-;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
-;;; NATURE WHATSOEVER.
-
-;;; Before attempting to port this code to a new implementation of
-;;; Scheme, please read the notes below carefully.
-
-;;; This file defines the syntax-case expander, sc-expand, and a set
-;;; of associated syntactic forms and procedures. Of these, the
-;;; following are documented in The Scheme Programming Language,
-;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996), which can be
-;;; found online at http://www.scheme.com. Most are also documented
-;;; in the R4RS and draft R5RS.
-;;;
-;;; bound-identifier=?
-;;; datum->syntax-object
-;;; define-syntax
-;;; fluid-let-syntax
-;;; free-identifier=?
-;;; generate-temporaries
-;;; identifier?
-;;; identifier-syntax
-;;; let-syntax
-;;; letrec-syntax
-;;; syntax
-;;; syntax-case
-;;; syntax-object->datum
-;;; syntax-rules
-;;; with-syntax
-;;;
-;;; All standard Scheme syntactic forms are supported by the expander
-;;; or syntactic abstractions defined in this file. Only the R4RS
-;;; delay is omitted, since its expansion is implementation-dependent.
-
-;;; Also defined are three forms that support modules: module, import,
-;;; and import-only. These are documented in the Chez Scheme User's
-;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
-;;; also be found online at http://www.scheme.com. They are described
-;;; briefly here as well.
-;;;
-;;; Both are definitions and may appear where and only where other
-;;; definitions may appear. modules may be named:
-;;;
-;;; (module id (ex ...) defn ... init ...)
-;;;
-;;; or anonymous:
-;;;
-;;; (module (ex ...) defn ... init ...)
-;;;
-;;; The latter form is semantically equivalent to:
-;;;
-;;; (module T (ex ...) defn ... init ...)
-;;; (import T)
-;;;
-;;; where T is a fresh identifier.
-;;;
-;;; In either form, each of the exports in (ex ...) is either an
-;;; identifier or of the form (id ex ...). In the former case, the
-;;; single identifier ex is exported. In the latter, the identifier
-;;; id is exported and the exports ex ... are "implicitly" exported.
-;;; This listing of implicit exports is useful only when id is a
-;;; keyword bound to a transformer that expands into references to
-;;; the listed implicit exports. In the present implementation,
-;;; listing of implicit exports is necessary only for top-level
-;;; modules and allows the implementation to avoid placing all
-;;; identifiers into the top-level environment where subsequent passes
-;;; of the compiler will be unable to deal effectively with them.
-;;;
-;;; Named modules may be referenced in import statements, which
-;;; always take one of the forms:
-;;;
-;;; (import id)
-;;; (import-only id)
-;;;
-;;; id must name a module. Each exported identifier becomes visible
-;;; within the scope of the import form. In the case of import-only,
-;;; all other identifiers become invisible in the scope of the
-;;; import-only form, except for those established by definitions
-;;; that appear textually after the import-only form.
-
-;;; The remaining exports are listed below. sc-expand, eval-when, and
-;;; syntax-error are described in the Chez Scheme User's Guide.
-;;;
-;;; (sc-expand datum)
-;;; if datum represents a valid expression, sc-expand returns an
-;;; expanded version of datum in a core language that includes no
-;;; syntactic abstractions. The core language includes begin,
-;;; define, if, lambda, letrec, quote, and set!.
-;;; (eval-when situations expr ...)
-;;; conditionally evaluates expr ... at compile-time or run-time
-;;; depending upon situations
-;;; (syntax-error object message)
-;;; used to report errors found during expansion
-;;; ($syntax-dispatch e p)
-;;; used by expanded code to handle syntax-case matching
-;;; ($sc-put-cte symbol val)
-;;; used to establish top-level compile-time (expand-time) bindings.
-
-;;; The following nonstandard procedures must be provided by the
-;;; implementation for this code to run.
-;;;
-;;; (void)
-;;; returns the implementation's cannonical "unspecified value". The
-;;; following usually works:
-;;;
-;;; (define void (lambda () (if #f #f))).
-;;;
-;;; (andmap proc list1 list2 ...)
-;;; returns true if proc returns true when applied to each element of list1
-;;; along with the corresponding elements of list2 .... The following
-;;; definition works but does no error checking:
-;;;
-;;; (define andmap
-;;; (lambda (f first . rest)
-;;; (or (null? first)
-;;; (if (null? rest)
-;;; (let andmap ((first first))
-;;; (let ((x (car first)) (first (cdr first)))
-;;; (if (null? first)
-;;; (f x)
-;;; (and (f x) (andmap first)))))
-;;; (let andmap ((first first) (rest rest))
-;;; (let ((x (car first))
-;;; (xr (map car rest))
-;;; (first (cdr first))
-;;; (rest (map cdr rest)))
-;;; (if (null? first)
-;;; (apply f (cons x xr))
-;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
-;;;
-;;; (ormap proc list1)
-;;; returns the first non-false return result of proc applied to
-;;; the elements of list1 or false if none. The following definition
-;;; works but does no error checking:
-;;;
-;;; (define ormap
-;;; (lambda (proc list1)
-;;; (and (not (null? list1))
-;;; (or (proc (car list1)) (ormap proc (cdr list1))))))
-;;;
-;;; The following nonstandard procedures must also be provided by the
-;;; implementation for this code to run using the standard portable
-;;; hooks and output constructors. They are not used by expanded code,
-;;; and so need be present only at expansion time.
-;;;
-;;; (eval x)
-;;; where x is always in the form ("noexpand" expr).
-;;; returns the value of expr. the "noexpand" flag is used to tell the
-;;; evaluator/expander that no expansion is necessary, since expr has
-;;; already been fully expanded to core forms.
-;;;
-;;; eval will not be invoked during the loading of psyntax.pp. After
-;;; psyntax.pp has been loaded, the expansion of any macro definition,
-;;; whether local or global, results in a call to eval. If, however,
-;;; sc-expand has already been registered as the expander to be used
-;;; by eval, and eval accepts one argument, nothing special must be done
-;;; to support the "noexpand" flag, since it is handled by sc-expand.
-;;;
-;;; (error who format-string why what)
-;;; where who is either a symbol or #f, format-string is always "~a ~s",
-;;; why is always a string, and what may be any object. error should
-;;; signal an error with a message something like
-;;;
-;;; "error in <who>: <why> <what>"
-;;;
-;;; (gensym)
-;;; returns a unique symbol each time it's called. In Chez Scheme, gensym
-;;; returns a symbol with a "globally" unique name so that gensyms that
-;;; end up in the object code of separately compiled files cannot conflict.
-;;; This is necessary only if you intend to support compiled files.
-;;;
-;;; (putprop symbol key value)
-;;; (getprop symbol key)
-;;; (remprop symbol key)
-;;; key is always a symbol; value may be any object. putprop should
-;;; associate the given value with the given symbol and key in some way
-;;; that it can be retrieved later with getprop. getprop should return
-;;; #f if no value is associated with the given symbol and key. remprop
-;;; should remove the association between the given symbol and key.
-
-;;; When porting to a new Scheme implementation, you should define the
-;;; procedures listed above, load the expanded version of psyntax.ss
-;;; (psyntax.pp, which should be available whereever you found
-;;; psyntax.ss), and register sc-expand as the current expander (how
-;;; you do this depends upon your implementation of Scheme). You may
-;;; change the hooks and constructors defined toward the beginning of
-;;; the code below, but to avoid bootstrapping problems, do so only
-;;; after you have a working version of the expander.
-
-;;; Chez Scheme allows the syntactic form (syntax <template>) to be
-;;; abbreviated to #'<template>, just as (quote <datum>) may be
-;;; abbreviated to '<datum>. The #' syntax makes programs written
-;;; using syntax-case shorter and more readable and draws out the
-;;; intuitive connection between syntax and quote. If you have access
-;;; to the source code of your Scheme system's reader, you might want
-;;; to implement this extension.
-
-;;; If you find that this code loads or runs slowly, consider
-;;; switching to faster hardware or a faster implementation of
-;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
-;;; compiling (with full optimization), and loading this file takes
-;;; between one and two seconds.
-
-;;; In the expander implementation, we sometimes use syntactic abstractions
-;;; when procedural abstractions would suffice. For example, we define
-;;; top-wrap and top-marked? as
-;;; (define-syntax top-wrap (identifier-syntax '((top))))
-;;; (define-syntax top-marked?
-;;; (syntax-rules ()
-;;; ((_ w) (memq 'top (wrap-marks w)))))
-;;; rather than
-;;; (define top-wrap '((top)))
-;;; (define top-marked?
-;;; (lambda (w) (memq 'top (wrap-marks w))))
-;;; On ther other hand, we don't do this consistently; we define make-wrap,
-;;; wrap-marks, and wrap-subst simply as
-;;; (define make-wrap cons)
-;;; (define wrap-marks car)
-;;; (define wrap-subst cdr)
-;;; In Chez Scheme, the syntactic and procedural forms of these
-;;; abstractions are equivalent, since the optimizer consistently
-;;; integrates constants and small procedures. Some Scheme
-;;; implementations, however, may benefit from more consistent use
-;;; of one form or the other.
-
-
-;;; Implementation notes:
-
-;;; "begin" is treated as a splicing construct at top level and at
-;;; the beginning of bodies. Any sequence of expressions that would
-;;; be allowed where the "begin" occurs is allowed.
-
-;;; "let-syntax" and "letrec-syntax" are also treated as splicing
-;;; constructs, in violation of the R5RS. A consequence is that let-syntax
-;;; and letrec-syntax do not create local contours, as do let and letrec.
-;;; Although the functionality is greater as it is presently implemented,
-;;; we will probably change it to conform to the R5RS. modules provide
-;;; similar functionality to nonsplicing letrec-syntax when the latter is
-;;; used as a definition.
-
-;;; Objects with no standard print syntax, including objects containing
-;;; cycles and syntax objects, are allowed in quoted data as long as they
-;;; are contained within a syntax form or produced by datum->syntax-object.
-;;; Such objects are never copied.
-
-;;; When the expander encounters a reference to an identifier that has
-;;; no global or lexical binding, it treats it as a global-variable
-;;; reference. This allows one to write mutually recursive top-level
-;;; definitions, e.g.:
-;;;
-;;; (define f (lambda (x) (g x)))
-;;; (define g (lambda (x) (f x)))
-;;;
-;;; but may not always yield the intended when the variable in question
-;;; is later defined as a keyword.
-
-;;; Top-level variable definitions of syntax keywords are permitted.
-;;; In order to make this work, top-level define not only produces a
-;;; top-level definition in the core language, but also modifies the
-;;; compile-time environment (using $sc-put-cte) to record the fact
-;;; that the identifier is a variable.
-
-;;; Top-level definitions of macro-introduced identifiers are visible
-;;; only in code produced by the macro. That is, a binding for a
-;;; hidden (generated) identifier is created instead, and subsequent
-;;; references within the macro output are renamed accordingly. For
-;;; example:
-;;;
-;;; (define-syntax a
-;;; (syntax-rules ()
-;;; ((_ var exp)
-;;; (begin
-;;; (define secret exp)
-;;; (define var
-;;; (lambda ()
-;;; (set! secret (+ secret 17))
-;;; secret))))))
-;;; (a x 0)
-;;; (x) => 17
-;;; (x) => 34
-;;; secret => Error: variable secret is not bound
-;;;
-;;; The definition above would fail if the definition for secret
-;;; were placed after the definition for var, since the expander would
-;;; encounter the references to secret before the definition that
-;;; establishes the compile-time map from the identifier secret to
-;;; the generated identifier.
-
-;;; Identifiers and syntax objects are implemented as vectors for
-;;; portability. As a result, it is possible to "forge" syntax
-;;; objects.
-
-;;; The input to sc-expand may contain "annotations" describing, e.g., the
-;;; source file and character position from where each object was read if
-;;; it was read from a file. These annotations are handled properly by
-;;; sc-expand only if the annotation? hook (see hooks below) is implemented
-;;; properly and the operators make-annotation, annotation-expression,
-;;; annotation-source, annotation-stripped, and set-annotation-stripped!
-;;; are supplied. If annotations are supplied, the proper annotation
-;;; source is passed to the various output constructors, allowing
-;;; implementations to accurately correlate source and expanded code.
-;;; Contact one of the authors for details if you wish to make use of
-;;; this feature.
-
-;;; Implementation of modules:
-;;;
-;;; The implementation of modules requires that implicit top-level exports
-;;; be listed with the exported macro at some level where both are visible,
-;;; e.g.,
-;;;
-;;; (module M (alpha (beta b))
-;;; (module ((alpha a) b)
-;;; (define-syntax alpha (identifier-syntax a))
-;;; (define a 'a)
-;;; (define b 'b))
-;;; (define-syntax beta (identifier-syntax b)))
-;;;
-;;; Listing of implicit imports is not needed for macros that do not make
-;;; it out to top level, including all macros that are local to a "body".
-;;; (They may be listed in this case, however.) We need this information
-;;; for top-level modules since a top-level module expands into a letrec
-;;; for non-top-level variables and top-level definitions (assignments) for
-;;; top-level variables. Because of the general nature of macro
-;;; transformers, we cannot determine the set of implicit exports from the
-;;; transformer code, so without the user's help, we'd have to put all
-;;; variables at top level.
-;;;
-;;; Each such top-level identifier is given a generated name (gensym).
-;;; When a top-level module is imported at top level, a compile-time
-;;; alias is established from the top-level name to the generated name.
-;;; The expander follows these aliases transparently. When any module is
-;;; imported anywhere other than at top level, the id-var-name of the
-;;; import identifier is set to the id-var-name of the export identifier.
-;;; Since we can't determine the actual labels for identifiers defined in
-;;; top-level modules until we determine which are placed in the letrec
-;;; and which make it to top level, we give each an "indirect" label---a
-;;; pair whose car will eventually contain the actual label. Import does
-;;; not follow the indirect, but id-var-name does.
-;;;
-;;; All identifiers defined within a local module are folded into the
-;;; letrec created for the enclosing body. Visibility is controlled in
-;;; this case and for nested top-level modules by introducing a new wrap
-;;; for each module.
-
-
-;;; Bootstrapping:
-
-;;; When changing syntax-object representations, it is necessary to support
-;;; both old and new syntax-object representations in id-var-name. It
-;;; should be sufficient to recognize old representations and treat
-;;; them as not lexically bound.
-
-
-(let ()
-
-(define-syntax when
- (syntax-rules ()
- ((_ test e1 e2 ...) (if test (begin e1 e2 ...)))))
-(define-syntax unless
- (syntax-rules ()
- ((_ test e1 e2 ...) (when (not test) (begin e1 e2 ...)))))
-(define-syntax define-structure
- (lambda (x)
- (define construct-name
- (lambda (template-identifier . args)
- (datum->syntax-object
- template-identifier
- (string->symbol
- (apply string-append
- (map (lambda (x)
- (if (string? x)
- x
- (symbol->string (syntax-object->datum x))))
- args))))))
- (syntax-case x ()
- ((_ (name id1 ...))
- (andmap identifier? (syntax (name id1 ...)))
- (with-syntax
- ((constructor (construct-name (syntax name) "make-" (syntax name)))
- (predicate (construct-name (syntax name) (syntax name) "?"))
- ((access ...)
- (map (lambda (x) (construct-name x (syntax name) "-" x))
- (syntax (id1 ...))))
- ((assign ...)
- (map (lambda (x)
- (construct-name x "set-" (syntax name) "-" x "!"))
- (syntax (id1 ...))))
- (structure-length
- (+ (length (syntax (id1 ...))) 1))
- ((index ...)
- (let f ((i 1) (ids (syntax (id1 ...))))
- (if (null? ids)
- '()
- (cons i (f (+ i 1) (cdr ids)))))))
- (syntax (begin
- (define constructor
- (lambda (id1 ...)
- (vector 'name id1 ... )))
- (define predicate
- (lambda (x)
- (and (vector? x)
- (= (vector-length x) structure-length)
- (eq? (vector-ref x 0) 'name))))
- (define access
- (lambda (x)
- (vector-ref x index)))
- ...
- (define assign
- (lambda (x update)
- (vector-set! x index update)))
- ...)))))))
-
-(define noexpand "noexpand")
-
-;;; hooks to nonportable run-time helpers
-(begin
-(define-syntax fx+ (identifier-syntax +))
-(define-syntax fx- (identifier-syntax -))
-(define-syntax fx= (identifier-syntax =))
-(define-syntax fx< (identifier-syntax <))
-
-(define annotation? (lambda (x) #f))
-
-(define top-level-eval-hook
- (lambda (x)
- (eval `(,noexpand ,x))))
-
-(define local-eval-hook
- (lambda (x)
- (eval `(,noexpand ,x))))
-
-(define error-hook
- (lambda (who why what)
- (error who "~a ~s" why what)))
-
-(define-syntax gensym-hook
- (syntax-rules ()
- ((_) (gensym))))
-
-(define put-global-definition-hook
- (lambda (symbol val)
- ($sc-put-cte symbol val)))
-
-(define get-global-definition-hook
- (lambda (symbol)
- (getprop symbol '*sc-expander*)))
-
-(define get-import-binding
- (lambda (symbol token)
- (getprop symbol token)))
-
-(define generate-id
- (let ((b (- 127 32 2)))
- ; session-key should generate a unique integer for each system run
- ; to support separate compilation
- (define session-key (lambda () 0))
- (define make-digit (lambda (x) (integer->char (fx+ x 33))))
- (define fmt
- (lambda (n)
- (let fmt ((n n) (a '()))
- (if (< n b)
- (list->string (cons (make-digit n) a))
- (let ((r (modulo n b)) (rest (quotient n b)))
- (fmt rest (cons (make-digit r) a)))))))
- (let ((prefix (fmt (session-key))) (n -1))
- (lambda (name)
- (set! n (+ n 1))
- (let ((newsym (string->symbol (string-append "#" prefix (fmt n)))))
- newsym)))))
-)
-
-
-;;; output constructors
-(begin
-(define-syntax build-application
- (syntax-rules ()
- ((_ source fun-exp arg-exps)
- `(,fun-exp . ,arg-exps))))
-
-(define-syntax build-conditional
- (syntax-rules ()
- ((_ source test-exp then-exp else-exp)
- `(if ,test-exp ,then-exp ,else-exp))))
-
-(define-syntax build-lexical-reference
- (syntax-rules ()
- ((_ type source var)
- var)))
-
-(define-syntax build-lexical-assignment
- (syntax-rules ()
- ((_ source var exp)
- `(set! ,var ,exp))))
-
-(define-syntax build-global-reference
- (syntax-rules ()
- ((_ source var)
- var)))
-
-(define-syntax build-global-assignment
- (syntax-rules ()
- ((_ source var exp)
- `(set! ,var ,exp))))
-
-(define-syntax build-global-definition
- (syntax-rules ()
- ((_ source var exp)
- `(define ,var ,exp))))
-
-(define-syntax build-module-definition
- ; should have the effect of a global definition but may not appear at top level
- (identifier-syntax build-global-assignment))
-
-(define-syntax build-cte-install
- ; should build a call that has the same effect as calling the
- ; global definition hook
- (syntax-rules ()
- ((_ sym exp) `($sc-put-cte ',sym ,exp))))
-
-(define-syntax build-lambda
- (syntax-rules ()
- ((_ src vars exp)
- `(lambda ,vars ,exp))))
-
-(define-syntax build-primref
- (syntax-rules ()
- ((_ src name) name)
- ((_ src level name) name)))
-
-(define-syntax build-data
- (syntax-rules ()
- ((_ src exp) `',exp)))
-
-(define build-sequence
- (lambda (src exps)
- (if (null? (cdr exps))
- (car exps)
- `(begin ,@exps))))
-
-(define build-letrec
- (lambda (src vars val-exps body-exp)
- (if (null? vars)
- body-exp
- `(letrec ,(map list vars val-exps) ,body-exp))))
-
-(define-syntax build-lexical-var
- (syntax-rules ()
- ((_ src id) (gensym))))
-
-(define-syntax self-evaluating?
- (syntax-rules ()
- ((_ e)
- (let ((x e))
- (or (boolean? x) (number? x) (string? x) (char? x) (null? x))))))
-)
-
-(define-structure (syntax-object expression wrap))
-
-(define-syntax unannotate
- (syntax-rules ()
- ((_ x)
- (let ((e x))
- (if (annotation? e)
- (annotation-expression e)
- e)))))
-
-(define-syntax no-source (identifier-syntax #f))
-
-(define source-annotation
- (lambda (x)
- (cond
- ((annotation? x) (annotation-source x))
- ((syntax-object? x) (source-annotation (syntax-object-expression x)))
- (else no-source))))
-
-(define-syntax arg-check
- (syntax-rules ()
- ((_ pred? e who)
- (let ((x e))
- (if (not (pred? x)) (error-hook who "invalid argument" x))))))
-
-;;; compile-time environments
-
-;;; wrap and environment comprise two level mapping.
-;;; wrap : id --> label
-;;; env : label --> <element>
-
-;;; environments are represented in two parts: a lexical part and a global
-;;; part. The lexical part is a simple list of associations from labels
-;;; to bindings. The global part is implemented by
-;;; {put,get}-global-definition-hook and associates symbols with
-;;; bindings.
-
-;;; global (assumed global variable) and displaced-lexical (see below)
-;;; do not show up in any environment; instead, they are fabricated by
-;;; lookup when it finds no other bindings.
-
-;;; <environment> ::= ((<label> . <binding>)*)
-
-;;; identifier bindings include a type and a value
-
-;;; <binding> ::= (macro . <procedure>) macros
-;;; (deferred . <expanded code>) lazy-evaluation of transformers
-;;; (core . <procedure>) core forms
-;;; (begin) begin
-;;; (define) define
-;;; (define-syntax) define-syntax
-;;; (local-syntax . rec?) let-syntax/letrec-syntax
-;;; (eval-when) eval-when
-;;; (syntax . (<var> . <level>)) pattern variables
-;;; (global . <symbol>) assumed global variable
-;;; (lexical . <var>) lexical variables
-;;; (displaced-lexical . #f) id-var-name not found in store
-;;; <level> ::= <nonnegative integer>
-;;; <var> ::= variable returned by build-lexical-var
-
-;;; a macro is a user-defined syntactic-form. a core is a system-defined
-;;; syntactic form. begin, define, define-syntax, and eval-when are
-;;; treated specially since they are sensitive to whether the form is
-;;; at top-level and (except for eval-when) can denote valid internal
-;;; definitions.
-
-;;; a pattern variable is a variable introduced by syntax-case and can
-;;; be referenced only within a syntax form.
-
-;;; any identifier for which no top-level syntax definition or local
-;;; binding of any kind has been seen is assumed to be a global
-;;; variable.
-
-;;; a lexical variable is a lambda- or letrec-bound variable.
-
-;;; a displaced-lexical identifier is a lexical identifier removed from
-;;; it's scope by the return of a syntax object containing the identifier.
-;;; a displaced lexical can also appear when a letrec-syntax-bound
-;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
-;;; a displaced lexical should never occur with properly written macros.
-
-(define make-binding (lambda (x y) (cons x y)))
-(define binding-type car)
-(define binding-value cdr)
-(define set-binding-type! set-car!)
-(define set-binding-value! set-cdr!)
-(define binding? (lambda (x) (and (pair? x) (symbol? (car x)))))
-
-(define-syntax null-env (identifier-syntax '()))
-
-(define extend-env
- (lambda (label binding r)
- (cons (cons label binding) r)))
-
-(define extend-env*
- (lambda (labels bindings r)
- (if (null? labels)
- r
- (extend-env* (cdr labels) (cdr bindings)
- (extend-env (car labels) (car bindings) r)))))
-
-(define extend-var-env*
- ; variant of extend-env* that forms "lexical" binding
- (lambda (labels vars r)
- (if (null? labels)
- r
- (extend-var-env* (cdr labels) (cdr vars)
- (extend-env (car labels) (make-binding 'lexical (car vars)) r)))))
-
-;;; we use a "macros only" environment in expansion of local macro
-;;; definitions so that their definitions can use local macros without
-;;; attempting to use other lexical identifiers.
-;;;
-;;; - can make this null-env if we don't want to allow macros to use other
-;;; macros in defining their transformers
-;;; - can add a cache here if it pays off
-(define transformer-env
- (lambda (r)
- (if (null? r)
- '()
- (let ((a (car r)))
- (if (eq? (cadr a) 'lexical) ; only strip out lexical so that (transformer x) works
- (transformer-env (cdr r))
- (cons a (transformer-env (cdr r))))))))
-
-(define displaced-lexical-error
- (lambda (id)
- (syntax-error id
- (if (id-var-name id empty-wrap)
- "identifier out of context"
- "identifier not visible"))))
-
-(define lookup*
- ; x may be a label or a symbol
- ; although symbols are usually global, we check the environment first
- ; anyway because a temporary binding may have been established by
- ; fluid-let-syntax
- (lambda (x r)
- (cond
- ((assq x r) => cdr)
- ((symbol? x)
- (or (get-global-definition-hook x) (make-binding 'global x)))
- (else (make-binding 'displaced-lexical #f)))))
-
-(define sanitize-binding
- (lambda (b)
- (cond
- ((procedure? b) (make-binding 'macro b))
- ((binding? b)
- (case (binding-type b)
- ((core macro macro!) (and (procedure? (binding-value b)) b))
- ((module) (and (interface? (binding-value b)) b))
- (else b)))
- (else #f))))
-
-(define lookup
- (lambda (x r)
- (define whack-binding!
- (lambda (b *b)
- (set-binding-type! b (binding-type *b))
- (set-binding-value! b (binding-value *b))))
- (let ((b (lookup* x r)))
- (case (binding-type b)
-; ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r))
- ((deferred)
- (whack-binding! b
- (let ((*b (local-eval-hook (binding-value b))))
- (or (sanitize-binding *b)
- (syntax-error *b "invalid transformer"))))
- (case (binding-type b)
-; ((*alias) (lookup (id-var-name (binding-value b) empty-wrap) r))
- (else b)))
- (else b)))))
-
-(define global-extend
- (lambda (type sym val)
- (put-global-definition-hook sym (make-binding type val))))
-
-
-;;; Conceptually, identifiers are always syntax objects. Internally,
-;;; however, the wrap is sometimes maintained separately (a source of
-;;; efficiency and confusion), so that symbols are also considered
-;;; identifiers by id?. Externally, they are always wrapped.
-
-(define nonsymbol-id?
- (lambda (x)
- (and (syntax-object? x)
- (symbol? (unannotate (syntax-object-expression x))))))
-
-(define id?
- (lambda (x)
- (cond
- ((symbol? x) #t)
- ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
- ((annotation? x) (symbol? (annotation-expression x)))
- (else #f))))
-
-(define-syntax id-sym-name
- (syntax-rules ()
- ((_ e)
- (let ((x e))
- (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
-
-(define id-sym-name&marks
- (lambda (x w)
- (if (syntax-object? x)
- (values
- (unannotate (syntax-object-expression x))
- (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
- (values (unannotate x) (wrap-marks w)))))
-
-;;; syntax object wraps
-
-;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
-;;; <subst> ::= <ribcage> | <shift>
-;;; <ribcage> ::= #((<ex-symname> ...) (<mark> ...) (<label> ...)) ; extensible, for chi-internal/external
-;;; | #(#(<symname> ...) #(<mark> ...) #(<label> ...)) ; nonextensible
-;;; <ex-symname> ::= <symname> | <import token> | <barrier>
-;;; <shift> ::= shift
-;;; <barrier> ::= #f ; inserted by import-only
-;;; <import token> ::= #<"import-token" <token>>
-;;; <token> ::= <generated id>
-
-(define make-wrap cons)
-(define wrap-marks car)
-(define wrap-subst cdr)
-
-(define-syntax subst-rename? (identifier-syntax vector?))
-(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
-(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
-(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
-(define-syntax make-rename
- (syntax-rules ()
- ((_ old new marks) (vector old new marks))))
-
-;;; labels
-
-;;; simple labels must be comparable with "eq?" and distinct from symbols
-;;; and pairs.
-
-;;; indirect labels, which are implemented as pairs, are used to support
-;;; import aliasing for identifiers exported (explictly or implicitly) from
-;;; top-level modules. chi-external creates an indirect label for each
-;;; defined identifier, import causes the pair to be shared aliases it
-;;; establishes, and chi-top-module whacks the pair to hold the top-level
-;;; identifier name (symbol) if the id is to be placed at top level, before
-;;; expanding the right-hand sides of the definitions in the module.
-
-(define gen-label
- (lambda () (string #\i)))
-(define label?
- (lambda (x)
- (or (string? x) ; normal lexical labels
- (symbol? x) ; global labels (symbolic names)
- (indirect-label? x))))
-
-(define gen-labels
- (lambda (ls)
- (if (null? ls)
- '()
- (cons (gen-label) (gen-labels (cdr ls))))))
-
-(define gen-indirect-label
- (lambda () (list (gen-label))))
-
-(define indirect-label? pair?)
-(define get-indirect-label car)
-(define set-indirect-label! set-car!)
-
-(define-structure (ribcage symnames marks labels))
-(define-syntax empty-wrap (identifier-syntax '(())))
-
-(define-syntax top-wrap (identifier-syntax '((top))))
-
-(define-syntax top-marked?
- (syntax-rules ()
- ((_ w) (memq 'top (wrap-marks w)))))
-
-(define-syntax only-top-marked?
- (syntax-rules ()
- ((_ id) (same-marks? (wrap-marks (syntax-object-wrap id)) (wrap-marks top-wrap)))))
-
-;;; Marks must be comparable with "eq?" and distinct from pairs and
-;;; the symbol top. We do not use integers so that marks will remain
-;;; unique even across file compiles.
-
-(define-syntax the-anti-mark (identifier-syntax #f))
-
-(define anti-mark
- (lambda (w)
- (make-wrap (cons the-anti-mark (wrap-marks w))
- (cons 'shift (wrap-subst w)))))
-
-(define-syntax new-mark
- (syntax-rules ()
- ((_) (string #\m))))
-
-(define barrier-marker #f)
-(module (make-import-token import-token? import-token-key)
- (define tag 'import-token)
- (define make-import-token (lambda (x) (cons tag x)))
- (define import-token? (lambda (x) (and (pair? x) (eq? (car x) tag))))
- (define import-token-key cdr))
-
-;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
-;;; internal definitions, in which the ribcages are built incrementally
-(define-syntax make-empty-ribcage
- (syntax-rules ()
- ((_) (make-ribcage '() '() '()))))
-
-(define extend-ribcage!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
- (lambda (ribcage id label)
- (set-ribcage-symnames! ribcage
- (cons (unannotate (syntax-object-expression id))
- (ribcage-symnames ribcage)))
- (set-ribcage-marks! ribcage
- (cons (wrap-marks (syntax-object-wrap id))
- (ribcage-marks ribcage)))
- (set-ribcage-labels! ribcage
- (cons label (ribcage-labels ribcage)))))
-
-(define extend-ribcage-barrier!
- ; must receive ids with complete wraps
- ; ribcage guaranteed to be list-based
- (lambda (ribcage killer-id)
- (extend-ribcage-barrier-help! ribcage (syntax-object-wrap killer-id))))
-
-(define extend-ribcage-barrier-help!
- (lambda (ribcage wrap)
- (set-ribcage-symnames! ribcage
- (cons barrier-marker (ribcage-symnames ribcage)))
- (set-ribcage-marks! ribcage
- (cons (wrap-marks wrap) (ribcage-marks ribcage)))))
-
-(define extend-ribcage-subst!
- ; ribcage guaranteed to be list-based
- (lambda (ribcage token)
- (set-ribcage-symnames! ribcage
- (cons (make-import-token token) (ribcage-symnames ribcage)))))
-
-(define lookup-import-binding-name
- (lambda (sym key marks)
- (let ((new (get-import-binding sym key)))
- (and new
- (let f ((new new))
- (cond
- ((pair? new) (or (f (car new)) (f (cdr new))))
- ((same-marks? marks (wrap-marks (syntax-object-wrap new))) new)
- (else #f)))))))
-
-;;; make-binding-wrap creates vector-based ribcages
-(define make-binding-wrap
- (lambda (ids labels w)
- (if (null? ids)
- w
- (make-wrap
- (wrap-marks w)
- (cons
- (let ((labelvec (list->vector labels)))
- (let ((n (vector-length labelvec)))
- (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
- (let f ((ids ids) (i 0))
- (if (not (null? ids))
- (call-with-values
- (lambda () (id-sym-name&marks (car ids) w))
- (lambda (symname marks)
- (vector-set! symnamevec i symname)
- (vector-set! marksvec i marks)
- (f (cdr ids) (fx+ i 1))))))
- (make-ribcage symnamevec marksvec labelvec))))
- (wrap-subst w))))))
-
-;;; make-trimmed-syntax-object is used by make-resolved-interface to support
-;;; creation of module export lists whose constituent ids do not contain
-;;; unnecessary substitutions or marks.
-(define make-trimmed-syntax-object
- (lambda (id)
- (call-with-values
- (lambda () (id-var-name&marks id empty-wrap))
- (lambda (tosym marks)
- (unless tosym
- (syntax-error id "identifier not visible for export"))
- (let ((fromsym (id-sym-name id)))
- (make-syntax-object fromsym
- (make-wrap marks
- (list (make-ribcage (vector fromsym) (vector marks) (vector tosym))))))))))
-
-;;; Scheme's append should not copy the first argument if the second is
-;;; nil, but it does, so we define a smart version here.
-(define smart-append
- (lambda (m1 m2)
- (if (null? m2)
- m1
- (append m1 m2))))
-
-(define join-wraps
- (lambda (w1 w2)
- (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
- (if (null? m1)
- (if (null? s1)
- w2
- (make-wrap
- (wrap-marks w2)
- (smart-append s1 (wrap-subst w2))))
- (make-wrap
- (smart-append m1 (wrap-marks w2))
- (smart-append s1 (wrap-subst w2)))))))
-
-(define join-marks
- (lambda (m1 m2)
- (smart-append m1 m2)))
-
-(define same-marks?
- (lambda (x y)
- (or (eq? x y)
- (and (not (null? x))
- (not (null? y))
- (eq? (car x) (car y))
- (same-marks? (cdr x) (cdr y))))))
-
-(define id-var-name-loc&marks
- (lambda (id w)
- (define search
- (lambda (sym subst marks)
- (if (null? subst)
- (values sym marks)
- (let ((fst (car subst)))
- (if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
- (let ((symnames (ribcage-symnames fst)))
- (if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
- (define search-list-rib
- (lambda (sym subst marks symnames ribcage)
- (let f ((symnames symnames) (i 0))
- (cond
- ((null? symnames) (search sym (cdr subst) marks))
- ((and (eq? (car symnames) sym)
- (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
- ((import-token? (car symnames))
- (cond
- ((lookup-import-binding-name sym (import-token-key (car symnames)) marks) =>
- (lambda (id)
- (if (symbol? id)
- (values id marks)
- (id-var-name&marks id empty-wrap)))) ; could be more efficient: new is a resolved id
- (else (f (cdr symnames) i))))
- ((and (eq? (car symnames) barrier-marker)
- (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values #f marks))
- (else (f (cdr symnames) (fx+ i 1)))))))
- (define search-vector-rib
- (lambda (sym subst marks symnames ribcage)
- (let ((n (vector-length symnames)))
- (let f ((i 0))
- (cond
- ((fx= i n) (search sym (cdr subst) marks))
- ((and (eq? (vector-ref symnames i) sym)
- (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
- (else (f (fx+ i 1))))))))
- (cond
- ((symbol? id) (search id (wrap-subst w) (wrap-marks w)))
- ((syntax-object? id)
- (let ((sym (unannotate (syntax-object-expression id)))
- (w1 (syntax-object-wrap id)))
- (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
- (call-with-values (lambda () (search sym (wrap-subst w) marks))
- (lambda (new-id marks)
- (if (eq? new-id sym)
- (search sym (wrap-subst w1) marks)
- (values new-id marks)))))))
- ((annotation? id) (search (unannotate id) (wrap-subst w) (wrap-marks w)))
- (else (error-hook 'id-var-name "invalid id" id)))))
-
-(define id-var-name&marks
- ; this version follows indirect labels
- (lambda (id w)
- (call-with-values
- (lambda () (id-var-name-loc&marks id w))
- (lambda (label marks)
- (values (if (indirect-label? label) (get-indirect-label label) label) marks)))))
-
-(define id-var-name-loc
- ; this version doesn't follow indirect labels
- (lambda (id w)
- (call-with-values
- (lambda () (id-var-name-loc&marks id w))
- (lambda (label marks) label))))
-
-(define id-var-name
- ; this version follows indirect labels
- (lambda (id w)
- (call-with-values
- (lambda () (id-var-name-loc&marks id w))
- (lambda (label marks)
- (if (indirect-label? label) (get-indirect-label label) label)))))
-
-;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
-;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
-
-(define free-id=?
- (lambda (i j)
- (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
- (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
-(define-syntax literal-id=? (identifier-syntax free-id=?))
-
-;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
-;;; long as the missing portion of the wrap is common to both of the ids
-;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
-
-(define bound-id=?
- (lambda (i j)
- (if (and (syntax-object? i) (syntax-object? j))
- (and (eq? (unannotate (syntax-object-expression i))
- (unannotate (syntax-object-expression j)))
- (same-marks? (wrap-marks (syntax-object-wrap i))
- (wrap-marks (syntax-object-wrap j))))
- (eq? (unannotate i) (unannotate j)))))
-
-;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
-;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
-;;; as long as the missing portion of the wrap is common to all of the
-;;; ids.
-
-(define valid-bound-ids?
- (lambda (ids)
- (and (let all-ids? ((ids ids))
- (or (null? ids)
- (and (id? (car ids))
- (all-ids? (cdr ids)))))
- (distinct-bound-ids? ids))))
-
-;;; distinct-bound-ids? expects a list of ids and returns #t if there are
-;;; no duplicates. It is quadratic on the length of the id list; long
-;;; lists could be sorted to make it more efficient. distinct-bound-ids?
-;;; may be passed unwrapped (or partially wrapped) ids as long as the
-;;; missing portion of the wrap is common to all of the ids.
-
-(define distinct-bound-ids?
- (lambda (ids)
- (let distinct? ((ids ids))
- (or (null? ids)
- (and (not (bound-id-member? (car ids) (cdr ids)))
- (distinct? (cdr ids)))))))
-
-(define invalid-ids-error
- ; find first bad one and complain about it
- (lambda (ids exp class)
- (let find ((ids ids) (gooduns '()))
- (if (null? ids)
- (syntax-error exp) ; shouldn't happen
- (if (id? (car ids))
- (if (bound-id-member? (car ids) gooduns)
- (syntax-error (car ids) "duplicate " class)
- (find (cdr ids) (cons (car ids) gooduns)))
- (syntax-error (car ids) "invalid " class))))))
-
-(define bound-id-member?
- (lambda (x list)
- (and (not (null? list))
- (or (bound-id=? x (car list))
- (bound-id-member? x (cdr list))))))
-
-;;; wrapping expressions and identifiers
-
-(define wrap
- (lambda (x w)
- (cond
- ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
- ((syntax-object? x)
- (make-syntax-object
- (syntax-object-expression x)
- (join-wraps w (syntax-object-wrap x))))
- ((null? x) x)
- (else (make-syntax-object x w)))))
-
-(define source-wrap
- (lambda (x w s)
- (wrap (if s (make-annotation x s #f) x) w)))
-
-;;; expanding
-
-(define chi-sequence
- (lambda (body r w s)
- (build-sequence s
- (let dobody ((body body) (r r) (w w))
- (if (null? body)
- '()
- (let ((first (chi (car body) r w)))
- (cons first (dobody (cdr body) r w))))))))
-
-(define chi-top-sequence
- (lambda (body r w s m esew ribcage)
- (build-sequence s
- (let dobody ((body body) (r r) (w w) (m m) (esew esew))
- (if (null? body)
- '()
- (let ((first (chi-top (car body) r w m esew ribcage)))
- (cons first (dobody (cdr body) r w m esew))))))))
-
-(define chi-when-list
- (lambda (e when-list w)
- ; when-list is syntax'd version of list of situations
- (let f ((when-list when-list) (situations '()))
- (if (null? when-list)
- situations
- (f (cdr when-list)
- (cons (let ((x (car when-list)))
- (cond
- ((literal-id=? x (syntax compile)) 'compile)
- ((literal-id=? x (syntax load)) 'load)
- ((literal-id=? x (syntax eval)) 'eval)
- (else (syntax-error (wrap x w)
- "invalid eval-when situation"))))
- situations))))))
-
-;;; syntax-type returns five values: type, value, e, w, and s. The first
-;;; two are described in the table below.
-;;;
-;;; type value explanation
-;;; -------------------------------------------------------------------
-;;; begin none begin keyword
-;;; begin-form none begin expression
-;;; call none any other call
-;;; constant none self-evaluating datum
-;;; core procedure core form (including singleton)
-;;; define none define keyword
-;;; define-form none variable definition
-;;; define-syntax none define-syntax keyword
-;;; define-syntax-form none syntax definition
-;;; displaced-lexical none displaced lexical identifier
-;;; eval-when none eval-when keyword
-;;; eval-when-form none eval-when form
-;;; global name global variable reference
-;;; import none import keyword
-;;; import-form none import form
-;;; lexical name lexical variable reference
-;;; lexical-call name call to lexical variable
-;;; local-syntax rec? letrec-syntax/let-syntax keyword
-;;; local-syntax-form rec? syntax definition
-;;; module none module keyword
-;;; module-form none module definition
-;;; other none anything else
-;;; syntax level pattern variable
-;;;
-;;; For all forms, e is the form, w is the wrap for e. and s is the source.
-;;;
-;;; syntax-type expands macros and unwraps as necessary to get to
-;;; one of the forms above.
-
-(define syntax-type
- (lambda (e r w s rib)
- (cond
- ((symbol? e)
- (let* ((n (id-var-name e w))
- (b (lookup n r))
- (type (binding-type b)))
- (case type
- ((lexical) (values type (binding-value b) e w s))
- ((global) (values type (binding-value b) e w s))
- ((macro macro!) (syntax-type (chi-macro (binding-value b) e r w s rib) r empty-wrap #f rib))
- (else (values type (binding-value b) e w s)))))
- ((pair? e)
- (let ((first (car e)))
- (if (id? first)
- (let* ((n (id-var-name first w))
- (b (lookup n r))
- (type (binding-type b)))
- (case type
- ((lexical) (values 'lexical-call (binding-value b) e w s))
- ((macro macro!)
- (syntax-type (chi-macro (binding-value b) e r w s rib)
- r empty-wrap #f rib))
- ((core) (values type (binding-value b) e w s))
- ((local-syntax)
- (values 'local-syntax-form (binding-value b) e w s))
- ((begin) (values 'begin-form #f e w s))
- ((eval-when) (values 'eval-when-form #f e w s))
- ((define) (values 'define-form #f e w s))
- ((define-syntax) (values 'define-syntax-form #f e w s))
- ((module-key) (values 'module-form #f e w s))
- ((import) (values 'import-form (and (binding-value b) (wrap first w)) e w s))
- ((set!) (chi-set! e r w s rib))
- (else (values 'call #f e w s))))
- (values 'call #f e w s))))
- ((syntax-object? e)
- ;; s can't be valid source if we've unwrapped
- (syntax-type (syntax-object-expression e)
- r
- (join-wraps w (syntax-object-wrap e))
- no-source rib))
- ((annotation? e)
- (syntax-type (annotation-expression e) r w (annotation-source e) rib))
- ((self-evaluating? e) (values 'constant #f e w s))
- (else (values 'other #f e w s)))))
-
-(define chi-top-expr
- (lambda (e r w top-ribcage)
- (call-with-values
- (lambda () (syntax-type e r w no-source top-ribcage))
- (lambda (type value e w s)
- (chi-expr type value e r w s)))))
-
-(define chi-top
- (lambda (e r w m esew top-ribcage)
- (define-syntax eval-if-c&e
- (syntax-rules ()
- ((_ m e)
- (let ((x e))
- (if (eq? m 'c&e) (top-level-eval-hook x))
- x))))
- (call-with-values
- (lambda () (syntax-type e r w no-source top-ribcage))
- (lambda (type value e w s)
- (case type
- ((begin-form)
- (syntax-case e ()
- ((_) (chi-void))
- ((_ e1 e2 ...)
- (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew top-ribcage))))
- ((local-syntax-form)
- (chi-local-syntax value e r w s
- (lambda (body r w s)
- (chi-top-sequence body r w s m esew top-ribcage))))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (chi-when-list e (syntax (x ...)) w))
- (body (syntax (e1 e2 ...))))
- (cond
- ((eq? m 'e)
- (if (memq 'eval when-list)
- (chi-top-sequence body r w s 'e '(eval) top-ribcage)
- (chi-void)))
- ((memq 'load when-list)
- (if (or (memq 'compile when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (chi-top-sequence body r w s 'c&e '(compile load) top-ribcage)
- (if (memq m '(c c&e))
- (chi-top-sequence body r w s 'c '(load) top-ribcage)
- (chi-void))))
- ((or (memq 'compile when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (top-level-eval-hook
- (chi-top-sequence body r w s 'e '(eval) top-ribcage))
- (chi-void))
- (else (chi-void)))))))
- ((define-syntax-form)
- (parse-define-syntax e w s
- (lambda (id rhs w)
- (let ((id (wrap id w)))
- (let ((n (id-var-name id empty-wrap)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((displaced-lexical) (displaced-lexical-error id)))))
- (ct-eval/residualize m esew
- (lambda ()
- (build-cte-install
- (let ((sym (id-sym-name id)))
- (if (only-top-marked? id)
- sym
- (let ((marks (wrap-marks (syntax-object-wrap id))))
- (make-syntax-object sym
- (make-wrap marks
- (list (make-ribcage (vector sym)
- (vector marks) (vector (generate-id sym)))))))))
- (chi rhs (transformer-env r) w))))))))
- ((define-form)
- (parse-define e w s
- (lambda (id rhs w)
- (let ((id (wrap id w)))
- (let ((n (id-var-name id empty-wrap)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((displaced-lexical) (displaced-lexical-error id)))))
- (let ((sym (id-sym-name id)))
- (let ((valsym (if (only-top-marked? id) sym (generate-id sym))))
- (build-sequence no-source
- (list
- (ct-eval/residualize m esew
- (lambda ()
- (build-cte-install
- (if (eq? sym valsym)
- sym
- (let ((marks (wrap-marks (syntax-object-wrap id))))
- (make-syntax-object sym
- (make-wrap marks
- (list (make-ribcage (vector sym)
- (vector marks) (vector valsym)))))))
- (build-data no-source (make-binding 'global valsym)))))
- (eval-if-c&e m (build-global-definition s valsym (chi rhs r w))))))
- )))))
- ((module-form)
- (let ((r (cons '("top-level module placeholder" . (placeholder)) r))
- (ribcage (make-empty-ribcage)))
- (parse-module e w s (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))
- (lambda (id exports forms)
- (if id
- (begin
- (let ((n (id-var-name id empty-wrap)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((displaced-lexical) (displaced-lexical-error (wrap id w))))))
- (chi-top-module e r ribcage w s m esew id exports forms))
- (chi-top-module e r ribcage w s m esew #f exports forms))))))
- ((import-form)
- (parse-import e w s
- (lambda (mid)
- (ct-eval/residualize m esew
- (lambda ()
- (when value (syntax-error (source-wrap e w s) "not valid at top-level"))
- (let ((binding (lookup (id-var-name mid empty-wrap) null-env)))
- (case (binding-type binding)
- ((module) (do-top-import mid (interface-token (binding-value binding))))
- ((displaced-lexical) (displaced-lexical-error mid))
- (else (syntax-error mid "import from unknown module")))))))))
- (else (eval-if-c&e m (chi-expr type value e r w s))))))))
-
-(define flatten-exports
- (lambda (exports)
- (let loop ((exports exports) (ls '()))
- (if (null? exports)
- ls
- (loop (cdr exports)
- (if (pair? (car exports))
- (loop (car exports) ls)
- (cons (car exports) ls)))))))
-
-
-(define-structure (interface exports token))
-
-(define make-trimmed-interface
- ; trim out implicit exports
- (lambda (exports)
- (make-interface
- (list->vector (map (lambda (x) (if (pair? x) (car x) x)) exports))
- #f)))
-
-(define make-resolved-interface
- ; trim out implicit exports & resolve others to actual top-level symbol
- (lambda (exports import-token)
- (make-interface
- (list->vector (map (lambda (x) (make-trimmed-syntax-object (if (pair? x) (car x) x))) exports))
- import-token)))
-
-(define-structure (module-binding type id label imps val))
-
-(define chi-top-module
- (lambda (e r ribcage w s m esew id exports forms)
- (let ((fexports (flatten-exports exports)))
- (chi-external ribcage (source-wrap e w s)
- (map (lambda (d) (cons r d)) forms) r exports fexports m esew
- (lambda (bindings inits)
- ; dvs & des: "defined" (letrec-bound) vars & rhs expressions
- ; svs & ses: "set!" (top-level) vars & rhs expressions
- (let partition ((fexports fexports) (bs bindings) (svs '()) (ses '()) (ctdefs '()))
- (if (null? fexports)
- ; remaining bindings are either local vars or local macros/modules
- (let partition ((bs bs) (dvs '()) (des '()))
- (if (null? bs)
- (let ((ses (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) ses))
- (des (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) des))
- (inits (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) inits)))
- ; we wait to do this here so that expansion of des & ses use
- ; local versions, which in particular, allows us to use macros
- ; locally even if esew tells us not to eval them
- (for-each (lambda (x)
- (apply (lambda (t label sym val)
- (when label (set-indirect-label! label sym)))
- x))
- ctdefs)
- (build-sequence no-source
- (list (ct-eval/residualize m esew
- (lambda ()
- (if (null? ctdefs)
- (chi-void)
- (build-sequence no-source
- (map (lambda (x)
- (apply (lambda (t label sym val)
- (build-cte-install sym
- (if (eq? t 'define-syntax-form)
- val
- (build-data no-source
- (make-binding 'module
- (make-resolved-interface val sym))))))
- x))
- ctdefs)))))
- (ct-eval/residualize m esew
- (lambda ()
- (let ((n (if id (id-sym-name id) #f)))
- (let* ((token (generate-id n))
- (b (build-data no-source
- (make-binding 'module
- (make-resolved-interface exports token)))))
- (if n
- (build-cte-install
- (if (only-top-marked? id)
- n
- (let ((marks (wrap-marks (syntax-object-wrap id))))
- (make-syntax-object n
- (make-wrap marks
- (list (make-ribcage (vector n)
- (vector marks) (vector (generate-id n))))))))
- b)
- (let ((n (generate-id 'tmp)))
- (build-sequence no-source
- (list (build-cte-install n b)
- (do-top-import n token)))))))))
- ; Some systems complain when undefined variables are assigned.
- (build-sequence no-source
- (map (lambda (v) (build-global-definition no-source v (chi-void))) svs))
- (build-letrec no-source
- dvs
- des
- (build-sequence no-source
- (list
- (if (null? svs)
- (chi-void)
- (build-sequence no-source
- (map (lambda (v e)
- (build-module-definition no-source v e))
- svs
- ses)))
- (if (null? inits)
- (chi-void)
- (build-sequence no-source inits)))))
- (chi-void))))
- (let ((b (car bs)))
- (case (module-binding-type b)
- ((define-form)
- (let ((var (gen-var (module-binding-id b))))
- (extend-store! r
- (get-indirect-label (module-binding-label b))
- (make-binding 'lexical var))
- (partition (cdr bs) (cons var dvs)
- (cons (module-binding-val b) des))))
- ((define-syntax-form module-form) (partition (cdr bs) dvs des))
- (else (error 'sc-expand-internal "unexpected module binding type"))))))
- (let ((id (car fexports)) (fexports (cdr fexports)))
- (define pluck-binding
- (lambda (id bs succ fail)
- (let loop ((bs bs) (new-bs '()))
- (if (null? bs)
- (fail)
- (if (bound-id=? (module-binding-id (car bs)) id)
- (succ (car bs) (smart-append (reverse new-bs) (cdr bs)))
- (loop (cdr bs) (cons (car bs) new-bs)))))))
- (pluck-binding id bs
- (lambda (b bs)
- (let ((t (module-binding-type b))
- (label (module-binding-label b))
- (imps (module-binding-imps b)))
- (let ((fexports (append imps fexports))
- (sym (generate-id (id-sym-name id))))
- (case t
- ((define-form)
- (set-indirect-label! label sym)
- (partition fexports bs (cons sym svs)
- (cons (module-binding-val b) ses)
- ctdefs))
- ((define-syntax-form)
- (partition fexports bs svs ses
- (cons (list t label sym (module-binding-val b)) ctdefs)))
- ((module-form)
- (let ((exports (module-binding-val b)))
- (partition (append (flatten-exports exports) fexports) bs
- svs ses
- (cons (list t label sym exports) ctdefs))))
- (else (error 'sc-expand-internal "unexpected module binding type"))))))
- (lambda () (partition fexports bs svs ses ctdefs)))))))))))
-
-(define id-set-diff
- (lambda (exports defs)
- (cond
- ((null? exports) '())
- ((bound-id-member? (car exports) defs) (id-set-diff (cdr exports) defs))
- (else (cons (car exports) (id-set-diff (cdr exports) defs))))))
-
-(define extend-store!
- (lambda (r label binding)
- (set-cdr! r (extend-env label binding (cdr r)))))
-
-(define check-module-exports
- ; After processing the definitions of a module this is called to verify that the
- ; module has defined or imported each exported identifier. Because ids in fexports are
- ; wrapped with the given ribcage, they will contain substitutions for anything defined
- ; or imported here. These subsitutions can be used by do-import! and do-import-top! to
- ; provide access to reexported bindings, for example.
- (lambda (source-exp fexports ids)
- (define defined?
- (lambda (e ids)
- (ormap (lambda (x)
- (if (interface? x)
- (let ((token (interface-token x)))
- (if token
- (lookup-import-binding-name (id-sym-name e) token (wrap-marks (syntax-object-wrap e)))
- (let ((v (interface-exports x)))
- (let lp ((i (fx- (vector-length v) 1)))
- (and (fx>= i 0)
- (or (bound-id=? e (vector-ref v i))
- (lp (fx- i 1))))))))
- (bound-id=? e x)))
- ids)))
- (let loop ((fexports fexports) (missing '()))
- (if (null? fexports)
- (unless (null? missing) (syntax-error missing "missing definition for export(s)"))
- (let ((e (car fexports)) (fexports (cdr fexports)))
- (if (defined? e ids)
- (loop fexports missing)
- (loop fexports (cons e missing))))))))
-
-(define check-defined-ids
- (lambda (source-exp ls)
- (define b-i=?
- ; cope with fat-fingered top-level
- (lambda (x y)
- (if (symbol? x)
- (if (symbol? y)
- (eq? x y)
- (and (eq? x (id-sym-name y))
- (same-marks? (wrap-marks (syntax-object-wrap y)) (wrap-marks top-wrap))))
- (if (symbol? y)
- (and (eq? y (id-sym-name x))
- (same-marks? (wrap-marks (syntax-object-wrap x)) (wrap-marks top-wrap)))
- (bound-id=? x y)))))
- (define vfold
- (lambda (v p cls)
- (let ((len (vector-length v)))
- (let lp ((i 0) (cls cls))
- (if (fx= i len)
- cls
- (lp (fx+ i 1) (p (vector-ref v i) cls)))))))
- (define conflicts
- (lambda (x y cls)
- (if (interface? x)
- (if (interface? y)
- (call-with-values
- (lambda ()
- (let ((xe (interface-exports x)) (ye (interface-exports y)))
- (if (fx> (vector-length xe) (vector-length ye))
- (values x ye)
- (values y xe))))
- (lambda (iface exports)
- (vfold exports (lambda (id cls) (id-iface-conflicts id iface cls)) cls)))
- (id-iface-conflicts y x cls))
- (if (interface? y)
- (id-iface-conflicts x y cls)
- (if (b-i=? x y) (cons x cls) cls)))))
- (define id-iface-conflicts
- (lambda (id iface cls)
- (let ((token (interface-token iface)))
- (if token
- (if (lookup-import-binding-name (id-sym-name id) token
- (if (symbol? id)
- (wrap-marks top-wrap)
- (wrap-marks (syntax-object-wrap id))))
- (cons id cls)
- cls)
- (vfold (interface-exports iface)
- (lambda (*id cls) (if (b-i=? *id id) (cons *id cls) cls))
- cls)))))
- (unless (null? ls)
- (let lp ((x (car ls)) (ls (cdr ls)) (cls '()))
- (if (null? ls)
- (unless (null? cls)
- (let ((cls (syntax-object->datum cls)))
- (syntax-error source-exp "duplicate definition for "
- (symbol->string (car cls))
- " in")))
- (let lp2 ((ls2 ls) (cls cls))
- (if (null? ls2)
- (lp (car ls) (cdr ls) cls)
- (lp2 (cdr ls2) (conflicts x (car ls2) cls)))))))))
-
-(define chi-external
- (lambda (ribcage source-exp body r exports fexports m esew k)
- (define return
- (lambda (bindings ids inits)
- (check-defined-ids source-exp ids)
- (check-module-exports source-exp fexports ids)
- (k bindings inits)))
- (define get-implicit-exports
- (lambda (id)
- (let f ((exports exports))
- (if (null? exports)
- '()
- (if (and (pair? (car exports)) (bound-id=? id (caar exports)))
- (flatten-exports (cdar exports))
- (f (cdr exports)))))))
- (define update-imp-exports
- (lambda (bindings exports)
- (let ((exports (map (lambda (x) (if (pair? x) (car x) x)) exports)))
- (map (lambda (b)
- (let ((id (module-binding-id b)))
- (if (not (bound-id-member? id exports))
- b
- (make-module-binding
- (module-binding-type b)
- id
- (module-binding-label b)
- (append (get-implicit-exports id) (module-binding-imps b))
- (module-binding-val b)))))
- bindings))))
- (let parse ((body body) (ids '()) (bindings '()) (inits '()))
- (if (null? body)
- (return bindings ids inits)
- (let ((e (cdar body)) (er (caar body)))
- (call-with-values
- (lambda () (syntax-type e er empty-wrap no-source ribcage))
- (lambda (type value e w s)
- (case type
- ((define-form)
- (parse-define e w s
- (lambda (id rhs w)
- (let* ((id (wrap id w))
- (label (gen-indirect-label))
- (imps (get-implicit-exports id)))
- (extend-ribcage! ribcage id label)
- (parse
- (cdr body)
- (cons id ids)
- (cons (make-module-binding type id label
- imps (cons er (wrap rhs w)))
- bindings)
- inits)))))
- ((define-syntax-form)
- (parse-define-syntax e w s
- (lambda (id rhs w)
- (let* ((id (wrap id w))
- (label (gen-indirect-label))
- (imps (get-implicit-exports id))
- (exp (chi rhs (transformer-env er) w)))
- ; arrange to evaluate the transformer lazily
- (extend-store! r (get-indirect-label label) (cons 'deferred exp))
- (extend-ribcage! ribcage id label)
- (parse
- (cdr body)
- (cons id ids)
- (cons (make-module-binding type id label imps exp)
- bindings)
- inits)))))
- ((module-form)
- (let* ((*ribcage (make-empty-ribcage))
- (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
- (parse-module e w s *w
- (lambda (id *exports forms)
- (chi-external *ribcage (source-wrap e w s)
- (map (lambda (d) (cons er d)) forms)
- r *exports (flatten-exports *exports) m esew
- (lambda (*bindings *inits)
- (let* ((iface (make-trimmed-interface *exports))
- (bindings (append (if id *bindings (update-imp-exports *bindings *exports)) bindings))
- (inits (append inits *inits)))
- (if id
- (let ((label (gen-indirect-label))
- (imps (get-implicit-exports id)))
- (extend-store! r (get-indirect-label label)
- (make-binding 'module iface))
- (extend-ribcage! ribcage id label)
- (parse
- (cdr body)
- (cons id ids)
- (cons (make-module-binding type id label imps *exports) bindings)
- inits))
- (let ()
- (do-import! iface ribcage)
- (parse (cdr body) (cons iface ids) bindings inits))))))))))
- ((import-form)
- (parse-import e w s
- (lambda (mid)
- (let ((mlabel (id-var-name mid empty-wrap)))
- (let ((binding (lookup mlabel r)))
- (case (binding-type binding)
- ((module)
- (let ((iface (binding-value binding)))
- (when value (extend-ribcage-barrier! ribcage value))
- (do-import! iface ribcage)
- (parse
- (cdr body)
- (cons iface ids)
- (update-imp-exports bindings (vector->list (interface-exports iface)))
- inits)))
- ((displaced-lexical) (displaced-lexical-error mid))
- (else (syntax-error mid "import from unknown module"))))))))
- ((begin-form)
- (syntax-case e ()
- ((_ e1 ...)
- (parse (let f ((forms (syntax (e1 ...))))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w))
- (f (cdr forms)))))
- ids bindings inits))))
- ((local-syntax-form)
- (chi-local-syntax value e er w s
- (lambda (forms er w s)
- (parse (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w))
- (f (cdr forms)))))
- ids bindings inits))))
- (else ; found an init expression
- (return bindings ids
- (append inits (cons (cons er (source-wrap e w s)) (cdr body)))))))))))))
-
-(define vmap
- (lambda (fn v)
- (do ((i (fx- (vector-length v) 1) (fx- i 1))
- (ls '() (cons (fn (vector-ref v i)) ls)))
- ((fx< i 0) ls))))
-
-(define vfor-each
- (lambda (fn v)
- (let ((len (vector-length v)))
- (do ((i 0 (fx+ i 1)))
- ((fx= i len))
- (fn (vector-ref v i))))))
-
-(define do-top-import
- (lambda (mid token)
- (build-cte-install mid
- (build-data no-source
- (make-binding 'do-import token)))))
-
-(define ct-eval/residualize
- (lambda (m esew thunk)
- (case m
- ((c) (if (memq 'compile esew)
- (let ((e (thunk)))
- (top-level-eval-hook e)
- (if (memq 'load esew) e (chi-void)))
- (if (memq 'load esew) (thunk) (chi-void))))
- ((c&e) (let ((e (thunk))) (top-level-eval-hook e) e))
- (else (if (memq 'eval esew) (top-level-eval-hook (thunk))) (chi-void)))))
-
-(define chi
- (lambda (e r w)
- (call-with-values
- (lambda () (syntax-type e r w no-source #f))
- (lambda (type value e w s)
- (chi-expr type value e r w s)))))
-
-(define chi-expr
- (lambda (type value e r w s)
- (case type
- ((lexical)
- (build-lexical-reference 'value s value))
- ((core) (value e r w s))
- ((lexical-call)
- (chi-application
- (build-lexical-reference 'fun (source-annotation (car e)) value)
- e r w s))
- ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
- ((global) (build-global-reference s value))
- ((call) (chi-application (chi (car e) r w) e r w s))
- ((begin-form)
- (syntax-case e ()
- ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
- ((local-syntax-form)
- (chi-local-syntax value e r w s chi-sequence))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (chi-when-list e (syntax (x ...)) w)))
- (if (memq 'eval when-list)
- (chi-sequence (syntax (e1 e2 ...)) r w s)
- (chi-void))))))
- ((define-form define-syntax-form module-form import-form)
- (syntax-error (source-wrap e w s) "invalid context for definition"))
- ((syntax)
- (syntax-error (source-wrap e w s)
- "reference to pattern variable outside syntax form"))
- ((displaced-lexical) (displaced-lexical-error (source-wrap e w s)))
- (else (syntax-error (source-wrap e w s))))))
-
-(define chi-application
- (lambda (x e r w s)
- (syntax-case e ()
- ((e0 e1 ...)
- (build-application s x
- (map (lambda (e) (chi e r w)) (syntax (e1 ...)))))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define chi-set!
- (lambda (e r w s rib)
- (syntax-case e ()
- ((_ id val)
- (id? (syntax id))
- (let ((n (id-var-name (syntax id) w)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((macro!)
- (let ((id (wrap (syntax id) w)) (val (wrap (syntax val) w)))
- (syntax-type (chi-macro (binding-value b)
- `(,(syntax set!) ,id ,val)
- r empty-wrap s rib) r empty-wrap s rib)))
- (else
- (values 'core
- (lambda (e r w s)
- ; repeat lookup in case we were first expression (init) in
- ; module or lambda body. we repeat id-var-name as well,
- ; although this is only necessary if we allow inits to
- ; preced definitions
- (let ((val (chi (syntax val) r w))
- (n (id-var-name (syntax id) w)))
- (let ((b (lookup n r)))
- (case (binding-type b)
- ((lexical) (build-lexical-assignment s (binding-value b) val))
- ((global) (build-global-assignment s (binding-value b) val))
- ((displaced-lexical)
- (syntax-error (wrap (syntax id) w) "identifier out of context"))
- (else (syntax-error (source-wrap e w s)))))))
- e w s))))))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define chi-macro
- (lambda (p e r w s rib)
- (define rebuild-macro-output
- (lambda (x m)
- (cond ((pair? x)
- (cons (rebuild-macro-output (car x) m)
- (rebuild-macro-output (cdr x) m)))
- ((syntax-object? x)
- (let ((w (syntax-object-wrap x)))
- (let ((ms (wrap-marks w)) (s (wrap-subst w)))
- (make-syntax-object (syntax-object-expression x)
- (if (and (pair? ms) (eq? (car ms) the-anti-mark))
- (make-wrap (cdr ms)
- (if rib (cons rib (cdr s)) (cdr s)))
- (make-wrap (cons m ms)
- (if rib
- (cons rib (cons 'shift s))
- (cons 'shift s))))))))
- ((vector? x)
- (let* ((n (vector-length x)) (v (make-vector n)))
- (do ((i 0 (fx+ i 1)))
- ((fx= i n) v)
- (vector-set! v i
- (rebuild-macro-output (vector-ref x i) m)))))
- ((symbol? x)
- (syntax-error (source-wrap e w s)
- "encountered raw symbol "
- (format "~s" x)
- " in output of macro"))
- (else x))))
- (rebuild-macro-output
- (let ((out (p (source-wrap e (anti-mark w) s))))
- (if (procedure? out)
- (out (lambda (id)
- (unless (identifier? id)
- (syntax-error id
- "environment argument is not an identifier"))
- (lookup (id-var-name id empty-wrap) r)))
- out))
- (new-mark))))
-
-(define chi-body
- ;; Here we create the empty wrap and new environment with placeholder
- ;; as required by chi-internal. On return we extend the environment
- ;; to recognize the var-labels as lexical variables and build a letrec
- ;; binding them to the var-vals which we expand here.
- (lambda (body outer-form r w)
- (let* ((r (cons '("placeholder" . (placeholder)) r))
- (ribcage (make-empty-ribcage))
- (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))
- (body (map (lambda (x) (cons r (wrap x w))) body)))
- (chi-internal ribcage outer-form body r
- (lambda (exprs ids vars vals inits)
- (when (null? exprs) (syntax-error outer-form "no expressions in body"))
- (build-letrec no-source
- vars
- (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) vals)
- (build-sequence no-source
- (map (lambda (x) (chi (cdr x) (car x) empty-wrap)) (append inits exprs)))))))))
-
-(define chi-internal
- ;; In processing the forms of the body, we create a new, empty wrap.
- ;; This wrap is augmented (destructively) each time we discover that
- ;; the next form is a definition. This is done:
- ;;
- ;; (1) to allow the first nondefinition form to be a call to
- ;; one of the defined ids even if the id previously denoted a
- ;; definition keyword or keyword for a macro expanding into a
- ;; definition;
- ;; (2) to prevent subsequent definition forms (but unfortunately
- ;; not earlier ones) and the first nondefinition form from
- ;; confusing one of the bound identifiers for an auxiliary
- ;; keyword; and
- ;; (3) so that we do not need to restart the expansion of the
- ;; first nondefinition form, which is problematic anyway
- ;; since it might be the first element of a begin that we
- ;; have just spliced into the body (meaning if we restarted,
- ;; we'd really need to restart with the begin or the macro
- ;; call that expanded into the begin, and we'd have to give
- ;; up allowing (begin <defn>+ <expr>+), which is itself
- ;; problematic since we don't know if a begin contains only
- ;; definitions until we've expanded it).
- ;;
- ;; Before processing the body, we also create a new environment
- ;; containing a placeholder for the bindings we will add later and
- ;; associate this environment with each form. In processing a
- ;; let-syntax or letrec-syntax, the associated environment may be
- ;; augmented with local keyword bindings, so the environment may
- ;; be different for different forms in the body. Once we have
- ;; gathered up all of the definitions, we evaluate the transformer
- ;; expressions and splice into r at the placeholder the new variable
- ;; and keyword bindings. This allows let-syntax or letrec-syntax
- ;; forms local to a portion or all of the body to shadow the
- ;; definition bindings.
- ;;
- ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
- ;; into the body.
- ;;
- ;; outer-form is fully wrapped w/source
- (lambda (ribcage source-exp body r k)
- (define return
- (lambda (exprs ids vars vals inits)
- (check-defined-ids source-exp ids)
- (k exprs ids vars vals inits)))
- (let parse ((body body) (ids '()) (vars '()) (vals '()) (inits '()))
- (if (null? body)
- (return body ids vars vals inits)
- (let ((e (cdar body)) (er (caar body)))
- (call-with-values
- (lambda () (syntax-type e er empty-wrap no-source ribcage))
- (lambda (type value e w s)
- (case type
- ((define-form)
- (parse-define e w s
- (lambda (id rhs w)
- (let ((id (wrap id w)) (label (gen-label)))
- (let ((var (gen-var id)))
- (extend-ribcage! ribcage id label)
- (extend-store! r label (make-binding 'lexical var))
- (parse
- (cdr body)
- (cons id ids)
- (cons var vars)
- (cons (cons er (wrap rhs w)) vals)
- inits))))))
- ((define-syntax-form)
- (parse-define-syntax e w s
- (lambda (id rhs w)
- (let ((id (wrap id w))
- (label (gen-label))
- (exp (chi rhs (transformer-env er) w)))
- (extend-ribcage! ribcage id label)
- (extend-store! r label (make-binding 'deferred exp))
- (parse (cdr body) (cons id ids) vars vals inits)))))
- ((module-form)
- (let* ((*ribcage (make-empty-ribcage))
- (*w (make-wrap (wrap-marks w) (cons *ribcage (wrap-subst w)))))
- (parse-module e w s *w
- (lambda (id exports forms)
- (chi-internal *ribcage (source-wrap e w s)
- (map (lambda (d) (cons er d)) forms) r
- (lambda (*body *ids *vars *vals *inits)
- ; valid bound ids checked already by chi-internal
- (check-module-exports source-exp (flatten-exports exports) *ids)
- (let ((iface (make-trimmed-interface exports))
- (vars (append *vars vars))
- (vals (append *vals vals))
- (inits (append inits *inits *body)))
- (if id
- (let ((label (gen-label)))
- (extend-ribcage! ribcage id label)
- (extend-store! r label (make-binding 'module iface))
- (parse (cdr body) (cons id ids) vars vals inits))
- (let ()
- (do-import! iface ribcage)
- (parse (cdr body) (cons iface ids) vars vals inits))))))))))
- ((import-form)
- (parse-import e w s
- (lambda (mid)
- (let ((mlabel (id-var-name mid empty-wrap)))
- (let ((binding (lookup mlabel r)))
- (case (car binding)
- ((module)
- (let ((iface (cdr binding)))
- (when value (extend-ribcage-barrier! ribcage value))
- (do-import! iface ribcage)
- (parse (cdr body) (cons iface ids) vars vals inits)))
- ((displaced-lexical) (displaced-lexical-error mid))
- (else (syntax-error mid "import from unknown module"))))))))
- ((begin-form)
- (syntax-case e ()
- ((_ e1 ...)
- (parse (let f ((forms (syntax (e1 ...))))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w))
- (f (cdr forms)))))
- ids vars vals inits))))
- ((local-syntax-form)
- (chi-local-syntax value e er w s
- (lambda (forms er w s)
- (parse (let f ((forms forms))
- (if (null? forms)
- (cdr body)
- (cons (cons er (wrap (car forms) w))
- (f (cdr forms)))))
- ids vars vals inits))))
- (else ; found a non-definition
- (return (cons (cons er (source-wrap e w s)) (cdr body))
- ids vars vals inits))))))))))
-
-(define do-import!
- (lambda (interface ribcage)
- (let ((token (interface-token interface)))
- (if token
- (extend-ribcage-subst! ribcage token)
- (vfor-each
- (lambda (id)
- (let ((label1 (id-var-name-loc id empty-wrap)))
- (unless label1
- (syntax-error id "exported identifier not visible"))
- (extend-ribcage! ribcage id label1)))
- (interface-exports interface))))))
-
-(define parse-module
- (lambda (e w s *w k)
- (define listify
- (lambda (exports)
- (if (null? exports)
- '()
- (cons (syntax-case (car exports) ()
- ((ex ...) (listify (syntax (ex ...))))
- (x (if (id? (syntax x))
- (wrap (syntax x) *w)
- (syntax-error (source-wrap e w s)
- "invalid exports list in"))))
- (listify (cdr exports))))))
- (define return
- (lambda (id exports forms)
- (k id (listify exports) (map (lambda (x) (wrap x *w)) forms))))
- (syntax-case e ()
- ((_ (ex ...) form ...)
- (return #f (syntax (ex ...)) (syntax (form ...))))
- ((_ mid (ex ...) form ...)
- (id? (syntax mid))
- ; id receives old wrap so it won't be confused with id of same name
- ; defined within the module
- (return (wrap (syntax mid) w) (syntax (ex ...)) (syntax (form ...))))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define parse-import
- (lambda (e w s k)
- (syntax-case e ()
- ((_ mid)
- (id? (syntax mid))
- (k (wrap (syntax mid) w)))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define parse-define
- (lambda (e w s k)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (k (syntax name) (syntax val) w))
- ((_ (name . args) e1 e2 ...)
- (and (id? (syntax name))
- (valid-bound-ids? (lambda-var-list (syntax args))))
- (k (wrap (syntax name) w)
- (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
- empty-wrap))
- ((_ name)
- (id? (syntax name))
- (k (wrap (syntax name) w) (syntax (void)) empty-wrap))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define parse-define-syntax
- (lambda (e w s k)
- (syntax-case e ()
- ((_ name val)
- (id? (syntax name))
- (k (syntax name) (syntax val) w))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define chi-lambda-clause
- (lambda (e c r w k)
- (syntax-case c ()
- (((id ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (syntax-error e "invalid parameter list in")
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (k new-vars
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env* labels new-vars r)
- (make-binding-wrap ids labels w)))))))
- ((ids e1 e2 ...)
- (let ((old-ids (lambda-var-list (syntax ids))))
- (if (not (valid-bound-ids? old-ids))
- (syntax-error e "invalid parameter list in")
- (let ((labels (gen-labels old-ids))
- (new-vars (map gen-var old-ids)))
- (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
- (if (null? ls1)
- ls2
- (f (cdr ls1) (cons (car ls1) ls2))))
- (chi-body (syntax (e1 e2 ...))
- e
- (extend-var-env* labels new-vars r)
- (make-binding-wrap old-ids labels w)))))))
- (_ (syntax-error e)))))
-
-(define chi-local-syntax
- (lambda (rec? e r w s k)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
- (source-wrap e w s)
- "keyword")
- (let ((labels (gen-labels ids)))
- (let ((new-w (make-binding-wrap ids labels w)))
- (k (syntax (e1 e2 ...))
- (extend-env*
- labels
- (let ((w (if rec? new-w w))
- (trans-r (transformer-env r)))
- (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...))))
- r)
- new-w
- s))))))
- (_ (syntax-error (source-wrap e w s))))))
-
-(define chi-void
- (lambda ()
- (build-application no-source (build-primref no-source 'void) '())))
-
-(define ellipsis?
- (lambda (x)
- (and (nonsymbol-id? x)
- (literal-id=? x (syntax (... ...))))))
-
-;;; data
-
-;;; strips all annotations from potentially circular reader output
-
-(define strip-annotation
- (lambda (x parent)
- (cond
- ((pair? x)
- (let ((new (cons #f #f)))
- (when parent (set-annotation-stripped! parent new))
- (set-car! new (strip-annotation (car x) #f))
- (set-cdr! new (strip-annotation (cdr x) #f))
- new))
- ((annotation? x)
- (or (annotation-stripped x)
- (strip-annotation (annotation-expression x) x)))
- ((vector? x)
- (let ((new (make-vector (vector-length x))))
- (when parent (set-annotation-stripped! parent new))
- (let loop ((i (- (vector-length x) 1)))
- (unless (fx< i 0)
- (vector-set! new i (strip-annotation (vector-ref x i) #f))
- (loop (fx- i 1))))
- new))
- (else x))))
-
-;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
-;;; on an annotation, strips the annotation as well.
-;;; since only the head of a list is annotated by the reader, not each pair
-;;; in the spine, we also check for pairs whose cars are annotated in case
-;;; we've been passed the cdr of an annotated list
-
-(define strip*
- (lambda (x w fn)
- (if (top-marked? w)
- (fn x)
- (let f ((x x))
- (cond
- ((syntax-object? x)
- (strip* (syntax-object-expression x) (syntax-object-wrap x) fn))
- ((pair? x)
- (let ((a (f (car x))) (d (f (cdr x))))
- (if (and (eq? a (car x)) (eq? d (cdr x)))
- x
- (cons a d))))
- ((vector? x)
- (let ((old (vector->list x)))
- (let ((new (map f old)))
- (if (andmap eq? old new) x (list->vector new)))))
- (else x))))))
-
-(define strip
- (lambda (x w)
- (strip* x w
- (lambda (x)
- (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
- (strip-annotation x #f)
- x)))))
-
-;;; lexical variables
-
-(define gen-var
- (lambda (id)
- (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
- (if (annotation? id)
- (build-lexical-var (annotation-source id) (annotation-expression id))
- (build-lexical-var no-source id)))))
-
-(define lambda-var-list
- (lambda (vars)
- (let lvl ((vars vars) (ls '()) (w empty-wrap))
- (cond
- ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
- ((id? vars) (cons (wrap vars w) ls))
- ((null? vars) ls)
- ((syntax-object? vars)
- (lvl (syntax-object-expression vars)
- ls
- (join-wraps w (syntax-object-wrap vars))))
- ((annotation? vars)
- (lvl (annotation-expression vars) ls w))
- ; include anything else to be caught by subsequent error
- ; checking
- (else (cons vars ls))))))
-
-
-; must precede global-extends
-
-(set! $sc-put-cte
- (lambda (id b)
- (define put-token
- (lambda (id token)
- (define cons-id
- (lambda (id x)
- (if (not x) id (cons id x))))
- (define weed
- (lambda (id x)
- (if (pair? x)
- (if (bound-id=? (car x) id) ; could just check same-marks
- (weed id (cdr x))
- (cons-id (car x) (weed id (cdr x))))
- (if (or (not x) (bound-id=? x id))
- #f
- x))))
- (let ((sym (id-sym-name id)))
- (let ((x (weed id (getprop sym token))))
- (if (and (not x) (symbol? id))
- ; don't pollute property list when all we have is a plain
- ; top-level binding, since that's what's assumed anyway
- (remprop sym token)
- (putprop sym token (cons-id id x)))))))
- (define sc-put-module
- (lambda (exports token)
- (vfor-each
- (lambda (id) (put-token id token))
- exports)))
- (define (put-cte id binding)
- ;; making assumption here that all macros should be visible to the user and that system
- ;; globals don't come through here (primvars.ss sets up their properties)
- (let ((sym (if (symbol? id) id (id-var-name id empty-wrap))))
- (putprop sym '*sc-expander* binding)))
- (let ((binding (or (sanitize-binding b) (error 'define-syntax "invalid transformer ~s" b))))
- (case (binding-type binding)
- ((module)
- (let ((iface (binding-value binding)))
- (sc-put-module (interface-exports iface) (interface-token iface)))
- (put-cte id binding))
- ((do-import) ; fake binding: id is module id, binding-value is import token
- (let ((token (binding-value b)))
- (let ((b (lookup (id-var-name id empty-wrap) null-env)))
- (case (binding-type b)
- ((module)
- (let ((iface (binding-value b)))
- (unless (eq? (interface-token iface) token)
- (syntax-error id "import mismatch for module"))
- (sc-put-module (interface-exports iface) '*top*)))
- (else (syntax-error id "import from unknown module"))))))
- (else (put-cte id binding))))))
-
-
-;;; core transformers
-
-(global-extend 'local-syntax 'letrec-syntax #t)
-(global-extend 'local-syntax 'let-syntax #f)
-
-
-(global-extend 'core 'fluid-let-syntax
- (lambda (e r w s)
- (syntax-case e ()
- ((_ ((var val) ...) e1 e2 ...)
- (valid-bound-ids? (syntax (var ...)))
- (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
- (for-each
- (lambda (id n)
- (case (binding-type (lookup n r))
- ((displaced-lexical) (displaced-lexical-error (wrap id w)))))
- (syntax (var ...))
- names)
- (chi-body
- (syntax (e1 e2 ...))
- (source-wrap e w s)
- (extend-env*
- names
- (let ((trans-r (transformer-env r)))
- (map (lambda (x) (make-binding 'deferred (chi x trans-r w))) (syntax (val ...))))
- r)
- w)))
- (_ (syntax-error (source-wrap e w s))))))
-
-(global-extend 'core 'quote
- (lambda (e r w s)
- (syntax-case e ()
- ((_ e) (build-data s (strip (syntax e) w)))
- (_ (syntax-error (source-wrap e w s))))))
-
-(global-extend 'core 'syntax
- (let ()
- (define gen-syntax
- (lambda (src e r maps ellipsis?)
- (if (id? e)
- (let ((label (id-var-name e empty-wrap)))
- (let ((b (lookup label r)))
- (if (eq? (binding-type b) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev (binding-value b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps)))
- (lambda (var maps) (values `(ref ,var) maps)))
- (if (ellipsis? e)
- (syntax-error src "misplaced ellipsis in syntax form")
- (values `(quote ,e) maps)))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? (syntax dots))
- (gen-syntax src (syntax e) r maps (lambda (x) #f)))
- ((x dots . y)
- ; this could be about a dozen lines of code, except that we
- ; choose to handle (syntax (x ... ...)) forms
- (ellipsis? (syntax dots))
- (let f ((y (syntax y))
- (k (lambda (maps)
- (call-with-values
- (lambda ()
- (gen-syntax src (syntax x) r
- (cons '() maps) ellipsis?))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
- (values (gen-map x (car maps))
- (cdr maps))))))))
- (syntax-case y ()
- ((dots . y)
- (ellipsis? (syntax dots))
- (f (syntax y)
- (lambda (maps)
- (call-with-values
- (lambda () (k (cons '() maps)))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
- (values (gen-mappend x (car maps))
- (cdr maps))))))))
- (_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis?))
- (lambda (y maps)
- (call-with-values
- (lambda () (k maps))
- (lambda (x maps)
- (values (gen-append x y) maps)))))))))
- ((x . y)
- (call-with-values
- (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
- (lambda (x maps)
- (call-with-values
- (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
- (lambda (y maps) (values (gen-cons x y) maps))))))
- (#(e1 e2 ...)
- (call-with-values
- (lambda ()
- (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
- (lambda (e maps) (values (gen-vector e) maps))))
- (_ (values `(quote ,e) maps))))))
-
- (define gen-ref
- (lambda (src var level maps)
- (if (fx= level 0)
- (values var maps)
- (if (null? maps)
- (syntax-error src "missing ellipsis in syntax form")
- (call-with-values
- (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
- (lambda (outer-var outer-maps)
- (let ((b (assq outer-var (car maps))))
- (if b
- (values (cdr b) maps)
- (let ((inner-var (gen-var 'tmp)))
- (values inner-var
- (cons (cons (cons outer-var inner-var)
- (car maps))
- outer-maps)))))))))))
-
- (define gen-mappend
- (lambda (e map-env)
- `(apply (primitive append) ,(gen-map e map-env))))
-
- (define gen-map
- (lambda (e map-env)
- (let ((formals (map cdr map-env))
- (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
- (cond
- ((eq? (car e) 'ref)
- ; identity map equivalence:
- ; (map (lambda (x) x) y) == y
- (car actuals))
- ((andmap
- (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
- (cdr e))
- ; eta map equivalence:
- ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
- `(map (primitive ,(car e))
- ,@(map (let ((r (map cons formals actuals)))
- (lambda (x) (cdr (assq (cadr x) r))))
- (cdr e))))
- (else `(map (lambda ,formals ,e) ,@actuals))))))
-
- (define gen-cons
- (lambda (x y)
- (case (car y)
- ((quote)
- (if (eq? (car x) 'quote)
- `(quote (,(cadr x) . ,(cadr y)))
- (if (eq? (cadr y) '())
- `(list ,x)
- `(cons ,x ,y))))
- ((list) `(list ,x ,@(cdr y)))
- (else `(cons ,x ,y)))))
-
- (define gen-append
- (lambda (x y)
- (if (equal? y '(quote ()))
- x
- `(append ,x ,y))))
-
- (define gen-vector
- (lambda (x)
- (cond
- ((eq? (car x) 'list) `(vector ,@(cdr x)))
- ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
- (else `(list->vector ,x)))))
-
-
- (define regen
- (lambda (x)
- (case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x)))
- ((primitive) (build-primref no-source (cadr x)))
- ((quote) (build-data no-source (cadr x)))
- ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
- ((map) (let ((ls (map regen (cdr x))))
- (build-application no-source
- (if (fx= (length ls) 2)
- (build-primref no-source 'map)
- ; really need to do our own checking here
- (build-primref no-source 2 'map)) ; require error check
- ls)))
- (else (build-application no-source
- (build-primref no-source (car x))
- (map regen (cdr x)))))))
-
- (lambda (e r w s)
- (let ((e (source-wrap e w s)))
- (syntax-case e ()
- ((_ x)
- (call-with-values
- (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
- (lambda (e maps) (regen e))))
- (_ (syntax-error e)))))))
-
-
-(global-extend 'core 'lambda
- (lambda (e r w s)
- (syntax-case e ()
- ((_ . c)
- (chi-lambda-clause (source-wrap e w s) (syntax c) r w
- (lambda (vars body) (build-lambda s vars body)))))))
-
-
-(global-extend 'core 'letrec
- (lambda (e r w s)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (let ((ids (syntax (id ...))))
- (if (not (valid-bound-ids? ids))
- (invalid-ids-error (map (lambda (x) (wrap x w)) ids)
- (source-wrap e w s) "bound variable")
- (let ((labels (gen-labels ids))
- (new-vars (map gen-var ids)))
- (let ((w (make-binding-wrap ids labels w))
- (r (extend-var-env* labels new-vars r)))
- (build-letrec s
- new-vars
- (map (lambda (x) (chi x r w)) (syntax (val ...)))
- (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
- (_ (syntax-error (source-wrap e w s))))))
-
-(global-extend 'core 'if
- (lambda (e r w s)
- (syntax-case e ()
- ((_ test then)
- (build-conditional s
- (chi (syntax test) r w)
- (chi (syntax then) r w)
- (chi-void)))
- ((_ test then else)
- (build-conditional s
- (chi (syntax test) r w)
- (chi (syntax then) r w)
- (chi (syntax else) r w)))
- (_ (syntax-error (source-wrap e w s))))))
-
-
-
-(global-extend 'set! 'set! '())
-
-(global-extend 'begin 'begin '())
-
-(global-extend 'module-key 'module '())
-(global-extend 'import 'import #f)
-(global-extend 'import 'import-only #t)
-
-(global-extend 'define 'define '())
-
-(global-extend 'define-syntax 'define-syntax '())
-
-(global-extend 'eval-when 'eval-when '())
-
-(global-extend 'core 'syntax-case
- (let ()
- (define convert-pattern
- ; accepts pattern & keys
- ; returns syntax-dispatch pattern & ids
- (lambda (pattern keys)
- (let cvt ((p pattern) (n 0) (ids '()))
- (if (id? p)
- (if (bound-id-member? p keys)
- (values (vector 'free-id p) ids)
- (values 'any (cons (cons p n) ids)))
- (syntax-case p ()
- ((x dots)
- (ellipsis? (syntax dots))
- (call-with-values
- (lambda () (cvt (syntax x) (fx+ n 1) ids))
- (lambda (p ids)
- (values (if (eq? p 'any) 'each-any (vector 'each p))
- ids))))
- ((x . y)
- (call-with-values
- (lambda () (cvt (syntax y) n ids))
- (lambda (y ids)
- (call-with-values
- (lambda () (cvt (syntax x) n ids))
- (lambda (x ids)
- (values (cons x y) ids))))))
- (() (values '() ids))
- (#(x ...)
- (call-with-values
- (lambda () (cvt (syntax (x ...)) n ids))
- (lambda (p ids) (values (vector 'vector p) ids))))
- (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
-
- (define build-dispatch-call
- (lambda (pvars exp y r)
- (let ((ids (map car pvars)) (levels (map cdr pvars)))
- (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
- (build-application no-source
- (build-primref no-source 'apply)
- (list (build-lambda no-source new-vars
- (chi exp
- (extend-env*
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- (make-binding-wrap ids labels empty-wrap)))
- y))))))
-
- (define gen-clause
- (lambda (x keys clauses r pat fender exp)
- (call-with-values
- (lambda () (convert-pattern pat keys))
- (lambda (p pvars)
- (cond
- ((not (distinct-bound-ids? (map car pvars)))
- (invalid-ids-error (map car pvars) pat "pattern variable"))
- ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
- (syntax-error pat
- "misplaced ellipsis in syntax-case pattern"))
- (else
- (let ((y (gen-var 'tmp)))
- ; fat finger binding and references to temp variable y
- (build-application no-source
- (build-lambda no-source (list y)
- (let-syntax ((y (identifier-syntax
- (build-lexical-reference 'value no-source y))))
- (build-conditional no-source
- (syntax-case fender ()
- (#t y)
- (_ (build-conditional no-source
- y
- (build-dispatch-call pvars fender y r)
- (build-data no-source #f))))
- (build-dispatch-call pvars exp y r)
- (gen-syntax-case x keys clauses r))))
- (list (if (eq? p 'any)
- (build-application no-source
- (build-primref no-source 'list)
- (list (build-lexical-reference no-source 'value x)))
- (build-application no-source
- (build-primref no-source '$syntax-dispatch)
- (list (build-lexical-reference no-source 'value x)
- (build-data no-source p)))))))))))))
-
- (define gen-syntax-case
- (lambda (x keys clauses r)
- (if (null? clauses)
- (build-application no-source
- (build-primref no-source 'syntax-error)
- (list (build-lexical-reference 'value no-source x)))
- (syntax-case (car clauses) ()
- ((pat exp)
- (if (and (id? (syntax pat))
- (not (bound-id-member? (syntax pat) keys))
- (not (ellipsis? (syntax pat))))
- (let ((label (gen-label))
- (var (gen-var (syntax pat))))
- (build-application no-source
- (build-lambda no-source (list var)
- (chi (syntax exp)
- (extend-env label (make-binding 'syntax `(,var . 0)) r)
- (make-binding-wrap (syntax (pat))
- (list label) empty-wrap)))
- (list (build-lexical-reference 'value no-source x))))
- (gen-clause x keys (cdr clauses) r
- (syntax pat) #t (syntax exp))))
- ((pat fender exp)
- (gen-clause x keys (cdr clauses) r
- (syntax pat) (syntax fender) (syntax exp)))
- (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
-
- (lambda (e r w s)
- (let ((e (source-wrap e w s)))
- (syntax-case e ()
- ((_ val (key ...) m ...)
- (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
- (syntax (key ...)))
- (let ((x (gen-var 'tmp)))
- ; fat finger binding and references to temp variable x
- (build-application s
- (build-lambda no-source (list x)
- (gen-syntax-case x
- (syntax (key ...)) (syntax (m ...))
- r))
- (list (chi (syntax val) r empty-wrap))))
- (syntax-error e "invalid literals list in"))))))))
-
-;;; The portable sc-expand seeds chi-top's mode m with 'e (for
-;;; evaluating) and esew (which stands for "eval syntax expanders
-;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
-;;; if we are compiling a file, and esew is set to
-;;; (eval-syntactic-expanders-when), which defaults to the list
-;;; '(compile load eval). This means that, by default, top-level
-;;; syntactic definitions are evaluated immediately after they are
-;;; expanded, and the expanded definitions are also residualized into
-;;; the object file if we are compiling a file.
-(set! sc-expand
- (let ((m 'e) (esew '(eval))
- (user-ribcage
- (let ((ribcage (make-empty-ribcage)))
- (extend-ribcage-subst! ribcage '*top*)
- ribcage)))
- (let ((user-top-wrap
- (make-wrap (wrap-marks top-wrap)
- (cons user-ribcage (wrap-subst top-wrap)))))
- (lambda (x)
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (chi-top x null-env user-top-wrap m esew user-ribcage))))))
-
-(set! identifier?
- (lambda (x)
- (nonsymbol-id? x)))
-
-(set! datum->syntax-object
- (lambda (id datum)
- (arg-check nonsymbol-id? id 'datum->syntax-object)
- (make-syntax-object datum (syntax-object-wrap id))))
-
-(set! syntax-object->datum
- ; accepts any object, since syntax objects may consist partially
- ; or entirely of unwrapped, nonsymbolic data
- (lambda (x)
- (strip x empty-wrap)))
-
-(set! generate-temporaries
- (lambda (ls)
- (arg-check list? ls 'generate-temporaries)
- (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
-
-(set! free-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'free-identifier=?)
- (arg-check nonsymbol-id? y 'free-identifier=?)
- (free-id=? x y)))
-
-(set! bound-identifier=?
- (lambda (x y)
- (arg-check nonsymbol-id? x 'bound-identifier=?)
- (arg-check nonsymbol-id? y 'bound-identifier=?)
- (bound-id=? x y)))
-
-
-(set! syntax-error
- (lambda (object . messages)
- (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
- (let ((message (if (null? messages)
- "invalid syntax"
- (apply string-append messages))))
- (error-hook #f message (strip object empty-wrap)))))
-
-;;; syntax-dispatch expects an expression and a pattern. If the expression
-;;; matches the pattern a list of the matching expressions for each
-;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
-;;; not work on r4rs implementations that violate the ieee requirement
-;;; that #f and () be distinct.)
-
-;;; The expression is matched with the pattern as follows:
-
-;;; pattern: matches:
-;;; () empty list
-;;; any anything
-;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
-;;; each-any (any*)
-;;; #(free-id <key>) <key> with free-identifier=?
-;;; #(each <pattern>) (<pattern>*)
-;;; #(vector <pattern>) (list->vector <pattern>)
-;;; #(atom <object>) <object> with "equal?"
-
-;;; Vector cops out to pair under assumption that vectors are rare. If
-;;; not, should convert to:
-;;; #(vector <pattern>*) #(<pattern>*)
-
-(let ()
-
-(define match-each
- (lambda (e p w)
- (cond
- ((annotation? e)
- (match-each (annotation-expression e) p w))
- ((pair? e)
- (let ((first (match (car e) p w '())))
- (and first
- (let ((rest (match-each (cdr e) p w)))
- (and rest (cons first rest))))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each (syntax-object-expression e)
- p
- (join-wraps w (syntax-object-wrap e))))
- (else #f))))
-
-(define match-each-any
- (lambda (e w)
- (cond
- ((annotation? e)
- (match-each-any (annotation-expression e) w))
- ((pair? e)
- (let ((l (match-each-any (cdr e) w)))
- (and l (cons (wrap (car e) w) l))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each-any (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))))
- (else #f))))
-
-(define match-empty
- (lambda (p r)
- (cond
- ((null? p) r)
- ((eq? p 'any) (cons '() r))
- ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
- ((eq? p 'each-any) (cons '() r))
- (else
- (case (vector-ref p 0)
- ((each) (match-empty (vector-ref p 1) r))
- ((free-id atom) r)
- ((vector) (match-empty (vector-ref p 1) r)))))))
-
-(define match*
- (lambda (e p w r)
- (cond
- ((null? p) (and (null? e) r))
- ((pair? p)
- (and (pair? e) (match (car e) (car p) w
- (match (cdr e) (cdr p) w r))))
- ((eq? p 'each-any)
- (let ((l (match-each-any e w))) (and l (cons l r))))
- (else
- (case (vector-ref p 0)
- ((each)
- (if (null? e)
- (match-empty (vector-ref p 1) r)
- (let ((l (match-each e (vector-ref p 1) w)))
- (and l
- (let collect ((l l))
- (if (null? (car l))
- r
- (cons (map car l) (collect (map cdr l)))))))))
- ((free-id) (and (id? e) (literal-id=? (wrap e w) (vector-ref p 1)) r))
- ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
- ((vector)
- (and (vector? e)
- (match (vector->list e) (vector-ref p 1) w r))))))))
-
-(define match
- (lambda (e p w r)
- (cond
- ((not r) #f)
- ((eq? p 'any) (cons (wrap e w) r))
- ((syntax-object? e)
- (match*
- (unannotate (syntax-object-expression e))
- p
- (join-wraps w (syntax-object-wrap e))
- r))
- (else (match* (unannotate e) p w r)))))
-
-(set! $syntax-dispatch
- (lambda (e p)
- (cond
- ((eq? p 'any) (list e))
- ((syntax-object? e)
- (match* (unannotate (syntax-object-expression e))
- p (syntax-object-wrap e) '()))
- (else (match* (unannotate e) p empty-wrap '())))))
-))
-
-
-(define-syntax with-syntax
- (lambda (x)
- (syntax-case x ()
- ((_ () e1 e2 ...)
- (syntax (begin e1 e2 ...)))
- ((_ ((out in)) e1 e2 ...)
- (syntax (syntax-case in () (out (begin e1 e2 ...)))))
- ((_ ((out in) ...) e1 e2 ...)
- (syntax (syntax-case (list in ...) ()
- ((out ...) (begin e1 e2 ...))))))))
-
-(define-syntax syntax-rules
- (lambda (x)
- (syntax-case x ()
- ((_ (k ...) ((keyword . pattern) template) ...)
- (syntax (lambda (x)
- (syntax-case x (k ...)
- ((dummy . pattern) (syntax template))
- ...)))))))
-
-(define-syntax or
- (lambda (x)
- (syntax-case x ()
- ((_) (syntax #f))
- ((_ e) (syntax e))
- ((_ e1 e2 e3 ...)
- (syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
-
-(define-syntax and
- (lambda (x)
- (syntax-case x ()
- ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
- ((_ e) (syntax e))
- ((_) (syntax #t)))))
-
-(define-syntax let
- (lambda (x)
- (syntax-case x ()
- ((_ ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (x ...)))
- (syntax ((lambda (x ...) e1 e2 ...) v ...)))
- ((_ f ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (f x ...)))
- (syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
- v ...))))))
-
-(define-syntax let*
- (lambda (x)
- (syntax-case x ()
- ((let* ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (x ...)))
- (let f ((bindings (syntax ((x v) ...))))
- (if (null? bindings)
- (syntax (let () e1 e2 ...))
- (with-syntax ((body (f (cdr bindings)))
- (binding (car bindings)))
- (syntax (let (binding) body)))))))))
-
-(define-syntax cond
- (lambda (x)
- (syntax-case x ()
- ((_ m1 m2 ...)
- (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
- (if (null? clauses)
- (syntax-case clause (else =>)
- ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
- ((e0) (syntax (let ((t e0)) (if t t))))
- ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t)))))
- ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...))))
- (_ (syntax-error x)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
- (syntax-case clause (else =>)
- ((e0) (syntax (let ((t e0)) (if t t rest))))
- ((e0 => e1) (syntax (let ((t e0)) (if t (e1 t) rest))))
- ((e0 e1 e2 ...) (syntax (if e0 (begin e1 e2 ...) rest)))
- (_ (syntax-error x))))))))))
-
-(define-syntax do
- (lambda (orig-x)
- (syntax-case orig-x ()
- ((_ ((var init . step) ...) (e0 e1 ...) c ...)
- (with-syntax (((step ...)
- (map (lambda (v s)
- (syntax-case s ()
- (() v)
- ((e) (syntax e))
- (_ (syntax-error orig-x))))
- (syntax (var ...))
- (syntax (step ...)))))
- (syntax-case (syntax (e1 ...)) ()
- (() (syntax (let doloop ((var init) ...)
- (if (not e0)
- (begin c ... (doloop step ...))))))
- ((e1 e2 ...)
- (syntax (let doloop ((var init) ...)
- (if e0
- (begin e1 e2 ...)
- (begin c ... (doloop step ...))))))))))))
-
-(define-syntax quasiquote
- (letrec
- ; these are here because syntax-case uses literal-identifier=?,
- ; and we want the more precise free-identifier=?
- ((isquote? (lambda (x)
- (and (identifier? x)
- (free-identifier=? x (syntax quote)))))
- (islist? (lambda (x)
- (and (identifier? x)
- (free-identifier=? x (syntax list)))))
- (iscons? (lambda (x)
- (and (identifier? x)
- (free-identifier=? x (syntax cons)))))
- (quote-nil? (lambda (x)
- (syntax-case x ()
- ((quote? ()) (isquote? (syntax quote?)))
- (_ #f))))
- (quasilist*
- (lambda (x y)
- (let f ((x x))
- (if (null? x)
- y
- (quasicons (car x) (f (cdr x)))))))
- (quasicons
- (lambda (x y)
- (with-syntax ((x x) (y y))
- (syntax-case (syntax y) ()
- ((quote? dy)
- (isquote? (syntax quote?))
- (syntax-case (syntax x) ()
- ((quote? dx)
- (isquote? (syntax quote?))
- (syntax (quote (dx . dy))))
- (_ (if (null? (syntax dy))
- (syntax (list x))
- (syntax (cons x y))))))
- ((listp . stuff)
- (islist? (syntax listp))
- (syntax (list x . stuff)))
- (else (syntax (cons x y)))))))
- (quasiappend
- (lambda (x y)
- (let ((ls (let f ((x x))
- (if (null? x)
- (if (quote-nil? y)
- '()
- (list y))
- (if (quote-nil? (car x))
- (f (cdr x))
- (cons (car x) (f (cdr x))))))))
- (cond
- ((null? ls) (syntax (quote ())))
- ((null? (cdr ls)) (car ls))
- (else (with-syntax (((p ...) ls))
- (syntax (append p ...))))))))
- (quasivector
- (lambda (x)
- (with-syntax ((pat-x x))
- (syntax-case (syntax pat-x) ()
- ((quote? (x ...))
- (isquote? (syntax quote?))
- (syntax (quote #(x ...))))
- (_ (let f ((x x) (k (lambda (ls) `(,(syntax vector) ,@ls))))
- (syntax-case x ()
- ((quote? (x ...))
- (isquote? (syntax quote?))
- (k (syntax ((quote x) ...))))
- ((listp x ...)
- (islist? (syntax listp))
- (k (syntax (x ...))))
- ((cons? x y)
- (iscons? (syntax cons?))
- (f (syntax y) (lambda (ls) (k (cons (syntax x) ls)))))
- (else
- (syntax (list->vector pat-x))))))))))
- (quasi
- (lambda (p lev)
- (syntax-case p (unquote unquote-splicing quasiquote)
- ((unquote p)
- (if (= lev 0)
- (syntax p)
- (quasicons (syntax (quote unquote))
- (quasi (syntax (p)) (- lev 1)))))
- (((unquote p ...) . q)
- (if (= lev 0)
- (quasilist* (syntax (p ...)) (quasi (syntax q) lev))
- (quasicons (quasicons (syntax (quote unquote))
- (quasi (syntax (p ...)) (- lev 1)))
- (quasi (syntax q) lev))))
- (((unquote-splicing p ...) . q)
- (if (= lev 0)
- (quasiappend (syntax (p ...)) (quasi (syntax q) lev))
- (quasicons (quasicons (syntax (quote unquote-splicing))
- (quasi (syntax (p ...)) (- lev 1)))
- (quasi (syntax q) lev))))
- ((quasiquote p)
- (quasicons (syntax (quote quasiquote))
- (quasi (syntax (p)) (+ lev 1))))
- ((p . q)
- (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
- (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
- (p (syntax (quote p)))))))
- (lambda (x)
- (syntax-case x ()
- ((_ e) (quasi (syntax e) 0))))))
-
-(define-syntax include
- (lambda (x)
- (define read-file
- (lambda (fn k)
- (let ((p (open-input-file fn)))
- (let f ()
- (let ((x (read p)))
- (if (eof-object? x)
- (begin (close-input-port p) '())
- (cons (datum->syntax-object k x) (f))))))))
- (syntax-case x ()
- ((k filename)
- (let ((fn (syntax-object->datum (syntax filename))))
- (with-syntax (((exp ...) (read-file fn (syntax k))))
- (syntax (begin exp ...))))))))
-
-(define-syntax unquote
- (lambda (x)
- (syntax-case x ()
- ((_ e ...)
- (syntax-error x
- "expression not valid outside of quasiquote")))))
-
-(define-syntax unquote-splicing
- (lambda (x)
- (syntax-case x ()
- ((_ e ...)
- (syntax-error x
- "expression not valid outside of quasiquote")))))
-
-(define-syntax case
- (lambda (x)
- (syntax-case x ()
- ((_ e m1 m2 ...)
- (with-syntax
- ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
- (if (null? clauses)
- (syntax-case clause (else)
- ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
- (((k ...) e1 e2 ...)
- (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
- (_ (syntax-error x)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
- (syntax-case clause (else)
- (((k ...) e1 e2 ...)
- (syntax (if (memv t '(k ...))
- (begin e1 e2 ...)
- rest)))
- (_ (syntax-error x))))))))
- (syntax (let ((t e)) body)))))))
-
-(define-syntax identifier-syntax
- (lambda (x)
- (syntax-case x (set!)
- ((_ e)
- (syntax
- (lambda (x)
- (syntax-case x ()
- (id
- (identifier? (syntax id))
- (syntax e))
- ((_ x (... ...))
- (syntax (e x (... ...))))))))
- ((_ (id exp1) ((set! var val) exp2))
- (and (identifier? (syntax id)) (identifier? (syntax var)))
- (syntax
- (cons 'macro!
- (lambda (x)
- (syntax-case x (set!)
- ((set! var val) (syntax exp2))
- ((id x (... ...)) (syntax (exp1 x (... ...))))
- (id (identifier? (syntax id)) (syntax exp1))))))))))
-
diff --git a/module/language/r5rs/spec.scm b/module/language/r5rs/spec.scm
deleted file mode 100644
index 67f8d74cf..000000000
--- a/module/language/r5rs/spec.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-;;; Guile R5RS
-
-;; 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 r5rs spec)
- #:use-module (system base language)
- #:use-module (language r5rs expand)
- #:use-module (language r5rs translate)
- #:export (r5rs))
-
-
-;;;
-;;; Translator
-;;;
-
-(define (translate x) (if (pair? x) (translate-pair x) x))
-
-(define (translate-pair x)
- (let ((head (car x)) (rest (cdr x)))
- (case head
- ((quote) (cons '@quote rest))
- ((define set! if and or begin)
- (cons (symbol-append '@ head) (map translate rest)))
- ((let let* letrec)
- (cons* (symbol-append '@ head)
- (map (lambda (b) (cons (car b) (map translate (cdr b))))
- (car rest))
- (map translate (cdr rest))))
- ((lambda)
- (cons* '@lambda (car rest) (map translate (cdr rest))))
- (else
- (cons (translate head) (map translate rest))))))
-
-
-;;;
-;;; Language definition
-;;;
-
-(define-language r5rs
- #:title "Standard Scheme (R5RS + syntax-case)"
- #:version "0.3"
- #:reader read
- #:expander expand
- #:translator translate
- #:printer write
-;; #:environment (global-ref 'Language::R5RS::core)
- )
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm
deleted file mode 100644
index dc03af6cf..000000000
--- a/module/language/scheme/compile-ghil.scm
+++ /dev/null
@@ -1,494 +0,0 @@
-;;; 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-ghil)
- #:use-module (system base pmatch)
- #:use-module (system base language)
- #:use-module (language ghil)
- #:use-module (language scheme inline)
- #:use-module (system vm objcode)
- #:use-module (ice-9 receive)
- #:use-module (ice-9 optargs)
- #:use-module (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|GHIL-ENV . EXTERNALS)
-(define (cenv-module env)
- (cond ((not env) #f)
- ((module? env) env)
- ((and (pair? env) (module? (car env))) (car env))
- (else (error "bad environment" env))))
-
-(define (cenv-ghil-env env)
- (cond ((not env) (make-ghil-toplevel-env))
- ((module? env) (make-ghil-toplevel-env))
- ((pair? env)
- (if (struct? (cadr env))
- (cadr env)
- (ghil-env-dereify (cadr env))))
- (else (error "bad environment" env))))
-
-(define (cenv-externals env)
- (cond ((not env) '())
- ((module? env) '())
- ((pair? env) (cddr env))
- (else (error "bad environment" env))))
-
-(define (make-cenv module lexicals externals)
- (cons module (cons lexicals externals)))
-
-
-
-(define (compile-ghil x e opts)
- (save-module-excursion
- (lambda ()
- (and=> (cenv-module e) set-current-module)
- (call-with-ghil-environment (cenv-ghil-env e) '()
- (lambda (env vars)
- (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))))))))
-
-
-;;;
-;;; Translator
-;;;
-
-(define *forbidden-primitives*
- ;; Guile's `procedure->macro' family is evil because it crosses the
- ;; compilation boundary. One solution might be to evaluate calls to
- ;; `procedure->memoizing-macro' at compilation time, but it may be more
- ;; compicated than that.
- '(procedure->syntax procedure->macro))
-
-;; Looks up transformers relative to the current module at
-;; compilation-time. See also the discussion of ghil-lookup in ghil.scm.
-;;
-;; FIXME shadowing lexicals?
-(define (lookup-transformer head retrans)
- (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) (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))
-
- ((macro? val)
- (syntax-error #f "unknown kind of macro" head))
-
- (else #f))))
-
-(define (translate-1 e l x)
- (let ((l (or l (location x))))
- (define (retrans x) (translate-1 e #f x))
- (define (retrans/loc x) (translate-1 e (or (location x) l) x))
- (cond ((pair? x)
- (let ((head (car x)) (tail (cdr x)))
- (cond
- ((lookup-transformer head retrans/loc)
- => (lambda (t) (t e l x)))
-
- ;; FIXME: lexical/module overrides of forbidden primitives
- ((memq head *forbidden-primitives*)
- (syntax-error l (format #f "`~a' is forbidden" head)
- (cons head tail)))
-
- (else
- (let ((tail (map retrans tail)))
- (or (and (symbol? head)
- (try-inline-with-env e l (cons head tail)))
- (make-ghil-call e l (retrans head) tail)))))))
-
- ((symbol? x)
- (make-ghil-ref e l (ghil-var-for-ref! e x)))
-
- ;; fixme: non-self-quoting objects like #<foo>
- (else
- (make-ghil-quote e l x)))))
-
-(define (valid-bindings? bindings . it-is-for-do)
- (define (valid-binding? b)
- (pmatch b
- ((,sym ,var) (guard (symbol? sym)) #t)
- ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
- (else #f)))
- (and (list? bindings) (and-map valid-binding? bindings)))
-
-(define *translate-table* (make-hash-table))
-
-(define-macro (-> form)
- `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form)))
-
-(define-macro (define-scheme-translator sym . clauses)
- `(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
- (module-ref (current-module) ',sym)
- (lambda (e l exp)
- (define (retrans x)
- ((@ (language scheme compile-ghil) translate-1)
- e
- (or ((@@ (language scheme compile-ghil) location) x) l)
- x))
- (define syntax-error (@ (system base compile) syntax-error))
- (pmatch (cdr exp)
- ,@clauses
- ,@(if (assq 'else clauses) '()
- `((else
- (syntax-error l (format #f "bad ~A" ',sym) exp))))))))
-
-(define-scheme-translator quote
- ;; (quote OBJ)
- ((,obj)
- (-> (quote obj))))
-
-(define-scheme-translator quasiquote
- ;; (quasiquote OBJ)
- ((,obj)
- (-> (quasiquote (trans-quasiquote e l obj 0)))))
-
-(define-scheme-translator define
- ;; (define NAME VAL)
- ((,name ,val) (guard (symbol? name)
- (ghil-toplevel-env? (ghil-env-parent e)))
- (-> (define (ghil-var-define! (ghil-env-parent e) name)
- (maybe-name-value! (retrans val) name))))
- ;; (define (NAME FORMALS...) BODY...)
- (((,name . ,formals) . ,body) (guard (symbol? name))
- ;; -> (define NAME (lambda FORMALS BODY...))
- (retrans `(define ,name (lambda ,formals ,@body)))))
-
-(define-scheme-translator set!
- ;; (set! NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> (set (ghil-var-for-set! e name) (retrans val))))
-
- ;; FIXME: Would be nice to verify the values of @ and @@ relative
- ;; to imported modules...
- (((@ ,modname ,name) ,val) (guard (symbol? name)
- (list? modname)
- (and-map symbol? modname)
- (not (ghil-var-is-bound? e '@)))
- (-> (set (ghil-var-at-module! e modname name #t) (retrans val))))
-
- (((@@ ,modname ,name) ,val) (guard (symbol? name)
- (list? modname)
- (and-map symbol? modname)
- (not (ghil-var-is-bound? e '@@)))
- (-> (set (ghil-var-at-module! e modname name #f) (retrans val))))
-
- ;; (set! (NAME ARGS...) VAL)
- (((,name . ,args) ,val) (guard (symbol? name))
- ;; -> ((setter NAME) ARGS... VAL)
- (retrans `((setter ,name) . (,@args ,val)))))
-
-(define-scheme-translator if
- ;; (if TEST THEN [ELSE])
- ((,test ,then)
- (-> (if (retrans test) (retrans then) (retrans '(begin)))))
- ((,test ,then ,else)
- (-> (if (retrans test) (retrans then) (retrans else)))))
-
-(define-scheme-translator and
- ;; (and EXPS...)
- (,tail
- (-> (and (map retrans tail)))))
-
-(define-scheme-translator or
- ;; (or EXPS...)
- (,tail
- (-> (or (map retrans tail)))))
-
-(define-scheme-translator begin
- ;; (begin EXPS...)
- (,tail
- (-> (begin (map retrans tail)))))
-
-(define-scheme-translator let
- ;; (let NAME ((SYM VAL) ...) BODY...)
- ((,name ,bindings . ,body) (guard (symbol? name)
- (valid-bindings? bindings))
- ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
- (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body)))
- (,name ,@(map cadr bindings)))))
-
- ;; (let () BODY...)
- ((() . ,body)
- ;; Note: this differs from `begin'
- (-> (begin (list (trans-body e l body)))))
-
- ;; (let ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (let ((vals (map (lambda (b)
- (maybe-name-value! (retrans (cadr b)) (car b)))
- bindings)))
- (call-with-ghil-bindings e (map car bindings)
- (lambda (vars)
- (-> (bind vars vals (trans-body e l body))))))))
-
-(define-scheme-translator let*
- ;; (let* ((SYM VAL) ...) BODY...)
- ((() . ,body)
- (retrans `(let () ,@body)))
- ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
- (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
-
-(define-scheme-translator letrec
- ;; (letrec ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (call-with-ghil-bindings e (map car bindings)
- (lambda (vars)
- (let ((vals (map (lambda (b)
- (maybe-name-value!
- (retrans (cadr b)) (car b)))
- bindings)))
- (-> (bind vars vals (trans-body e l body))))))))
-
-(define-scheme-translator cond
- ;; (cond (CLAUSE BODY...) ...)
- (() (retrans '(begin)))
- (((else . ,body)) (retrans `(begin ,@body)))
- (((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
- (((,test => ,proc) . ,rest)
- ;; FIXME hygiene!
- (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
- (((,test . ,body) . ,rest)
- (retrans `(if ,test (begin ,@body) (cond ,@rest)))))
-
-(define-scheme-translator case
- ;; (case EXP ((KEY...) BODY...) ...)
- ((,exp . ,clauses)
- (retrans
- ;; FIXME hygiene!
- `(let ((_t ,exp))
- ,(let loop ((ls clauses))
- (cond ((null? ls) '(begin))
- ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
- (else `(if (memv _t ',(caar ls))
- (begin ,@(cdar ls))
- ,(loop (cdr ls))))))))))
-
-(define-scheme-translator do
- ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
- ((,bindings (,test . ,result) . ,body)
- (let ((sym (map car bindings))
- (val (map cadr bindings))
- (update (map cddr bindings)))
- (define (next s x) (if (pair? x) (car x) s))
- (retrans
- ;; FIXME hygiene!
- `(letrec ((_l (lambda ,sym
- (if ,test
- (begin ,@result)
- (begin ,@body
- (_l ,@(map next sym update)))))))
- (_l ,@val))))))
-
-(define-scheme-translator lambda
- ;; (lambda FORMALS BODY...)
- ((,formals . ,body)
- (receive (syms rest) (parse-formals formals)
- (call-with-ghil-environment e syms
- (lambda (e vars)
- (receive (meta body) (parse-lambda-meta body)
- (-> (lambda vars rest meta (trans-body e l body)))))))))
-
-(define-scheme-translator delay
- ;; FIXME not hygienic
- ((,expr)
- (retrans `(make-promise (lambda () ,expr)))))
-
-(define-scheme-translator @
- ((,modname ,sym)
- (-> (ref (ghil-var-at-module! e modname sym #t)))))
-
-(define-scheme-translator @@
- ((,modname ,sym)
- (-> (ref (ghil-var-at-module! e modname sym #f)))))
-
-(define *the-compile-toplevel-symbol* 'compile-toplevel)
-(define-scheme-translator eval-when
- ((,when . ,body) (guard (list? when) (and-map symbol? when))
- (if (memq 'compile when)
- (primitive-eval `(begin . ,body)))
- (if (memq 'load when)
- (retrans `(begin . ,body))
- (retrans `(begin)))))
-
-(define-scheme-translator apply
- ;; FIXME: not hygienic, relies on @apply not being shadowed
- (,args (retrans `(@apply ,@args))))
-
-;; FIXME: we could add inliners for `list' and `vector'
-
-(define-scheme-translator @apply
- ((,proc ,arg1 . ,args)
- (let ((args (cons (retrans arg1) (map retrans args))))
- (cond ((and (symbol? proc)
- (not (ghil-var-is-bound? e proc))
- (and=> (module-variable (current-module) proc)
- (lambda (var)
- (and (variable-bound? var)
- (lookup-apply-transformer (variable-ref var))))))
- ;; that is, a variable, not part of this compilation
- ;; unit, but defined in the toplevel environment, and has
- ;; an apply transformer registered
- => (lambda (t) (t e l args)))
- (else
- (-> (inline 'apply (cons (retrans proc) args))))))))
-
-(define-scheme-translator call-with-values
- ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
- ((,producer ,consumer)
- (retrans `(@call-with-values ,producer ,consumer)))
- (else #f))
-
-(define-scheme-translator @call-with-values
- ((,producer ,consumer)
- (-> (mv-call (retrans producer) (retrans consumer)))))
-
-(define-scheme-translator call-with-current-continuation
- ;; FIXME: not hygienic, relies on @call-with-current-continuation
- ;; not being shadowed
- ((,proc)
- (retrans `(@call-with-current-continuation ,proc)))
- (else #f))
-
-(define-scheme-translator @call-with-current-continuation
- ((,proc)
- (-> (inline 'call/cc (list (retrans proc))))))
-
-(define-scheme-translator receive
- ((,formals ,producer-exp . ,body)
- ;; Lovely, self-referential usage. Not strictly necessary, the
- ;; macro would do the trick; but it's good to test the mv-bind
- ;; code.
- (receive (syms rest) (parse-formals formals)
- (let ((producer (retrans `(lambda () ,producer-exp))))
- (call-with-ghil-bindings e syms
- (lambda (vars)
- (-> (mv-bind producer vars rest
- (trans-body e l body)))))))))
-
-(define-scheme-translator values
- ((,x) (retrans x))
- (,args
- (-> (values (map retrans args)))))
-
-(define (lookup-apply-transformer proc)
- (cond ((eq? proc values)
- (lambda (e l args)
- (-> (values* args))))
- (else #f)))
-
-(define (trans-quasiquote e l x level)
- (cond ((not (pair? x)) x)
- ((memq (car x) '(unquote unquote-splicing))
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj)
- (cond
- ((zero? level)
- (if (eq? (car x) 'unquote)
- (-> (unquote (translate-1 e l obj)))
- (-> (unquote-splicing (translate-1 e l obj)))))
- (else
- (list (car x) (trans-quasiquote e l obj (1- level))))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- ((eq? (car x) 'quasiquote)
- (let ((l (location x)))
- (pmatch (cdr x)
- ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level))))
- (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
- (else (cons (trans-quasiquote e l (car x) level)
- (trans-quasiquote e l (cdr x) level)))))
-
-(define (trans-body e l body)
- (define (define->binding df)
- (pmatch (cdr df)
- ((,name ,val) (guard (symbol? name)) (list name val))
- (((,name . ,formals) . ,body) (guard (symbol? name))
- (list name `(lambda ,formals ,@body)))
- (else (syntax-error (location df) "bad define" df))))
- ;; main
- (let loop ((ls body) (ds '()))
- (pmatch ls
- (() (syntax-error l "bad body" body))
- (((define . _) . _)
- (loop (cdr ls) (cons (car ls) ds)))
- (else
- (if (null? ds)
- (translate-1 e l `(begin ,@ls))
- (translate-1 e l `(letrec ,(map define->binding ds) ,@ls)))))))
-
-(define (parse-formals formals)
- (cond
- ;; (lambda x ...)
- ((symbol? formals) (values (list formals) #t))
- ;; (lambda (x y z) ...)
- ((list? formals) (values formals #f))
- ;; (lambda (x y . z) ...)
- ((pair? formals)
- (let loop ((l formals) (v '()))
- (if (pair? l)
- (loop (cdr l) (cons (car l) v))
- (values (reverse! (cons l v)) #t))))
- (else (syntax-error (location formals) "bad formals" formals))))
-
-(define (parse-lambda-meta body)
- (cond ((or (null? body) (null? (cdr body))) (values '() body))
- ((string? (car body))
- (values `((documentation . ,(car body))) (cdr body)))
- (else (values '() body))))
-
-(define (maybe-name-value! val name)
- (cond
- ((ghil-lambda? val)
- (if (not (assq-ref (ghil-lambda-meta val) 'name))
- (set! (ghil-lambda-meta val)
- (acons 'name name (ghil-lambda-meta val))))))
- val)
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- props))))
diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm
index 4ac33d77e..5d01a2651 100644
--- a/module/language/scheme/compile-tree-il.scm
+++ b/module/language/scheme/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile Scheme specification
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; 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
@@ -24,40 +24,11 @@
;;; 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)
+ (set-current-module e)
(let* ((x (sc-expand x 'c '(compile load eval)))
- (cenv (make-cenv (current-module)
- (cenv-lexicals e) (cenv-externals e))))
+ (cenv (current-module)))
(values x cenv cenv)))))
diff --git a/module/language/scheme/inline.scm b/module/language/scheme/inline.scm
deleted file mode 100644
index b178b2adc..000000000
--- a/module/language/scheme/inline.scm
+++ /dev/null
@@ -1,205 +0,0 @@
-;;; GHIL macros
-
-;; 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 inline)
- #:use-module (system base syntax)
- #:use-module (language ghil)
- #:use-module (srfi srfi-16)
- #:export (*inline-table* define-inline try-inline try-inline-with-env))
-
-(define *inline-table* '())
-
-(define-macro (define-inline sym . clauses)
- (define (inline-args args)
- (let lp ((in args) (out '()))
- (cond ((null? in) `(list ,@(reverse out)))
- ((symbol? in) `(cons* ,@(reverse out) ,in))
- ((pair? (car in))
- (lp (cdr in)
- (cons `(or (try-inline ,(caar in) ,(inline-args (cdar in)))
- (error "what" ',(car in)))
- out)))
- ((symbol? (car in))
- ;; assume it's locally bound
- (lp (cdr in) (cons (car in) out)))
- ((number? (car in))
- (lp (cdr in) (cons `(make-ghil-quote #f #f ,(car in)) out)))
- (else
- (error "what what" (car in))))))
- (define (consequent exp)
- (cond
- ((pair? exp)
- `(make-ghil-inline #f #f ',(car exp) ,(inline-args (cdr exp))))
- ((symbol? exp)
- ;; assume locally bound
- exp)
- ((number? exp)
- `(make-ghil-quote #f #f ,exp))
- (else (error "bad consequent yall" exp))))
- `(set! (@ (language scheme inline) *inline-table*)
- (assq-set! (@ (language scheme inline) *inline-table*)
- ,sym
- (let ((make-ghil-inline (@ (language ghil) make-ghil-inline))
- (make-ghil-quote (@ (language ghil) make-ghil-quote))
- (try-inline (@ (language scheme inline) try-inline)))
- (case-lambda
- ,@(let lp ((in clauses) (out '()))
- (if (null? in)
- (reverse (cons '(else #f) out))
- (lp (cddr in)
- (cons `(,(car in)
- ,(consequent (cadr in))) out)))))))))
-
-(define (try-inline head-value args)
- (and=> (assq-ref *inline-table* head-value)
- (lambda (proc) (apply proc args))))
-
-
-(define (try-inline-with-env env loc exp)
- (let ((sym (car exp)))
- (let loop ((e env))
- (record-case e
- ((<ghil-toplevel-env> table)
- (let ((mod (current-module)))
- (and (not (assoc-ref table (cons (module-name mod) sym)))
- (module-bound? mod sym)
- (try-inline (module-ref mod sym) (cdr exp)))))
- ((<ghil-env> parent table variables)
- (and (not (assq-ref table sym))
- (loop parent)))))))
-
-(define-inline eq? (x y)
- (eq? x y))
-
-(define-inline eqv? (x y)
- (eqv? x y))
-
-(define-inline equal? (x y)
- (equal? x y))
-
-(define-inline = (x y)
- (ee? x y))
-
-(define-inline < (x y)
- (lt? x y))
-
-(define-inline > (x y)
- (gt? x y))
-
-(define-inline <= (x y)
- (le? x y))
-
-(define-inline >= (x y)
- (ge? x y))
-
-(define-inline zero? (x)
- (ee? x 0))
-
-(define-inline +
- () 0
- (x) x
- (x y) (add x y)
- (x y . rest) (add x (+ y . rest)))
-
-(define-inline *
- () 1
- (x) x
- (x y) (mul x y)
- (x y . rest) (mul x (* y . rest)))
-
-(define-inline -
- (x) (sub 0 x)
- (x y) (sub x y)
- (x y . rest) (sub x (+ y . rest)))
-
-(define-inline 1-
- (x) (sub x 1))
-
-(define-inline /
- (x) (div 1 x)
- (x y) (div x y)
- (x y . rest) (div x (* y . rest)))
-
-(define-inline quotient (x y)
- (quo x y))
-
-(define-inline remainder (x y)
- (rem x y))
-
-(define-inline modulo (x y)
- (mod x y))
-
-(define-inline not (x)
- (not x))
-
-(define-inline pair? (x)
- (pair? x))
-
-(define-inline cons (x y)
- (cons x y))
-
-(define-inline car (x) (car x))
-(define-inline cdr (x) (cdr x))
-
-(define-inline set-car! (x y) (set-car! x y))
-(define-inline set-cdr! (x y) (set-cdr! x y))
-
-(define-inline caar (x) (car (car x)))
-(define-inline cadr (x) (car (cdr x)))
-(define-inline cdar (x) (cdr (car x)))
-(define-inline cddr (x) (cdr (cdr x)))
-(define-inline caaar (x) (car (car (car x))))
-(define-inline caadr (x) (car (car (cdr x))))
-(define-inline cadar (x) (car (cdr (car x))))
-(define-inline caddr (x) (car (cdr (cdr x))))
-(define-inline cdaar (x) (cdr (car (car x))))
-(define-inline cdadr (x) (cdr (car (cdr x))))
-(define-inline cddar (x) (cdr (cdr (car x))))
-(define-inline cdddr (x) (cdr (cdr (cdr x))))
-(define-inline caaaar (x) (car (car (car (car x)))))
-(define-inline caaadr (x) (car (car (car (cdr x)))))
-(define-inline caadar (x) (car (car (cdr (car x)))))
-(define-inline caaddr (x) (car (car (cdr (cdr x)))))
-(define-inline cadaar (x) (car (cdr (car (car x)))))
-(define-inline cadadr (x) (car (cdr (car (cdr x)))))
-(define-inline caddar (x) (car (cdr (cdr (car x)))))
-(define-inline cadddr (x) (car (cdr (cdr (cdr x)))))
-(define-inline cdaaar (x) (cdr (car (car (car x)))))
-(define-inline cdaadr (x) (cdr (car (car (cdr x)))))
-(define-inline cdadar (x) (cdr (car (cdr (car x)))))
-(define-inline cdaddr (x) (cdr (car (cdr (cdr x)))))
-(define-inline cddaar (x) (cdr (cdr (car (car x)))))
-(define-inline cddadr (x) (cdr (cdr (car (cdr x)))))
-(define-inline cdddar (x) (cdr (cdr (cdr (car x)))))
-(define-inline cddddr (x) (cdr (cdr (cdr (cdr x)))))
-
-(define-inline null? (x)
- (null? x))
-
-(define-inline list? (x)
- (list? x))
-
-(define-inline cons*
- (x) x
- (x y) (cons x y)
- (x y . rest) (cons x (cons* y . rest)))
-
-(define-inline acons
- (x y z) (cons (cons x y) z))
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index df618581f..6cfbc422f 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -19,6 +19,7 @@
;;; Code:
(define-module (language scheme spec)
+ #:use-module (system base compile)
#:use-module (system base language)
#:use-module (language scheme compile-tree-il)
#:use-module (language scheme decompile-tree-il)
@@ -37,9 +38,26 @@
(define-language scheme
#:title "Guile Scheme"
#:version "0.5"
- #:reader read
+ #:reader (lambda (port env)
+ ;; Use the binding of current-reader from the environment.
+ ;; FIXME: Handle `read-options' as well?
+ ((or (and=> (and=> (module-variable env 'current-reader)
+ variable-ref)
+ fluid-ref)
+ read)
+ port))
+
#:compilers `((tree-il . ,compile-tree-il))
#:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
- )
+ #:make-default-environment
+ (lambda ()
+ ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
+ ;; `fluid-set!', etc. don't have any effect in the current environment.
+ (let ((m (make-fresh-user-module)))
+ ;; Provide a separate `current-reader' fluid so that
+ ;; compile-time changes to `current-reader' are
+ ;; limited to the current compilation unit.
+ (module-define! m 'current-reader (make-fluid))
+ m)))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index ad8b73176..e6a8213e7 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -36,11 +36,15 @@
<conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
<application> application? make-application application-src application-proc application-args
<sequence> sequence? make-sequence sequence-src sequence-exps
- <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
+ <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
+ <lambda-case> lambda-case? make-lambda-case lambda-case-src
+ lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
+ lambda-case-inits lambda-case-vars
+ lambda-case-predicate lambda-case-body lambda-case-else
<let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
- <let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
+ <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
parse-tree-il
unparse-tree-il
@@ -65,11 +69,12 @@
(<conditional> test then else)
(<application> proc args)
(<sequence> exps)
- (<lambda> names vars meta body)
+ (<lambda> meta body)
+ (<lambda-case> req opt rest kw inits vars predicate body else)
(<let> names vars vals body)
(<letrec> names vars vals body)
(<fix> names vars vals body)
- (<let-values> names vars exp body))
+ (<let-values> exp body))
@@ -127,11 +132,22 @@
((define ,name ,exp) (guard (symbol? name))
(make-toplevel-define loc name (retrans exp)))
- ((lambda ,names ,vars ,exp)
- (make-lambda loc names vars '() (retrans exp)))
+ ((lambda ,meta ,body)
+ (make-lambda loc meta (retrans body)))
- ((lambda ,names ,vars ,meta ,exp)
- (make-lambda loc names vars meta (retrans exp)))
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars ,predicate) ,body) ,else)
+ (make-lambda-case loc req opt rest kw
+ (map retrans inits) vars
+ (and=> predicate retrans)
+ (retrans body)
+ (and=> else retrans)))
+
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars ,predicate) ,body))
+ (make-lambda-case loc req opt rest kw
+ (map retrans inits) vars
+ (and=> predicate retrans)
+ (retrans body)
+ #f))
((const ,exp)
(make-const loc exp))
@@ -148,8 +164,8 @@
((fix ,names ,vars ,vals ,body)
(make-fix loc names vars (map retrans vals) (retrans body)))
- ((let-values ,names ,vars ,exp ,body)
- (make-let-values loc names vars (retrans exp) (retrans body)))
+ ((let-values ,exp ,body)
+ (make-let-values loc (retrans exp) (retrans body)))
(else
(error "unrecognized tree-il" exp)))))
@@ -189,8 +205,14 @@
((<toplevel-define> name exp)
`(define ,name ,(unparse-tree-il exp)))
- ((<lambda> names vars meta body)
- `(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
+ ((<lambda> meta body)
+ `(lambda ,meta ,(unparse-tree-il body)))
+
+ ((<lambda-case> req opt rest kw inits vars predicate body else)
+ `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars
+ ,(and=> predicate unparse-tree-il))
+ ,(unparse-tree-il body))
+ . ,(if else (list (unparse-tree-il else)) '())))
((<const> exp)
`(const ,exp))
@@ -207,8 +229,8 @@
((<fix> names vars vals body)
`(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<let-values> names vars exp body)
- `(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
+ ((<let-values> exp body)
+ `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
(define (tree-il->scheme e)
(record-case e
@@ -226,10 +248,10 @@
((<primitive-ref> name)
name)
- ((<lexical-ref> name gensym)
+ ((<lexical-ref> gensym)
gensym)
- ((<lexical-set> name gensym exp)
+ ((<lexical-set> gensym exp)
`(set! ,gensym ,(tree-il->scheme exp)))
((<module-ref> mod name public?)
@@ -247,10 +269,18 @@
((<toplevel-define> name exp)
`(define ,name ,(tree-il->scheme exp)))
- ((<lambda> vars meta body)
- `(lambda ,vars
- ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
- ,(tree-il->scheme body)))
+ ((<lambda> meta body)
+ ;; fixme: put in docstring
+ (if (and (lambda-case? body)
+ (not (lambda-case-else body)))
+ `(lambda ,@(car (tree-il->scheme body)))
+ `(case-lambda ,@(tree-il->scheme body))))
+
+ ((<lambda-case> req opt rest kw inits vars predicate body else)
+ ;; FIXME! use parse-lambda-case?
+ `((,(if rest (apply cons* vars) vars)
+ ,(tree-il->scheme body))
+ ,@(if else (tree-il->scheme else) '())))
((<const> exp)
(if (and (self-evaluating? exp) (not (vector? exp)))
@@ -272,7 +302,7 @@
((<let-values> vars exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
- (lambda ,vars ,(tree-il->scheme body))))))
+ ,(tree-il->scheme (make-lambda #f '() body))))))
(define (tree-il-fold leaf down up seed tree)
@@ -306,6 +336,15 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop exps (down tree result))))
((<lambda> body)
(up tree (loop body (down tree result))))
+ ((<lambda-case> inits predicate body else)
+ (up tree (if else
+ (loop else
+ (if predicate
+ (loop body (loop predicate (loop inits (down tree result))))
+ (loop body (loop inits (down tree result)))))
+ (if predicate
+ (loop body (loop predicate (loop inits (down tree result))))
+ (loop body (loop inits (down tree result)))))))
((<let> vals body)
(up tree (loop body
(loop vals
@@ -357,6 +396,19 @@ This is an implementation of `foldts' as described by Andy Wingo in
(fold-values foldts exps seed ...))
((<lambda> body)
(foldts body seed ...))
+ ((<lambda-case> inits predicate body else)
+ (let-values (((seed ...) (fold-values foldts inits seed ...)))
+ (if predicate
+ (if else
+ (let*-values (((seed ...) (foldts predicate seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (foldts else seed ...))
+ (let-values (((seed ...) (foldts predicate seed ...)))
+ (foldts body seed ...)))
+ (if else
+ (let-values (((seed ...) (foldts body seed ...)))
+ (foldts else seed ...))
+ (foldts body seed ...)))))
((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
@@ -397,9 +449,17 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<toplevel-define> name exp)
(set! (toplevel-define-exp x) (lp exp)))
- ((<lambda> vars meta body)
+ ((<lambda> body)
(set! (lambda-body x) (lp body)))
+ ((<lambda-case> inits predicate body else)
+ (set! inits (map lp inits))
+ (if predicate
+ (set! (lambda-case-predicate x) (lp predicate)))
+ (set! (lambda-case-body x) (lp body))
+ (if else
+ (set! (lambda-case-else x) (lp else))))
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
@@ -415,7 +475,7 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
- ((<let-values> vars exp body)
+ ((<let-values> exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
@@ -436,37 +496,43 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (conditional-then x) (lp then))
(set! (conditional-else x) (lp else)))
- ((<lexical-set> name gensym exp)
+ ((<lexical-set> exp)
(set! (lexical-set-exp x) (lp exp)))
- ((<module-set> mod name public? exp)
+ ((<module-set> exp)
(set! (module-set-exp x) (lp exp)))
- ((<toplevel-set> name exp)
+ ((<toplevel-set> exp)
(set! (toplevel-set-exp x) (lp exp)))
- ((<toplevel-define> name exp)
+ ((<toplevel-define> exp)
(set! (toplevel-define-exp x) (lp exp)))
- ((<lambda> vars meta body)
+ ((<lambda> body)
(set! (lambda-body x) (lp body)))
+ ((<lambda-case> inits predicate body else)
+ (set! inits (map lp inits))
+ (if predicate (set! (lambda-case-predicate x) (lp predicate)))
+ (set! (lambda-case-body x) (lp body))
+ (if else (set! (lambda-case-else x) (lp else))))
+
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
- ((<let> vars vals body)
+ ((<let> vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
- ((<letrec> vars vals body)
+ ((<letrec> vals body)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
- ((<fix> vars vals body)
+ ((<fix> vals body)
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
- ((<let-values> vars exp body)
+ ((<let-values> exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index b93a0bd7e..5faed6f5f 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -25,7 +25,8 @@
#:use-module (system base message)
#:use-module (language tree-il)
#:export (analyze-lexicals
- report-unused-variables))
+ report-unused-variables
+ report-possibly-unbound-variables))
;; Allocation is the process of assigning storage locations for lexical
;; variables. A lexical variable has a distinct "address", or storage
@@ -111,13 +112,20 @@
;; translated into labels, and information on what free variables to
;; capture from its lexical parent procedure.
;;
+;; In addition, we have a conflation: while we're traversing the code,
+;; recording information to pass to the compiler, we take the
+;; opportunity to generate labels for each lambda-case clause, so that
+;; generated code can skip argument checks at runtime if they match at
+;; compile-time.
+;;
;; That is:
;;
;; sym -> {lambda -> address}
-;; lambda -> (nlocs labels . free-locs)
+;; lambda -> (labels . free-locs)
+;; lambda-case -> (gensym . nlocs)
;;
;; address ::= (local? boxed? . index)
-;; labels ::= ((sym . lambda-vars) ...)
+;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
@@ -140,9 +148,9 @@
;; refcounts: sym -> count
;; allows us to detect the or-expansion in O(1) time
(define refcounts (make-hash-table))
- ;; labels: sym -> lambda-vars
+ ;; labels: sym -> lambda
;; for determining if fixed-point procedures can be rendered as
- ;; labels. lambda-vars may be an improper list.
+ ;; labels.
(define labels (make-hash-table))
;; returns variables referenced in expr
@@ -162,28 +170,40 @@
((<conditional> test then else)
(lset-union eq? (step test) (step-tail then) (step-tail else)))
- ((<lexical-ref> name gensym)
+ ((<lexical-ref> 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))))))
+ (let ((p (hashq-ref labels gensym)))
+ (and p
+ (let lp ((c (lambda-body p)))
+ (and c (lambda-case? c)
+ (or
+ ;; for now prohibit optional &
+ ;; keyword arguments; can relax this
+ ;; restriction later
+ (and (= (length (lambda-case-req c))
+ (length tail-call-args))
+ (not (lambda-case-opt c))
+ (not (lambda-case-kw c))
+ (not (lambda-case-rest c))
+ (not (lambda-case-predicate c)))
+ (lp (lambda-case-else c)))))))))
(hashq-set! labels gensym #f))
(list gensym))
- ((<lexical-set> name gensym exp)
+ ((<lexical-set> gensym exp)
(hashq-set! assigned gensym #t)
(hashq-set! labels gensym #f)
(lset-adjoin eq? (step exp) gensym))
- ((<module-set> mod name public? exp)
+ ((<module-set> exp)
(step exp))
- ((<toplevel-set> name exp)
+ ((<toplevel-set> exp)
(step exp))
- ((<toplevel-define> name exp)
+ ((<toplevel-define> exp)
(step exp))
((<sequence> exps)
@@ -194,19 +214,26 @@
(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)))
+ ((<lambda> body)
+ ;; order is important here
+ (hashq-set! bound-vars x '())
+ (let ((free (recur body x)))
+ (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
+ (hashq-set! free-vars x free)
+ free))
+
+ ((<lambda-case> opt kw inits vars predicate body else)
+ (hashq-set! bound-vars proc
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ (lset-union
+ eq?
+ (lset-difference eq?
+ (lset-union eq?
+ (apply lset-union eq? (map step inits))
+ (if predicate (step predicate) '())
+ (step-tail body))
+ vars)
+ (if else (step-tail else) '())))
((<let> vars vals body)
(hashq-set! bound-vars proc
@@ -225,7 +252,7 @@
((<fix> vars vals body)
;; Try to allocate these procedures as labels.
- (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val)))
+ (for-each (lambda (sym val) (hashq-set! labels sym val))
vars vals)
(hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc)))
@@ -239,21 +266,14 @@
;; prevent label allocation.)
(lambda (x)
(record-case x
- ((<lambda> (lvars vars) body)
- (let ((locally-bound
- (let rev* ((lvars lvars) (out '()))
- (cond ((null? lvars) out)
- ((pair? lvars) (rev* (cdr lvars)
- (cons (car lvars) out)))
- (else (cons lvars out))))))
- (hashq-set! bound-vars x locally-bound)
- ;; recur/labels, the difference from the closure case
- (let* ((referenced (recur/labels body x vars))
- (free (lset-difference eq? referenced locally-bound))
- (all-bound (reverse! (hashq-ref bound-vars x))))
- (hashq-set! bound-vars x all-bound)
- (hashq-set! free-vars x free)
- free)))))
+ ((<lambda> body)
+ ;; just like the closure case, except here we use
+ ;; recur/labels instead of recur
+ (hashq-set! bound-vars x '())
+ (let ((free (recur/labels body x vars)))
+ (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
+ (hashq-set! free-vars x free)
+ free))))
vals))
(vars-with-refs (map cons vars var-refs))
(body-refs (recur/labels body proc vars)))
@@ -301,15 +321,8 @@
(apply lset-union eq? body-refs var-refs)
vars)))
- ((<let-values> vars exp body)
- (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
- (if (pair? in)
- (lp (cons (car in) out) (cdr in))
- (if (null? in) out (cons in out))))))
- (hashq-set! bound-vars proc bound)
- (lset-difference eq?
- (lset-union eq? (step exp) (step-tail body))
- bound)))
+ ((<let-values> exp body)
+ (lset-union eq? (step exp) (step body)))
(else '())))
@@ -326,22 +339,22 @@
((<conditional> test then else)
(max (recur test) (recur then) (recur else)))
- ((<lexical-set> name gensym exp)
+ ((<lexical-set> exp)
(recur exp))
- ((<module-set> mod name public? exp)
+ ((<module-set> exp)
(recur exp))
- ((<toplevel-set> name exp)
+ ((<toplevel-set> exp)
(recur exp))
- ((<toplevel-define> name exp)
+ ((<toplevel-define> exp)
(recur exp))
((<sequence> exps)
(apply max (map recur exps)))
- ((<lambda> vars meta body)
+ ((<lambda> body)
;; allocate closure vars in order
(let lp ((c (hashq-ref free-vars x)) (n 0))
(if (pair? c)
@@ -351,17 +364,7 @@
`(#f ,(hashq-ref assigned (car c)) . ,n))
(lp (cdr c) (1+ n)))))
- (let ((nlocs
- (let lp ((vars vars) (n 0))
- (if (not (null? vars))
- ;; allocate args
- (let ((v (if (pair? vars) (car vars) vars)))
- (hashq-set! allocation v
- (make-hashq
- x `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
- ;; allocate body, return number of additional locals
- (- (allocate! body x n) n))))
+ (let ((nlocs (allocate! body x 0))
(free-addresses
(map (lambda (v)
(hashq-ref (hashq-ref allocation v) proc))
@@ -371,9 +374,30 @@
(cons sym (hashq-ref labels sym)))
(hashq-ref bound-vars x)))))
;; set procedure allocations
- (hashq-set! allocation x (cons* nlocs labels free-addresses)))
+ (hashq-set! allocation x (cons labels free-addresses)))
n)
+ ((<lambda-case> opt kw inits vars predicate body else)
+ (max
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (let ((nlocs (apply
+ max
+ (if predicate (allocate! predicate body n) n)
+ (allocate! body proc n)
+ ;; inits not logically at the end, but they
+ ;; are the list...
+ (map (lambda (x) (allocate! x body n)) inits))))
+ ;; label and nlocs for the case
+ (hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
+ nlocs)
+ (begin
+ (hashq-set! allocation (car vars)
+ (make-hashq
+ proc `(#t ,(hashq-ref assigned (car vars)) . ,n)))
+ (lp (cdr vars) (1+ n)))))
+ (if else (allocate! else proc n) n)))
+
((<let> vars vals body)
(let ((nmax (apply max (map recur vals))))
(cond
@@ -425,22 +449,12 @@
((null? vars)
(max nmax (allocate! body proc n)))
((hashq-ref labels (car vars))
- ;; allocate label bindings & body inline to proc
+ ;; allocate lambda body inline to proc
(lp (cdr vars)
(cdr vals)
(record-case (car vals)
- ((<lambda> vars body)
- (let lp ((vars vars) (n n))
- (if (not (null? vars))
- ;; allocate bindings
- (let ((v (if (pair? vars) (car vars) vars)))
- (hashq-set!
- allocation v
- (make-hashq
- proc `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
- ;; allocate body
- (max nmax (allocate! body proc n))))))))
+ ((<lambda> body)
+ (max nmax (allocate! body proc n))))))
(else
;; allocate closure
(lp (cdr vars)
@@ -459,25 +473,8 @@
(hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
(lp (cdr in) (1+ n))))))))
- ((<let-values> vars exp body)
- (let ((nmax (recur exp)))
- (let lp ((vars vars) (n n))
- (cond
- ((null? vars)
- (max nmax (allocate! body proc n)))
- ((not (pair? vars))
- (hashq-set! allocation vars
- (make-hashq proc
- `(#t ,(hashq-ref assigned vars) . ,n)))
- ;; the 1+ for this var
- (max nmax (allocate! body proc (1+ n))))
- (else
- (let ((v (car vars)))
- (hashq-set!
- allocation v
- (make-hashq proc
- `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (cdr vars) (1+ n))))))))
+ ((<let-values> exp body)
+ (max (recur exp) (recur body)))
(else n)))
@@ -502,21 +499,10 @@
(refs binding-info-refs) ;; (GENSYM ...)
(locs binding-info-locs)) ;; (LOCATION ...)
-(define (report-unused-variables tree)
+;; FIXME!!
+(define (report-unused-variables tree env)
"Report about unused variables in TREE. Return TREE."
- (define (dotless-list lst)
- ;; If LST is a dotted list, return a proper list equal to LST except that
- ;; the very last element is a pair; otherwise return LST.
- (let loop ((lst lst)
- (result '()))
- (cond ((null? lst)
- (reverse result))
- ((pair? lst)
- (loop (cdr lst) (cons (car lst) result)))
- (else
- (loop '() (cons lst result))))))
-
(tree-il-fold (lambda (x info)
;; X is a leaf: extend INFO's refs accordingly.
(let ((refs (binding-info-refs info))
@@ -544,9 +530,12 @@
((<lexical-set> gensym)
(make-binding-info vars (cons gensym refs)
(cons src locs)))
- ((<lambda> vars names)
- (let ((vars (dotless-list vars))
- (names (dotless-list names)))
+ ((<lambda-case> req opt inits rest kw vars)
+ ;; FIXME keywords.
+ (let ((names `(,@req
+ ,@(map car (or opt '()))
+ ,@(if rest (list rest) '())
+ ,@(if kw (map cadr (cdr kw)) '()))))
(make-binding-info (extend vars names) refs
(cons src locs))))
((<let> vars names)
@@ -558,9 +547,6 @@
((<fix> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
- ((<let-values> vars names)
- (make-binding-info (extend vars names) refs
- (cons src locs)))
(else info))))
(lambda (x info)
@@ -575,7 +561,7 @@
;; Don't report lambda parameters as
;; unused.
(if (and (not (memq gensym refs))
- (not (and (lambda? x)
+ (not (and (lambda-case? x)
(memq gensym
inner-vars))))
(let ((name (cadr var))
@@ -595,10 +581,9 @@
;; It doesn't hurt as these are unique names, it just
;; makes REFS unnecessarily fat.
(record-case x
- ((<lambda> vars)
- (let ((vars (dotless-list vars)))
- (make-binding-info (shrink vars refs) refs
- (cdr locs))))
+ ((<lambda-case> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
((<let> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
@@ -608,10 +593,130 @@
((<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)
+
+
+;;;
+;;; Unbound variable analysis.
+;;;
+
+;; <toplevel-info> records are used during tree traversal in search of
+;; possibly unbound variable. They contain a list of references to
+;; potentially unbound top-level variables, a list of the top-level defines
+;; that have been encountered, and a "location stack" (see above).
+(define-record-type <toplevel-info>
+ (make-toplevel-info refs defs locs)
+ toplevel-info?
+ (refs toplevel-info-refs) ;; ((VARIABLE-NAME . LOCATION) ...)
+ (defs toplevel-info-defs) ;; (VARIABLE-NAME ...)
+ (locs toplevel-info-locs)) ;; (LOCATION ...)
+
+(define (goops-toplevel-definition proc args env)
+ ;; If application of PROC to ARGS is a GOOPS top-level definition, return
+ ;; the name of the variable being defined; otherwise return #f. This
+ ;; assumes knowledge of the current implementation of `define-class' et al.
+ (define (toplevel-define-arg args)
+ (and (pair? args) (pair? (cdr args)) (null? (cddr args))
+ (record-case (car args)
+ ((<const> exp)
+ (and (symbol? exp) exp))
+ (else #f))))
+
+ (record-case proc
+ ((<module-ref> mod public? name)
+ (and (equal? mod '(oop goops))
+ (not public?)
+ (eq? name 'toplevel-define!)
+ (toplevel-define-arg args)))
+ ((<toplevel-ref> name)
+ ;; This may be the result of expanding one of the GOOPS macros within
+ ;; `oop/goops.scm'.
+ (and (eq? name 'toplevel-define!)
+ (eq? env (resolve-module '(oop goops)))
+ (toplevel-define-arg args)))
+ (else #f)))
+
+;; TODO: Combine with `report-unused-variables' so we don't traverse the tree
+;; once for each warning type.
+
+(define (report-possibly-unbound-variables tree env)
+ "Return possibly unbound variables in TREE. Return TREE."
+ (define toplevel
+ (tree-il-fold (lambda (x info)
+ ;; X is a leaf: extend INFO's refs accordingly.
+ (let ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (locs (toplevel-info-locs info)))
+ (define (bound? name)
+ (or (and (module? env)
+ (module-variable env name))
+ (memq name defs)))
+
+ (record-case x
+ ((<toplevel-ref> name src)
+ (if (bound? name)
+ info
+ (let ((src (or src (find pair? locs))))
+ (make-toplevel-info (alist-cons name src refs)
+ defs
+ locs))))
+ (else info))))
+
+ (lambda (x info)
+ ;; Going down into X.
+ (let* ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (src (tree-il-src x))
+ (locs (cons src (toplevel-info-locs info))))
+ (define (bound? name)
+ (or (and (module? env)
+ (module-variable env name))
+ (memq name defs)))
+
+ (record-case x
+ ((<toplevel-set> name src)
+ (if (bound? name)
+ (make-toplevel-info refs defs locs)
+ (let ((src (find pair? locs)))
+ (make-toplevel-info (alist-cons name src refs)
+ defs
+ locs))))
+ ((<toplevel-define> name)
+ (make-toplevel-info (alist-delete name refs eq?)
+ (cons name defs)
+ locs))
+
+ ((<application> proc args)
+ ;; Check for a dynamic top-level definition, as is
+ ;; done by code expanded from GOOPS macros.
+ (let ((name (goops-toplevel-definition proc args
+ env)))
+ (if (symbol? name)
+ (make-toplevel-info (alist-delete name refs
+ eq?)
+ (cons name defs)
+ locs)
+ (make-toplevel-info refs defs locs))))
+ (else
+ (make-toplevel-info refs defs locs)))))
+
+ (lambda (x info)
+ ;; Leaving X's scope.
+ (let ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (locs (toplevel-info-locs info)))
+ (make-toplevel-info refs defs (cdr locs))))
+
+ (make-toplevel-info '() '() '())
+ tree))
+
+ (for-each (lambda (name+loc)
+ (let ((name (car name+loc))
+ (loc (cdr name+loc)))
+ (warning 'unbound-variable loc name)))
+ (reverse (toplevel-info-refs toplevel)))
+
+ tree)
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 86b610f94..a809e2d32 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -30,44 +30,43 @@
#: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)
+;; lambda -> (labels . free-locs)
+;; lambda-case -> (gensym . nlocs)
;;
-;; address := (local? boxed? . index)
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
(define *comp-module* (make-fluid))
(define %warning-passes
- `((unused-variable . ,report-unused-variables)))
+ `((unused-variable . ,report-unused-variables)
+ (unbound-variable . ,report-possibly-unbound-variables)))
(define (compile-glil x e opts)
(define warnings
(or (and=> (memq #:warnings opts) cadr)
'()))
- ;; Go throught the warning passes.
+ ;; Go through the warning passes.
(for-each (lambda (kind)
(let ((warn (assoc-ref %warning-passes kind)))
(and (procedure? warn)
- (warn x))))
+ (warn x e))))
warnings)
- (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+ (let* ((x (make-lambda (tree-il-src x) '()
+ (make-lambda-case #f '() #f #f #f '() '() #f x #f)))
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
- (with-fluid* *comp-module* (or (and e (car e)) (current-module))
+ (with-fluid* *comp-module* e
(lambda ()
(values (flatten-lambda x #f allocation)
- (and e (cons (car e) (cddr e)))
+ e
e)))))
@@ -163,7 +162,6 @@
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))))
@@ -178,41 +176,21 @@
(reverse out)))
(define (flatten-lambda x self-label allocation)
- (receive (ids vars nargs nrest)
- (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
- (oids '()) (ovars '()) (n 0))
- (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
- ((pair? vars) (lp (cdr ids) (cdr vars)
- (cons (car ids) oids) (cons (car vars) ovars)
- (1+ n)))
- (else (values (reverse (cons ids oids))
- (reverse (cons vars ovars))
- (1+ n) 1))))
- (let ((nlocs (car (hashq-ref allocation x)))
- (labels (cadr (hashq-ref allocation x))))
- (make-glil-program
- nargs nrest nlocs (lambda-meta x)
- (with-output-to-code
- (lambda (emit-code)
- ;; emit label for self tail calls
- (if self-label
- (emit-code #f (make-glil-label self-label)))
- ;; write bindings and source debugging info
- (if (not (null? ids))
- (emit-bindings #f ids vars allocation x emit-code))
- (if (lambda-src x)
- (emit-code #f (make-glil-source (lambda-src x))))
- ;; box args if necessary
- (for-each
- (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) x)
- ((#t #t . ,n)
- (emit-code #f (make-glil-lexical #t #f 'ref n))
- (emit-code #f (make-glil-lexical #t #t 'box n)))))
- vars)
- ;; and here, here, dear reader: we compile.
- (flatten (lambda-body x) allocation x self-label
- labels emit-code)))))))
+ (record-case x
+ ((<lambda> src meta body)
+ (make-glil-program
+ meta
+ (with-output-to-code
+ (lambda (emit-code)
+ ;; write source info for proc
+ (if src (emit-code #f (make-glil-source src)))
+ ;; emit pre-prelude label for self tail calls in which the
+ ;; number of arguments doesn't check out at compile time
+ (if self-label
+ (emit-code #f (make-glil-label self-label)))
+ ;; compile the body, yo
+ (flatten body allocation x self-label (car (hashq-ref allocation x))
+ emit-code)))))))
(define (flatten x allocation self self-label fix-labels emit-code)
(define (emit-label label)
@@ -251,7 +229,7 @@
(maybe-emit-return))
;; FIXME: should represent sequence as exps tail
- ((<sequence> src exps)
+ ((<sequence> exps)
(let lp ((exps exps))
(if (null? (cdr exps))
(comp-tail (car exps))
@@ -409,43 +387,78 @@
(error "bad primitive op: too many pushes"
op (instruction-pushes op))))))
- ;; da capo al fine
+ ;; self-call in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
- ;; self-call in tail position is a goto
- (eq? context 'tail)
- ;; make sure the arity is right
- (list? (lambda-vars self))
- (= (length args) (length (lambda-vars self))))
- ;; evaluate new values
+ (eq? context 'tail))
+ ;; first, evaluate new values, pushing them on the stack
(for-each comp-push args)
- ;; rename & goto
- (for-each (lambda (sym)
- (pmatch (hashq-ref (hashq-ref allocation sym) self)
- ((#t ,boxed? . ,index)
- ;; set unboxed, as the proc prelude will box if needed
- (emit-code #f (make-glil-lexical #t #f 'set index)))
- (,x (error "what" x))))
- (reverse (lambda-vars self)))
- (emit-branch src 'br self-label))
+ (let lp ((lcase (lambda-body self)))
+ (cond
+ ((and (lambda-case? lcase)
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-opt lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args) (length (lambda-case-req lcase))))
+ ;; we have a case that matches the args; rename variables
+ ;; and goto the case label
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index) ; unboxed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index) ; boxed
+ ;; new box
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "what" x))))
+ (reverse (lambda-case-vars lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
+ ((lambda-case? lcase)
+ ;; no match, try next case
+ (lp (lambda-case-else lcase)))
+ (else
+ ;; no cases left; shuffle args down and jump before the prelude.
+ (for-each (lambda (i)
+ (emit-code #f (make-glil-lexical #t #f 'set i)))
+ (reverse (iota (length args))))
+ (emit-branch src 'br self-label)))))
;; lambda, the ultimate goto
((and (lexical-ref? proc)
(assq (lexical-ref-gensym proc) fix-labels))
- ;; evaluate new values, assuming that analyze-lexicals did its
- ;; job, and that the arity was right
+ ;; like the self-tail-call case, though we can handle "drop"
+ ;; contexts too. first, evaluate new values, pushing them on
+ ;; the stack
(for-each comp-push args)
- ;; rename
- (for-each (lambda (sym)
- (pmatch (hashq-ref (hashq-ref allocation sym) self)
- ((#t #f . ,index)
- (emit-code #f (make-glil-lexical #t #f 'set index)))
- ((#t #t . ,index)
- (emit-code #f (make-glil-lexical #t #t 'box index)))
- (,x (error "what" x))))
- (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
- ;; goto!
- (emit-branch src 'br (lexical-ref-gensym proc)))
+ ;; find the specific case, rename args, and goto the case label
+ (let lp ((lcase (lambda-body
+ (assq-ref fix-labels (lexical-ref-gensym proc)))))
+ (cond
+ ((and (lambda-case? lcase)
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-opt lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args) (length (lambda-case-req lcase))))
+ ;; we have a case that matches the args; rename variables
+ ;; and goto the case label
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index) ; unboxed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index) ; boxed
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "what" x))))
+ (reverse (lambda-case-vars lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
+ ((lambda-case? lcase)
+ ;; no match, try next case
+ (lp (lambda-case-else lcase)))
+ (else
+ ;; no cases left. we can't really handle this currently.
+ ;; ideally we would push on a new frame, then do a "local
+ ;; call" -- which doesn't require consing up a program
+ ;; object. but for now error, as this sort of case should
+ ;; preclude label allocation.
+ (error "couldn't find matching case for label call" x)))))
(else
(if (not (eq? context 'tail))
@@ -510,7 +523,7 @@
'ref (module-name (fluid-ref *comp-module*)) name #f))))
(maybe-emit-return))))
- ((<lexical-ref> src name gensym)
+ ((<lexical-ref> src gensym)
(case context
((push vals tail)
(pmatch (hashq-ref (hashq-ref allocation gensym) self)
@@ -520,7 +533,7 @@
(error "badness" x loc)))))
(maybe-emit-return))
- ((<lexical-set> src name gensym exp)
+ ((<lexical-set> src gensym exp)
(comp-push exp)
(pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
@@ -569,7 +582,7 @@
(maybe-emit-return))
((<lambda>)
- (let ((free-locs (cddr (hashq-ref allocation x))))
+ (let ((free-locs (cdr (hashq-ref allocation x))))
(case context
((push vals tail)
(emit-code #f (flatten-lambda x #f allocation))
@@ -586,6 +599,111 @@
(emit-code #f (make-glil-call 'make-closure 2)))))))
(maybe-emit-return))
+ ((<lambda-case> src req opt rest kw inits vars predicate else body)
+ ;; o/~ feature on top of feature o/~
+ ;; req := (name ...)
+ ;; opt := (name ...) | #f
+ ;; rest := name | #f
+ ;; kw: (allow-other-keys? (keyword name var) ...) | #f
+ ;; vars: (sym ...)
+ ;; predicate: tree-il in context of vars
+ ;; init: tree-il in context of vars
+ ;; vars map to named arguments in the following order:
+ ;; required, optional (positional), rest, keyword.
+ (let* ((nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (rest-idx (and rest (+ nreq nopt)))
+ (opt-names (or opt '()))
+ (allow-other-keys? (if kw (car kw) #f))
+ (kw-indices (map (lambda (x)
+ (pmatch x
+ ((,key ,name ,var)
+ (cons key (list-index vars var)))
+ (else (error "bad kwarg" x))))
+ (if kw (cdr kw) '())))
+ (nargs (apply max (+ nreq nopt (if rest 1 0))
+ (map 1+ (map cdr kw-indices))))
+ (nlocs (cdr (hashq-ref allocation x)))
+ (else-label (and else (make-label))))
+ (or (= nargs
+ (length vars)
+ (+ nreq (length inits) (if rest 1 0)))
+ (error "something went wrong"
+ req opt rest kw inits vars nreq nopt kw-indices nargs))
+ ;; the prelude, to check args & reset the stack pointer,
+ ;; allowing room for locals
+ (emit-code
+ src
+ (cond
+ (kw
+ (make-glil-kw-prelude nreq nopt rest-idx kw-indices
+ allow-other-keys? nlocs else-label))
+ ((or rest opt)
+ (make-glil-opt-prelude nreq nopt rest-idx nlocs else-label))
+ (#t
+ (make-glil-std-prelude nreq nlocs else-label))))
+ ;; box args if necessary
+ (for-each
+ (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'ref n))
+ (emit-code #f (make-glil-lexical #t #t 'box n)))))
+ vars)
+ ;; write bindings info
+ (if (not (null? vars))
+ (emit-bindings
+ #f
+ (let lp ((kw (if kw (cdr kw) '()))
+ (names (append (reverse opt-names) (reverse req)))
+ (vars (list-tail vars (+ nreq nopt
+ (if rest 1 0)))))
+ (pmatch kw
+ (()
+ ;; fixme: check that vars is empty
+ (reverse (if rest (cons rest names) names)))
+ (((,key ,name ,var) . ,kw)
+ (if (memq var vars)
+ (lp kw (cons name names) (delq var vars))
+ (lp kw names vars)))
+ (,kw (error "bad keywords, yo" kw))))
+ vars allocation self emit-code))
+ ;; init optional/kw args
+ (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq)))
+ (cond
+ ((null? inits)) ; done
+ ((and rest-idx (= n rest-idx))
+ (lp inits (1+ n) (cdr vars)))
+ (#t
+ (pmatch (hashq-ref (hashq-ref allocation (car vars)) self)
+ ((#t ,boxed? . ,n*) (guard (= n* n))
+ (let ((L (make-label)))
+ (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
+ (emit-code #f (make-glil-branch 'br-if L))
+ (comp-push (car inits))
+ (emit-code #f (make-glil-lexical #t boxed? 'set n))
+ (emit-label L)
+ (lp (cdr inits) (1+ n) (cdr vars))))
+ (#t (error "what" inits))))))
+ ;; post-prelude case label for label calls
+ (emit-label (car (hashq-ref allocation x)))
+ (if predicate
+ (begin
+ (comp-push predicate)
+ (if else-label
+ ;; fixme: debox if necessary
+ (emit-branch src 'br-if-not else-label)
+ (comp-push (make-application
+ src (make-primitive-ref #f 'error)
+ (list (make-const #f "precondition not met")))))))
+ (comp-tail body)
+ (if (not (null? vars))
+ (emit-code #f (make-glil-unbind)))
+ (if else-label
+ (begin
+ (emit-label else-label)
+ (comp-tail else)))))
+
((<let> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation self emit-code)
@@ -629,14 +747,14 @@
;; 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))))
+ (let ((new-RA (if (or (eq? context 'tail) RA) #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))))
+ (if (not (null? (cdr (hashq-ref allocation x))))
;; Need to make-closure first, but with a temporary #f
;; free-variables vector, so we are mutating fresh
;; closures on the heap.
@@ -651,15 +769,19 @@
;; labels allocation: emit label & body, but jump over it
(let ((POST (make-label)))
(emit-branch #f 'br POST)
- (emit-label v)
- ;; we know the lambda vars are a list
- (emit-bindings #f (lambda-names x) (lambda-vars x)
- allocation self emit-code)
- (if (lambda-src x)
- (emit-code #f (make-glil-source (lambda-src x))))
- (comp-fix (lambda-body x) RA)
- (emit-code #f (make-glil-unbind))
- (emit-label POST)))))
+ (let lp ((lcase (lambda-body x)))
+ (if lcase
+ (record-case lcase
+ ((<lambda-case> src req vars body else)
+ (emit-label (car (hashq-ref allocation lcase)))
+ ;; FIXME: opt & kw args in the bindings
+ (emit-bindings #f req vars allocation self emit-code)
+ (if src
+ (emit-code #f (make-glil-source src)))
+ (comp-fix body (or RA new-RA))
+ (emit-code #f (make-glil-unbind))
+ (lp else)))
+ (emit-label POST)))))))
vals
vars)
;; Emit bindings metadata for closures
@@ -676,7 +798,7 @@
(for-each
(lambda (x v)
(let ((free-locs (if (hashq-ref allocation x)
- (cddr (hashq-ref allocation x))
+ (cdr (hashq-ref allocation x))
;; can hit this latter case for labels allocation
'())))
(if (not (null? free-locs))
@@ -696,34 +818,31 @@
vals
vars)
(comp-tail body)
- (emit-label RA)
+ (if new-RA
+ (emit-label new-RA))
(emit-code #f (make-glil-unbind))))
- ((<let-values> src names vars exp body)
- (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
- (cond
- ((pair? inames)
- (lp (cons (car inames) names) (cons (car ivars) vars)
- (cdr inames) (cdr ivars) #f))
- ((not (null? inames))
- (lp (cons inames names) (cons ivars vars) '() '() #t))
- (else
- (let ((names (reverse! names))
- (vars (reverse! vars))
- (MV (make-label)))
- (comp-vals exp MV)
- (emit-code #f (make-glil-const 1))
- (emit-label MV)
- (emit-code src (make-glil-mv-bind
- (vars->bind-list names vars allocation self)
- rest?))
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
- (reverse vars))
- (comp-tail body)
- (emit-code #f (make-glil-unbind))))))))))
+ ((<let-values> src exp body)
+ (record-case body
+ ((<lambda-case> req opt kw rest vars predicate body else)
+ (if (or opt kw predicate else)
+ (error "unexpected lambda-case in let-values" x))
+ (let ((MV (make-label)))
+ (comp-vals exp MV)
+ (emit-code #f (make-glil-const 1))
+ (emit-label MV)
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list
+ (append req (if rest (list rest) '()))
+ vars allocation self)
+ (and rest #t)))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "badness" x loc))))
+ (reverse vars))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind)))))))))
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index adc3f18bd..9b53ec68f 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -17,6 +17,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language tree-il inline)
+ #:use-module (system base pmatch)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:export (inline!))
@@ -34,16 +35,21 @@
;; This is a completely brain-dead optimization pass whose sole claim to
;; fame is ((lambda () x)) => x.
(define (inline! x)
- (post-order!
- (lambda (x)
- (record-case x
- ((<application> src proc args)
- (cond
-
- ;; ((lambda () x)) => x
- ((and (lambda? proc) (null? (lambda-vars proc))
- (null? args))
- (lambda-body proc))
+ (define (inline1 x)
+ (record-case x
+ ((<application> src proc args)
+ (record-case proc
+ ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
+ ((<lambda> body)
+ (let lp ((lcase body))
+ (and lcase
+ (record-case lcase
+ ((<lambda-case> req opt rest kw inits vars predicate body else)
+ (if (and (= (length vars) (length req) (length args))
+ (not predicate))
+ (let ((x (make-let src req vars args body)))
+ (or (inline1 x) x))
+ (lp else)))))))
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar)
@@ -51,31 +57,33 @@
;; Note that this is a singly-binding form of let-values. Also
;; note that Scheme's let-values expands into call-with-values,
;; then here we reduce it to tree-il's let-values.
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2)
- (lambda? (cadr args)))
- (let ((producer (car args))
- (consumer (cadr args)))
- (make-let-values src
- (lambda-names consumer)
- (lambda-vars consumer)
- (if (and (lambda? producer)
- (null? (lambda-names producer)))
- (lambda-body producer)
- (make-application src producer '()))
- (lambda-body consumer))))
+ ((<primitive-ref> name)
+ (and (eq? name '@call-with-values)
+ (pmatch args
+ ((,producer ,consumer)
+ (guard (lambda? consumer)
+ (lambda-case? (lambda-body consumer))
+ (not (lambda-case-opt (lambda-body consumer)))
+ (not (lambda-case-kw (lambda-body consumer)))
+ (not (lambda-case-predicate (lambda-body consumer)))
+ (not (lambda-case-else (lambda-body consumer))))
+ (make-let-values
+ src
+ (let ((x (make-application src producer '())))
+ (or (inline1 x) x))
+ (lambda-body consumer)))
+ (else #f))))
(else #f)))
- ((<let> vars body)
- (if (null? vars) body x))
+ ((<let> vars body)
+ (if (null? vars) body x))
- ((<letrec> vars body)
- (if (null? vars) body x))
+ ((<letrec> vars body)
+ (if (null? vars) body x))
- ((<fix> vars body)
- (if (null? vars) body x))
+ ((<fix> vars body)
+ (if (null? vars) body x))
- (else #f)))
- x))
+ (else #f)))
+ (post-order! inline1 x))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 0e490a636..dbbc21655 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -25,11 +25,8 @@
#: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))))))
+ (resolve-primitives! x env)))))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 955c7bf25..8d9376042 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -208,13 +208,17 @@
(x) x
(x y) (if (and (const? y)
(let ((y (const-exp y)))
- (and (exact? y) (= y 1))))
+ (and (number? y) (exact? y) (= y 1))))
(1+ x)
- (if (and (const? x)
- (let ((x (const-exp x)))
- (and (exact? x) (= x 1))))
- (1+ y)
- (+ x y)))
+ (if (and (const? y)
+ (let ((y (const-exp y)))
+ (and (number? y) (exact? y) (= y -1))))
+ (1- x)
+ (if (and (const? x)
+ (let ((x (const-exp x)))
+ (and (number? y) (exact? x) (= x 1))))
+ (1+ y)
+ (+ x y))))
(x y z . rest) (+ x (+ y z . rest)))
(define-primitive-expander *
@@ -226,7 +230,7 @@
(x) (- 0 x)
(x y) (if (and (const? y)
(let ((y (const-exp y)))
- (and (exact? y) (= y 1))))
+ (and (number? y) (exact? y) (= y 1))))
(1- x)
(- x y))
(x y z . rest) (- x (+ y z . rest)))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index 2d24f7bf6..b2ebcfcab 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -20,6 +20,7 @@
(define-module (language tree-il spec)
#:use-module (system base language)
+ #:use-module (system base pmatch)
#:use-module (language glil)
#:use-module (language tree-il)
#:use-module (language tree-il compile-glil)
@@ -29,12 +30,15 @@
(apply write (unparse-tree-il exp) port))
(define (join exps env)
- (make-sequence #f exps))
+ (pmatch exps
+ (() (make-void #f))
+ ((,x) x)
+ (else (make-sequence #f exps))))
(define-language tree-il
#:title "Tree Intermediate Language"
#:version "1.0"
- #:reader read
+ #:reader (lambda (port env) (read port))
#:printer write-tree-il
#:parser parse-tree-il
#:joiner join
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index c1754da3e..7871c2f7f 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 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
@@ -226,8 +226,7 @@
slots))
(if (not (list? supers))
(goops-error "malformed superclass list: ~S" supers))
- (let ((slot-defs (cons #f '()))
- (slots (take-while (lambda (x) (not (keyword? x))) slots))
+ (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
(options (or (find-tail keyword? slots) '())))
`(make-class
;; evaluate super class variables
@@ -1074,8 +1073,7 @@
(define (compute-slot-accessors class slots env)
(for-each
(lambda (s g-n-s)
- (let ((name (slot-definition-name s))
- (getter-function (slot-definition-getter s))
+ (let ((getter-function (slot-definition-getter s))
(setter-function (slot-definition-setter s))
(accessor (slot-definition-accessor s)))
(if getter-function
@@ -1159,7 +1157,7 @@
(define-standard-accessor-method ((bound-check-get n) o)
(let ((x (@slot-ref o n)))
(if (unbound? x)
- (slot-unbound obj)
+ (slot-unbound o)
x)))
(define-standard-accessor-method ((standard-get n) o)
@@ -1412,8 +1410,7 @@
((#:virtual) ;; No allocation
;; slot-ref and slot-set! function must be given by the user
(let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
- (set (get-keyword #:slot-set! (slot-definition-options s) #f))
- (env (class-environment class)))
+ (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
(if (not (and get set))
(goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
s))
diff --git a/module/oop/goops/active-slot.scm b/module/oop/goops/active-slot.scm
index 5cd2afe10..79aa1b3f2 100644
--- a/module/oop/goops/active-slot.scm
+++ b/module/oop/goops/active-slot.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 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
@@ -34,9 +34,7 @@
(define-method (compute-get-n-set (class <active-class>) slot)
(if (eq? (slot-definition-allocation slot) #:active)
(let* ((index (slot-ref class 'nfields))
- (name (car slot))
(s (cdr slot))
- (env (class-environment class))
(before-ref (get-keyword #:before-slot-ref s #f))
(after-ref (get-keyword #:after-slot-ref s #f))
(before-set! (get-keyword #:before-slot-set! s #f))
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index 0dd169d59..88abf8045 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 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
@@ -186,8 +186,7 @@
(set! sum (+ sum (struct-ref (car classes) hashset-index))))))
(define (cache-try-hash! min-misses hashset cache entries)
- (let ((max-misses 0)
- (mask (- (vector-length cache) 1)))
+ (let ((mask (- (vector-length cache) 1)))
(let outer ((in entries) (max-misses 0))
(if (null? in)
max-misses
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm
index 0c7d71a2d..b500a0c32 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 2000,2001,2002, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000,2001,2002, 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
@@ -183,8 +183,7 @@
(enumerate-component! (shared-array-root o) env))
(define (make-mapper array)
- (let* ((dims (array-dimensions array))
- (n (array-rank array))
+ (let* ((n (array-rank array))
(indices (reverse (if (<= n 11)
(list-tail '(t s r q p n m l k j i) (- 11 n))
(let loop ((n n)
diff --git a/module/scripts/autofrisk.scm b/module/scripts/autofrisk.scm
index e29ccc992..943c90227 100644
--- a/module/scripts/autofrisk.scm
+++ b/module/scripts/autofrisk.scm
@@ -1,6 +1,6 @@
;;; autofrisk --- Generate module checks for use with auto* tools
-;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 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
@@ -157,7 +157,6 @@
(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)))
diff --git a/module/srfi/srfi-16.scm b/module/srfi/srfi-16.scm
index dc3c70920..caec784ba 100644
--- a/module/srfi/srfi-16.scm
+++ b/module/srfi/srfi-16.scm
@@ -1,6 +1,6 @@
;;; srfi-16.scm --- case-lambda
-;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 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
@@ -46,81 +46,8 @@
;;; Code:
(define-module (srfi srfi-16)
- :export-syntax (case-lambda))
+ #:re-export (case-lambda))
-(cond-expand-provide (current-module) '(srfi-16))
-
-(define-macro (case-lambda . clauses)
-
- ;; Return the length of the list @var{l}, but allow dotted list.
- ;;
- (define (alength l)
- (cond ((null? l) 0)
- ((pair? l) (+ 1 (alength (cdr l))))
- (else 0)))
-
- ;; Return @code{#t} if @var{l} is a dotted list, @code{#f} if it is
- ;; a normal list.
- ;;
- (define (dotted? l)
- (cond ((null? l) #f)
- ((pair? l) (dotted? (cdr l)))
- (else #t)))
-
- ;; Return the expression for accessing the @var{index}th element of
- ;; the list called @var{args-name}. If @var{tail?} is true, code
- ;; for accessing the list-tail is generated, otherwise for accessing
- ;; the list element itself.
- ;;
- (define (accessor args-name index tail?)
- (if tail?
- (case index
- ((0) `,args-name)
- ((1) `(cdr ,args-name))
- ((2) `(cddr ,args-name))
- ((3) `(cdddr ,args-name))
- ((4) `(cddddr ,args-name))
- (else `(list-tail ,args-name ,index)))
- (case index
- ((0) `(car ,args-name))
- ((1) `(cadr ,args-name))
- ((2) `(caddr ,args-name))
- ((3) `(cadddr ,args-name))
- (else `(list-ref ,args-name ,index)))))
+;; Case-lambda is now provided by code psyntax.
- ;; Generate the binding lists of the variables of one case-lambda
- ;; clause. @var{vars} is the (possibly dotted) list of variables
- ;; and @var{args-name} is the generated name used for the argument
- ;; list.
- ;;
- (define (gen-temps vars args-name)
- (let lp ((v vars) (i 0))
- (cond ((null? v) '())
- ((pair? v)
- (cons `(,(car v) ,(accessor args-name i #f))
- (lp (cdr v) (+ i 1))))
- (else `((,v ,(accessor args-name i #t)))))))
-
- ;; Generate the cond clauses for each of the clauses of case-lambda,
- ;; including the parameter count check, binding of the parameters
- ;; and the code of the corresponding body.
- ;;
- (define (gen-clauses l length-name args-name)
- (cond ((null? l) (list '(else (error "too few arguments"))))
- (else
- (cons
- `((,(if (dotted? (caar l)) '>= '=)
- ,length-name ,(alength (caar l)))
- (let ,(gen-temps (caar l) args-name)
- ,@(cdar l)))
- (gen-clauses (cdr l) length-name args-name)))))
-
- (let ((args-name (gensym))
- (length-name (gensym)))
- (let ((proc
- `(lambda ,args-name
- (let ((,length-name (length ,args-name)))
- (cond ,@(gen-clauses clauses length-name args-name))))))
- proc)))
-
-;;; srfi-16.scm ends here
+(cond-expand-provide (current-module) '(srfi-16))
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 26acb6300..4a171b4fd 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -1,6 +1,6 @@
;;; srfi-18.scm --- Multithreading support
-;; Copyright (C) 2008 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -232,7 +232,7 @@
(let* ((ct (time->seconds (current-time)))
(t (cond ((time? timeout) (- (time->seconds timeout) ct))
((number? timeout) (- timeout ct))
- (else (scm-error 'wrong-type-arg caller
+ (else (scm-error 'wrong-type-arg "thread-sleep!"
"Wrong type argument: ~S"
(list timeout)
'()))))
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index b91824976..282061584 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -1,6 +1,6 @@
;;; srfi-19.scm --- Time/Date Library
-;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -42,6 +42,7 @@
:use-module (srfi srfi-6)
:use-module (srfi srfi-8)
:use-module (srfi srfi-9)
+ :autoload (ice-9 rdelim) (read-line)
:use-module (ice-9 i18n))
(begin-deprecated
@@ -300,7 +301,7 @@
(set-tm:hour result (date-hour date))
;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday).
(set-tm:mday result (date-day date))
- (set-tm:month result (- (date-month date) 1))
+ (set-tm:mon result (- (date-month date) 1))
;; FIXME: need to signal error on range violation.
(set-tm:year result (+ 1900 (date-year date)))
(set-tm:isdst result -1)
@@ -489,33 +490,38 @@
;; -- these depend on time-monotonic having the same definition as time-tai!
(define (time-monotonic->time-utc time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-monotonic->time-utc
+ 'incompatible-time-types time-in))
(let ((ntime (copy-time time-in)))
(set-time-type! ntime time-tai)
(priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
(define (time-monotonic->time-utc! time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-monotonic->time-utc!
+ 'incompatible-time-types time-in))
(set-time-type! time-in time-tai)
- (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))
+ (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
(define (time-monotonic->time-tai time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-monotonic->time-tai
+ 'incompatible-time-types time-in))
(let ((ntime (copy-time time-in)))
(set-time-type! ntime time-tai)
ntime))
(define (time-monotonic->time-tai! time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-monotonic->time-tai!
+ 'incompatible-time-types time-in))
(set-time-type! time-in time-tai)
time-in)
(define (time-utc->time-monotonic time-in)
(if (not (eq? (time-type time-in) time-utc))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-utc->time-monotonic
+ 'incompatible-time-types time-in))
(let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f)
'time-utc->time-monotonic)))
(set-time-type! ntime time-monotonic)
@@ -523,7 +529,8 @@
(define (time-utc->time-monotonic! time-in)
(if (not (eq? (time-type time-in) time-utc))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-utc->time-monotonic!
+ 'incompatible-time-types time-in))
(let ((ntime (priv:time-utc->time-tai! time-in time-in
'time-utc->time-monotonic!)))
(set-time-type! ntime time-monotonic)
@@ -531,14 +538,16 @@
(define (time-tai->time-monotonic time-in)
(if (not (eq? (time-type time-in) time-tai))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-tai->time-monotonic
+ 'incompatible-time-types time-in))
(let ((ntime (copy-time time-in)))
(set-time-type! ntime time-monotonic)
ntime))
(define (time-tai->time-monotonic! time-in)
(if (not (eq? (time-type time-in) time-tai))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (priv:time-error 'time-tai->time-monotonic!
+ 'incompatible-time-types time-in))
(set-time-type! time-in time-monotonic)
time-in)
@@ -741,7 +750,7 @@
(define (priv:year-day day month year)
(let ((days-pr (assoc month priv:month-assoc)))
(if (not days-pr)
- (priv:error 'date-year-day 'invalid-month-specification month))
+ (priv:time-error 'date-year-day 'invalid-month-specification month))
(if (and (priv:leap-year? year) (> month 2))
(+ day (cdr days-pr) 1)
(+ day (cdr days-pr)))))
@@ -1216,7 +1225,7 @@
((#\8) 8)
((#\9) 9)
(else (priv:time-error 'bad-date-template-string
- (list "Non-integer character" ch i)))))
+ (list "Non-integer character" ch)))))
;; read an integer upto n characters long on port; upto -> #f is any length
(define (priv:integer-reader upto port)
@@ -1345,9 +1354,7 @@
(define priv:read-directives
(let ((ireader4 (priv:make-integer-reader 4))
(ireader2 (priv:make-integer-reader 2))
- (ireaderf (priv:make-integer-reader #f))
(eireader2 (priv:make-integer-exact-reader 2))
- (eireader4 (priv:make-integer-exact-reader 4))
(locale-reader-abbr-weekday (priv:make-locale-reader
priv:locale-abbr-weekday->index))
(locale-reader-long-weekday (priv:make-locale-reader
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 873b08b13..12aa83a8c 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -28,7 +28,6 @@
(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
@@ -58,6 +57,19 @@
(number->string (object-address ct)
16))))))
+(define (%make-condition-type layout id parent all-fields)
+ (let ((struct (make-struct %condition-type-vtable 0
+ (make-struct-layout layout) ;; layout
+ print-condition ;; printer
+ id parent all-fields)))
+
+ ;; Hack to associate STRUCT with a name, providing a better name for
+ ;; GOOPS classes as returned by `class-of' et al.
+ (set-struct-vtable-name! struct (cond ((symbol? id) id)
+ ((string? id) (string->symbol id))
+ (else (string->symbol ""))))
+ struct))
+
(define (condition-type? obj)
"Return true if OBJ is a condition type."
(and (struct? obj)
@@ -105,10 +117,8 @@ supertypes."
field-names parent-fields)))
(let* ((all-fields (append parent-fields field-names))
(layout (struct-layout-for-condition all-fields)))
- (make-struct %condition-type-vtable 0
- (make-struct-layout layout) ;; layout
- print-condition ;; printer
- id parent all-fields))
+ (%make-condition-type layout
+ id parent all-fields))
(error "invalid condition type field names"
field-names)))
(error "parent is not a condition type" parent))
@@ -127,13 +137,10 @@ supertypes."
(let* ((all-fields (append-map condition-type-all-fields
parents))
(layout (struct-layout-for-condition all-fields)))
- (make-struct %condition-type-vtable 0
- (make-struct-layout layout) ;; layout
- print-condition ;; printer
- id
- parents ;; list of parents!
- all-fields
- all-fields)))))
+ (%make-condition-type layout
+ id
+ parents ;; list of parents!
+ all-fields)))))
;;;
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
index d3f73b3e9..c5c41ea92 100644
--- a/module/srfi/srfi-4/gnu.scm
+++ b/module/srfi/srfi-4/gnu.scm
@@ -1,6 +1,6 @@
;;; Extensions to SRFI-4
-;; Copyright (C) 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
+;; 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
diff --git a/module/srfi/srfi-88.scm b/module/srfi/srfi-88.scm
index 0fec19ee1..9538f5c3d 100644
--- a/module/srfi/srfi-88.scm
+++ b/module/srfi/srfi-88.scm
@@ -1,6 +1,6 @@
;;; srfi-88.scm --- Keyword Objects
-;; Copyright (C) 2008 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -33,7 +33,10 @@
(cond-expand-provide (current-module) '(srfi-88))
-(read-set! keywords 'postfix)
+;; Change the keyword syntax both at compile time and run time; the latter is
+;; useful at the REPL.
+(eval-when (compile load)
+ (read-set! keywords 'postfix))
(define (keyword->string k)
"Return the name of @var{k} as a string."
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 26dd29e20..da3f7cd98 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -28,7 +28,10 @@
#:use-module (ice-9 receive)
#:export (syntax-error
*current-language*
- compiled-file-name compile-file compile-and-load
+ compiled-file-name
+ compile-file
+ compile-and-load
+ read-and-compile
compile
decompile)
#:export-syntax (call-with-compile-error-catch))
@@ -141,9 +144,9 @@
(define* (compile-file file #:key
(output-file #f)
- (env #f)
(from (current-language))
(to 'objcode)
+ (env (default-environment from))
(opts '()))
(let* ((comp (or output-file (compiled-file-name file)))
(in (open-input-file file))
@@ -159,9 +162,11 @@
file)
comp))
-(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
+(define* (compile-and-load file #:key (from 'scheme) (to 'value)
+ (env (current-module)) (opts '()))
(read-and-compile (open-input-file file)
- #:from from #:to to #:opts opts))
+ #:from from #:to to #:opts opts
+ #:env env))
;;;
@@ -191,20 +196,23 @@
(lp (cdr in) (caar in))))))
(define* (read-and-compile port #:key
- (env #f)
(from (current-language))
(to 'objcode)
+ (env (default-environment from))
(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)))
+ (let ((x ((language-reader (current-language)) port cenv)))
(cond
((eof-object? x)
(compile ((language-joiner joint) (reverse exps) env)
- #:from joint #:to to #:env env #:opts opts))
+ #:from joint #:to to
+ ;; env can be false if no expressions were read.
+ #:env (or env (default-environment joint))
+ #:opts opts))
(else
;; compile-fold instead of compile so we get the env too
(receive (jexp jenv jcenv)
@@ -213,9 +221,9 @@
(lp (cons jexp exps) jenv jcenv))))))))))
(define* (compile x #:key
- (env #f)
(from (current-language))
(to 'value)
+ (env (default-environment from))
(opts '()))
(let ((warnings (memq #:warnings opts)))
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 3670c53d9..046e11dbe 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -25,10 +25,10 @@
language-name language-title language-version language-reader
language-printer language-parser
language-compilers language-decompilers language-evaluator
- language-joiner
+ language-joiner language-make-default-environment
lookup-compilation-order lookup-decompilation-order
- invalidate-compilation-cache!))
+ invalidate-compilation-cache! default-environment))
;;;
@@ -45,7 +45,8 @@
(compilers '())
(decompilers '())
(evaluator #f)
- (joiner #f))
+ (joiner #f)
+ (make-default-environment make-fresh-user-module))
(define-macro (define-language name . spec)
`(begin
@@ -97,3 +98,8 @@
reverse!)))
(set! *decompilation-cache* (acons key order *decompilation-cache*))
order))))
+
+(define (default-environment lang)
+ "Return the default compilation environment for source language LANG."
+ ((language-make-default-environment
+ (if (language? lang) lang (lookup-language lang)))))
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 6b68c5639..48a00b80a 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -79,6 +79,12 @@
"report unused variables"
,(lambda (port loc name)
(format port "~A: warning: unused variable `~A'~%"
+ loc name)))
+
+ (unbound-variable
+ "report possibly unbound variables"
+ ,(lambda (port loc name)
+ (format port "~A: warning: possibly unbound variable `~A'~%"
loc name))))))
(define (lookup-warning-type name)
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index a99e1bae9..1da2d6c6f 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -133,9 +133,13 @@
(define (name repl)
docstring
(let* ((expression0
- (with-fluid* current-reader
- (language-reader (repl-language repl))
- (lambda () (repl-reader ""))))
+ (repl-reader ""
+ (lambda args
+ (let ((port (if (pair? args)
+ (car args)
+ (current-input-port))))
+ ((language-reader (repl-language repl))
+ port (current-module))))))
...)
(apply (lambda datums b0 b1 ...)
(let ((port (open-input-string (read-line repl))))
@@ -263,16 +267,16 @@ Import modules / List those imported."
(for-each puts (map module-name (module-uses (current-module))))
(for-each use args))))
+(define guile:load load)
(define-meta-command (load repl file . opts)
"load FILE
Load a file in the current module.
-f Load source file (see `compile')"
- (let* ((file (->string file))
- (objcode (if (memq #:f opts)
- (apply load-source-file file opts)
- (apply load-file file opts))))
- (vm-load (repl-vm repl) objcode)))
+ (let ((file (->string file)))
+ (if (memq #:f opts)
+ (primitive-load file)
+ (guile:load file))))
(define-meta-command (binding repl)
"binding
@@ -337,13 +341,11 @@ Disassemble a file."
(define-meta-command (time repl (form))
"time FORM
Time execution."
- (let* ((vms-start (vm-stats (repl-vm repl)))
- (gc-start (gc-run-time))
+ (let* ((gc-start (gc-run-time))
(tms-start (times))
(result (repl-eval repl (repl-parse repl form)))
(tms-end (times))
- (gc-end (gc-run-time))
- (vms-end (vm-stats (repl-vm repl))))
+ (gc-end (gc-run-time)))
(define (get proc start end)
(exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
(repl-print repl result)
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 2db4518ad..ba18e2ea0 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -1,6 +1,6 @@
;;; Repl common routines
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; 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
@@ -61,14 +61,16 @@
(module-name (current-module))))
(define (repl-read repl)
- ((language-reader (repl-language repl))))
+ ((language-reader (repl-language repl)) (current-input-port)
+ (current-module)))
(define (repl-compile repl form . opts)
(let ((to (lookup-language (cond ((memq #:e opts) 'scheme)
((memq #:t opts) 'ghil)
((memq #:c opts) 'glil)
- (else 'objcode)))))
- (compile form #:from (repl-language repl) #:to to #:opts opts)))
+ (else 'objcode))))
+ (from (repl-language repl)))
+ (compile form #:from from #:to to #:opts opts #:env (current-module))))
(define (repl-parse repl form)
(let ((parser (language-parser (repl-language repl))))
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 2f4a3783a..a3496f3b8 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -32,29 +32,28 @@
(define meta-command-token (cons 'meta 'command))
-(define (meta-reader read)
+(define (meta-reader read env)
(lambda read-args
- (with-input-from-port
- (if (pair? read-args) (car read-args) (current-input-port))
- (lambda ()
- (let ((ch (next-char #t)))
- (cond ((eof-object? ch)
- ;; apparently sometimes even if this is eof, read will
- ;; wait on somethingorother. strange.
- ch)
- ((eqv? ch #\,)
- (read-char)
- meta-command-token)
- (else (read))))))))
+ (let ((port (if (pair? read-args) (car read-args) (current-input-port))))
+ (with-input-from-port port
+ (lambda ()
+ (let ((ch (next-char #t)))
+ (cond ((eof-object? ch)
+ ;; apparently sometimes even if this is eof, read will
+ ;; wait on somethingorother. strange.
+ ch)
+ ((eqv? ch #\,)
+ (read-char port)
+ meta-command-token)
+ (else (read port env)))))))))
;; repl-reader is a function defined in boot-9.scm, and is replaced by
;; something else if readline has been activated. much of this hoopla is
;; to be able to re-use the existing readline machinery.
(define (prompting-meta-read repl)
- (let ((prompt (lambda () (repl-prompt repl)))
- (lread (language-reader (repl-language repl))))
- (with-fluid* current-reader (meta-reader lread)
- (lambda () (repl-reader (lambda () (repl-prompt repl)))))))
+ (repl-reader (lambda () (repl-prompt repl))
+ (meta-reader (language-reader (repl-language repl))
+ (current-module))))
(define (default-catch-handler . args)
(pmatch args
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 332cd6172..ace7d59e3 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,7 +1,6 @@
;;; Guile VM frame functions
-;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
-;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
+;;; Copyright (C) 2001, 2005, 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
@@ -20,16 +19,21 @@
;;; Code:
(define-module (system vm frame)
+ #:use-module (system base pmatch)
#:use-module (system vm program)
#:use-module (system vm instruction)
+ #:use-module (system vm objcode)
#:use-module ((srfi srfi-1) #:select (fold))
#:export (vm-frame?
vm-frame-program
vm-frame-local-ref vm-frame-local-set!
+ vm-frame-instruction-pointer
vm-frame-return-address vm-frame-mv-return-address
vm-frame-dynamic-link
- vm-frame-stack
+ vm-frame-num-locals
+ vm-frame-bindings vm-frame-binding-ref vm-frame-binding-set!
+ vm-frame-arguments
vm-frame-number vm-frame-address
make-frame-chain
@@ -44,6 +48,63 @@
(load-extension "libguile" "scm_init_frames")
+(define (vm-frame-bindings frame)
+ (map (lambda (b)
+ (cons (binding:name b) (binding:index b)))
+ (program-bindings-for-ip (vm-frame-program frame)
+ (vm-frame-instruction-pointer frame))))
+
+(define (vm-frame-binding-set! frame var val)
+ (let ((i (assq-ref (vm-frame-bindings frame) var)))
+ (if i
+ (vm-frame-local-set! frame i val)
+ (error "variable not bound in frame" var frame))))
+
+(define (vm-frame-binding-ref frame var)
+ (let ((i (assq-ref (vm-frame-bindings frame) var)))
+ (if i
+ (vm-frame-local-ref frame i)
+ (error "variable not bound in frame" var frame))))
+
+;; Basically there are two cases to deal with here:
+;;
+;; 1. We've already parsed the arguments, and bound them to local
+;; variables. In a standard (lambda (a b c) ...) call, this doesn't
+;; involve any argument shuffling; but with rest, optional, or
+;; keyword arguments, the arguments as given to the procedure may
+;; not correspond to what's on the stack. We reconstruct the
+;; arguments using e.g. for the case above: `(,a ,b ,c). This works
+;; for rest arguments too: (a b . c) => `(,a ,b . ,c)
+;;
+;; 2. We have failed to parse the arguments. Perhaps it's the wrong
+;; number of arguments, or perhaps we're doing a typed dispatch and
+;; the types don't match. In that case the arguments are all on the
+;; stack, and nothing else is on the stack.
+(define (vm-frame-arguments frame)
+ (cond
+ ((program-lambda-list (vm-frame-program frame)
+ (vm-frame-instruction-pointer frame))
+ ;; case 1
+ => (lambda (formals)
+ (let lp ((formals formals))
+ (pmatch formals
+ (() '())
+ ((,x . ,rest) (guard (symbol? x))
+ (cons (vm-frame-binding-ref frame x) (lp rest)))
+ ((,x . ,rest)
+ ;; could be a keyword
+ (cons x (lp rest)))
+ (,rest (guard (symbol? rest))
+ (vm-frame-binding-ref frame rest))
+ ;; let's not error here, as we are called during
+ ;; backtraces...
+ (else '???)))))
+ (else
+ ;; case 2
+ (map (lambda (i)
+ (vm-frame-local-ref frame i))
+ (iota (vm-frame-num-locals frame))))))
+
;;;
;;; Frame chain
;;;
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 755c606e2..f02fbe663 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -19,28 +19,31 @@
;;; Code:
(define-module (system vm program)
+ #:use-module (system base pmatch)
+ #:use-module (ice-9 optargs)
#:export (make-program
- arity:nargs arity:nrest arity:nlocs
-
make-binding binding:name binding:boxed? binding:index
binding:start binding:end
source:addr source:line source:column source:file
- program-bindings program-sources program-source
+ program-sources program-source
program-properties program-property program-documentation
- program-name program-arguments
-
- program-arity program-meta
+ program-name
+
+ program-bindings program-bindings-by-index program-bindings-for-ip
+ program-arities program-arity arity:start arity:end
+
+ arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
+
+ program-arguments program-lambda-list
+
+ program-meta
program-objcode program? program-objects
program-module program-base program-free-variables))
(load-extension "libguile" "scm_init_programs")
-(define arity:nargs car)
-(define arity:nrest cadr)
-(define arity:nlocs caddr)
-
(define (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
@@ -59,36 +62,133 @@
(cdddr source))
(define (program-property prog prop)
- (assq-ref (program-properties proc) prop))
+ (assq-ref (program-properties prog) prop))
(define (program-documentation prog)
(assq-ref (program-properties prog) 'documentation))
-(define (program-arguments prog)
- (let ((bindings (program-bindings prog))
- (nargs (arity:nargs (program-arity prog)))
- (rest? (not (zero? (arity:nrest (program-arity prog))))))
- (if bindings
- (let ((args (map binding:name (list-head bindings nargs))))
- (if rest?
- `((required . ,(list-head args (1- (length args))))
- (rest . ,(car (last-pair args))))
- `((required . ,args))))
- #f)))
-
-(define (program-bindings-as-lambda-list prog)
- (let ((bindings (program-bindings prog))
- (nargs (arity:nargs (program-arity prog)))
- (rest? (not (zero? (arity:nrest (program-arity prog))))))
- (if (not bindings)
- (if rest? (cons (1- nargs) 1) (list nargs))
- (let ((args (map binding:name (list-head bindings nargs))))
- (if rest?
- (apply cons* args)
- args)))))
+(define (collapse-locals locs)
+ (let lp ((ret '()) (locs locs))
+ (if (null? locs)
+ (map cdr (sort! ret
+ (lambda (x y) (< (car x) (car y)))))
+ (let ((b (car locs)))
+ (cond
+ ((assv-ref ret (binding:index b))
+ => (lambda (bindings)
+ (append! bindings (list b))
+ (lp ret (cdr locs))))
+ (else
+ (lp (acons (binding:index b) (list b) ret)
+ (cdr locs))))))))
+
+;; returns list of list of bindings
+;; (list-ref ret N) == bindings bound to the Nth local slot
+(define (program-bindings-by-index prog)
+ (cond ((program-bindings prog) => collapse-locals)
+ (else '())))
+
+(define (program-bindings-for-ip prog ip)
+ (let lp ((in (program-bindings-by-index prog)) (out '()))
+ (if (null? in)
+ (reverse out)
+ (lp (cdr in)
+ (let inner ((binds (car in)))
+ (cond ((null? binds) out)
+ ((<= (binding:start (car binds))
+ ip
+ (binding:end (car binds)))
+ (cons (car binds) out))
+ (else (inner (cdr binds)))))))))
+
+(define (arity:start a)
+ (pmatch a ((,start ,end . _) start) (else (error "bad arity" a))))
+(define (arity:end a)
+ (pmatch a ((,start ,end . _) end) (else (error "bad arity" a))))
+(define (arity:nreq a)
+ (pmatch a ((_ _ ,nreq . _) nreq) (else 0)))
+(define (arity:nopt a)
+ (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0)))
+(define (arity:rest? a)
+ (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
+(define (arity:kw a)
+ (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
+(define (arity:allow-other-keys? a)
+ (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
+
+(define (program-arity prog ip)
+ (let ((arities (program-arities prog)))
+ (and arities
+ (let lp ((arities arities))
+ (cond ((null? arities) #f)
+ ((and (< (arity:start (car arities)) ip)
+ (<= ip (arity:end (car arities))))
+ (car arities))
+ (else (lp (cdr arities))))))))
+
+(define (arglist->arguments arglist)
+ (pmatch arglist
+ ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
+ `((required . ,req)
+ (optional . ,opt)
+ (keyword . ,keyword)
+ (allow-other-keys? . ,allow-other-keys?)
+ (rest . ,rest)
+ (extents . ,extents)))
+ (else #f)))
+
+(define (arity->arguments prog arity)
+ (define var-by-index
+ (let ((rbinds (map (lambda (x)
+ (cons (binding:index x) (binding:name x)))
+ (program-bindings-for-ip prog
+ (arity:start arity)))))
+ (lambda (i)
+ (assv-ref rbinds i))))
+
+ (let lp ((nreq (arity:nreq arity)) (req '())
+ (nopt (arity:nopt arity)) (opt '())
+ (rest? (arity:rest? arity)) (rest #f)
+ (n 0))
+ (cond
+ ((< 0 nreq)
+ (lp (1- nreq) (cons (var-by-index n) req)
+ nopt opt rest? rest (1+ n)))
+ ((< 0 nopt)
+ (lp nreq req
+ (1- nopt) (cons (var-by-index n) opt)
+ rest? rest (1+ n)))
+ (rest?
+ (lp nreq req nopt opt
+ #f (var-by-index n)
+ (1+ n)))
+ (else
+ `((required . ,(reverse req))
+ (optional . ,(reverse opt))
+ (keyword . ,(arity:kw arity))
+ (allow-other-keys? . ,(arity:allow-other-keys? arity))
+ (rest . ,rest))))))
+
+(define* (program-arguments prog #:optional ip)
+ (let ((arity (program-arity prog ip)))
+ (and arity
+ (arity->arguments prog arity))))
+
+(define* (program-lambda-list prog #:optional ip)
+ (and=> (program-arguments prog ip) arguments->lambda-list))
+
+(define (arguments->lambda-list arguments)
+ (let ((req (or (assq-ref arguments 'required) '()))
+ (opt (or (assq-ref arguments 'optional) '()))
+ (key (or (assq-ref arguments 'keyword) '()))
+ (rest (or (assq-ref arguments 'rest) '())))
+ `(,@req
+ ,@(if (pair? opt) (cons #:optional opt) '())
+ ,@(if (pair? key) (cons #:key key) '())
+ . ,rest)))
(define (write-program prog port)
- (format port "#<program ~a ~a>"
+ (format port "#<program ~a~a>"
(or (program-name prog)
(and=> (program-source prog 0)
(lambda (s)
@@ -97,4 +197,14 @@
(or (source:file s) "<unknown port>")
(source:line s) (source:column s))))
(number->string (object-address prog) 16))
- (program-bindings-as-lambda-list prog)))
+ (let ((arities (program-arities prog)))
+ (if (null? arities)
+ ""
+ (string-append
+ " " (string-join (map (lambda (a)
+ (object->string
+ (arguments->lambda-list
+ (arity->arguments prog a))))
+ arities)
+ " | "))))))
+
diff --git a/module/system/xref.scm b/module/system/xref.scm
index 906ec8e4a..94ecb5bbf 100644
--- a/module/system/xref.scm
+++ b/module/system/xref.scm
@@ -35,7 +35,7 @@
(progv (make-vector (vector-length objects) #f))
(asm (decompile (program-objcode prog) #:to 'assembly)))
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,labels ,len . ,body)
+ ((load-program ,labels ,len . ,body)
(for-each
(lambda (x)
(pmatch x
diff --git a/srfi/Makefile.am b/srfi/Makefile.am
index 648603007..459d60633 100644
--- a/srfi/Makefile.am
+++ b/srfi/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 2001, 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+## Copyright (C) 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -30,6 +30,7 @@ AM_CPPFLAGS = -I.. -I$(srcdir)/.. \
-I$(top_srcdir)/lib -I$(top_builddir)/lib
AM_CFLAGS = $(GCC_CFLAGS)
+AM_LDFLAGS = $(GNU_LD_FLAGS)
srfiincludedir = $(pkgincludedir)/srfi
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 476d6e688..145975c9b 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test \
tests/arbiters.test \
tests/asm-to-bytecode.test \
tests/bit-operations.test \
+ tests/brainfuck.test \
tests/bytevectors.test \
tests/c-api.test \
tests/chars.test \
@@ -67,6 +68,7 @@ SCM_TESTS = tests/alist.test \
tests/reader.test \
tests/receive.test \
tests/regexp.test \
+ tests/signals.test \
tests/socket.test \
tests/srcprop.test \
tests/srfi-1.test \
diff --git a/test-suite/standalone/.gitignore b/test-suite/standalone/.gitignore
index 9dadde6e2..194393699 100644
--- a/test-suite/standalone/.gitignore
+++ b/test-suite/standalone/.gitignore
@@ -10,3 +10,4 @@
/test-scm-c-read
/test-fast-slot-ref
/test-scm-take-locale-symbol
+/test-scm-take-u8vector
diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am
index 488eb1453..1b0d9d600 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -129,6 +129,13 @@ test_scm_take_locale_symbol_LDADD = ${top_builddir}/libguile/libguile.la
check_PROGRAMS += test-scm-take-locale-symbol
TESTS += test-scm-take-locale-symbol
+# test-scm-take-u8vector
+test_scm_take_u8vector_SOURCES = test-scm-take-u8vector.c
+test_scm_take_u8vector_CFLAGS = ${test_cflags}
+test_scm_take_u8vector_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-scm-take-u8vector
+TESTS += test-scm-take-u8vector
+
# test-extensions
noinst_LTLIBRARIES += libtest-extensions.la
libtest_extensions_la_SOURCES = test-extensions-lib.c
diff --git a/test-suite/standalone/test-scm-take-u8vector.c b/test-suite/standalone/test-scm-take-u8vector.c
new file mode 100644
index 000000000..fff3af47f
--- /dev/null
+++ b/test-suite/standalone/test-scm-take-u8vector.c
@@ -0,0 +1,65 @@
+/* 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
+ */
+
+/* Make sure `scm_take_u8vector ()' returns a u8vector that actually uses the
+ provided storage. */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <stdlib.h>
+
+
+static void *
+do_test (void *result)
+{
+#define LEN 123
+ SCM u8v;
+ scm_t_uint8 *data;
+ scm_t_array_handle handle;
+
+ data = scm_malloc (LEN);
+ u8v = scm_take_u8vector (data, LEN);
+
+ scm_array_get_handle (u8v, &handle);
+
+ if (scm_array_handle_u8_writable_elements (&handle) == data
+ && scm_array_handle_u8_elements (&handle) == data)
+ * (int *) result = EXIT_SUCCESS;
+ else
+ * (int *) result = EXIT_FAILURE;
+
+ scm_array_handle_release (&handle);
+
+ return NULL;
+#undef LEN
+}
+
+int
+main (int argc, char *argv[])
+{
+ int result;
+
+ scm_with_guile (do_test, &result);
+
+ return result;
+}
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index a8e251b83..304a84da9 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -77,34 +77,28 @@
(vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o)
(char->integer #\o)))
- (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
+ (comp-test '(load-program () 3 #f (make-int8 3) (return))
#(load-program
- 3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 3) ;; len
(uint32 0) ;; metalen
- (uint32 0) ;; padding
make-int8 3
return))
;; the nops are to pad meta to an 8-byte alignment. not strictly
;; necessary for this test, but representative of the common case.
- (comp-test '(load-program 3 2 1 () 8
- (load-program 3 2 1 () 3
+ (comp-test '(load-program () 8
+ (load-program () 3
#f
(make-int8 3) (return))
(make-int8 3) (return)
(nop) (nop) (nop) (nop) (nop))
#(load-program
- 3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 8) ;; len
- (uint32 19) ;; metalen
- (uint32 0) ;; padding
+ (uint32 11) ;; metalen
make-int8 3
return
nop nop nop nop nop
- 3 2 (uint16 1) ;; nargs, nrest, nlocs
(uint32 3) ;; len
(uint32 0) ;; metalen
- (uint32 0) ;; padding
make-int8 3
return))))
diff --git a/test-suite/tests/brainfuck.test b/test-suite/tests/brainfuck.test
new file mode 100644
index 000000000..f612fb50a
--- /dev/null
+++ b/test-suite/tests/brainfuck.test
@@ -0,0 +1,51 @@
+;;;; test brainfuck compilation -*- scheme -*-
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite tests brainfuck)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile))
+
+;; This program taken from Wikipedia's brainfuck introduction page.
+(define prog "
+ +++ +++ +++ + initialize counter (cell #0) to 10
+ [ use loop to set the next four cells to 70/100/30/10
+ > +++ +++ + add 7 to cell #1
+ > +++ +++ +++ + add 10 to cell #2
+ > +++ add 3 to cell #3
+ > + add 1 to cell #4
+ <<< < - decrement counter (cell #0)
+ ]
+ >++ . print 'H'
+ >+. print 'e'
+ +++ +++ +. print 'l'
+ . print 'l'
+ +++ . print 'o'
+ >++ . print ' '
+ <<+ +++ +++ +++ +++ ++. print 'W'
+ >. print 'o'
+ +++ . print 'r'
+ --- --- . print 'l'
+ --- --- --. print 'd'
+ >+. print '!'")
+
+(pass-if
+ (equal? (with-output-to-string
+ (lambda ()
+ (call-with-input-string
+ prog
+ (lambda (port)
+ (read-and-compile port #:from 'brainfuck #:to 'value)))))
+ "Hello World!"))
diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test
index 1009fb051..fe54b020c 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -31,12 +31,13 @@
(begin (pass-if (string-append test-name " (eval)")
(primitive-eval 'exp))
(pass-if (string-append test-name " (compile)")
- (compile 'exp #:to 'value))))
+ (compile 'exp #:to 'value #:env (current-module)))))
((_ (pass-if-exception test-name exc exp))
(begin (pass-if-exception (string-append test-name " (eval)")
exc (primitive-eval 'exp))
(pass-if-exception (string-append test-name " (compile)")
- exc (compile 'exp #:to 'value))))))
+ exc (compile 'exp #:to 'value
+ #:env (current-module)))))))
(define-syntax with-test-prefix/c&e
(syntax-rules ()
@@ -671,11 +672,30 @@
(pass-if-exception "make-typed-array [out-of-range]"
exception:out-of-range
- (make-typed-array 'vu8 256 77))
+ (make-typed-array 'vu8 256 77)))
- (pass-if "uniform-array->bytevector"
+
+(with-test-prefix "uniform-array->bytevector"
+
+ (pass-if "bytevector"
(let ((bv #vu8(0 1 128 255)))
- (equal? bv (uniform-array->bytevector bv)))))
+ (equal? bv (uniform-array->bytevector bv))))
+
+ (pass-if "empty bitvector"
+ (let ((bv (uniform-array->bytevector (make-bitvector 0))))
+ (equal? bv #vu8())))
+
+ (pass-if "bitvector < 8"
+ (let ((bv (uniform-array->bytevector (make-bitvector 4 #t))))
+ (= (bytevector-length bv) 1)))
+
+ (pass-if "bitvector == 8"
+ (let ((bv (uniform-array->bytevector (make-bitvector 8 #t))))
+ (= (bytevector-length bv) 1)))
+
+ (pass-if "bitvector > 8"
+ (let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
+ (= (bytevector-length bv) 2))))
;;; Local Variables:
diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test
index b52b384c5..7dc719ce7 100644
--- a/test-suite/tests/chars.test
+++ b/test-suite/tests/chars.test
@@ -1,7 +1,7 @@
;;;; chars.test --- test suite for Guile's char functions -*- scheme -*-
;;;; Greg J. Badros <gjb@cs.washington.edu>
;;;;
-;;;; Copyright (C) 2000, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 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
@@ -22,6 +22,12 @@
(define exception:wrong-type-to-apply
(cons 'misc-error "^Wrong type to apply:"))
+(define exception:unknown-character-name
+ (cons #t "unknown character"))
+
+(define exception:out-of-range-octal
+ (cons #t "out-of-range"))
+
(with-test-prefix "basic char handling"
@@ -31,13 +37,252 @@
;; evaluator-internal instruction codes and characters.
(pass-if-exception "evaluating chars"
exception:wrong-type-to-apply
- (eval '(#\0) (interaction-environment)))))
-
-(pass-if "char-is-both? works"
- (and
- (not (char-is-both? #\?))
- (not (char-is-both? #\newline))
- (char-is-both? #\a)
- (char-is-both? #\Z)
- (not (char-is-both? #\1))))
+ (eval '(#\0) (interaction-environment))))
+
+ (with-test-prefix "comparisons"
+
+ ;; char=?
+ (pass-if "char=? #\\A #\\A"
+ (char=? #\A #\A))
+
+ (expect-fail "char=? #\\A #\\a"
+ (char=? #\A #\a))
+
+ (expect-fail "char=? #\\A #\\B"
+ (char=? #\A #\B))
+
+ (expect-fail "char=? #\\B #\\A"
+ (char=? #\A #\B))
+
+ ;; char<?
+ (expect-fail "char<? #\\A #\\A"
+ (char<? #\A #\A))
+
+ (pass-if "char<? #\\A #\\a"
+ (char<? #\A #\a))
+
+ (pass-if "char<? #\\A #\\B"
+ (char<? #\A #\B))
+
+ (expect-fail "char<? #\\B #\\A"
+ (char<? #\B #\A))
+
+ ;; char<=?
+ (pass-if "char<=? #\\A #\\A"
+ (char<=? #\A #\A))
+
+ (pass-if "char<=? #\\A #\\a"
+ (char<=? #\A #\a))
+
+ (pass-if "char<=? #\\A #\\B"
+ (char<=? #\A #\B))
+
+ (expect-fail "char<=? #\\B #\\A"
+ (char<=? #\B #\A))
+
+ ;; char>?
+ (expect-fail "char>? #\\A #\\A"
+ (char>? #\A #\A))
+
+ (expect-fail "char>? #\\A #\\a"
+ (char>? #\A #\a))
+
+ (expect-fail "char>? #\\A #\\B"
+ (char>? #\A #\B))
+
+ (pass-if "char>? #\\B #\\A"
+ (char>? #\B #\A))
+
+ ;; char>=?
+ (pass-if "char>=? #\\A #\\A"
+ (char>=? #\A #\A))
+
+ (expect-fail "char>=? #\\A #\\a"
+ (char>=? #\A #\a))
+
+ (expect-fail "char>=? #\\A #\\B"
+ (char>=? #\A #\B))
+
+ (pass-if "char>=? #\\B #\\A"
+ (char>=? #\B #\A))
+
+ ;; char-ci=?
+ (pass-if "char-ci=? #\\A #\\A"
+ (char-ci=? #\A #\A))
+
+ (pass-if "char-ci=? #\\A #\\a"
+ (char-ci=? #\A #\a))
+
+ (expect-fail "char-ci=? #\\A #\\B"
+ (char-ci=? #\A #\B))
+
+ (expect-fail "char-ci=? #\\B #\\A"
+ (char-ci=? #\A #\B))
+
+ ;; char-ci<?
+ (expect-fail "char-ci<? #\\A #\\A"
+ (char-ci<? #\A #\A))
+
+ (expect-fail "char-ci<? #\\A #\\a"
+ (char-ci<? #\A #\a))
+
+ (pass-if "char-ci<? #\\A #\\B"
+ (char-ci<? #\A #\B))
+
+ (expect-fail "char-ci<? #\\B #\\A"
+ (char-ci<? #\B #\A))
+
+ ;; char-ci<=?
+ (pass-if "char-ci<=? #\\A #\\A"
+ (char-ci<=? #\A #\A))
+
+ (pass-if "char-ci<=? #\\A #\\a"
+ (char-ci<=? #\A #\a))
+
+ (pass-if "char-ci<=? #\\A #\\B"
+ (char-ci<=? #\A #\B))
+
+ (expect-fail "char-ci<=? #\\B #\\A"
+ (char-ci<=? #\B #\A))
+
+ ;; char-ci>?
+ (expect-fail "char-ci>? #\\A #\\A"
+ (char-ci>? #\A #\A))
+
+ (expect-fail "char-ci>? #\\A #\\a"
+ (char-ci>? #\A #\a))
+
+ (expect-fail "char-ci>? #\\A #\\B"
+ (char-ci>? #\A #\B))
+
+ (pass-if "char-ci>? #\\B #\\A"
+ (char-ci>? #\B #\A))
+
+ ;; char-ci>=?
+ (pass-if "char-ci>=? #\\A #\\A"
+ (char-ci>=? #\A #\A))
+
+ (pass-if "char-ci>=? #\\A #\\a"
+ (char-ci>=? #\A #\a))
+
+ (expect-fail "char-ci>=? #\\A #\\B"
+ (char-ci>=? #\A #\B))
+
+ (pass-if "char-ci>=? #\\B #\\A"
+ (char-ci>=? #\B #\A)))
+
+ (with-test-prefix "categories"
+
+ (pass-if "char-alphabetic?"
+ (and (char-alphabetic? #\a)
+ (char-alphabetic? #\A)
+ (not (char-alphabetic? #\1))
+ (not (char-alphabetic? #\+))))
+
+ (pass-if "char-numeric?"
+ (and (not (char-numeric? #\a))
+ (not (char-numeric? #\A))
+ (char-numeric? #\1)
+ (not (char-numeric? #\+))))
+
+ (pass-if "char-whitespace?"
+ (and (not (char-whitespace? #\a))
+ (not (char-whitespace? #\A))
+ (not (char-whitespace? #\1))
+ (char-whitespace? #\space)
+ (not (char-whitespace? #\+))))
+
+ (pass-if "char-upper-case?"
+ (and (not (char-upper-case? #\a))
+ (char-upper-case? #\A)
+ (not (char-upper-case? #\1))
+ (not (char-upper-case? #\+))))
+
+ (pass-if "char-lower-case?"
+ (and (char-lower-case? #\a)
+ (not (char-lower-case? #\A))
+ (not (char-lower-case? #\1))
+ (not (char-lower-case? #\+))))
+
+ (pass-if "char-is-both? works"
+ (and
+ (not (char-is-both? #\?))
+ (not (char-is-both? #\newline))
+ (char-is-both? #\a)
+ (char-is-both? #\Z)
+ (not (char-is-both? #\1)))))
+
+ (with-test-prefix "integer"
+
+ (pass-if "char->integer"
+ (eqv? (char->integer #\A) 65))
+
+ (pass-if "integer->char"
+ (eqv? (integer->char 65) #\A))
+
+ (pass-if-exception "integer->char out of range, -1" exception:out-of-range
+ (integer->char -1))
+
+ (pass-if-exception "integer->char out of range, surrrogate"
+ exception:out-of-range
+ (integer->char #xd800))
+
+ (pass-if-exception "integer->char out of range, too big"
+ exception:out-of-range
+ (integer->char #x110000))
+
+ (pass-if-exception "octal out of range, surrrogate"
+ exception:out-of-range-octal
+ (with-input-from-string "#\\154000" read))
+
+ (pass-if-exception "octal out of range, too big"
+ exception:out-of-range-octal
+ (with-input-from-string "#\\4200000" read)))
+
+ (with-test-prefix "case"
+
+ (pass-if "char-upcase"
+ (eqv? (char-upcase #\a) #\A))
+
+ (pass-if "char-downcase"
+ (eqv? (char-downcase #\A) #\a)))
+
+ (with-test-prefix "charnames"
+
+ (pass-if "R5RS character names are case insensitive"
+ (and (eqv? #\space #\ )
+ (eqv? #\SPACE #\ )
+ (eqv? #\Space #\ )
+ (eqv? #\newline (integer->char 10))
+ (eqv? #\NEWLINE (integer->char 10))
+ (eqv? #\Newline (integer->char 10))))
+
+ (pass-if "C0 control names are case insensitive"
+ (and (eqv? #\nul #\000)
+ (eqv? #\soh #\001)
+ (eqv? #\stx #\002)
+ (eqv? #\NUL #\000)
+ (eqv? #\SOH #\001)
+ (eqv? #\STX #\002)
+ (eqv? #\Nul #\000)
+ (eqv? #\Soh #\001)
+ (eqv? #\Stx #\002)))
+
+ (pass-if "alt charnames are case insensitive"
+ (eqv? #\null #\nul)
+ (eqv? #\NULL #\nul)
+ (eqv? #\Null #\nul))
+
+ (pass-if-exception "bad charname" exception:unknown-character-name
+ (with-input-from-string "#\\blammo" read))
+
+ (pass-if "R5RS character names are preferred write format"
+ (string=?
+ (with-output-to-string (lambda () (write #\space)))
+ "#\\space"))
+
+ (pass-if "C0 control character names are preferred write format"
+ (string=?
+ (with-output-to-string (lambda () (write #\soh)))
+ "#\\soh"))))
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index f9fabd7bc..6d433ebac 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -18,7 +18,11 @@
(define-module (test-suite tests compiler)
:use-module (test-suite lib)
:use-module (test-suite guile-test)
- :use-module (system base compile))
+ :use-module (system base compile)
+ :use-module ((system vm vm) #:select (the-vm vm-load)))
+
+(define read-and-compile
+ (@@ (system base compile) read-and-compile))
@@ -30,18 +34,23 @@
(with-test-prefix "psyntax"
- (pass-if "redefinition"
- ;; In this case the locally-bound `round' must have the same value as the
- ;; imported `round'. See the same test in `syntax.test' for details.
+ (pass-if "compile uses a fresh module by default"
(begin
- (compile '(define round round))
- (compile '(eq? round (@@ (guile) round)))))
+ (compile '(define + -))
+ (eq? (compile '+) +)))
+
+ (pass-if "compile-time definitions are isolated"
+ (begin
+ (compile '(define foo-bar #t))
+ (not (module-variable (current-module) 'foo-bar))))
(pass-if "compile in current module"
(let ((o (begin
- (compile '(define-macro (foo) 'bar))
- (compile '(let ((bar 'ok)) (foo))))))
- (and (module-ref (current-module) 'foo)
+ (compile '(define-macro (foo) 'bar)
+ #:env (current-module))
+ (compile '(let ((bar 'ok)) (foo))
+ #:env (current-module)))))
+ (and (macro? (module-ref (current-module) 'foo))
(eq? o 'ok))))
(pass-if "compile in fresh module"
@@ -52,4 +61,47 @@
(compile '(define-macro (foo) 'bar) #:env m)
(compile '(let ((bar 'ok)) (foo)) #:env m))))
(and (module-ref m 'foo)
- (eq? o 'ok)))))
+ (eq? o 'ok))))
+
+ (pass-if "redefinition"
+ ;; In this case the locally-bound `round' must have the same value as the
+ ;; imported `round'. See the same test in `syntax.test' for details.
+ (let ((m (make-module)))
+ (beautify-user-module! m)
+ (compile '(define round round) #:env m)
+ (eq? round (module-ref m 'round)))))
+
+
+(with-test-prefix "current-reader"
+
+ (pass-if "default compile-time current-reader differs"
+ (not (eq? (compile 'current-reader)
+ current-reader)))
+
+ (pass-if "compile-time changes are honored and isolated"
+ ;; Make sure changing `current-reader' as the side-effect of a defmacro
+ ;; actually works.
+ (let ((r (fluid-ref current-reader))
+ (input (open-input-string
+ "(define-macro (install-reader!)
+ ;;(format #t \"current-reader = ~A~%\" current-reader)
+ (fluid-set! current-reader
+ (let ((first? #t))
+ (lambda args
+ (if first?
+ (begin
+ (set! first? #f)
+ ''ok)
+ (read (open-input-string \"\"))))))
+ #f)
+ (install-reader!)
+ this-should-be-ignored")))
+ (and (eq? (vm-load (the-vm) (read-and-compile input))
+ 'ok)
+ (eq? r (fluid-ref current-reader)))))
+
+ (pass-if "with eval-when"
+ (let ((r (fluid-ref current-reader)))
+ (compile '(eval-when (compile eval)
+ (fluid-set! current-reader (lambda args 'chbouib))))
+ (eq? (fluid-ref current-reader) r))))
diff --git a/test-suite/tests/encoding-escapes.test b/test-suite/tests/encoding-escapes.test
index ea7a821e7..85f613f49 100644
--- a/test-suite/tests/encoding-escapes.test
+++ b/test-suite/tests/encoding-escapes.test
@@ -1,21 +1,20 @@
;;;; encoding-escapes.test --- test suite for Guile's string encodings -*- mode: scheme; coding: utf-8 -*-
;;;;
;;;; 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,
+;;;;
+;;;; 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 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
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-strings)
#:use-module (test-suite lib)
diff --git a/test-suite/tests/encoding-iso88591.test b/test-suite/tests/encoding-iso88591.test
index d4de5e534..32d2ed511 100644
--- a/test-suite/tests/encoding-iso88591.test
+++ b/test-suite/tests/encoding-iso88591.test
@@ -1,21 +1,20 @@
-;;;; strings.test --- test suite for Guile's string functions -*- mode: scheme; coding: iso-8859-1 -*-
+;;;; encoding-iso88591.test --- test suite for Guile's string encodings -*- mode: scheme; coding: iso-8859-1 -*-
;;;;
;;;; 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,
+;;;;
+;;;; 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 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
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-strings)
#:use-module (test-suite lib)
@@ -33,6 +32,67 @@
(if (defined? 'setlocale)
(set! oldlocale (setlocale LC_ALL "")))
+(define ascii-a (integer->char 65)) ; LATIN CAPITAL LETTER A
+(define a-acute (integer->char #x00c1)) ; LATIN CAPITAL LETTER A WITH ACUTE
+(define alpha (integer->char #x03b1)) ; GREEK SMALL LETTER ALPHA
+(define cherokee-a (integer->char #x13a0)) ; CHEROKEE LETTER A
+
+(with-test-prefix "characters"
+ (pass-if "input A"
+ (char=? ascii-a #\A))
+
+ (pass-if "input A acute"
+ (char=? a-acute #\Á))
+
+ (pass-if "display A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (display ascii-a pt)
+ (string=? "A"
+ (get-output-string pt))))
+
+ (pass-if "display A acute"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (display a-acute pt)
+ (string=? "Á"
+ (get-output-string pt))))
+
+ (pass-if "display alpha"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (display alpha pt)
+ (string-ci=? "\\u03b1"
+ (get-output-string pt))))
+
+ (pass-if "display Cherokee a"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (display cherokee-a pt)
+ (string-ci=? "\\u13a0"
+ (get-output-string pt))))
+
+ (pass-if "write A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (write ascii-a pt)
+ (string=? "#\\A"
+ (get-output-string pt))))
+
+ (pass-if "write A acute"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'escape)
+ (write a-acute pt)
+ (string=? "#\\Á"
+ (get-output-string pt)))))
+
+
(define s1 "última")
(define s2 "cédula")
(define s3 "años")
@@ -84,27 +144,6 @@
(list= eqv? (string->list s4)
(list #\¿ #\C #\ó #\m #\o #\?))))
-;; Check that the output is in ISO-8859-1 encoding
-(with-test-prefix "display"
-
- (pass-if "s1"
- (let ((pt (open-output-string)))
- (set-port-encoding! pt "ISO-8859-1")
- (display s1 pt)
- (list= eqv?
- (list #xfa #x6c #x74 #x69 #x6d #x61)
- (u8vector->list
- (get-output-locale-u8vector pt)))))
-
- (pass-if "s2"
- (let ((pt (open-output-string)))
- (set-port-encoding! pt "ISO-8859-1")
- (display s2 pt)
- (list= eqv?
- (list #x63 #xe9 #x64 #x75 #x6c #x61)
- (u8vector->list
- (get-output-locale-u8vector pt))))))
-
(with-test-prefix "symbols == strings"
(pass-if "última"
diff --git a/test-suite/tests/encoding-iso88597.test b/test-suite/tests/encoding-iso88597.test
index 22212690c..eae3fab4d 100644
--- a/test-suite/tests/encoding-iso88597.test
+++ b/test-suite/tests/encoding-iso88597.test
@@ -1,21 +1,20 @@
-;;;; strings.test --- test suite for Guile's string functions -*- mode: scheme; coding: iso-8859-7 -*-
+;;;; encoding-iso88697.test --- test suite for Guile's string encodings -*- mode: scheme; coding: iso-8859-7 -*-
;;;;
;;;; 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,
+;;;;
+;;;; 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 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
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-strings)
#:use-module (test-suite lib)
@@ -31,6 +30,65 @@
(define oldlocale #f)
(if (defined? 'setlocale)
(set! oldlocale (setlocale LC_ALL "")))
+(define ascii-a (integer->char 65)) ; LATIN CAPITAL LETTER A
+(define a-acute (integer->char #x00c1)) ; LATIN CAPITAL LETTER A WITH ACUTE
+(define alpha (integer->char #x03b1)) ; GREEK SMALL LETTER ALPHA
+(define cherokee-a (integer->char #x13a0)) ; CHEROKEE LETTER A
+
+(with-test-prefix "characters"
+ (pass-if "input A"
+ (char=? ascii-a #\A))
+
+ (pass-if "input alpha"
+ (char=? alpha #\á))
+
+ (pass-if "display A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (display ascii-a pt)
+ (string=? "A"
+ (get-output-string pt))))
+
+ (pass-if "display A acute"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (display a-acute pt)
+ (string-ci=? "\\xc1"
+ (get-output-string pt))))
+
+ (pass-if "display alpha"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (display alpha pt)
+ (string-ci=? "á"
+ (get-output-string pt))))
+
+ (pass-if "display Cherokee A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (display cherokee-a pt)
+ (string-ci=? "\\u13a0"
+ (get-output-string pt))))
+
+ (pass-if "write A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (write ascii-a pt)
+ (string=? "#\\A"
+ (get-output-string pt))))
+
+ (pass-if "write alpha"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'escape)
+ (write alpha pt)
+ (string=? "#\\á"
+ (get-output-string pt)))))
(define s1 "Ðåñß")
(define s2 "ôçò")
@@ -83,27 +141,6 @@
(list= eqv? (string->list s4)
(list #\ê #\á #\é))))
-;; Testing that the display of the string is output in the ISO-8859-7
-;; encoding
-(with-test-prefix "display"
-
- (pass-if "s1"
- (let ((pt (open-output-string)))
- (set-port-encoding! pt "ISO-8859-7")
- (display s1 pt)
- (list= eqv?
- (list #xd0 #xe5 #xf1 #xdf)
- (u8vector->list
- (get-output-locale-u8vector pt)))))
- (pass-if "s2"
- (let ((pt (open-output-string)))
- (set-port-encoding! pt "ISO-8859-7")
- (display s2 pt)
- (list= eqv?
- (list #xf4 #xe7 #xf2)
- (u8vector->list
- (get-output-locale-u8vector pt))))))
-
(with-test-prefix "symbols == strings"
(pass-if "Ðåñß"
diff --git a/test-suite/tests/encoding-utf8.test b/test-suite/tests/encoding-utf8.test
index a2613f1d7..d5e637048 100644
--- a/test-suite/tests/encoding-utf8.test
+++ b/test-suite/tests/encoding-utf8.test
@@ -1,21 +1,20 @@
-;;;; strings.test --- test suite for Guile's string functions -*- mode: scheme; coding: utf-8 -*-
+;;;; encoding-utf8.test --- test suite for Guile's string encodings -*- mode: scheme; coding: utf-8 -*-
;;;;
;;;; 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,
+;;;;
+;;;; 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 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
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-strings)
#:use-module (test-suite lib)
@@ -32,6 +31,88 @@
(if (defined? 'setlocale)
(set! oldlocale (setlocale LC_ALL "")))
+(define ascii-a (integer->char 65)) ; LATIN CAPITAL LETTER A
+(define a-acute (integer->char #x00c1)) ; LATIN CAPITAL LETTER A WITH ACUTE
+(define alpha (integer->char #x03b1)) ; GREEK SMALL LETTER ALPHA
+(define cherokee-a (integer->char #x13a0)) ; CHEROKEE LETTER A
+
+(with-test-prefix "characters"
+ (pass-if "input A"
+ (char=? ascii-a #\A))
+
+ (pass-if "input A acute"
+ (char=? a-acute #\Ã))
+
+ (pass-if "input alpha"
+ (char=? alpha #\α))
+
+ (pass-if "input Cherokee A"
+ (char=? cherokee-a #\Ꭰ))
+
+ (pass-if "display A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'substitute)
+ (display ascii-a pt)
+ (string=? "A"
+ (get-output-string pt))))
+
+ (pass-if "display A acute"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'substitute)
+ (display a-acute pt)
+ (string=? "Ã"
+ (get-output-string pt))))
+
+ (pass-if "display alpha"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'substitute)
+ (display alpha pt)
+ (string-ci=? "α"
+ (get-output-string pt))))
+
+ (pass-if "display Cherokee A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'substitute)
+ (display cherokee-a pt)
+ (string-ci=? "Ꭰ"
+ (get-output-string pt))))
+
+ (pass-if "write A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'escape)
+ (write ascii-a pt)
+ (string=? "#\\A"
+ (get-output-string pt))))
+
+ (pass-if "write A acute"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'escape)
+ (write a-acute pt)
+ (string=? "#\\Ã"
+ (get-output-string pt))))
+
+ (pass-if "write alpha"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'escape)
+ (write alpha pt)
+ (string=? "#\\α"
+ (get-output-string pt))))
+
+ (pass-if "write Cherokee A"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "UTF-8")
+ (set-port-conversion-strategy! pt 'escape)
+ (write cherokee-a pt)
+ (string=? "#\\Ꭰ"
+ (get-output-string pt)))))
+
(define s1 "última")
(define s2 "cédula")
(define s3 "años")
diff --git a/test-suite/tests/environments.nottest b/test-suite/tests/environments.nottest
deleted file mode 100644
index 90ef80f63..000000000
--- a/test-suite/tests/environments.nottest
+++ /dev/null
@@ -1,1051 +0,0 @@
-;;;; environments.test -*- scheme -*-
-;;;; Copyright (C) 2000, 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 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
-
-(use-modules (ice-9 documentation)
- (test-suite lib))
-
-;;; environments are currently commented out of libguile, so these
-;;; tests must be commented out also. - NJ 2006-11-02.
-(if #f (let ()
-
-;;;
-;;; miscellaneous
-;;;
-
-(define exception:unbound-symbol
- (cons 'misc-error "^Symbol .* not bound in environment"))
-
-(define (documented? object)
- (not (not (object-documentation object))))
-
-(define (folder sym val res)
- (cons (cons sym val) res))
-
-(define (make-observer-func)
- (let* ((counter 0))
- (lambda args
- (if (null? args)
- counter
- (set! counter (+ counter 1))))))
-
-(define (make-erroneous-observer-func)
- (let* ((func (make-observer-func)))
- (lambda args
- (if (null? args)
- (func)
- (begin
- (func args)
- (error))))))
-
-;;;
-;;; leaf-environments
-;;;
-
-(with-test-prefix "leaf-environments"
-
- (with-test-prefix "leaf-environment?"
-
- (pass-if "documented?"
- (documented? leaf-environment?))
-
- (pass-if "non-environment-object"
- (not (leaf-environment? #f))))
-
-
- (with-test-prefix "make-leaf-environment"
-
- (pass-if "documented?"
- (documented? make-leaf-environment))
-
- (pass-if "produces an environment"
- (environment? (make-leaf-environment)))
-
- (pass-if "produces a leaf-environment"
- (leaf-environment? (make-leaf-environment)))
-
- (pass-if "produces always a new environment"
- (not (eq? (make-leaf-environment) (make-leaf-environment)))))
-
-
- (with-test-prefix "bound, define, ref, set!, cell"
-
- (pass-if "symbols are unbound by default"
- (let* ((env (make-leaf-environment)))
- (and (not (environment-bound? env 'a))
- (not (environment-bound? env 'b))
- (not (environment-bound? env 'c)))))
-
- (pass-if "symbol is bound after define"
- (let* ((env (make-leaf-environment)))
- (environment-bound? env 'a)
- (environment-define env 'a #t)
- (environment-bound? env 'a)))
-
- (pass-if "ref a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-bound? env 'a)
- (environment-bound? env 'b)
- (environment-define env 'a #t)
- (environment-define env 'b #f)
- (and (environment-ref env 'a)
- (not (environment-ref env 'b)))))
-
- (pass-if "set! a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (environment-define env 'b #f)
- (environment-ref env 'a)
- (environment-ref env 'b)
- (environment-set! env 'a #f)
- (environment-set! env 'b #t)
- (and (not (environment-ref env 'a))
- (environment-ref env 'b))))
-
- (pass-if "get a read-only cell"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (let* ((cell (environment-cell env 'a #f)))
- (and (cdr cell)
- (begin
- (environment-set! env 'a #f)
- (not (cdr cell)))))))
-
- (pass-if "a read-only cell gets rebound after define"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (let* ((cell (environment-cell env 'a #f)))
- (environment-define env 'a #f)
- (not (eq? (environment-cell env 'a #f) cell)))))
-
- (pass-if "get a writable cell"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (let* ((readable (environment-cell env 'a #f))
- (writable (environment-cell env 'a #t)))
- (and (eq? readable writable)
- (begin
- (environment-set! env 'a #f)
- (not (cdr writable)))
- (begin
- (set-cdr! writable #t)
- (environment-ref env 'a))
- (begin
- (set-cdr! (environment-cell env 'a #t) #f)
- (not (cdr writable)))))))
-
- (pass-if "a writable cell gets rebound after define"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (let* ((cell (environment-cell env 'a #t)))
- (environment-define env 'a #f)
- (not (eq? (environment-cell env 'a #t) cell)))))
-
- (pass-if-exception "reference an unbound symbol"
- exception:unbound-symbol
- (environment-ref (make-leaf-environment) 'a))
-
- (pass-if-exception "set! an unbound symbol"
- exception:unbound-symbol
- (environment-set! (make-leaf-environment) 'a #f))
-
- (pass-if-exception "get a readable cell for an unbound symbol"
- exception:unbound-symbol
- (environment-cell (make-leaf-environment) 'a #f))
-
- (pass-if-exception "get a writable cell for an unbound symbol"
- exception:unbound-symbol
- (environment-cell (make-leaf-environment) 'a #t)))
-
-
- (with-test-prefix "undefine"
-
- (pass-if "undefine a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (environment-ref env 'a)
- (environment-undefine env 'a)
- (not (environment-bound? env 'a))))
-
- (pass-if "undefine an already undefined symbol"
- (environment-undefine (make-leaf-environment) 'a)
- #t))
-
-
- (with-test-prefix "fold"
-
- (pass-if "empty environment"
- (let* ((env (make-leaf-environment)))
- (eq? 'success (environment-fold env folder 'success))))
-
- (pass-if "one symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (equal? '((a . #t)) (environment-fold env folder '()))))
-
- (pass-if "two symbols"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a #t)
- (environment-define env 'b #f)
- (let ((folded (environment-fold env folder '())))
- (or (equal? folded '((a . #t) (b . #f)))
- (equal? folded '((b . #f) (a . #t))))))))
-
-
- (with-test-prefix "observe"
-
- (pass-if "observe an environment"
- (let* ((env (make-leaf-environment)))
- (environment-observe env (make-observer-func))
- #t))
-
- (pass-if "observe an environment twice"
- (let* ((env (make-leaf-environment))
- (observer-1 (environment-observe env (make-observer-func)))
- (observer-2 (environment-observe env (make-observer-func))))
- (not (eq? observer-1 observer-2))))
-
- (pass-if "definition of an undefined symbol"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func)))
- (environment-observe env func)
- (environment-define env 'a 1)
- (eqv? (func) 1)))
-
- (pass-if "definition of an already defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-define env 'a 1)
- (eqv? (func) 1))))
-
- (pass-if "set!ing of a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-set! env 'a 1)
- (eqv? (func) 0))))
-
- (pass-if "undefining a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-undefine env 'a)
- (eqv? (func) 1))))
-
- (pass-if "undefining an already undefined symbol"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func)))
- (environment-observe env func)
- (environment-undefine env 'a)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an active observer"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func))
- (observer (environment-observe env func)))
- (environment-unobserve observer)
- (environment-define env 'a 1)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an inactive observer"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func))
- (observer (environment-observe env func)))
- (environment-unobserve observer)
- (environment-unobserve observer)
- #t)))
-
-
- (with-test-prefix "observe-weak"
-
- (pass-if "observe an environment"
- (let* ((env (make-leaf-environment)))
- (environment-observe-weak env (make-observer-func))
- #t))
-
- (pass-if "observe an environment twice"
- (let* ((env (make-leaf-environment))
- (observer-1 (environment-observe-weak env (make-observer-func)))
- (observer-2 (environment-observe-weak env (make-observer-func))))
- (not (eq? observer-1 observer-2))))
-
- (pass-if "definition of an undefined symbol"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-define env 'a 1)
- (eqv? (func) 1)))
-
- (pass-if "definition of an already defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-define env 'a 1)
- (eqv? (func) 1))))
-
- (pass-if "set!ing of a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-set! env 'a 1)
- (eqv? (func) 0))))
-
- (pass-if "undefining a defined symbol"
- (let* ((env (make-leaf-environment)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-undefine env 'a)
- (eqv? (func) 1))))
-
- (pass-if "undefining an already undefined symbol"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-undefine env 'a)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an active observer"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func))
- (observer (environment-observe-weak env func)))
- (environment-unobserve observer)
- (environment-define env 'a 1)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an inactive observer"
- (let* ((env (make-leaf-environment))
- (func (make-observer-func))
- (observer (environment-observe-weak env func)))
- (environment-unobserve observer)
- (environment-unobserve observer)
- #t))
-
- (pass-if "weak observer gets collected"
- (gc)
- (let* ((env (make-leaf-environment))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (gc)
- (environment-define env 'a 1)
- (if (not (eqv? (func) 0))
- (throw 'unresolved) ; note: conservative scanning
- #t))))
-
-
- (with-test-prefix "erroneous observers"
-
- (pass-if "update continues after error"
- (let* ((env (make-leaf-environment))
- (func-1 (make-erroneous-observer-func))
- (func-2 (make-erroneous-observer-func)))
- (environment-observe env func-1)
- (environment-observe env func-2)
- (catch #t
- (lambda ()
- (environment-define env 'a 1)
- #f)
- (lambda args
- (and (eq? (func-1) 1)
- (eq? (func-2) 1))))))))
-
-
-;;;
-;;; leaf-environment based eval-environments
-;;;
-
-(with-test-prefix "leaf-environment based eval-environments"
-
- (with-test-prefix "eval-environment?"
-
- (pass-if "documented?"
- (documented? eval-environment?))
-
- (pass-if "non-environment-object"
- (not (eval-environment? #f)))
-
- (pass-if "leaf-environment-object"
- (not (eval-environment? (make-leaf-environment)))))
-
-
- (with-test-prefix "make-eval-environment"
-
- (pass-if "documented?"
- (documented? make-eval-environment))
-
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment)))
-
- (pass-if "produces an environment"
- (environment? (make-eval-environment local imported)))
-
- (pass-if "produces an eval-environment"
- (eval-environment? (make-eval-environment local imported)))
-
- (pass-if "produces always a new environment"
- (not (eq? (make-eval-environment local imported)
- (make-eval-environment local imported))))))
-
-
- (with-test-prefix "eval-environment-local"
-
- (pass-if "documented?"
- (documented? eval-environment-local))
-
- (pass-if "returns local"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (eq? (eval-environment-local env) local))))
-
-
- (with-test-prefix "eval-environment-imported"
-
- (pass-if "documented?"
- (documented? eval-environment-imported))
-
- (pass-if "returns imported"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (eq? (eval-environment-imported env) imported))))
-
-
- (with-test-prefix "bound, define, ref, set!, cell"
-
- (pass-if "symbols are unbound by default"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (and (not (environment-bound? env 'a))
- (not (environment-bound? env 'b))
- (not (environment-bound? env 'c)))))
-
- (with-test-prefix "symbols bound in imported"
-
- (pass-if "binding is visible"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-bound? env 'a)
- (environment-define imported 'a #t)
- (environment-bound? env 'a)))
-
- (pass-if "ref works"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-bound? env 'a)
- (environment-define imported 'a #t)
- (environment-ref env 'a)))
-
- (pass-if "set! works"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #f)
- (environment-set! env 'a #t)
- (environment-ref imported 'a)))
-
- (pass-if "cells are passed through"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (let* ((imported-cell (environment-cell imported 'a #f))
- (env-cell (environment-cell env 'a #f)))
- (eq? env-cell imported-cell)))))
-
- (with-test-prefix "symbols bound in local"
-
- (pass-if "binding is visible"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-bound? env 'a)
- (environment-define local 'a #t)
- (environment-bound? env 'a)))
-
- (pass-if "ref works"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (environment-ref env 'a)))
-
- (pass-if "set! works"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #f)
- (environment-set! env 'a #t)
- (environment-ref local 'a)))
-
- (pass-if "cells are passed through"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (let* ((local-cell (environment-cell local 'a #f))
- (env-cell (environment-cell env 'a #f)))
- (eq? env-cell local-cell)))))
-
- (with-test-prefix "symbols bound in local and imported"
-
- (pass-if "binding is visible"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-bound? env 'a)
- (environment-define imported 'a #t)
- (environment-define local 'a #f)
- (environment-bound? env 'a)))
-
- (pass-if "ref works"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #f)
- (environment-define local 'a #t)
- (environment-ref env 'a)))
-
- (pass-if "set! changes local"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #f)
- (environment-define local 'a #f)
- (environment-set! env 'a #t)
- (environment-ref local 'a)))
-
- (pass-if "set! does not touch imported"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (environment-define local 'a #t)
- (environment-set! env 'a #f)
- (environment-ref imported 'a)))
-
- (pass-if "cells from local are passed through"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (let* ((local-cell (environment-cell local 'a #f))
- (env-cell (environment-cell env 'a #f)))
- (eq? env-cell local-cell)))))
-
- (with-test-prefix "defining symbols"
-
- (pass-if "symbols are bound in local after define"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a #t)
- (environment-bound? local 'a)))
-
- (pass-if "cells in local get rebound after define"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a #f)
- (let* ((old-cell (environment-cell local 'a #f)))
- (environment-define env 'a #f)
- (let* ((new-cell (environment-cell local 'a #f)))
- (not (eq? new-cell old-cell))))))
-
- (pass-if "cells in imported get shadowed after define"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #f)
- (environment-define env 'a #t)
- (environment-ref local 'a))))
-
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
-
- (pass-if-exception "reference an unbound symbol"
- exception:unbound-symbol
- (environment-ref env 'b))
-
- (pass-if-exception "set! an unbound symbol"
- exception:unbound-symbol
- (environment-set! env 'b #f))
-
- (pass-if-exception "get a readable cell for an unbound symbol"
- exception:unbound-symbol
- (environment-cell env 'b #f))
-
- (pass-if-exception "get a writable cell for an unbound symbol"
- exception:unbound-symbol
- (environment-cell env 'b #t))))
-
- (with-test-prefix "eval-environment-set-local!"
-
- (pass-if "documented?"
- (documented? eval-environment-set-local!))
-
- (pass-if "new binding becomes visible"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-bound? env 'a)
- (environment-define new-local 'a #t)
- (eval-environment-set-local! env new-local)
- (environment-bound? env 'a)))
-
- (pass-if "existing binding is replaced"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-define old-local 'a #f)
- (environment-ref env 'a)
- (environment-define new-local 'a #t)
- (eval-environment-set-local! env new-local)
- (environment-ref env 'a)))
-
- (pass-if "undefined binding is removed"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-define old-local 'a #f)
- (environment-ref env 'a)
- (eval-environment-set-local! env new-local)
- (not (environment-bound? env 'a))))
-
- (pass-if "binding in imported remains shadowed"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-define imported 'a #f)
- (environment-define old-local 'a #f)
- (environment-ref env 'a)
- (environment-define new-local 'a #t)
- (eval-environment-set-local! env new-local)
- (environment-ref env 'a)))
-
- (pass-if "binding in imported gets shadowed"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-define imported 'a #f)
- (environment-ref env 'a)
- (environment-define new-local 'a #t)
- (eval-environment-set-local! env new-local)
- (environment-ref env 'a)))
-
- (pass-if "binding in imported becomes visible"
- (let* ((old-local (make-leaf-environment))
- (new-local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment old-local imported)))
- (environment-define imported 'a #t)
- (environment-define old-local 'a #f)
- (environment-ref env 'a)
- (eval-environment-set-local! env new-local)
- (environment-ref env 'a))))
-
- (with-test-prefix "eval-environment-set-imported!"
-
- (pass-if "documented?"
- (documented? eval-environment-set-imported!))
-
- (pass-if "new binding becomes visible"
- (let* ((local (make-leaf-environment))
- (old-imported (make-leaf-environment))
- (new-imported (make-leaf-environment))
- (env (make-eval-environment local old-imported)))
- (environment-bound? env 'a)
- (environment-define new-imported 'a #t)
- (eval-environment-set-imported! env new-imported)
- (environment-bound? env 'a)))
-
- (pass-if "existing binding is replaced"
- (let* ((local (make-leaf-environment))
- (old-imported (make-leaf-environment))
- (new-imported (make-leaf-environment))
- (env (make-eval-environment local old-imported)))
- (environment-define old-imported 'a #f)
- (environment-ref env 'a)
- (environment-define new-imported 'a #t)
- (eval-environment-set-imported! env new-imported)
- (environment-ref env 'a)))
-
- (pass-if "undefined binding is removed"
- (let* ((local (make-leaf-environment))
- (old-imported (make-leaf-environment))
- (new-imported (make-leaf-environment))
- (env (make-eval-environment local old-imported)))
- (environment-define old-imported 'a #f)
- (environment-ref env 'a)
- (eval-environment-set-imported! env new-imported)
- (not (environment-bound? env 'a))))
-
- (pass-if "binding in imported remains shadowed"
- (let* ((local (make-leaf-environment))
- (old-imported (make-leaf-environment))
- (new-imported (make-leaf-environment))
- (env (make-eval-environment local old-imported)))
- (environment-define local 'a #t)
- (environment-define old-imported 'a #f)
- (environment-ref env 'a)
- (environment-define new-imported 'a #t)
- (eval-environment-set-imported! env new-imported)
- (environment-ref env 'a)))
-
- (pass-if "binding in imported gets shadowed"
- (let* ((local (make-leaf-environment))
- (old-imported (make-leaf-environment))
- (new-imported (make-leaf-environment))
- (env (make-eval-environment local old-imported)))
- (environment-define local 'a #t)
- (environment-ref env 'a)
- (environment-define new-imported 'a #f)
- (eval-environment-set-imported! env new-imported)
- (environment-ref env 'a))))
-
- (with-test-prefix "undefine"
-
- (pass-if "undefine an already undefined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-undefine env 'a)
- #t))
-
- (pass-if "undefine removes a binding from local"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (environment-undefine env 'a)
- (not (environment-bound? local 'a))))
-
- (pass-if "undefine does not influence imported"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (environment-undefine env 'a)
- (environment-bound? imported 'a)))
-
- (pass-if "undefine an imported symbol does not undefine it"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (environment-undefine env 'a)
- (environment-bound? env 'a)))
-
- (pass-if "undefine unshadows an imported symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (environment-define local 'a #f)
- (environment-undefine env 'a)
- (environment-ref env 'a))))
-
- (with-test-prefix "fold"
-
- (pass-if "empty environment"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (eq? 'success (environment-fold env folder 'success))))
-
- (pass-if "one symbol in local"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (equal? '((a . #t)) (environment-fold env folder '()))))
-
- (pass-if "one symbol in imported"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define imported 'a #t)
- (equal? '((a . #t)) (environment-fold env folder '()))))
-
- (pass-if "shadowed symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (environment-define imported 'a #f)
- (equal? '((a . #t)) (environment-fold env folder '()))))
-
- (pass-if "one symbol each"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define local 'a #t)
- (environment-define imported 'b #f)
- (let ((folded (environment-fold env folder '())))
- (or (equal? folded '((a . #t) (b . #f)))
- (equal? folded '((b . #f) (a . #t))))))))
-
-
- (with-test-prefix "observe"
-
- (pass-if "observe an environment"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-observe env (make-observer-func))
- #t))
-
- (pass-if "observe an environment twice"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (observer-1 (environment-observe env (make-observer-func)))
- (observer-2 (environment-observe env (make-observer-func))))
- (not (eq? observer-1 observer-2))))
-
- (pass-if "definition of an undefined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func)))
- (environment-observe env func)
- (environment-define env 'a 1)
- (eqv? (func) 1)))
-
- (pass-if "definition of an already defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-define env 'a 1)
- (eqv? (func) 1))))
-
- (pass-if "set!ing of a defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-set! env 'a 1)
- (eqv? (func) 0))))
-
- (pass-if "undefining a defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe env func)
- (environment-undefine env 'a)
- (eqv? (func) 1))))
-
- (pass-if "undefining an already undefined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func)))
- (environment-observe env func)
- (environment-undefine env 'a)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an active observer"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func))
- (observer (environment-observe env func)))
- (environment-unobserve observer)
- (environment-define env 'a 1)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an inactive observer"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func))
- (observer (environment-observe env func)))
- (environment-unobserve observer)
- (environment-unobserve observer)
- #t)))
-
-
- (with-test-prefix "observe-weak"
-
- (pass-if "observe an environment"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-observe-weak env (make-observer-func))
- #t))
-
- (pass-if "observe an environment twice"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (observer-1 (environment-observe-weak env (make-observer-func)))
- (observer-2 (environment-observe-weak env (make-observer-func))))
- (not (eq? observer-1 observer-2))))
-
- (pass-if "definition of an undefined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-define env 'a 1)
- (eqv? (func) 1)))
-
- (pass-if "definition of an already defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-define env 'a 1)
- (eqv? (func) 1))))
-
- (pass-if "set!ing of a defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-set! env 'a 1)
- (eqv? (func) 0))))
-
- (pass-if "undefining a defined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (environment-define env 'a 1)
- (let* ((func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-undefine env 'a)
- (eqv? (func) 1))))
-
- (pass-if "undefining an already undefined symbol"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (environment-undefine env 'a)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an active observer"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func))
- (observer (environment-observe-weak env func)))
- (environment-unobserve observer)
- (environment-define env 'a 1)
- (eqv? (func) 0)))
-
- (pass-if "unobserve an inactive observer"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func))
- (observer (environment-observe-weak env func)))
- (environment-unobserve observer)
- (environment-unobserve observer)
- #t))
-
- (pass-if "weak observer gets collected"
- (gc)
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func (make-observer-func)))
- (environment-observe-weak env func)
- (gc)
- (environment-define env 'a 1)
- (if (not (eqv? (func) 0))
- (throw 'unresolved) ; note: conservative scanning
- #t))))
-
-
- (with-test-prefix "erroneous observers"
-
- (pass-if "update continues after error"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported))
- (func-1 (make-erroneous-observer-func))
- (func-2 (make-erroneous-observer-func)))
- (environment-observe env func-1)
- (environment-observe env func-2)
- (catch #t
- (lambda ()
- (environment-define env 'a 1)
- #f)
- (lambda args
- (and (eq? (func-1) 1)
- (eq? (func-2) 1))))))))
-
-
-;;;
-;;; leaf-environment based import-environments
-;;;
-
-(with-test-prefix "leaf-environment based import-environments"
-
- (with-test-prefix "import-environment?"
-
- (pass-if "documented?"
- (documented? import-environment?))
-
- (pass-if "non-environment-object"
- (not (import-environment? #f)))
-
- (pass-if "leaf-environment-object"
- (not (import-environment? (make-leaf-environment))))
-
- (pass-if "eval-environment-object"
- (let* ((local (make-leaf-environment))
- (imported (make-leaf-environment))
- (env (make-eval-environment local imported)))
- (not (import-environment? (make-leaf-environment))))))
-
-
- (with-test-prefix "make-import-environment"
-
- (pass-if "documented?"
- (documented? make-import-environment))))
-
-;;; End of commenting out. - NJ 2006-11-02.
-))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 47d7ca99f..a428a0778 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -382,7 +382,30 @@
hashq-ref)))
frames)))))))
(lambda (key result)
- (= 1 result))))))
+ (= 1 result))))
+
+ (pass-if "arguments of a gsubr stack frame"
+ ;; Create a stack with two gsubr frames and make sure the arguments are
+ ;; correct.
+ (catch 'result
+ (lambda ()
+ (start-stack 'foo
+ (lazy-catch 'wrong-type-arg
+ (lambda ()
+ ;; Trigger a `wrong-type-arg' exception.
+ (substring 'wrong 'type 'arg))
+ (lambda _
+ (let* ((stack (make-stack #t))
+ (frames (stack->frames stack)))
+ (throw 'result
+ (map (lambda (frame)
+ (cons (frame-procedure frame)
+ (frame-arguments frame)))
+ frames)))))))
+ (lambda (key result)
+ (and (equal? (car result) `(,make-stack #t))
+ (pair? (member `(,substring wrong type arg)
+ (cdr result)))))))))
;;;
;;; letrec init evaluation
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index 063dad6d1..cf252ce9e 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -1,5 +1,5 @@
;;;; gc.test --- test guile's garbage collection -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -68,7 +68,7 @@
;; don't leave a reference to one of the modules we created. It
;; proved to be useful on SPARC:
;; http://lists.gnu.org/archive/html/guile-devel/2008-02/msg00006.html .
- (let cleanup ((i 10))
+ (let cleanup ((i 20))
(and (> i 0)
(begin (cleanup (1- i)) i)))
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index c060d12a6..c7a03d633 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -139,7 +139,12 @@
(eq? (class-of "foo") <string>))
(pass-if "port"
- (is-a? (%make-void-port "w") <port>)))
+ (is-a? (%make-void-port "w") <port>))
+
+ (pass-if "struct vtable"
+ ;; Previously, `class-of' would fail for nameless structs, i.e., structs
+ ;; for which `struct-vtable-name' is #f.
+ (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>)))
(with-test-prefix "defining classes"
diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test
index c4777c21c..89924b612 100644
--- a/test-suite/tests/i18n.test
+++ b/test-suite/tests/i18n.test
@@ -1,7 +1,7 @@
-;;;; i18n.test --- Exercise the i18n API.
+;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*-
;;;;
-;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
-;;;; Ludovic Courtès
+;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -82,49 +82,114 @@
(define %french-locale-name
"fr_FR.ISO-8859-1")
+(define %french-utf8-locale-name
+ "fr_FR.UTF-8")
+
+(define %turkish-utf8-locale-name
+ "tr_TR.UTF-8")
+
(define %french-locale
(false-if-exception
(make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
%french-locale-name)))
-(define (under-french-locale-or-unresolved thunk)
+(define %french-utf8-locale
+ (false-if-exception
+ (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
+ %french-utf8-locale-name)))
+
+(define %turkish-utf8-locale
+ (false-if-exception
+ (make-locale LC_ALL
+ %turkish-utf8-locale-name)))
+
+(define (under-locale-or-unresolved locale thunk)
;; On non-GNU systems, an exception may be raised only when the locale is
;; actually used rather than at `make-locale'-time. Thus, we must guard
;; against both.
- (if %french-locale
- (catch 'system-error thunk
- (lambda (key . args)
- (throw 'unresolved)))
+ (if locale
+ (if (string-contains %host-type "-gnu")
+ (thunk)
+ (catch 'system-error thunk
+ (lambda (key . args)
+ (throw 'unresolved))))
(throw 'unresolved)))
+(define (under-french-locale-or-unresolved thunk)
+ (under-locale-or-unresolved %french-locale thunk))
+
+(define (under-french-utf8-locale-or-unresolved thunk)
+ (under-locale-or-unresolved %french-utf8-locale thunk))
+
+(define (under-turkish-utf8-locale-or-unresolved thunk)
+ (under-locale-or-unresolved %turkish-utf8-locale thunk))
+
(with-test-prefix "text collation (French)"
(pass-if "string-locale<?"
(under-french-locale-or-unresolved
(lambda ()
- (string-locale<? "été" "hiver" %french-locale))))
+ (string-locale<? "été" "hiver" %french-locale))))
(pass-if "char-locale<?"
(under-french-locale-or-unresolved
(lambda ()
- (char-locale<? #\é #\h %french-locale))))
+ (char-locale<? #\é #\h %french-locale))))
(pass-if "string-locale-ci=?"
(under-french-locale-or-unresolved
(lambda ()
- (string-locale-ci=? "ÉTÉ" "été" %french-locale))))
+ (string-locale-ci=? "ÉTÉ" "été" %french-locale))))
+
+ (pass-if "string-locale-ci=? (2 args, wide strings)"
+ (under-french-utf8-locale-or-unresolved
+ (lambda ()
+ ;; Note: Character `Å“' is not part of Latin-1, so these are wide
+ ;; strings.
+ (dynamic-wind
+ (lambda ()
+ (setlocale LC_ALL "fr_FR.UTF-8"))
+ (lambda ()
+ (string-locale-ci=? "œuf" "ŒUF"))
+ (lambda ()
+ (setlocale LC_ALL "C"))))))
+
+ (pass-if "string-locale-ci=? (3 args, wide strings)"
+ (under-french-utf8-locale-or-unresolved
+ (lambda ()
+ (string-locale-ci=? "œuf" "ŒUF" %french-utf8-locale))))
(pass-if "string-locale-ci<>?"
(under-french-locale-or-unresolved
(lambda ()
- (and (string-locale-ci<? "été" "Hiver" %french-locale)
- (string-locale-ci>? "HiVeR" "été" %french-locale)))))
+ (and (string-locale-ci<? "été" "Hiver" %french-locale)
+ (string-locale-ci>? "HiVeR" "été" %french-locale)))))
+
+ (pass-if "string-locale-ci<>? (wide strings)"
+ (under-french-utf8-locale-or-unresolved
+ (lambda ()
+ ;; One of the strings is UCS-4, the other is Latin-1.
+ (and (string-locale-ci<? "Œdème" "œuf" %french-utf8-locale)
+ (string-locale-ci>? "Œuf" "œdÈMe" %french-utf8-locale)))))
+
+ (pass-if "string-locale-ci<>? (wide and narrow strings)"
+ (under-french-utf8-locale-or-unresolved
+ (lambda ()
+ ;; One of the strings is UCS-4, the other is Latin-1.
+ (and (string-locale-ci>? "Œdème" "odyssée" %french-utf8-locale)
+ (string-locale-ci<? "Odyssée" "œdème" %french-utf8-locale)))))
(pass-if "char-locale-ci<>?"
(under-french-locale-or-unresolved
(lambda ()
- (and (char-locale-ci<? #\é #\H %french-locale)
- (char-locale-ci>? #\h #\É %french-locale))))))
+ (and (char-locale-ci<? #\é #\H %french-locale)
+ (char-locale-ci>? #\h #\É %french-locale)))))
+
+ (pass-if "char-locale-ci<>? (wide)"
+ (under-french-utf8-locale-or-unresolved
+ (lambda ()
+ (and (char-locale-ci<? #\o #\Å“ %french-utf8-locale)
+ (char-locale-ci>? #\Å’ #\e %french-utf8-locale))))))
(with-test-prefix "character mapping"
@@ -135,7 +200,50 @@
(pass-if "char-locale-upcase"
(and (eq? #\Z (char-locale-upcase #\z))
- (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C"))))))
+ (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))
+
+ (pass-if "char-locale-upcase Turkish"
+ (under-turkish-utf8-locale-or-unresolved
+ (lambda ()
+ ;; This test is disabled for now, because char-locale-upcase is
+ ;; incomplete.
+ (throw 'untested)
+ (eq? #\İ (char-locale-upcase #\i %turkish-utf8-locale)))))
+
+ (pass-if "char-locale-downcase Turkish"
+ (under-turkish-utf8-locale-or-unresolved
+ (lambda ()
+ ;; This test is disabled for now, because char-locale-downcase
+ ;; is incomplete.
+ (throw 'untested)
+ (eq? #\i (char-locale-downcase #\İ %turkish-utf8-locale))))))
+
+
+(with-test-prefix "string mapping"
+
+ (pass-if "string-locale-downcase"
+ (and (string=? "a" (string-locale-downcase "A"))
+ (string=? "a" (string-locale-downcase "A" (make-locale LC_ALL "C")))))
+
+ (pass-if "string-locale-upcase"
+ (and (string=? "Z" (string-locale-upcase "z"))
+ (string=? "Z" (string-locale-upcase "z" (make-locale LC_ALL "C")))))
+
+ (pass-if "string-locale-upcase Turkish"
+ (under-turkish-utf8-locale-or-unresolved
+ (lambda ()
+ ;; This test is disabled for now, because string-locale-upcase
+ ;; is incomplete.
+ (throw 'untested)
+ (string=? "İI" (string-locale-upcase "iı" %turkish-utf8-locale)))))
+
+ (pass-if "string-locale-downcase Turkish"
+ (under-turkish-utf8-locale-or-unresolved
+ (lambda ()
+ ;; This test is disabled for now, because
+ ;; string-locale-downcase is incomplete.
+ (throw 'untested)
+ (string=? "iı" (string-locale-downcase "İI" %turkish-utf8-locale))))))
(with-test-prefix "number parsing"
@@ -242,9 +350,3 @@
(string-ci=? result "Tuesday"))))
(lambda ()
(setlocale LC_ALL "C")))))))
-
-
-;;; Local Variables:
-;;; coding: latin-1
-;;; mode: scheme
-;;; End:
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index 5929ce909..f8459ba0e 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -1,7 +1,7 @@
;;;; optargs.test --- test suite for optional arg processing -*- scheme -*-
;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,10 +18,30 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-optargs)
- :use-module (test-suite lib)
- :use-module (ice-9 optargs))
-
-(with-test-prefix "optional argument processing"
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (ice-9 optargs))
+
+(define-syntax c&e
+ (syntax-rules (pass-if pass-if-exception)
+ ((_ (pass-if test-name exp))
+ (begin (pass-if (string-append test-name " (eval)")
+ (primitive-eval 'exp))
+ (pass-if (string-append test-name " (compile)")
+ (compile 'exp #:to 'value #:env (current-module)))))
+ ((_ (pass-if-exception test-name exc exp))
+ (begin (pass-if-exception (string-append test-name " (eval)")
+ exc (primitive-eval 'exp))
+ (pass-if-exception (string-append test-name " (compile)")
+ exc (compile 'exp #:to 'value
+ #:env (current-module)))))))
+
+(define-syntax with-test-prefix/c&e
+ (syntax-rules ()
+ ((_ section-name exp ...)
+ (with-test-prefix section-name (c&e exp) ...))))
+
+(with-test-prefix/c&e "optional argument processing"
(pass-if "local defines work with optional arguments"
(eval '(begin
(define* (test-1 #:optional (x 0))
@@ -34,7 +54,7 @@
;;; let-keywords
;;;
-(with-test-prefix "let-keywords"
+(with-test-prefix/c&e "let-keywords"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
@@ -55,7 +75,7 @@
;;; let-keywords*
;;;
-(with-test-prefix "let-keywords*"
+(with-test-prefix/c&e "let-keywords*"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
@@ -76,7 +96,7 @@
;;; let-optional
;;;
-(with-test-prefix "let-optional"
+(with-test-prefix/c&e "let-optional"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
@@ -98,7 +118,7 @@
;;; let-optional*
;;;
-(with-test-prefix "let-optional*"
+(with-test-prefix/c&e "let-optional*"
;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
;; which caused apparently internal defines to "leak" out into the
@@ -115,3 +135,15 @@
(let ((rest '(123)))
(let-optional* rest ((foo 999))
(= foo 123)))))
+
+(define* (foo a b #:optional c (d 1) (e c) f #:key g (h a) (i r) #:rest r)
+ (list a b c d e f g h i r))
+
+;; So we could use lots more tests here, but the fact that lambda* is in
+;; the compiler, and the compiler compiles itself, using the evaluator
+;; (when bootstrapping) and compiled code (when doing a partial rebuild)
+;; makes me a bit complacent.
+(with-test-prefix/c&e "define*"
+ (pass-if "the whole enchilada"
+ (equal? (foo 1 2)
+ '(1 2 #f 1 #f #f #f 1 () ()))))
diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test
index 0bae630b5..0bab38cc4 100644
--- a/test-suite/tests/r5rs_pitfall.test
+++ b/test-suite/tests/r5rs_pitfall.test
@@ -20,7 +20,6 @@
;; macro has been modified to fit into our test suite machinery.
(define-module (test-suite test-r5rs-pitfall)
- :use-syntax (ice-9 syncase)
:use-module (test-suite lib))
(define-syntax should-be
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 0eb851508..2ee21c158 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -1,6 +1,6 @@
;;;; reader.test --- Exercise the reader. -*- Scheme -*-
;;;;
-;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009 Free Software Foundation, Inc.
;;;; Jim Blandy <jimb@red-bean.com>
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -18,6 +18,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite reader)
+ :use-module (srfi srfi-1)
:use-module (test-suite lib))
@@ -26,7 +27,7 @@
(define exception:unexpected-rparen
(cons 'read-error "unexpected \")\"$"))
(define exception:unterminated-block-comment
- (cons 'read-error "unterminated `#! ... !#' comment$"))
+ (cons 'read-error "unterminated `#. \\.\\.\\. .#' comment$"))
(define exception:unknown-character-name
(cons 'read-error "unknown character name .*$"))
(define exception:unknown-sharp-object
@@ -83,6 +84,30 @@
(equal? '(+ 2)
(read-string "(+ 2 #! a comment\n!#\n) ")))
+ (pass-if "R6RS/SRFI-30 block comment"
+ (equal? '(+ 1 2 3)
+ (read-string "(+ 1 #| this is a\ncomment |# 2 3)")))
+
+ (pass-if "R6RS/SRFI-30 nested block comment"
+ (equal? '(a b c)
+ (read-string "(a b c #| d #| e |# f |#)")))
+
+ (pass-if "R6RS/SRFI-30 block comment syntax overridden"
+ ;; To be compatible with 1.8 and earlier, we should be able to override
+ ;; this syntax.
+ (let ((rhp read-hash-procedures))
+ (dynamic-wind
+ (lambda ()
+ (read-hash-extend #\| (lambda args 'not)))
+ (lambda ()
+ (fold (lambda (x y result)
+ (and result (eq? x y)))
+ #t
+ (read-string "(this is #| a comment)")
+ `(this is not a comment)))
+ (lambda ()
+ (set! read-hash-procedures rhp)))))
+
(pass-if "unprintable symbol"
;; The reader tolerates unprintable characters for symbols.
(equal? (string->symbol "\001\002\003")
@@ -131,6 +156,9 @@
(pass-if-exception "unterminated block comment"
exception:unterminated-block-comment
(read-string "(+ 1 #! comment\n..."))
+ (pass-if-exception "R6RS/SRFI-30 unterminated nested block comment"
+ exception:unterminated-block-comment
+ (read-string "(foo #| bar #| |#)"))
(pass-if-exception "unknown character name"
exception:unknown-character-name
(read-string "#\\theunknowncharacter"))
diff --git a/test-suite/tests/records.test b/test-suite/tests/records.test
new file mode 100644
index 000000000..7f8e63621
--- /dev/null
+++ b/test-suite/tests/records.test
@@ -0,0 +1,74 @@
+;;;; records.test --- Test suite for Guile's records. -*- mode: scheme; coding: utf-8 -*-
+;;;;
+;;;; 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 (test-records)
+ #:use-module (test-suite lib))
+
+;; ascii names and symbols
+(define rtd-foo (make-record-type "foo" '(x y)))
+(define make-foo (record-constructor rtd-foo))
+(define foo? (record-predicate rtd-foo))
+(define get-foo-x (record-accessor rtd-foo 'x))
+(define get-foo-y (record-accessor rtd-foo 'y))
+(define set-foo-x! (record-modifier rtd-foo 'x))
+(define set-foo-y! (record-modifier rtd-foo 'y))
+
+;; non-Latin-1 names and symbols
+(define rtd-fÅÅ (make-record-type "fÅÅ" '(x ȳ)))
+(define make-fÅÅ (record-constructor rtd-fÅÅ))
+(define fÅÅ? (record-predicate rtd-fÅÅ))
+(define get-fÅÅ-x (record-accessor rtd-fÅÅ 'x))
+(define get-fÅÅ-ȳ (record-accessor rtd-fÅÅ 'ȳ))
+(define set-fÅÅ-x! (record-modifier rtd-fÅÅ 'x))
+(define set-fÅÅ-ȳ! (record-modifier rtd-fÅÅ 'ȳ))
+
+(with-test-prefix "records"
+
+ (with-test-prefix "constructor"
+
+ (pass-if-exception "0 args (2 required)" exception:wrong-num-args
+ (make-foo))
+
+ (pass-if-exception "1 arg (2 required)" exception:wrong-num-args
+ (make-foo 1))
+
+ (pass-if "2 args (2 required)" exception:wrong-num-args
+ (foo? (make-foo 1 2)))
+
+ (pass-if "non-latin-1" exception:wrong-num-args
+ (fÅÅ? (make-fÅÅ 1 2))))
+
+ (with-test-prefix "modifier and getter"
+
+ (pass-if "set"
+ (let ((r (make-foo 1 2)))
+ (set-foo-x! r 3)
+ (eqv? (get-foo-x r) 3)))
+
+ (pass-if "set 2"
+ (let ((r (make-fÅÅ 1 2)))
+ (set-fÅÅ-ȳ! r 3)
+ (eqv? (get-fÅÅ-ȳ r) 3))))
+
+ (with-test-prefix "record type name"
+
+ (pass-if "foo"
+ (string=? "foo" (record-type-name rtd-foo)))
+
+ (pass-if "fÅÅ"
+ (string=? "fÅÅ" (record-type-name rtd-fÅÅ)))))
diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test
index 730839970..422d8f3cb 100644
--- a/test-suite/tests/regexp.test
+++ b/test-suite/tests/regexp.test
@@ -1,7 +1,7 @@
;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
;;;;
-;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,8 +19,57 @@
(define-module (test-suite test-regexp)
#:use-module (test-suite lib)
+ #:use-module (srfi srfi-1)
#:use-module (ice-9 regex))
+;; Set the locale to LOC, if possible. Failing that, set the locale
+;; to C. If that fails, force the port encoding to ASCII.
+(define (mysetlocale loc)
+ (or
+ (and (defined? 'setlocale)
+ (false-if-exception (setlocale LC_ALL loc)))
+ (and (defined? 'setlocale)
+ (false-if-exception (setlocale LC_ALL "C")))
+ (begin
+ (false-if-exception (set-port-encoding! (current-input-port)
+ "ASCII"))
+ (false-if-exception (set-port-encoding! (current-output-port)
+ "ASCII"))
+ #f)))
+
+;; Set the locale to a Latin-1 friendly locale. Failing that, force
+;; the port encoding to Latin-1. Returns the encoding used.
+(define (set-latin-1)
+ (set-port-conversion-strategy! (current-output-port) 'escape)
+ (or
+ (any
+ (lambda (loc)
+ (if (defined? 'setlocale)
+ (let ((ret (false-if-exception (setlocale LC_ALL loc))))
+ (if ret
+ loc
+ #f))
+ #f))
+ (append
+ (map (lambda (name)
+ (string-append name ".ISO-8859-1"))
+ '("fr_FR" "es_MX" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))
+ (map (lambda (name)
+ (string-append name ".iso88591"))
+ '("fr_FR" "es_MX" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))
+ (map (lambda (name)
+ (string-append name ".ISO8859-1"))
+ '("fr_FR" "es_MX" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT"))
+ ))
+ (begin
+ (false-if-exception (set-port-encoding! (current-input-port)
+ "ISO-8859-1"))
+ (false-if-exception (set-port-encoding! (current-output-port)
+ "ISO-8859-1"))
+ #f)))
+
+(mysetlocale "C")
+
;;; Run a regexp-substitute or regexp-substitute/global test, once
;;; providing a real port and once providing #f, requesting direct
@@ -154,37 +203,44 @@
;; try on each individual character, except #\nul
(do ((i 1 (1+ i)))
((>= i char-code-limit))
- (let* ((c (integer->char i))
- (s (string c))
- (q (regexp-quote s)))
- (pass-if (list "char" i c s q)
- (let ((m (regexp-exec (make-regexp q flag) s)))
- (and (= 0 (match:start m))
- (= 1 (match:end m)))))))
+ (let* ((c (integer->char i))
+ (s (string c))
+ (q (regexp-quote s)))
+ (pass-if (list "char" i (format #f "~s ~s ~s" c s q))
+ (set-latin-1) ; set locale for regexp processing
+ ; on binary data
+ (let ((m (regexp-exec (make-regexp q flag) s)))
+ (mysetlocale "") ; restore locale
+ (and (= 0 (match:start m))
+ (= 1 (match:end m)))))))
;; try on pattern "aX" where X is each character, except #\nul
;; this exposes things like "?" which are special only when they
;; follow a pattern to repeat or whatever ("a" in this case)
(do ((i 1 (1+ i)))
((>= i char-code-limit))
- (let* ((c (integer->char i))
- (s (string #\a c))
- (q (regexp-quote s)))
- (pass-if (list "string \"aX\"" i c s q)
- (let ((m (regexp-exec (make-regexp q flag) s)))
- (and (= 0 (match:start m))
- (= 2 (match:end m)))))))
+ (let* ((c (integer->char i))
+ (s (string #\a c))
+ (q (regexp-quote s)))
+ (pass-if (list "string \"aX\"" i (format #f "~s ~s ~s" c s q))
+ (set-latin-1)
+ (let* ((m (regexp-exec (make-regexp q flag) s)))
+ (mysetlocale "")
+ (and (= 0 (match:start m))
+ (= 2 (match:end m)))))))
(pass-if "string of all chars"
- (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
- flag) allchars)))
- (and (= 0 (match:start m))
- (= (string-length allchars) (match:end m))))))))
+ (set-latin-1)
+ (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
+ flag) allchars)))
+ (and (= 0 (match:start m))
+ (= (string-length allchars) (match:end m))))))))
lst)))
;;;
;;; regexp-substitute
;;;
+(mysetlocale "C")
(with-test-prefix "regexp-substitute"
(let ((match
diff --git a/module/language/r5rs/null.il b/test-suite/tests/signals.test
index a290025de..c05ecd94c 100644
--- a/module/language/r5rs/null.il
+++ b/test-suite/tests/signals.test
@@ -1,7 +1,7 @@
-;;; R5RS null environment
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
+;;;; signals.test --- test suite for Guile's signal functions -*- scheme -*-
+;;;;
+;;;; 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
@@ -13,7 +13,17 @@
;;;; 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
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-signals)
+ #:use-module (test-suite lib))
+
+(with-test-prefix "sigaction"
+
+ (pass-if-exception "handler arg is an invalid integer"
+ exception:out-of-range
+ (sigaction SIGINT 51))
-;;; Code:
+ )
diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test
index 7626ceebf..8fccc36c5 100644
--- a/test-suite/tests/socket.test
+++ b/test-suite/tests/socket.test
@@ -277,6 +277,8 @@
(set! server-listening? #t)
#t)))
+ (force-output (current-output-port))
+ (force-output (current-error-port))
(if server-listening?
(let ((pid (primitive-fork)))
;; Spawn a server process.
@@ -320,3 +322,90 @@
#t)))
+
+(if (defined? 'AF_INET6)
+ (with-test-prefix "AF_INET6/SOCK_STREAM"
+
+ ;; testing `bind', `listen' and `connect' on stream-oriented sockets
+
+ (let ((server-socket (socket AF_INET6 SOCK_STREAM 0))
+ (server-bound? #f)
+ (server-listening? #f)
+ (server-pid #f)
+ (ipv6-addr 1) ; ::1
+ (server-port 8889)
+ (client-port 9998))
+
+ (pass-if "bind"
+ (catch 'system-error
+ (lambda ()
+ (bind server-socket AF_INET6 ipv6-addr server-port)
+ (set! server-bound? #t)
+ #t)
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EADDRINUSE) (throw 'unresolved))
+ (else (apply throw args)))))))
+
+ (pass-if "bind/sockaddr"
+ (let* ((sock (socket AF_INET6 SOCK_STREAM 0))
+ (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
+ (catch 'system-error
+ (lambda ()
+ (bind sock sockaddr)
+ #t)
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EADDRINUSE) (throw 'unresolved))
+ (else (apply throw args))))))))
+
+ (pass-if "listen"
+ (if (not server-bound?)
+ (throw 'unresolved)
+ (begin
+ (listen server-socket 123)
+ (set! server-listening? #t)
+ #t)))
+
+ (force-output (current-output-port))
+ (force-output (current-error-port))
+ (if server-listening?
+ (let ((pid (primitive-fork)))
+ ;; Spawn a server process.
+ (case pid
+ ((-1) (throw 'unresolved))
+ ((0) ;; the kid: serve two connections and exit
+ (let serve ((conn
+ (false-if-exception (accept server-socket)))
+ (count 1))
+ (if (not conn)
+ (exit 1)
+ (if (> count 0)
+ (serve (false-if-exception (accept server-socket))
+ (- count 1)))))
+ (exit 0))
+ (else ;; the parent
+ (set! server-pid pid)
+ #t))))
+
+ (pass-if "connect"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((s (socket AF_INET6 SOCK_STREAM 0)))
+ (connect s AF_INET6 ipv6-addr server-port)
+ #t)))
+
+ (pass-if "connect/sockaddr"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((s (socket AF_INET6 SOCK_STREAM 0)))
+ (connect s (make-socket-address AF_INET6 ipv6-addr server-port))
+ #t)))
+
+ (pass-if "accept"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((status (cdr (waitpid server-pid))))
+ (eq? 0 (status:exit-val status)))))
+
+ #t))) \ No newline at end of file
diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test
index d8e379959..0d2ff59a0 100644
--- a/test-suite/tests/srfi-13.test
+++ b/test-suite/tests/srfi-13.test
@@ -40,6 +40,12 @@
(with-test-prefix "string-any"
+ (pass-if "null string"
+ (not (string-any #\a "")))
+
+ (pass-if "start index == end index"
+ (not (string-any #\a "aaa" 1 1)))
+
(with-test-prefix "bad char_pred"
(pass-if-exception "integer" exception:wrong-type-arg
@@ -259,6 +265,12 @@
(with-test-prefix "string-every"
+ (pass-if "null string"
+ (string-every #\a ""))
+
+ (pass-if "start index == end index"
+ (string-every #\a "bbb" 1 1))
+
(with-test-prefix "bad char_pred"
(pass-if-exception "integer" exception:wrong-type-arg
diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test
index 56c944a42..f12a2557c 100644
--- a/test-suite/tests/srfi-14.test
+++ b/test-suite/tests/srfi-14.test
@@ -53,6 +53,214 @@
(char-set->list (char-set #\a #\c #\e))
(list #\a #\c #\e))))
+(with-test-prefix "char set additition"
+
+ (pass-if "empty + x"
+ (let ((cs (char-set)))
+ (char-set-adjoin! cs #\x)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\x))))
+
+ (pass-if "x + y"
+ (let ((cs (char-set #\x)))
+ (char-set-adjoin! cs #\y)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\x #\y))))
+
+ (pass-if "x + w"
+ (let ((cs (char-set #\x)))
+ (char-set-adjoin! cs #\w)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\w #\x))))
+
+ (pass-if "x + z"
+ (let ((cs (char-set #\x)))
+ (char-set-adjoin! cs #\z)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\x #\z))))
+
+ (pass-if "x + v"
+ (let ((cs (char-set #\x)))
+ (char-set-adjoin! cs #\v)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\v #\x))))
+
+ (pass-if "uv + w"
+ (let ((cs (char-set #\u #\v)))
+ (char-set-adjoin! cs #\w)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\u #\v #\w))))
+
+ (pass-if "uv + t"
+ (let ((cs (char-set #\u #\v)))
+ (char-set-adjoin! cs #\t)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\t #\u #\v))))
+
+ (pass-if "uv + x"
+ (let ((cs (char-set #\u #\v)))
+ (char-set-adjoin! cs #\x)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\u #\v #\x))))
+
+ (pass-if "uv + s"
+ (let ((cs (char-set #\u #\v)))
+ (char-set-adjoin! cs #\s)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\s #\u #\v))))
+
+ (pass-if "uvx + w"
+ (let ((cs (char-set #\u #\v #\x)))
+ (char-set-adjoin! cs #\w)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\u #\v #\w #\x))))
+
+ (pass-if "uvx + y"
+ (let ((cs (char-set #\u #\v #\x)))
+ (char-set-adjoin! cs #\y)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\u #\v #\x #\y))))
+
+ (pass-if "uvxy + w"
+ (let ((cs (char-set #\u #\v #\x #\y)))
+ (char-set-adjoin! cs #\w)
+ (list= eqv?
+ (char-set->list cs)
+ (list #\u #\v #\w #\x #\y)))))
+
+(with-test-prefix "char set union"
+ (pass-if "null U abc"
+ (char-set= (char-set-union (char-set) (->char-set "abc"))
+ (->char-set "abc")))
+
+ (pass-if "ab U ab"
+ (char-set= (char-set-union (->char-set "ab") (->char-set "ab"))
+ (->char-set "ab")))
+
+ (pass-if "ab U bc"
+ (char-set= (char-set-union (->char-set "ab") (->char-set "bc"))
+ (->char-set "abc")))
+
+ (pass-if "ab U cd"
+ (char-set= (char-set-union (->char-set "ab") (->char-set "cd"))
+ (->char-set "abcd")))
+
+ (pass-if "ab U de"
+ (char-set= (char-set-union (->char-set "ab") (->char-set "de"))
+ (->char-set "abde")))
+
+ (pass-if "abc U bcd"
+ (char-set= (char-set-union (->char-set "abc") (->char-set "bcd"))
+ (->char-set "abcd")))
+
+ (pass-if "abdf U abcdefg"
+ (char-set= (char-set-union (->char-set "abdf") (->char-set "abcdefg"))
+ (->char-set "abcdefg")))
+
+ (pass-if "abef U cd"
+ (char-set= (char-set-union (->char-set "abef") (->char-set "cd"))
+ (->char-set "abcdef")))
+
+ (pass-if "abgh U cd"
+ (char-set= (char-set-union (->char-set "abgh") (->char-set "cd"))
+ (->char-set "abcdgh")))
+
+ (pass-if "bc U ab"
+ (char-set= (char-set-union (->char-set "bc") (->char-set "ab"))
+ (->char-set "abc")))
+
+ (pass-if "cd U ab"
+ (char-set= (char-set-union (->char-set "cd") (->char-set "ab"))
+ (->char-set "abcd")))
+
+ (pass-if "de U ab"
+ (char-set= (char-set-union (->char-set "de") (->char-set "ab"))
+ (->char-set "abde")))
+
+ (pass-if "cd U abc"
+ (char-set= (char-set-union (->char-set "cd") (->char-set "abc"))
+ (->char-set "abcd")))
+
+ (pass-if "cd U abcd"
+ (char-set= (char-set-union (->char-set "cd") (->char-set "abcd"))
+ (->char-set "abcd")))
+
+ (pass-if "cde U abcdef"
+ (char-set= (char-set-union (->char-set "cde") (->char-set "abcdef"))
+ (->char-set "abcdef"))))
+
+(with-test-prefix "char set xor"
+ (pass-if "null - xy"
+ (char-set= (char-set-xor (char-set) (char-set #\x #\y))
+ (char-set #\x #\y)))
+
+ (pass-if "x - x"
+ (char-set= (char-set-xor (char-set #\x) (char-set #\x))
+ (char-set)))
+
+ (pass-if "xy - x"
+ (char-set= (char-set-xor (char-set #\x #\y) (char-set #\x))
+ (char-set #\y)))
+
+ (pass-if "xy - y"
+ (char-set= (char-set-xor (char-set #\x #\y) (char-set #\y))
+ (char-set #\x)))
+
+ (pass-if "wxy - w"
+ (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\w))
+ (char-set #\x #\y)))
+
+ (pass-if "wxy - x"
+ (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\x))
+ (char-set #\w #\y)))
+
+ (pass-if "wxy - y"
+ (char-set= (char-set-xor (char-set #\w #\x #\y) (char-set #\y))
+ (char-set #\w #\x)))
+
+ (pass-if "uvxy - u"
+ (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\u))
+ (char-set #\v #\x #\y)))
+
+ (pass-if "uvxy - v"
+ (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\v))
+ (char-set #\u #\x #\y)))
+
+ (pass-if "uvxy - x"
+ (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\x))
+ (char-set #\u #\v #\y)))
+
+ (pass-if "uvxy - y"
+ (char-set= (char-set-xor (char-set #\u #\v #\x #\y) (char-set #\y))
+ (char-set #\u #\v #\x)))
+
+ (pass-if "uwy - u"
+ (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\u))
+ (char-set #\w #\y)))
+
+ (pass-if "uwy - w"
+ (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\w))
+ (char-set #\u #\y)))
+
+ (pass-if "uwy - y"
+ (char-set= (char-set-xor (char-set #\u #\w #\y) (char-set #\y))
+ (char-set #\u #\w)))
+
+ (pass-if "uvwy - v"
+ (char-set= (char-set-xor (char-set #\u #\v #\w #\y) (char-set #\v))
+ (char-set #\u #\w #\y))))
+
(with-test-prefix "char-set?"
@@ -83,7 +291,10 @@
(not (char-set= (char-set #\a) (char-set))))
(pass-if "success, more args"
- (char-set= char-set:blank char-set:blank char-set:blank)))
+ (char-set= char-set:blank char-set:blank char-set:blank))
+
+ (pass-if "failure, same length, different elements"
+ (not (char-set= (char-set #\a #\b #\d) (char-set #\a #\c #\d)))))
(with-test-prefix "char-set<="
(pass-if "success, no arg"
@@ -238,6 +449,199 @@
(string=? (char-set->string cs)
"egilu"))))
+(with-test-prefix "list->char-set"
+
+ (pass-if "list->char-set"
+ (char-set= (list->char-set '(#\a #\b #\c))
+ (->char-set "abc")))
+
+ (pass-if "list->char-set!"
+ (let* ((cs (char-set #\a #\z)))
+ (list->char-set! '(#\m #\n) cs)
+ (char-set= cs
+ (char-set #\a #\m #\n #\z)))))
+
+(with-test-prefix "string->char-set"
+
+ (pass-if "string->char-set"
+ (char-set= (string->char-set "foobar")
+ (string->char-set "barfoo")))
+
+ (pass-if "string->char-set cs"
+ (char-set= (string->char-set "foo" (string->char-set "bar"))
+ (string->char-set "barfoo")))
+
+ (pass-if "string->char-set!"
+ (let ((cs (string->char-set "bar")))
+ (string->char-set! "foo" cs)
+ (char-set= cs
+ (string->char-set "barfoo")))))
+
+(with-test-prefix "char-set-filter"
+
+ (pass-if "filter w/o base"
+ (char-set=
+ (char-set-filter (lambda (c) (char=? c #\x))
+ (->char-set "qrstuvwxyz"))
+ (->char-set #\x)))
+
+ (pass-if "filter w/ base"
+ (char-set=
+ (char-set-filter (lambda (c) (char=? c #\x))
+ (->char-set "qrstuvwxyz")
+ (->char-set "op"))
+
+ (->char-set "opx")))
+
+ (pass-if "filter!"
+ (let ((cs (->char-set "abc")))
+ (set! cs (char-set-filter! (lambda (c) (char=? c #\x))
+ (->char-set "qrstuvwxyz")
+ cs))
+ (char-set= (string->char-set "abcx")
+ cs))))
+
+
+(with-test-prefix "char-set-intersection"
+
+ (pass-if "empty"
+ (char-set= (char-set-intersection (char-set) (char-set))
+ (char-set)))
+
+ (pass-if "identical, one element"
+ (char-set= (char-set-intersection (char-set #\a) (char-set #\a))
+ (char-set #\a)))
+
+ (pass-if "identical, two elements"
+ (char-set= (char-set-intersection (char-set #\a #\b) (char-set #\a #\b))
+ (char-set #\a #\b)))
+
+ (pass-if "identical, two elements"
+ (char-set= (char-set-intersection (char-set #\a #\c) (char-set #\a #\c))
+ (char-set #\a #\c)))
+
+ (pass-if "one vs null"
+ (char-set= (char-set-intersection (char-set #\a) (char-set))
+ (char-set)))
+
+ (pass-if "null vs one"
+ (char-set= (char-set-intersection (char-set) (char-set #\a))
+ (char-set)))
+
+ (pass-if "no elements shared"
+ (char-set= (char-set-intersection (char-set #\a #\c) (char-set #\b #\d))
+ (char-set)))
+
+ (pass-if "one elements shared"
+ (char-set= (char-set-intersection (char-set #\a #\c #\d) (char-set #\b #\d))
+ (char-set #\d))))
+
+(with-test-prefix "char-set-complement"
+
+ (pass-if "complement of null"
+ (char-set= (char-set-complement (char-set))
+ (char-set-union (ucs-range->char-set 0 #xd800)
+ (ucs-range->char-set #xe000 #x110000))))
+
+ (pass-if "complement of null (2)"
+ (char-set= (char-set-complement (char-set))
+ (ucs-range->char-set 0 #x110000)))
+
+ (pass-if "complement of #\\0"
+ (char-set= (char-set-complement (char-set #\nul))
+ (ucs-range->char-set 1 #x110000)))
+
+ (pass-if "complement of U+10FFFF"
+ (char-set= (char-set-complement (char-set (integer->char #x10ffff)))
+ (ucs-range->char-set 0 #x10ffff)))
+
+ (pass-if "complement of 'FOO'"
+ (char-set= (char-set-complement (->char-set "FOO"))
+ (char-set-union (ucs-range->char-set 0 (char->integer #\F))
+ (ucs-range->char-set (char->integer #\G)
+ (char->integer #\O))
+ (ucs-range->char-set (char->integer #\P)
+ #x110000))))
+ (pass-if "complement of #\\a #\\b U+010300"
+ (char-set= (char-set-complement (char-set #\a #\b (integer->char #x010300)))
+ (char-set-union (ucs-range->char-set 0 (char->integer #\a))
+ (ucs-range->char-set (char->integer #\c) #x010300)
+ (ucs-range->char-set #x010301 #x110000)))))
+
+(with-test-prefix "ucs-range->char-set"
+ (pass-if "char-set"
+ (char-set= (ucs-range->char-set 65 68)
+ (->char-set "ABC")))
+
+ (pass-if "char-set w/ base"
+ (char-set= (ucs-range->char-set 65 68 #f (->char-set "DEF"))
+ (->char-set "ABCDEF")))
+
+ (pass-if "char-set!"
+ (let ((cs (->char-set "DEF")))
+ (ucs-range->char-set! 65 68 #f cs)
+ (char-set= cs
+ (->char-set "ABCDEF")))))
+
+(with-test-prefix "char-set-count"
+ (pass-if "null"
+ (= 0 (char-set-count (lambda (c) #t) (char-set))))
+
+ (pass-if "count"
+ (= 5 (char-set-count (lambda (c) #t)
+ (->char-set "guile")))))
+
+(with-test-prefix "char-set-contains?"
+ (pass-if "#\\a not in null"
+ (not (char-set-contains? (char-set) #\a)))
+
+ (pass-if "#\\a is in 'abc'"
+ (char-set-contains? (->char-set "abc") #\a)))
+
+(with-test-prefix "any / every"
+ (pass-if "char-set-every #t"
+ (char-set-every (lambda (c) #t)
+ (->char-set "abc")))
+
+ (pass-if "char-set-every #f"
+ (not (char-set-every (lambda (c) (char=? c #\c))
+ (->char-set "abc"))))
+
+ (pass-if "char-set-any #t"
+ (char-set-any (lambda (c) (char=? c #\c))
+ (->char-set "abc")))
+
+ (pass-if "char-set-any #f"
+ (not (char-set-any (lambda (c) #f)
+ (->char-set "abc")))))
+
+(with-test-prefix "char-set-delete"
+ (pass-if "abc - a"
+ (char-set= (char-set-delete (->char-set "abc") #\a)
+ (char-set #\b #\c)))
+
+ (pass-if "abc - d"
+ (char-set= (char-set-delete (->char-set "abc") #\d)
+ (char-set #\a #\b #\c)))
+
+ (pass-if "delete! abc - a"
+ (let ((cs (char-set #\a #\b #\c)))
+ (char-set-delete! cs #\a)
+ (char-set= cs (char-set #\b #\c)))))
+
+(with-test-prefix "char-set-difference"
+ (pass-if "not different"
+ (char-set= (char-set-difference (->char-set "foobar") (->char-set "foobar"))
+ (char-set)))
+
+ (pass-if "completely different"
+ (char-set= (char-set-difference (->char-set "foo") (->char-set "bar"))
+ (->char-set "foo")))
+
+ (pass-if "partially different"
+ (char-set= (char-set-difference (->char-set "breakfast") (->char-set "breakroom"))
+ (->char-set "fst"))))
+
(with-test-prefix "standard char sets (ASCII)"
(pass-if "char-set:lower-case"
diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test
index 24ee60248..849d1dea2 100644
--- a/test-suite/tests/srfi-35.test
+++ b/test-suite/tests/srfi-35.test
@@ -1,7 +1,7 @@
;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*-
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
-;;;; 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
@@ -33,7 +33,11 @@
(condition-type? &condition))
(pass-if "make-condition-type"
- (condition-type? (make-condition-type 'foo &condition '(a b)))))
+ (condition-type? (make-condition-type 'foo &condition '(a b))))
+
+ (pass-if "struct-vtable-name"
+ (let ((ct (make-condition-type 'chbouib &condition '(a b))))
+ (eq? 'chbouib (struct-vtable-name ct)))))
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index c78fe55ff..013c1a863 100644
--- a/test-suite/tests/strings.test
+++ b/test-suite/tests/strings.test
@@ -177,7 +177,7 @@
(let ((s "\U000040"))
(not (assq-ref (%string-dump s) 'stringbuf-wide))))))
-(with-test-prefix "hex escapes"
+(with-test-prefix "escapes"
(pass-if-exception "non-hex char in two-digit hex-escape"
exception:illegal-escape
@@ -216,7 +216,44 @@
(integer->char #x010300)))
(pass-if "escaped characters match non-escaped ASCII characters"
- (string=? "ABC" "\x41\u0042\U000043")))
+ (string=? "ABC" "\x41\u0042\U000043"))
+
+ (pass-if "R5RS backslash escapes"
+ (string=? "\"\\" (string #\" #\\)))
+
+ (pass-if "Guile extensions backslash escapes"
+ (string=? "\0\a\f\n\r\t\v"
+ (apply string (map integer->char '(0 7 12 10 13 9 11))))))
+
+;;
+;; string?
+;;
+(with-test-prefix "string?"
+
+ (pass-if "string"
+ (string? "abc"))
+
+ (pass-if "symbol"
+ (not (string? 'abc))))
+
+;;
+;; string-null?
+;;
+
+(with-test-prefix "string-null?"
+
+ (pass-if "null string"
+ (string-null? ""))
+
+ (pass-if "non-null string"
+ (not (string-null? "a")))
+
+ (pass-if "respects \\0"
+ (not (string-null? "\0")))
+
+ (pass-if-exception "symbol"
+ exception:wrong-type-arg
+ (string-null? 'a)))
;;
;; string=?
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index 4cd93369a..72acdeccb 100644
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -22,11 +22,6 @@
(define-module (test-suite test-syncase)
:use-module (test-suite lib))
-(pass-if "(ice-9 syncase) loads"
- (false-if-exception
- (begin (eval '(use-syntax (ice-9 syncase)) (current-module))
- #t)))
-
(define-syntax plus
(syntax-rules ()
((plus x ...) (+ x ...))))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 282072b5b..ec5528070 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -58,11 +58,11 @@
(define exception:bad-body
(cons 'misc-error "^bad body"))
(define exception:bad-formals
- '(syntax-error . "invalid parameter list"))
+ '(syntax-error . "invalid argument list"))
(define exception:bad-formal
(cons 'syntax-error "Bad formal"))
-(define exception:duplicate-formal
- (cons 'syntax-error "Duplicate formal"))
+(define exception:duplicate-formals
+ (cons 'syntax-error "duplicate identifier in argument list"))
(define exception:missing-clauses
(cons 'syntax-error "Missing clauses"))
@@ -228,13 +228,13 @@
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x) 1)"
- exception:bad-formals
+ exception:duplicate-formals
(eval '(lambda (x x) 1)
(interaction-environment)))
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x x) 1)"
- exception:bad-formals
+ exception:duplicate-formals
(eval '(lambda (x x x) 1)
(interaction-environment))))
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index 26efe8580..58a2ebafa 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -1,6 +1,6 @@
;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2007, 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
@@ -363,7 +363,21 @@
(pass-if "locking mutex with no owner"
(let ((m (make-mutex)))
(lock-mutex m #f #f)
- (not (mutex-owner m)))))
+ (not (mutex-owner m))))
+
+ (pass-if "mutex with owner not retained (bug #27450)"
+ (let ((g (make-guardian)))
+ (g (let ((m (make-mutex))) (lock-mutex m) m))
+
+ ;; Avoid false references to M on the stack.
+ (let cleanup ((i 20))
+ (and (> i 0)
+ (begin (cleanup (1- i)) i)))
+
+ (gc) (gc)
+ (let ((m (g)))
+ (and (mutex? m)
+ (eq? (mutex-owner m) (current-thread)))))))
;;
;; mutex lock levels
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index ee5e4d352..2e78a1a07 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -26,6 +26,9 @@
#:use-module (language glil)
#:use-module (srfi srfi-13))
+(define read-and-compile
+ (@@ (system base compile) read-and-compile))
+
;; Of course, the GLIL that is emitted depends on the source info of the
;; input. Here we're not concerned about that, so we strip source
;; information from the incoming tree-il.
@@ -45,14 +48,6 @@
(define-syntax assert-tree-il->glil
(syntax-rules ()
- ((_ in out)
- (pass-if 'in
- (let ((tree-il (strip-source (parse-tree-il 'in))))
- (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
- 'out))))))
-
-(define-syntax assert-tree-il->glil/pmatch
- (syntax-rules ()
((_ in pat test ...)
(let ((exp 'in))
(pass-if 'in
@@ -66,21 +61,21 @@
(with-test-prefix "void"
(assert-tree-il->glil
(void)
- (program 0 0 0 () (void) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
(assert-tree-il->glil
(begin (void) (const 1))
- (program 0 0 0 () (const 1) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
(assert-tree-il->glil
(apply (primitive +) (void) (const 1))
- (program 0 0 0 () (void) (call add1 1) (call return 1))))
+ (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
(apply (toplevel foo) (const 1))
- (program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
- (assert-tree-il->glil/pmatch
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call goto/args 1)))
+ (assert-tree-il->glil
(begin (apply (toplevel foo) (const 1)) (void))
- (program 0 0 0 () (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+ (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2)
(label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
@@ -88,26 +83,26 @@
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar)))
- (program 0 0 0 () (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
(call goto/args 1))))
(with-test-prefix "conditional"
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(if (const #t) (const 1) (const 2))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1)
(const 1) (call return 1)
(label ,l2) (const 2) (call return 1))
(eq? l1 l2))
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(begin (if (const #t) (const 1) (const 2)) (const #f))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
+ (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1) (branch br ,l2)
(label ,l3) (label ,l4) (const #f) (call return 1))
(eq? l1 l3) (eq? l2 l4))
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(apply (primitive null?) (if (const #t) (const 1) (const 2)))
- (program 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (program () (std-prelude 0 0 #f) (label _) (const #t) (branch br-if-not ,l1)
(const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4)
(call null? 1) (call return 1))
@@ -116,35 +111,35 @@
(with-test-prefix "primitive-ref"
(assert-tree-il->glil
(primitive +)
- (program 0 0 0 () (toplevel ref +) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
(assert-tree-il->glil
(begin (primitive +) (const #f))
- (program 0 0 0 () (const #f) (call return 1)))
+ (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (primitive +))
- (program 0 0 0 () (toplevel ref +) (call null? 1)
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
(call return 1))))
(with-test-prefix "lexical refs"
(assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1)
(unbind))))
@@ -154,7 +149,7 @@
;; unreferenced sets may be optimized away -- make sure they are ref'd
(let (x) (y) ((const 1))
(set! (lexical x y) (apply (primitive 1+) (lexical x y))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(void) (call return 1)
@@ -164,7 +159,7 @@
(let (x) (y) ((const 1))
(begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
(lexical x y)))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(lexical #t #t ref 0) (call return 1)
@@ -174,7 +169,7 @@
(let (x) (y) ((const 1))
(apply (primitive null?)
(set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
(call null? 1) (call return 1)
@@ -183,234 +178,259 @@
(with-test-prefix "module refs"
(assert-tree-il->glil
(@ (foo) bar)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@ (foo) bar) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@ (foo) bar))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar)
(call null? 1) (call return 1)))
(assert-tree-il->glil
(@@ (foo) bar)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@@ (foo) bar) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (@@ (foo) bar))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar)
(call null? 1) (call return 1))))
(with-test-prefix "module sets"
(assert-tree-il->glil
(set! (@ (foo) bar) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@ (foo) bar) (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@ (foo) bar) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1)))
(assert-tree-il->glil
(set! (@@ (foo) bar) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (@@ (foo) bar) (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel refs"
(assert-tree-il->glil
(toplevel bar)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar)
(call return 1)))
(assert-tree-il->glil
(begin (toplevel bar) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (toplevel bar))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar)
(call null? 1) (call return 1))))
(with-test-prefix "toplevel sets"
(assert-tree-il->glil
(set! (toplevel bar) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (set! (toplevel bar) (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (set! (toplevel bar) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel defines"
(assert-tree-il->glil
(define bar (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (define bar (const 2)) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (define bar (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(void) (call null? 1) (call return 1))))
(with-test-prefix "constants"
(assert-tree-il->glil
(const 2)
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (call return 1)))
(assert-tree-il->glil
(begin (const 2) (const #f))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (const 2))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1))))
(with-test-prefix "lambda"
(assert-tree-il->glil
- (lambda (x) (y) () (const 2))
- (program 0 0 0 ()
- (program 1 0 0 ()
- (bind (x #f 0))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f #f #f () (y) #f) (const 2)) #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (std-prelude 1 1 #f)
+ (bind (x #f 0)) (label _)
+ (const 2) (call return 1) (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x x1) (y y1) () (const 2))
- (program 0 0 0 ()
- (program 2 0 0 ()
- (bind (x #f 0) (x1 #f 1))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case (((x y) #f #f #f () (x1 y1) #f)
+ (const 2))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (std-prelude 2 2 #f)
+ (bind (x #f 0) (y #f 1)) (label _)
+ (const 2) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda x y () (const 2))
- (program 0 0 0 ()
- (program 1 1 0 ()
- (bind (x #f 0))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case ((() #f x #f () (y) #f) (const 2))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 0 0 0 1 #f)
+ (bind (x #f 0)) (label _)
+ (const 2) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x . x1) (y . y1) () (const 2))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (const 2) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f x1 #f () (y y1) #f) (const 2))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 1 0 1 2 #f)
+ (bind (x #f 0) (x1 #f 1)) (label _)
+ (const 2) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x . x1) (y . y1) () (lexical x y))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (lexical #t #f ref 0) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f x1 #f () (y y1) #f) (lexical x y))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 1 0 1 2 #f)
+ (bind (x #f 0) (x1 #f 1)) (label _)
+ (lexical #t #f ref 0) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x . x1) (y . y1) () (lexical x1 y1))
- (program 0 0 0 ()
- (program 2 1 0 ()
- (bind (x #f 0) (x1 #f 1))
- (lexical #t #f ref 1) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f x1 #f () (y y1) #f) (lexical x1 y1))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (opt-prelude 1 0 1 2 #f)
+ (bind (x #f 0) (x1 #f 1)) (label _)
+ (lexical #t #f ref 1) (call return 1)
+ (unbind))
(call return 1)))
(assert-tree-il->glil
- (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
- (program 0 0 0 ()
- (program 1 0 0 ()
- (bind (x #f 0))
- (program 1 0 0 ()
- (bind (y #f 0))
- (lexical #f #f ref 0) (call return 1))
+ (lambda ()
+ (lambda-case (((x) #f #f #f () (x1) #f)
+ (lambda ()
+ (lambda-case (((y) #f #f #f () (y1) #f)
+ (lexical x x1))
+ #f)))
+ #f))
+ (program () (std-prelude 0 0 #f) (label _)
+ (program () (std-prelude 1 1 #f)
+ (bind (x #f 0)) (label _)
+ (program () (std-prelude 1 1 #f)
+ (bind (y #f 0)) (label _)
+ (lexical #f #f ref 0) (call return 1)
+ (unbind))
(lexical #t #f ref 0)
(call vector 1)
(call make-closure 2)
- (call return 1))
+ (call return 1)
+ (unbind))
(call return 1))))
(with-test-prefix "sequence"
(assert-tree-il->glil
(begin (begin (const 2) (const #f)) (const #t))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const #t) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1))))
;; FIXME: binding info for or-hacked locals might bork the disassembler,
;; and could be tightened in any case
(with-test-prefix "the or hack"
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical a b))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1)
@@ -422,13 +442,13 @@
(eq? l1 l2))
;; second bound var is unreferenced
- (assert-tree-il->glil/pmatch
+ (assert-tree-il->glil
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical x y))))
- (program 0 0 1 ()
+ (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1)
@@ -440,10 +460,10 @@
(with-test-prefix "apply"
(assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar))
- (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
- (assert-tree-il->glil/pmatch
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
+ (assert-tree-il->glil
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
@@ -451,7 +471,7 @@
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
(call goto/args 1))))
@@ -459,10 +479,10 @@
(with-test-prefix "call/cc"
(assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo))
- (program 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
- (assert-tree-il->glil/pmatch
+ (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call goto/cc 1)))
+ (assert-tree-il->glil
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4)
@@ -471,7 +491,7 @@
(assert-tree-il->glil
(apply (toplevel foo)
(apply (toplevel @call-with-current-continuation) (toplevel bar)))
- (program 0 0 0 ()
+ (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))
@@ -504,15 +524,18 @@
(1+ y))
0
(parse-tree-il
- '(lambda (x y) (x1 y1)
- (apply (toplevel +)
- (lexical x x1)
- (lexical y y1)))))))
+ '(lambda ()
+ (lambda-case
+ (((x y) #f #f #f () (x1 y1) #f)
+ (apply (toplevel +)
+ (lexical x x1)
+ (lexical y y1)))
+ #f))))))
(and (equal? (map strip-source leaves)
(list (make-lexical-ref #f 'y 'y1)
(make-lexical-ref #f 'x 'x1)
(make-toplevel-ref #f '+)))
- (= (length downs) 2)
+ (= (length downs) 3)
(equal? (reverse (map strip-source ups))
(map strip-source downs))))))
@@ -535,6 +558,8 @@
(define %opts-w-unused
'(#:warnings (unused-variable)))
+(define %opts-w-unbound
+ '(#:warnings (unbound-variable)))
(with-test-prefix "warnings"
@@ -588,4 +613,77 @@
(null? (call-with-warnings
(lambda ()
(compile '(lambda (x y z) #t)
- #:opts %opts-w-unused)))))))
+ #:opts %opts-w-unused))))))
+
+ (with-test-prefix "unbound variable"
+
+ (pass-if "quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '+ #:opts %opts-w-unbound)))))
+
+ (pass-if "ref"
+ (let* ((v (gensym))
+ (w (call-with-warnings
+ (lambda ()
+ (compile v
+ #:to 'assembly
+ #:opts %opts-w-unbound)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ (format #f "unbound variable `~A'"
+ v))))))
+
+ (pass-if "set!"
+ (let* ((v (gensym))
+ (w (call-with-warnings
+ (lambda ()
+ (compile `(set! ,v 7)
+ #:to 'assembly
+ #:opts %opts-w-unbound)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ (format #f "unbound variable `~A'"
+ v))))))
+
+ (pass-if "module-local top-level is visible"
+ (let ((m (make-module))
+ (v (gensym)))
+ (beautify-user-module! m)
+ (compile `(define ,v 123)
+ #:env m #:opts %opts-w-unbound)
+ (null? (call-with-warnings
+ (lambda ()
+ (compile v
+ #:env m
+ #:to 'assembly
+ #:opts %opts-w-unbound))))))
+
+ (pass-if "module-local top-level is visible after"
+ (let ((m (make-module))
+ (v (gensym)))
+ (beautify-user-module! m)
+ (null? (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string
+ "(define (f)
+ (set! chbouib 3))
+ (define chbouib 5)")))
+ (read-and-compile in
+ #:env m
+ #:opts %opts-w-unbound)))))))
+
+ (pass-if "GOOPS definitions are visible"
+ (let ((m (make-module))
+ (v (gensym)))
+ (beautify-user-module! m)
+ (module-use! m (resolve-interface '(oop goops)))
+ (null? (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string
+ "(define-class <foo> ()
+ (bar #:getter foo-bar))
+ (define z (foo-bar (make <foo>)))")))
+ (read-and-compile in
+ #:env m
+ #:opts %opts-w-unbound)))))))))
diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test
index 5d584e86e..092f7aac2 100644
--- a/test-suite/tests/unif.test
+++ b/test-suite/tests/unif.test
@@ -17,7 +17,8 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-unif)
- #:use-module (test-suite lib))
+ #:use-module ((system base compile) #:select (compile))
+ #:use-module (test-suite lib))
;;;
;;; array?
@@ -546,8 +547,10 @@
(eq? 'b (array-ref a -2)))))
(pass-if-exception "negative length" exception:length-non-negative
- (with-input-from-string "'#1:-3(#t #t)" read)))
+ (with-input-from-string "'#1:-3(#t #t)" read))
+ (pass-if "bitvector is self-evaluating"
+ (equal? (compile (bitvector)) (bitvector))))
;;;
;;; equal? with vector and one-dimensional array
diff --git a/test-suite/tests/vectors.test b/test-suite/tests/vectors.test
index 22434bfc6..fe856251f 100644
--- a/test-suite/tests/vectors.test
+++ b/test-suite/tests/vectors.test
@@ -36,7 +36,29 @@
(pass-if "simple vector"
(equal? '(1 2 3) (vector->list #(1 2 3))))
+ (pass-if "string vector 1"
+ (equal? '("abc" "def" "ghi") (vector->list #("abc" "def" "ghi"))))
+
+ (pass-if "string-vector 2"
+ (equal? '("abc\u0100" "def\u0101" "ghi\u0102")
+ (vector->list #("abc\u0100" "def\u0101" "ghi\u0102"))))
+
(pass-if "shared array"
(let ((b (make-shared-array #(1) (lambda (x) '(0)) 2)))
(equal? b (list->vector (vector->list b))))))
+(with-test-prefix "make-vector"
+
+ (pass-if "null"
+ (equal? #() (make-vector 0)))
+
+ (pass-if "fill with num"
+ (equal? #(1 1 1) (make-vector 3 1)))
+
+ (pass-if "fill with string"
+ (equal? #("abc" "abc" "abc") (make-vector 3 "abc")))
+
+ (pass-if "fill with string 2"
+ (equal? #("ab\u0100" "ab\u0100" "ab\u0100")
+ (make-vector 3 "ab\u0100"))))
+
diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test
index b469887c2..b39d2e78f 100644
--- a/test-suite/tests/weaks.test
+++ b/test-suite/tests/weaks.test
@@ -1,5 +1,5 @@
;;;; weaks.test --- tests guile's weaks -*- scheme -*-
-;;;; Copyright (C) 1999, 2001, 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 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
@@ -95,11 +95,11 @@
(define global-weak (make-weak-vector 10 #f))
(begin
- (vector-set! global-weak 0 "string")
- (vector-set! global-weak 1 "beans")
- (vector-set! global-weak 2 "to")
- (vector-set! global-weak 3 "utah")
- (vector-set! global-weak 4 "yum yum")
+ (vector-set! global-weak 0 (string-copy "string"))
+ (vector-set! global-weak 1 (string-copy "beans"))
+ (vector-set! global-weak 2 (string-copy "to"))
+ (vector-set! global-weak 3 (string-copy "utah"))
+ (vector-set! global-weak 4 (string-copy "yum yum"))
(gc))
;;; Normal weak vectors