summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore11
-rw-r--r--GUILE-VERSION2
-rw-r--r--Makefile.am3
-rw-r--r--NEWS158
-rw-r--r--README5
-rw-r--r--THANKS2
-rw-r--r--acinclude.m469
-rw-r--r--benchmark-suite/benchmarks/chars.bm57
-rw-r--r--benchmark-suite/benchmarks/srfi-13.bm310
-rw-r--r--check-guile.in2
-rw-r--r--configure.ac (renamed from configure.in)38
-rw-r--r--doc/Makefile.am2
-rw-r--r--doc/README4
-rw-r--r--doc/goops/Makefile.am29
-rw-r--r--doc/ref/.gitignore1
-rw-r--r--doc/ref/ChangeLog-goops-2008 (renamed from doc/goops/ChangeLog-2008)0
-rw-r--r--doc/ref/Makefile.am13
-rw-r--r--doc/ref/api-binding.texi16
-rw-r--r--doc/ref/api-compound.texi37
-rw-r--r--doc/ref/api-control.texi28
-rwxr-xr-xdoc/ref/api-data.texi25
-rw-r--r--doc/ref/api-debug.texi56
-rw-r--r--doc/ref/api-io.texi16
-rw-r--r--doc/ref/api-modules.texi44
-rw-r--r--doc/ref/api-options.texi15
-rw-r--r--doc/ref/api-scheduling.texi63
-rw-r--r--doc/ref/autoconf.texi19
-rw-r--r--doc/ref/compiler.texi168
-rw-r--r--doc/ref/effective-version.texi.in1
-rw-r--r--doc/ref/expect.texi16
-rw-r--r--doc/ref/goops-tutorial.texi (renamed from doc/goops/goops-tutorial.texi)392
-rw-r--r--doc/ref/goops.texi (renamed from doc/goops/goops.texi)391
-rw-r--r--doc/ref/guile.texi17
-rw-r--r--doc/ref/hierarchy.eps (renamed from doc/goops/hierarchy.eps)0
-rw-r--r--doc/ref/hierarchy.pdf (renamed from doc/goops/hierarchy.pdf)0
-rw-r--r--doc/ref/hierarchy.png (renamed from doc/goops/hierarchy.png)bin6251 -> 6251 bytes
-rw-r--r--doc/ref/hierarchy.txt (renamed from doc/goops/hierarchy.txt)0
-rw-r--r--doc/ref/intro.texi18
-rw-r--r--doc/ref/libguile-extensions.texi4
-rw-r--r--doc/ref/libguile-linking.texi3
-rw-r--r--doc/ref/libguile-smobs.texi26
-rw-r--r--doc/ref/mop.text (renamed from doc/goops/mop.text)0
-rw-r--r--doc/ref/posix.texi4
-rw-r--r--doc/ref/preface.texi24
-rw-r--r--doc/ref/scheme-debugging.texi12
-rw-r--r--doc/ref/scheme-ideas.texi6
-rw-r--r--doc/ref/scsh.texi4
-rw-r--r--doc/ref/slib.texi13
-rw-r--r--doc/ref/tools.texi6
-rw-r--r--doc/ref/vm.texi439
-rw-r--r--guile-readline/Makefile.am37
-rwxr-xr-xguile-readline/autogen.sh8
-rw-r--r--guile-readline/configure.in88
-rw-r--r--guile-readline/ice-9/Makefile.am28
-rw-r--r--guile-readline/readline.c8
-rw-r--r--lang/elisp/interface.scm5
-rw-r--r--lib/Makefile.am4
-rw-r--r--lib/iconv_open-aix.h2
-rw-r--r--lib/time.in.h8
-rw-r--r--lib/unistd.in.h13
-rw-r--r--libguile.h9
-rw-r--r--libguile/Makefile.am501
-rw-r--r--libguile/__scm.h24
-rw-r--r--libguile/_scm.h33
-rw-r--r--libguile/array-handle.c162
-rw-r--r--libguile/array-handle.h129
-rw-r--r--libguile/array-map.c (renamed from libguile/ramap.c)25
-rw-r--r--libguile/array-map.h (renamed from libguile/ramap.h)10
-rw-r--r--libguile/arrays.c1156
-rw-r--r--libguile/arrays.h91
-rw-r--r--libguile/bitvectors.c910
-rw-r--r--libguile/bitvectors.h81
-rw-r--r--libguile/bytevectors.c318
-rw-r--r--libguile/bytevectors.h16
-rw-r--r--libguile/chars.c8
-rw-r--r--libguile/chars.h20
-rw-r--r--libguile/continuations.c6
-rw-r--r--libguile/continuations.h2
-rw-r--r--libguile/conv-uinteger.i.c25
-rw-r--r--libguile/convert.c147
-rw-r--r--libguile/convert.h51
-rw-r--r--libguile/convert.i.c171
-rw-r--r--libguile/debug.c1
-rw-r--r--libguile/deprecated.c38
-rw-r--r--libguile/deprecated.h3
-rw-r--r--libguile/discouraged.c2
-rw-r--r--libguile/eq.c6
-rw-r--r--libguile/error.c13
-rw-r--r--libguile/error.h2
-rw-r--r--libguile/eval.c284
-rw-r--r--libguile/eval.h45
-rw-r--r--libguile/eval.i.c29
-rw-r--r--libguile/evalext.c47
-rw-r--r--libguile/extensions.c5
-rw-r--r--libguile/filesys.c60
-rw-r--r--libguile/fports.c4
-rw-r--r--libguile/frames.c8
-rw-r--r--libguile/frames.h40
-rw-r--r--libguile/gc-card.c6
-rw-r--r--libguile/gc-malloc.c10
-rw-r--r--libguile/gc-mark.c18
-rw-r--r--libguile/gc.c4
-rw-r--r--libguile/gen-scmconfig.c9
-rw-r--r--libguile/generalized-arrays.c276
-rw-r--r--libguile/generalized-arrays.h63
-rw-r--r--libguile/generalized-vectors.c201
-rw-r--r--libguile/generalized-vectors.h61
-rw-r--r--libguile/goops.c71
-rw-r--r--libguile/hash.c17
-rw-r--r--libguile/hash.h1
-rw-r--r--libguile/init.c27
-rw-r--r--libguile/inline.h42
-rw-r--r--libguile/libguile.map44
-rw-r--r--libguile/load.c34
-rw-r--r--libguile/load.h1
-rw-r--r--libguile/numbers.c140
-rw-r--r--libguile/numbers.h7
-rw-r--r--libguile/objcodes.c45
-rw-r--r--libguile/ports.c655
-rw-r--r--libguile/ports.h33
-rw-r--r--libguile/posix.c46
-rw-r--r--libguile/posix.h1
-rw-r--r--libguile/print.c299
-rw-r--r--libguile/print.h3
-rw-r--r--libguile/procprop.c6
-rw-r--r--libguile/procs.c9
-rw-r--r--libguile/programs.c70
-rw-r--r--libguile/programs.h18
-rw-r--r--libguile/random.c5
-rw-r--r--libguile/rdelim.c6
-rw-r--r--libguile/read.c625
-rw-r--r--libguile/read.h2
-rw-r--r--libguile/rw.c2
-rw-r--r--libguile/socket.c37
-rw-r--r--libguile/sort.c6
-rw-r--r--libguile/srcprop.c139
-rw-r--r--libguile/srcprop.h2
-rw-r--r--libguile/srfi-13.c1523
-rw-r--r--libguile/srfi-14.c1531
-rw-r--r--libguile/srfi-14.h34
-rw-r--r--libguile/srfi-14.i.c7150
-rw-r--r--libguile/srfi-4.c329
-rw-r--r--libguile/srfi-4.h31
-rw-r--r--libguile/srfi-4.i.c15
-rw-r--r--libguile/stime.c50
-rw-r--r--libguile/strings.c1189
-rw-r--r--libguile/strings.h83
-rw-r--r--libguile/strports.c139
-rw-r--r--libguile/strports.h6
-rw-r--r--libguile/struct.c76
-rw-r--r--libguile/symbols.c108
-rw-r--r--libguile/tags.h4
-rw-r--r--libguile/threads.c19
-rw-r--r--libguile/threads.h2
-rw-r--r--libguile/throw.c19
-rw-r--r--libguile/unif.c3034
-rw-r--r--libguile/unif.h198
-rw-r--r--libguile/uniform.c254
-rw-r--r--libguile/uniform.h77
-rw-r--r--libguile/vectors.c153
-rw-r--r--libguile/vectors.h17
-rw-r--r--libguile/vm-engine.c35
-rw-r--r--libguile/vm-engine.h30
-rw-r--r--libguile/vm-i-loader.c82
-rw-r--r--libguile/vm-i-scheme.c36
-rw-r--r--libguile/vm-i-system.c454
-rw-r--r--libguile/vm.c17
-rw-r--r--libguile/vm.h6
-rw-r--r--m4/gnulib-cache.m43
-rw-r--r--m4/gnulib-comp.m46
-rw-r--r--m4/iconv.m46
-rw-r--r--m4/ld-version-script.m444
-rw-r--r--m4/time_h.m44
-rw-r--r--m4/unistd_h.m43
-rw-r--r--meta/Makefile.am13
-rw-r--r--meta/gdb-uninstalled-guile.in4
-rw-r--r--meta/guile-2.0-uninstalled.pc.in (renamed from meta/guile-1.8-uninstalled.pc.in)0
-rw-r--r--meta/guile-2.0.pc.in (renamed from meta/guile-1.8.pc.in)0
-rwxr-xr-xmeta/guile-config4
-rwxr-xr-xmeta/guile-tools.in (renamed from meta/guile-tools)6
-rw-r--r--meta/guile.in4
-rw-r--r--meta/uninstalled-env.in3
-rw-r--r--module/Makefile.am18
-rw-r--r--module/ice-9/boot-9.scm80
-rw-r--r--module/ice-9/deprecated.scm12
-rw-r--r--module/ice-9/lineio.scm2
-rw-r--r--module/ice-9/psyntax-pp.scm11074
-rw-r--r--module/ice-9/psyntax.scm8
-rw-r--r--module/language/assembly.scm12
-rw-r--r--module/language/assembly/compile-bytecode.scm31
-rw-r--r--module/language/assembly/decompile-bytecode.scm13
-rw-r--r--module/language/assembly/disassemble.scm2
-rw-r--r--module/language/ecmascript/compile-ghil.scm561
-rw-r--r--module/language/ecmascript/compile-tree-il.scm549
-rw-r--r--module/language/ecmascript/spec.scm4
-rw-r--r--module/language/ecmascript/tokenize.scm2
-rw-r--r--module/language/glil/compile-assembly.scm79
-rw-r--r--module/language/scheme/spec.scm6
-rw-r--r--module/language/tree-il.scm80
-rw-r--r--module/language/tree-il/analyze.scm262
-rw-r--r--module/language/tree-il/compile-glil.scm378
-rw-r--r--module/language/tree-il/fix-letrec.scm240
-rw-r--r--module/language/tree-il/inline.scm81
-rw-r--r--module/language/tree-il/optimize.scm18
-rw-r--r--module/language/tree-il/primitives.scm66
-rw-r--r--module/scripts/compile.scm16
-rw-r--r--module/srfi/srfi-11.scm215
-rw-r--r--module/srfi/srfi-4/gnu.scm52
-rw-r--r--module/system/base/compile.scm7
-rw-r--r--module/system/base/syntax.scm89
-rw-r--r--module/system/xref.scm2
-rw-r--r--test-suite/standalone/Makefile.am18
-rw-r--r--test-suite/tests/asm-to-bytecode.test13
-rw-r--r--test-suite/tests/compiler.test32
-rw-r--r--test-suite/tests/dynamic-scope.test16
-rw-r--r--test-suite/tests/encoding-escapes.test139
-rw-r--r--test-suite/tests/encoding-iso88591.test135
-rw-r--r--test-suite/tests/encoding-iso88597.test136
-rw-r--r--test-suite/tests/encoding-utf8.test105
-rw-r--r--test-suite/tests/modules.test9
-rw-r--r--test-suite/tests/numbers.test1
-rw-r--r--test-suite/tests/ports.test3
-rw-r--r--test-suite/tests/procprop.test4
-rw-r--r--test-suite/tests/r6rs-ports.test3
-rw-r--r--test-suite/tests/srcprop.test42
-rw-r--r--test-suite/tests/srfi-13.test56
-rw-r--r--test-suite/tests/srfi-14.test297
-rw-r--r--test-suite/tests/strings.test258
-rw-r--r--test-suite/tests/symbols.test85
-rw-r--r--test-suite/tests/syntax.test46
-rw-r--r--test-suite/tests/time.test5
-rw-r--r--test-suite/tests/tree-il.test37
-rw-r--r--test-suite/tests/unif.test4
-rw-r--r--testsuite/run-vm-tests.scm3
234 files changed, 27591 insertions, 14909 deletions
diff --git a/.gitignore b/.gitignore
index 29f29be5f..9d507e11b 100644
--- a/.gitignore
+++ b/.gitignore
@@ -12,7 +12,6 @@ config.guess
config.status
config.log
config.h
-guile-readline-config.h
*.doc
*.x
*.lo
@@ -65,11 +64,10 @@ pre-inst-guile-env
stamp-h1
guile-procedures.txt
guile-config/guile-config
-guile-readline/guile-readline-config.h
-guile-readline/guile-readline-config.h.in
*.go
TAGS
-guile-1.8.pc
+/meta/guile-2.0.pc
+/meta/guile-2.0-uninstalled.pc
gdb-pre-inst-guile
cscope.out
cscope.files
@@ -108,3 +106,8 @@ INSTALL
/lib/time.h
/lib/unistd.h
/lib/unistr/.dirstamp
+/GPATH
+/GRTAGS
+/GSYMS
+/GTAGS
+/meta/guile-tools
diff --git a/GUILE-VERSION b/GUILE-VERSION
index fa96ed95a..6d86dd8dd 100644
--- a/GUILE-VERSION
+++ b/GUILE-VERSION
@@ -2,7 +2,7 @@
GUILE_MAJOR_VERSION=1
GUILE_MINOR_VERSION=9
-GUILE_MICRO_VERSION=1
+GUILE_MICRO_VERSION=2
GUILE_EFFECTIVE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION}
GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION}
diff --git a/Makefile.am b/Makefile.am
index 4562dddf3..80231bb37 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -42,6 +42,9 @@ DISTCLEANFILES = check-guile.log
dist-hook: gen-ChangeLog
+clean-local:
+ rm -rf cache/
+
gen_start_rev = 61db429e251bfd2f75cb4632972e0238056eb24b
.PHONY: gen-ChangeLog
gen-ChangeLog:
diff --git a/NEWS b/NEWS
index 96c3a9b1d..0f2d6930d 100644
--- a/NEWS
+++ b/NEWS
@@ -8,89 +8,31 @@ 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.2 (since the 1.9.1 prerelease):
+Changes in 1.9.3 (since the 1.9.2 prerelease):
-** Global variables `scm_charnames' and `scm_charnums' are removed.
+** 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
-These variables contained the names of control characters and were
-used when writing characters. While these were global, they were
-never intended to be public API. They have been replaced with private
-functions.
-
-** EBCDIC support is removed.
-
-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.
-
-Changes in 1.9.1 (since the 1.9.0 prerelease):
-
-** `scm_set_port_seek' and `scm_set_port_truncate' use the `scm_t_off' type
-
-Previously they would use the `off_t' type, which is fragile since its
-definition depends on the application's value for `_FILE_OFFSET_BITS'.
-
-** Automatically compiled files will be placed in ~/.cache, not ~/.guile-ccache.
-
-Actually, they will be placed in $XDG_CACHE_HOME/guile/ccache/1.9,
-defaulting to XDG_CACHE_HOME=~/.cache. Users may remove their
-~/.guile-ccache directories.
-
-** New language: Brainfuck.
-
-Brainfuck is a toy language that closely models Turing machines. Guile's
-brainfuck compiler is meant to be an example of implementing other
-languages. See the manual for details, or
-http://en.wikipedia.org/wiki/Brainfuck for more information about the
-Brainfuck language itself.
-
-** A number of Scheme files were corrected to be LGPLv3+.
-
-Some Scheme files imported for the compiler were erroneously labeled as
-being LGPLv2+ or GPLv2+. This oversight has been fixed.
-
-** Bytevectors may now be accessed with a C-friendly API.
-
-New functions: `scm_is_bytevector ()', `scm_c_bytevector_length ()',
-`scm_c_bytevector_length ()', and `scm_c_bytevector_set_x ()'. See the
-manual for details.
-
-** Bytevectors are now accessible using the generalized-vector API.
-
-As a side effect, this change allows compilation of literal bytevectors
-(`#vu8(...)').
-
-** Meta-commands to the REPL work better with strange languages.
-
-Specifically, meta-commands that take expressions as arguments will use
-the current language's reader to read those expressions, which may span
-multiple lines, with readline integration if the user has that enabled.
-
-** The object code file format has changed.
-
-The objcode loader will complain about a "bad header cookie" if it
-happens to find an old file. The workaround for that is currently to
-find all stale .go files and remove them. This is likely to affect users
-who have checked out Guile's git repository, not those that build from
-tarballs.
+These functions have been deprecated since early 2005.
-** Vector access has been sped up considerably.
+** scm_array_p has one argument, not two
-Guile's virtual machine now has vector and bytevector operations. Using
-Guile to process large amounts of data is now easier. This is because
-`vector-ref' and `vector-set!' now have fast opcodes. In addition, there
-are opcodes for `ref' and `set' operations on bytevectors for everything
-from 8-bit integers to 64-bit floating-point values.
+Use of the second argument produced a deprecation warning, so it is
+unlikely that any code out there actually used this functionality.
-In the next release, we hope to extend this speedup to other kinds of
-uniform vectors.
+** Removed deprecated uniform array procedures:
+ dimensions->uniform-array, list->uniform-array, array-prototype
-** The `long_long' C type, deprecated in 1.8, has been removed.
-
-** And of course, the usual collection of bugfixes.
+Instead, use make-typed-array, list->typed-array, or array-type,
+respectively.
+** 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)
@@ -538,6 +480,35 @@ This decision may be revisited before the 2.0 release. Feedback welcome
to guile-devel@gnu.org (subscription required) or bug-guile@gnu.org (no
subscription required).
+** Unicode characters
+
+Unicode characters may be entered in octal format via e.g. `#\454', or
+created via (integer->char 300). A hex external representation will
+probably be introduced at some point.
+
+** Unicode strings
+
+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.
+
+** Global variables `scm_charnames' and `scm_charnums' are removed
+
+These variables contained the names of control characters and were
+used when writing characters. While these were global, they were
+never intended to be public API. They have been replaced with private
+functions.
+
+** EBCDIC support is removed
+
+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.
+
** New macro type: syncase-macro
XXX Need to decide whether to document this for 2.0, probably should:
@@ -571,6 +542,10 @@ These are analogous to %load-path and %load-extensions.
`(make-promise (lambda () foo))' is equivalent to `(delay foo)'.
+** `defined?' may accept a module as its second argument
+
+Previously it only accepted internal structures from the evaluator.
+
** New entry into %guile-build-info: `ccachedir'
** Fix bug in `module-bound?'.
@@ -584,6 +559,12 @@ 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.
+** 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.
+
* Changes to the C interface
** The GH interface (deprecated in version 1.6, 2001) was removed.
@@ -612,6 +593,18 @@ definition depends on the application's value for `_FILE_OFFSET_BITS'.
** The `long_long' C type, deprecated in 1.8, has been removed
+** 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
+
+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+
@@ -627,6 +620,11 @@ part of Guile).
guile.m4 has yet to be modified to call pkg-config instead of
guile-config.
+** Guile now provides `guile-2.0.pc' instead of `guile-1.8.pc'
+
+Programs that use `pkg-config' to find Guile or one of its Autoconf
+macros should now require `guile-2.0' instead of `guile-1.8'.
+
** New installation directory: $(pkglibdir)/1.9/ccache
If $(libdir) is /usr/lib, for example, Guile will install its .go files
@@ -634,9 +632,17 @@ to /usr/lib/guile/1.9/ccache. These files are architecture-specific.
** New dependency: GNU libunistring.
-See http://www.gnu.org/software/libunistring/. We hope to merge in
-Unicode support in the next prerelease.
+See http://www.gnu.org/software/libunistring/, for more information. Our
+unicode support uses routines from libunistring.
+
+
+
+Changes in 1.8.8 (since 1.8.7)
+
+* Bugs fixed
+** Fix possible buffer overruns when parsing numbers
+** Avoid clash with system setjmp/longjmp on IA64
Changes in 1.8.7 (since 1.8.6)
diff --git a/README b/README
index 1f71b8afe..bea40debc 100644
--- a/README
+++ b/README
@@ -299,9 +299,8 @@ Guile Documentation ==================================================
If you've never used Scheme before, then the Guile Tutorial
(guile-tut.info) is a good starting point. The Guile Reference Manual
-(guile.info) is the primary documentation for Guile. The Goops object
-system is documented separately (goops.info). A copy of the R5RS
-Scheme specification is included too (r5rs.info).
+(guile.info) is the primary documentation for Guile. A copy of the
+R5RS Scheme specification is included too (r5rs.info).
Info format versions of this documentation are installed as part of
the normal build process. The texinfo sources are under the doc
diff --git a/THANKS b/THANKS
index 47aa93cc7..e458a7625 100644
--- a/THANKS
+++ b/THANKS
@@ -3,6 +3,7 @@ Contributors since the last release:
Rob Browning
Ludovic Courtès
Julian Graham
+ Mike Gran
Stefan Jahn
Neil Jerram
Gregory Marton
@@ -69,6 +70,7 @@ For fixes or providing information which led to a fix:
Jeff Long
Marco Maggi
Gregory Marton
+ Kjetil S. Matheussen
Antoine Mathys
Dan McMahill
Roger Mc Murtrie
diff --git a/acinclude.m4 b/acinclude.m4
index 345e323b3..5629263b7 100644
--- a/acinclude.m4
+++ b/acinclude.m4
@@ -1,3 +1,5 @@
+dnl -*- Autoconf -*-
+
dnl On the NeXT, #including <utime.h> doesn't give you a definition for
dnl struct utime, unless you #define _POSIX_SOURCE.
@@ -308,3 +310,70 @@ else
fi
AC_LANG_RESTORE
])dnl ACX_PTHREAD
+
+dnl GUILE_READLINE
+dnl
+dnl Check all the things needed by `guile-readline', the Readline
+dnl bindings.
+AC_DEFUN([GUILE_READLINE], [
+ for termlib in ncurses curses termcap terminfo termlib ; do
+ AC_CHECK_LIB(${termlib}, [tgoto],
+ [READLINE_LIBS="-l${termlib} $READLINE_LIBS"; break])
+ done
+
+ AC_LIB_LINKFLAGS([readline])
+
+ if test "x$LTLIBREADLINE" = "x"; then
+ AC_MSG_WARN([GNU Readline was not found on your system.])
+ else
+ rl_save_LIBS="$LIBS"
+ LIBS="$LIBREADLINE $READLINE_LIBS $LIBS"
+
+ AC_CHECK_FUNCS([siginterrupt rl_clear_signals rl_cleanup_after_signal])
+
+ dnl Check for modern readline naming
+ AC_CHECK_FUNCS([rl_filename_completion_function])
+
+ dnl Check for rl_get_keymap. We only use this for deciding whether to
+ dnl install paren matching on the Guile command line (when using
+ dnl readline for input), so it's completely optional.
+ AC_CHECK_FUNCS([rl_get_keymap])
+
+ AC_CACHE_CHECK([for rl_getc_function pointer in readline],
+ ac_cv_var_rl_getc_function,
+ [AC_TRY_LINK([
+ #include <stdio.h>
+ #include <readline/readline.h>],
+ [printf ("%ld", (long) rl_getc_function)],
+ [ac_cv_var_rl_getc_function=yes],
+ [ac_cv_var_rl_getc_function=no])])
+ if test "${ac_cv_var_rl_getc_function}" = "yes"; then
+ AC_DEFINE([HAVE_RL_GETC_FUNCTION], 1,
+ [Define if your readline library has the rl_getc_function variable.])
+ fi
+
+ if test $ac_cv_var_rl_getc_function = no; then
+ AC_MSG_WARN([*** GNU Readline is too old on your system.])
+ AC_MSG_WARN([*** You need readline version 2.1 or later.])
+ LTLIBREADLINE=""
+ LIBREADLINE=""
+ fi
+
+ LIBS="$rl_save_LIBS"
+
+ READLINE_LIBS="$LTLIBREADLINE $READLINE_LIBS"
+ fi
+
+ AM_CONDITIONAL([HAVE_READLINE], [test "x$LTLIBREADLINE" != "x"])
+
+ AC_CHECK_FUNCS([strdup])
+
+ AC_SUBST([READLINE_LIBS])
+
+ . $srcdir/guile-readline/LIBGUILEREADLINE-VERSION
+ AC_SUBST(LIBGUILEREADLINE_MAJOR)
+ AC_SUBST(LIBGUILEREADLINE_INTERFACE_CURRENT)
+ AC_SUBST(LIBGUILEREADLINE_INTERFACE_REVISION)
+ AC_SUBST(LIBGUILEREADLINE_INTERFACE_AGE)
+ AC_SUBST(LIBGUILEREADLINE_INTERFACE)
+])
diff --git a/benchmark-suite/benchmarks/chars.bm b/benchmark-suite/benchmarks/chars.bm
new file mode 100644
index 000000000..dc6ad94aa
--- /dev/null
+++ b/benchmark-suite/benchmarks/chars.bm
@@ -0,0 +1,57 @@
+;;; -*- mode: scheme; coding: latin-1; -*-
+;;; chars.bm
+;;;
+;;; 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 Lesser General Public License
+;;; as published by the Free Software Foundation; either version 3, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this software; see the file COPYING.LESSER. If
+;;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmarks chars)
+ :use-module (benchmark-suite lib))
+
+
+(with-benchmark-prefix "chars"
+
+ (benchmark "char" 1000000
+ #\a)
+
+ (benchmark "octal" 1000000
+ #\123)
+
+ (benchmark "char? eq" 1000000
+ (char? #\a))
+
+ (benchmark "char=?" 1000000
+ (char=? #\a #\a))
+
+ (benchmark "char<?" 1000000
+ (char=? #\a #\a))
+
+ (benchmark "char-ci=?" 1000000
+ (char=? #\a #\a))
+
+ (benchmark "char-ci<? " 1000000
+ (char=? #\a #\a))
+
+ (benchmark "char->integer" 1000000
+ (char->integer #\a))
+
+ (benchmark "char-alphabetic?" 1000000
+ (char-upcase #\a))
+
+ (benchmark "char-numeric?" 1000000
+ (char-upcase #\a)))
+
diff --git a/benchmark-suite/benchmarks/srfi-13.bm b/benchmark-suite/benchmarks/srfi-13.bm
new file mode 100644
index 000000000..e648e2af9
--- /dev/null
+++ b/benchmark-suite/benchmarks/srfi-13.bm
@@ -0,0 +1,310 @@
+;;; -*- mode: scheme; coding: latin-1; -*-
+;;; srfi-13.bm
+;;;
+;;; 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 Lesser General Public License
+;;; as published by the Free Software Foundation; either version 3, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this software; see the file COPYING.LESSER. If
+;;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmarks strings)
+ :use-module (benchmark-suite lib))
+
+(seed->random-state 1)
+
+(define short-string "Hi")
+(define medium-string
+"ARMA virumque cano, Troiae qui primus ab oris
+Italiam, fato profugus, Laviniaque venit")
+(define long-string
+ (string-tabulate
+ (lambda (n) (integer->char (+ 32 (random 90))))
+ 1000))
+
+(define short-chlist (string->list short-string))
+(define medium-chlist (string->list medium-string))
+(define long-chlist (string->list long-string))
+
+(define str1 (string-copy short-string))
+(define str2 (string-copy medium-string))
+(define str3 (string-copy long-string))
+
+
+(with-benchmark-prefix "strings"
+
+ (with-benchmark-prefix "predicates"
+
+ (benchmark "string?" 1190000
+ (string? short-string)
+ (string? medium-string)
+ (string? long-string))
+
+ (benchmark "null?" 969000
+ (string-null? short-string)
+ (string-null? medium-string)
+ (string-null? long-string))
+
+ (benchmark "any" 94000
+ (string-any #\a short-string)
+ (string-any #\a medium-string)
+ (string-any #\a long-string))
+
+ (benchmark "every" 94000
+ (string-every #\a short-string)
+ (string-every #\a medium-string)
+ (string-every #\a long-string)))
+
+ (with-benchmark-prefix "constructors"
+
+ (benchmark "string" 5000
+ (apply string short-chlist)
+ (apply string medium-chlist)
+ (apply string long-chlist))
+
+ (benchmark "list->" 4500
+ (list->string short-chlist)
+ (list->string medium-chlist)
+ (list->string long-chlist))
+
+ (benchmark "reverse-list->" 5000
+ (reverse-list->string short-chlist)
+ (reverse-list->string medium-chlist)
+ (reverse-list->string long-chlist))
+
+ (benchmark "make" 22000
+ (make-string 250 #\x))
+
+ (benchmark "tabulate" 17000
+ (string-tabulate integer->char 250))
+
+ (benchmark "join" 5500
+ (string-join (list short-string medium-string long-string) "|" 'suffix)))
+
+ (with-benchmark-prefix "list/string"
+ (benchmark "->list" 7300
+ (string->list short-string)
+ (string->list medium-string)
+ (string->list long-string))
+
+ (benchmark "split" 60000
+ (string-split short-string #\a)
+ (string-split medium-string #\a)
+ (string-split long-string #\a)))
+
+ (with-benchmark-prefix "selection"
+
+ (benchmark "ref" 660
+ (let loop ((k 0))
+ (if (< k (string-length short-string))
+ (begin
+ (string-ref short-string k)
+ (loop (+ k 1)))))
+ (let loop ((k 0))
+ (if (< k (string-length medium-string))
+ (begin
+ (string-ref medium-string k)
+ (loop (+ k 1)))))
+ (let loop ((k 0))
+ (if (< k (string-length long-string))
+ (begin
+ (string-ref long-string k)
+ (loop (+ k 1))))))
+
+ (benchmark "copy" 1100
+ (string-copy short-string)
+ (string-copy medium-string)
+ (string-copy long-string)
+ (substring/copy short-string 0 1)
+ (substring/copy medium-string 10 20)
+ (substring/copy long-string 100 200))
+
+ (benchmark "pad" 6800
+ (string-pad short-string 100)
+ (string-pad medium-string 100)
+ (string-pad long-string 100))
+
+ (benchmark "trim trim-right trim-both" 60000
+ (string-trim short-string char-alphabetic?)
+ (string-trim medium-string char-alphabetic?)
+ (string-trim long-string char-alphabetic?)
+ (string-trim-right short-string char-alphabetic?)
+ (string-trim-right medium-string char-alphabetic?)
+ (string-trim-right long-string char-alphabetic?)
+ (string-trim-both short-string char-alphabetic?)
+ (string-trim-both medium-string char-alphabetic?)
+ (string-trim-both long-string char-alphabetic?)))
+
+ (with-benchmark-prefix "modification"
+
+ (set! str1 (string-copy short-string))
+ (set! str2 (string-copy medium-string))
+ (set! str3 (string-copy long-string))
+
+ (benchmark "set!" 3000
+ (let loop ((k 1))
+ (if (< k (string-length short-string))
+ (begin
+ (string-set! str1 k #\x)
+ (loop (+ k 1)))))
+ (let loop ((k 20))
+ (if (< k (string-length medium-string))
+ (begin
+ (string-set! str2 k #\x)
+ (loop (+ k 1)))))
+ (let loop ((k 900))
+ (if (< k (string-length long-string))
+ (begin
+ (string-set! str3 k #\x)
+ (loop (+ k 1))))))
+
+ (set! str1 (string-copy short-string))
+ (set! str2 (string-copy medium-string))
+ (set! str3 (string-copy long-string))
+
+ (benchmark "sub-move!" 230000
+ (substring-move! short-string 0 2 str2 10)
+ (substring-move! medium-string 10 20 str3 20))
+
+ (set! str1 (string-copy short-string))
+ (set! str2 (string-copy medium-string))
+ (set! str3 (string-copy long-string))
+
+ (benchmark "fill!" 230000
+ (string-fill! str1 #\y 0 1)
+ (string-fill! str2 #\y 10 20)
+ (string-fill! str3 #\y 20 30))
+
+ (with-benchmark-prefix "comparison"
+
+ (benchmark "compare compare-ci" 140000
+ (string-compare short-string medium-string string<? string=? string>?)
+ (string-compare long-string medium-string string<? string=? string>?)
+ (string-compare-ci short-string medium-string string<? string=? string>?)
+ (string-compare-ci long-string medium-string string<? string=? string>?))
+
+ (benchmark "hash hash-ci" 1000
+ (string-hash short-string)
+ (string-hash medium-string)
+ (string-hash long-string)
+ (string-hash-ci short-string)
+ (string-hash-ci medium-string)
+ (string-hash-ci long-string))))
+
+ (with-benchmark-prefix "searching" 20000
+
+ (benchmark "prefix-length suffix-length" 270
+ (string-prefix-length short-string
+ (string-append short-string medium-string))
+ (string-prefix-length long-string
+ (string-append long-string medium-string))
+ (string-suffix-length short-string
+ (string-append medium-string short-string))
+ (string-suffix-length long-string
+ (string-append medium-string long-string))
+ (string-prefix-length-ci short-string
+ (string-append short-string medium-string))
+ (string-prefix-length-ci long-string
+ (string-append long-string medium-string))
+ (string-suffix-length-ci short-string
+ (string-append medium-string short-string))
+ (string-suffix-length-ci long-string
+ (string-append medium-string long-string)))
+
+ (benchmark "prefix? suffix?" 270
+ (string-prefix? short-string
+ (string-append short-string medium-string))
+ (string-prefix? long-string
+ (string-append long-string medium-string))
+ (string-suffix? short-string
+ (string-append medium-string short-string))
+ (string-suffix? long-string
+ (string-append medium-string long-string))
+ (string-prefix-ci? short-string
+ (string-append short-string medium-string))
+ (string-prefix-ci? long-string
+ (string-append long-string medium-string))
+ (string-suffix-ci? short-string
+ (string-append medium-string short-string))
+ (string-suffix-ci? long-string
+ (string-append medium-string long-string)))
+
+ (benchmark "index index-right rindex" 100000
+ (string-index short-string #\T)
+ (string-index medium-string #\T)
+ (string-index long-string #\T)
+ (string-index-right short-string #\T)
+ (string-index-right medium-string #\T)
+ (string-index-right long-string #\T)
+ (string-rindex short-string #\T)
+ (string-rindex medium-string #\T)
+ (string-rindex long-string #\T))
+
+ (benchmark "skip skip-right?" 100000
+ (string-skip short-string char-alphabetic?)
+ (string-skip medium-string char-alphabetic?)
+ (string-skip long-string char-alphabetic?)
+ (string-skip-right short-string char-alphabetic?)
+ (string-skip-right medium-string char-alphabetic?)
+ (string-skip-right long-string char-alphabetic?))
+
+ (benchmark "count" 10000
+ (string-count short-string char-alphabetic?)
+ (string-count medium-string char-alphabetic?)
+ (string-count long-string char-alphabetic?))
+
+ (benchmark "contains contains-ci" 34000
+ (string-contains short-string short-string)
+ (string-contains medium-string (substring medium-string 10 15))
+ (string-contains long-string (substring long-string 100 130))
+ (string-contains-ci short-string short-string)
+ (string-contains-ci medium-string (substring medium-string 10 15))
+ (string-contains-ci long-string (substring long-string 100 130)))
+
+ (set! str1 (string-copy short-string))
+ (set! str2 (string-copy medium-string))
+ (set! str3 (string-copy long-string))
+
+ (benchmark "upcase downcase upcase! downcase!" 600
+ (string-upcase short-string)
+ (string-upcase medium-string)
+ (string-upcase long-string)
+ (string-downcase short-string)
+ (string-downcase medium-string)
+ (string-downcase long-string)
+ (string-upcase! str1 0 1)
+ (string-upcase! str2 10 20)
+ (string-upcase! str3 100 130)
+ (string-downcase! str1 0 1)
+ (string-downcase! str2 10 20)
+ (string-downcase! str3 100 130)))
+
+ (with-benchmark-prefix "readers"
+
+ (benchmark "read token, method 1" 1200
+ (let ((buf (make-string 512)))
+ (let loop ((i 0))
+ (if (< i 512)
+ (begin
+ (string-set! buf i #\x)
+ (loop (+ i 1)))
+ buf))))
+
+ (benchmark "read token, method 2" 1200
+ (let ((lst '()))
+ (let loop ((i 0))
+ (set! lst (append! lst (list #\x)))
+ (if (< i 512)
+ (loop (+ i 1))
+ (list->string lst)))))))
diff --git a/check-guile.in b/check-guile.in
index 3162fa6fc..dde51b37d 100644
--- a/check-guile.in
+++ b/check-guile.in
@@ -41,7 +41,7 @@ if [ ! -f guile-procedures.txt ] ; then
fi
exec $guile \
- -e main -s "$TEST_SUITE_DIR/guile-test" \
+ --no-autocompile -e main -s "$TEST_SUITE_DIR/guile-test" \
--test-suite "$TEST_SUITE_DIR/tests" \
--log-file check-guile.log "$@"
diff --git a/configure.in b/configure.ac
index 53049eb79..8f420b555 100644
--- a/configure.in
+++ b/configure.ac
@@ -52,14 +52,6 @@ AC_CONFIG_HEADERS([config.h])
AH_TOP(/*GUILE_CONFIGURE_COPYRIGHT*/)
#--------------------------------------------------------------------
-#
-# Independent Subdirectories
-#
-#--------------------------------------------------------------------
-
-AC_CONFIG_SUBDIRS(guile-readline)
-
-#--------------------------------------------------------------------
AC_LANG([C])
@@ -827,22 +819,13 @@ fi
dnl GMP tests
-AC_LIB_LINKFLAGS(gmp)
-AC_CHECK_LIB([gmp], [__gmpz_init], ,
- [AC_MSG_ERROR([GNU MP not found, see README])])
-
-# mpz_import is a macro so we need to include <gmp.h>
-AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <gmp.h>]],
- [[mpz_import (0, 0, 0, 0, 0, 0, 0); ]])],
+AC_LIB_HAVE_LINKFLAGS(gmp,
[],
- [AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])])
+ [#include <gmp.h>],
+ [mpz_import (0, 0, 0, 0, 0, 0, 0);],
+ AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README]))
-dnl GNU libunistring tests.
-if test "x$LTLIBUNISTRING" != "x"; then
- LIBS="$LTLIBUNISTRING $LIBS"
-else
- AC_MSG_ERROR([GNU libunistring is required, please install it.])
-fi
+dnl GNU libunistring is checked for by Gnulib's `libunistring' module.
dnl i18n tests
#AC_CHECK_HEADERS([libintl.h])
@@ -1446,6 +1429,9 @@ LIBLOBJS="`echo ${LIB@&t@OBJS} | sed 's,\.[[^.]]* ,.lo ,g;s,\.[[^.]]*$,.lo,'`"
EXTRA_DOT_DOC_FILES="`echo ${LIB@&t@OBJS} | sed 's,\.[[^.]]* ,.doc ,g;s,\.[[^.]]*$,.doc,'`"
EXTRA_DOT_X_FILES="`echo ${LIB@&t@OBJS} | sed 's,\.[[^.]]* ,.x ,g;s,\.[[^.]]*$,.x,'`"
+# GNU Readline bindings.
+GUILE_READLINE
+
AC_SUBST(GUILE_MAJOR_VERSION)
AC_SUBST(GUILE_MINOR_VERSION)
AC_SUBST(GUILE_MICRO_VERSION)
@@ -1532,7 +1518,6 @@ AC_CONFIG_FILES([
lib/Makefile
benchmark-suite/Makefile
doc/Makefile
- doc/goops/Makefile
doc/r5rs/Makefile
doc/ref/Makefile
doc/tutorial/Makefile
@@ -1541,6 +1526,7 @@ AC_CONFIG_FILES([
lang/Makefile
libguile/Makefile
srfi/Makefile
+ guile-readline/Makefile
test-suite/Makefile
test-suite/standalone/Makefile
meta/Makefile
@@ -1548,13 +1534,14 @@ AC_CONFIG_FILES([
testsuite/Makefile
])
-AC_CONFIG_FILES([meta/guile-1.8.pc])
-AC_CONFIG_FILES([meta/guile-1.8-uninstalled.pc])
+AC_CONFIG_FILES([meta/guile-2.0.pc])
+AC_CONFIG_FILES([meta/guile-2.0-uninstalled.pc])
AC_CONFIG_FILES([check-guile], [chmod +x check-guile])
AC_CONFIG_FILES([benchmark-guile], [chmod +x benchmark-guile])
AC_CONFIG_FILES([meta/guile], [chmod +x meta/guile])
AC_CONFIG_FILES([meta/uninstalled-env], [chmod +x meta/uninstalled-env])
AC_CONFIG_FILES([meta/gdb-uninstalled-guile], [chmod +x meta/gdb-uninstalled-guile])
+AC_CONFIG_FILES([meta/guile-tools], [chmod +x meta/guile-tools])
AC_CONFIG_FILES([libguile/guile-snarf],
[chmod +x libguile/guile-snarf])
AC_CONFIG_FILES([libguile/guile-doc-snarf],
@@ -1567,6 +1554,7 @@ AC_CONFIG_FILES([test-suite/standalone/test-use-srfi],
[chmod +x test-suite/standalone/test-use-srfi])
AC_CONFIG_FILES([test-suite/standalone/test-fast-slot-ref],
[chmod +x test-suite/standalone/test-fast-slot-ref])
+AC_CONFIG_FILES([doc/ref/effective-version.texi])
AC_OUTPUT
diff --git a/doc/Makefile.am b/doc/Makefile.am
index 0a6b14ed5..06f55a7e3 100644
--- a/doc/Makefile.am
+++ b/doc/Makefile.am
@@ -21,7 +21,7 @@
AUTOMAKE_OPTIONS = gnu
-SUBDIRS = ref tutorial goops r5rs
+SUBDIRS = ref tutorial r5rs
dist_man1_MANS = guile.1
diff --git a/doc/README b/doc/README
index 3ecd329b4..18862a6b8 100644
--- a/doc/README
+++ b/doc/README
@@ -8,10 +8,6 @@ The documentation consists of the following manuals.
- The Guile Reference Manual (guile.texi) contains (or is intended to
contain) reference documentation on all aspects of Guile.
-- The GOOPS Manual (goops.texi) contains both tutorial-style and
- reference documentation for using GOOPS, Guile's Object Oriented
- Programming System.
-
- The Revised^5 Report on the Algorithmic Language Scheme (r5rs.texi).
Please be aware that this is all very much work in progress (apart
diff --git a/doc/goops/Makefile.am b/doc/goops/Makefile.am
deleted file mode 100644
index 49bfb29b9..000000000
--- a/doc/goops/Makefile.am
+++ /dev/null
@@ -1,29 +0,0 @@
-## Process this file with Automake to create Makefile.in
-##
-## Copyright (C) 1998, 2004, 2006, 2008 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE is free software; you can redistribute it and/or modify it
-## under the terms of the GNU Lesser General Public License as
-## published by the Free Software Foundation; either version 3, or
-## (at your option) any later version.
-##
-## GUILE is distributed in the hope that it will be useful, but
-## WITHOUT ANY WARRANTY; without even the implied warranty of
-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU Lesser General Public License for more details.
-##
-## You should have received a copy of the GNU Lesser General Public
-## License along with GUILE; see the file COPYING.LESSER. If not,
-## write to the Free Software Foundation, Inc., 51 Franklin Street,
-## Fifth Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-info_TEXINFOS = goops.texi
-
-goops_TEXINFOS = goops-tutorial.texi \
- hierarchy.eps hierarchy.png hierarchy.txt hierarchy.pdf
-
-EXTRA_DIST = ChangeLog-2008
diff --git a/doc/ref/.gitignore b/doc/ref/.gitignore
index fc69e3188..c76e2e4af 100644
--- a/doc/ref/.gitignore
+++ b/doc/ref/.gitignore
@@ -1,2 +1,3 @@
autoconf-macros.texi
lib-version.texi
+effective-version.texi
diff --git a/doc/goops/ChangeLog-2008 b/doc/ref/ChangeLog-goops-2008
index a5a637d7b..a5a637d7b 100644
--- a/doc/goops/ChangeLog-2008
+++ b/doc/ref/ChangeLog-goops-2008
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index abf42edfe..2f218a565 100644
--- a/doc/ref/Makefile.am
+++ b/doc/ref/Makefile.am
@@ -78,11 +78,20 @@ guile_TEXINFOS = preface.texi \
libguile-linking.texi \
libguile-extensions.texi \
api-init.texi \
- mod-getopt-long.texi
+ mod-getopt-long.texi \
+ goops.texi \
+ goops-tutorial.texi \
+ effective-version.texi
ETAGS_ARGS = $(info_TEXINFOS) $(guile_TEXINFOS)
-EXTRA_DIST = ChangeLog-2008
+PICTURES = hierarchy.eps \
+ hierarchy.pdf \
+ hierarchy.png \
+ hierarchy.txt \
+ mop.text
+
+EXTRA_DIST = ChangeLog-2008 $(PICTURES)
include $(top_srcdir)/am/pre-inst-guile
diff --git a/doc/ref/api-binding.texi b/doc/ref/api-binding.texi
index b42f5567f..e53c48040 100644
--- a/doc/ref/api-binding.texi
+++ b/doc/ref/api-binding.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.
@@ -271,10 +271,16 @@ with duplicate bindings.
Guile provides a procedure for checking whether a symbol is bound in the
top level environment.
-@c NJFIXME explain [env]
-@deffn {Scheme Procedure} defined? sym [env]
-@deffnx {C Function} scm_defined_p (sym, env)
-Return @code{#t} if @var{sym} is defined in the lexical environment @var{env}. When @var{env} is not specified, look in the top-level environment as defined by the current module.
+@deffn {Scheme Procedure} defined? sym [module]
+@deffnx {C Function} scm_defined_p (sym, module)
+Return @code{#t} if @var{sym} is defined in the module @var{module} or
+the current module when @var{module} is not specified; otherwise return
+@code{#f}.
+
+Up to Guile 1.8, the second optional argument had to be @dfn{lexical
+environment} as returned by @code{the-environment}, for example. The
+behavior of this function remains unchanged when the second argument is
+omitted.
@end deffn
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 7eccb8690..059390bb8 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1344,9 +1344,9 @@ otherwise.
@deftypefn {C Function} SCM scm_take_u8vector (const scm_t_uint8 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_s8vector (const scm_t_int8 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_u16vector (const scm_t_uint16 *data, size_t len)
-@deftypefnx {C Function} SCM scm_take_s168vector (const scm_t_int16 *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_s16vector (const scm_t_int16 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_u32vector (const scm_t_uint32 *data, size_t len)
-@deftypefnx {C Function} SCM scm_take_s328vector (const scm_t_int32 *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_s32vector (const scm_t_int32 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_u64vector (const scm_t_uint64 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_s64vector (const scm_t_int64 *data, size_t len)
@deftypefnx {C Function} SCM scm_take_f32vector (const float *data, size_t len)
@@ -2001,13 +2001,24 @@ enclosed array is unspecified.
For example,
@lisp
-(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1)
+(enclose-array '#3(((a b c)
+ (d e f))
+ ((1 2 3)
+ (4 5 6)))
+ 1)
@result{}
-#<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>
-
-(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0)
+#<enclosed-array (#1(a d) #1(b e) #1(c f))
+ (#1(1 4) #1(2 5) #1(3 6))>
+
+(enclose-array '#3(((a b c)
+ (d e f))
+ ((1 2 3)
+ (4 5 6)))
+ 1 0)
@result{}
-#<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>
+#<enclosed-array #2((a 1) (d 4))
+ #2((b 2) (e 5))
+ #2((c 3) (f 6))>
@end lisp
@end deffn
@@ -3083,8 +3094,10 @@ which can be changed.
(color ball)
(owner ball)))
ball-color))
-(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
-(define (owner ball) (struct-ref ball 0))
+(define (color ball)
+ (struct-ref (struct-vtable ball) vtable-offset-user))
+(define (owner ball)
+ (struct-ref ball 0))
(define red (make-ball-type 'red))
(define green (make-ball-type 'green))
@@ -3460,7 +3473,8 @@ whole is not a proper list:
(assoc "mary" '((1 . 2) ("key" . "door") . "open sesame"))
@result{}
ERROR: In procedure assoc in expression (assoc "mary" (quote #)):
-ERROR: Wrong type argument in position 2 (expecting association list): ((1 . 2) ("key" . "door") . "open sesame")
+ERROR: Wrong type argument in position 2 (expecting
+ association list): ((1 . 2) ("key" . "door") . "open sesame")
(sloppy-assoc "mary" '((1 . 2) ("key" . "door") . "open sesame"))
@result{}
@@ -3474,7 +3488,8 @@ Secondly, if one of the entries in the specified alist is not a pair:
(assoc 2 '((1 . 1) 2 (3 . 9)))
@result{}
ERROR: In procedure assoc in expression (assoc 2 (quote #)):
-ERROR: Wrong type argument in position 2 (expecting association list): ((1 . 1) 2 (3 . 9))
+ERROR: Wrong type argument in position 2 (expecting
+ association list): ((1 . 1) 2 (3 . 9))
(sloppy-assoc 2 '((1 . 1) 2 (3 . 9)))
@result{}
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index ed6411f29..e7614d136 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -22,6 +22,7 @@ flow of Scheme affects C code.
* Error Reporting:: Procedures for signaling errors.
* Dynamic Wind:: Dealing with non-local entrance/exit.
* Handling Errors:: How to handle errors in C code.
+* Continuation Barriers:: Protection from non-local control flow.
@end menu
@node begin
@@ -1501,6 +1502,33 @@ which is the name of the procedure incorrectly invoked.
@end deftypefn
+@node Continuation Barriers
+@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.
+
+@deffn {Scheme Procedure} with-continuation-barrier proc
+@deffnx {C Function} scm_with_continuation_barrier (proc)
+Call @var{proc} and return its result. Do not allow the invocation of
+continuations that would leave or enter the dynamic extent of the call
+to @code{with-continuation-barrier}. Such an attempt causes an error
+to be signaled.
+
+Throws (such as errors) that are not caught from within @var{proc} are
+caught by @code{with-continuation-barrier}. In that case, a short
+message is printed to the current error port and @code{#f} is returned.
+
+Thus, @code{with-continuation-barrier} returns exactly once.
+@end deffn
+
+@deftypefn {C Function} {void *} scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
+Like @code{scm_with_continuation_barrier} but call @var{func} on
+@var{data}. When an error is caught, @code{NULL} is returned.
+@end deftypefn
+
+
@c Local Variables:
@c TeX-master: "guile.texi"
@c End:
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 6e1a67ae1..0fd4ee1cf 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -3477,9 +3477,9 @@ allocated string.
@deffnx {C Function} scm_string_concatenate_reverse (ls, final_string, end)
Without optional arguments, this procedure is equivalent to
-@smalllisp
+@lisp
(string-concatenate (reverse ls))
-@end smalllisp
+@end lisp
If the optional argument @var{final_string} is specified, it is
consed onto the beginning to @var{ls} before performing the
@@ -3535,11 +3535,12 @@ For example, to change characters to alternately upper and lower case,
@example
(define str (string-copy "studly"))
-(string-for-each-index (lambda (i)
- (string-set! str i
- ((if (even? i) char-upcase char-downcase)
- (string-ref str i))))
- str)
+(string-for-each-index
+ (lambda (i)
+ (string-set! str i
+ ((if (even? i) char-upcase char-downcase)
+ (string-ref str i))))
+ str)
str @result{} "StUdLy"
@end example
@end deffn
@@ -4447,7 +4448,8 @@ Or matching a @sc{yyyymmdd} format date such as @samp{20020828} and
re-ordering and hyphenating the fields.
@lisp
-(define date-regex "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")
+(define date-regex
+ "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")
(define s "Date 20020429 12am.")
(regexp-substitute #f (string-match date-regex s)
'pre 2 "-" 3 "-" 1 'post " (" 0 ")")
@@ -4507,7 +4509,8 @@ example the following is the date example from
@code{string-match} call.
@lisp
-(define date-regex "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")
+(define date-regex
+ "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")
(define s "Date 20020429 12am.")
(regexp-substitute/global #f date-regex s
'pre 2 "-" 3 "-" 1 'post " (" 0 ")")
@@ -5502,7 +5505,7 @@ the @code{read-set!} procedure documented in @ref{User level options
interfaces} and @ref{Reader options}. Note that the @code{prefix} and
@code{postfix} syntax are mutually exclusive.
-@smalllisp
+@lisp
(read-set! keywords 'prefix)
#:type
@@ -5534,7 +5537,7 @@ type:
ERROR: In expression :type:
ERROR: Unbound variable: :type
ABORT: (unbound-variable)
-@end smalllisp
+@end lisp
@node Keyword Procedures
@subsubsection Keyword Procedures
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 78863665d..42e0676a6 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -283,9 +283,9 @@ runs a script non-interactively.
The following procedures can be used to access and set the source
properties of read expressions.
-@deffn {Scheme Procedure} set-source-properties! obj plist
-@deffnx {C Function} scm_set_source_properties_x (obj, plist)
-Install the association list @var{plist} as the source property
+@deffn {Scheme Procedure} set-source-properties! obj alist
+@deffnx {C Function} scm_set_source_properties_x (obj, alist)
+Install the association list @var{alist} as the source property
list for @var{obj}.
@end deffn
@@ -302,12 +302,12 @@ Return the source property association list of @var{obj}.
@deffn {Scheme Procedure} source-property obj key
@deffnx {C Function} scm_source_property (obj, key)
-Return the source property specified by @var{key} from
-@var{obj}'s source property list.
+Return the property specified by @var{key} from @var{obj}'s source
+properties.
@end deffn
In practice there are only two ways that you should use the ability to
-set an expression's source breakpoints.
+set an expression's source properties.
@itemize
@item
@@ -330,9 +330,9 @@ involved in a backtrace or error report.
If you are looking for a way to attach arbitrary information to an
expression other than these properties, you should use
-@code{make-object-property} instead (@pxref{Object Properties}), because
-that will avoid bloating the source property hash table, which is really
-only intended for the specific purposes described in this section.
+@code{make-object-property} instead (@pxref{Object Properties}). That
+will avoid bloating the source property hash table, which is really
+only intended for the debugging purposes just described.
@node Decoding Memoized Source Expressions
@@ -1732,16 +1732,16 @@ Frame 2 at matrix.scm:8:3
[mkmatrix]
debug> next
Frame 3 at matrix.scm:4:3
- (let ((x 1)) (quote this-is-a-matric))
+ (let ((x 1)) (quote hi!))
debug> info frame
Stack frame: 3
This frame is an evaluation.
The expression being evaluated is:
matrix.scm:4:3:
- (let ((x 1)) (quote this-is-a-matric))
+ (let ((x 1)) (quote hi!))
debug> next
Frame 3 at matrix.scm:5:21
- (quote this-is-a-matric)
+ (quote hi!)
debug> bt
In unknown file:
?: 0* [primitive-eval (do-main 4)]
@@ -1750,9 +1750,9 @@ In standard input:
In matrix.scm:
8: 2 [mkmatrix]
...
- 5: 3 (quote this-is-a-matric)
+ 5: 3 (quote hi!)
debug> quit
-this-is-a-matric
+hi!
guile>
@end lisp
@@ -1813,7 +1813,7 @@ guile> (do-main 4)
| 5: (memq sym bindings)
| 5: [memq let (debug)]
| 5: =>#f
-| 2: (letrec ((yy 23)) (let ((x 1)) (quote this-is-a-matric)))
+| 2: (letrec ((yy 23)) (let ((x 1)) (quote hi!)))
| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
| 4: (and (memq sym bindings) (let ...))
@@ -1832,7 +1832,7 @@ guile> (do-main 4)
| 5: (memq sym bindings)
| 5: [memq let (debug)]
| 5: =>#f
-| 2: (let ((x 1)) (quote this-is-a-matric))
+| 2: (let ((x 1)) (quote hi!))
| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
| 4: (and (memq sym bindings) (let ...))
@@ -1841,15 +1841,15 @@ guile> (do-main 4)
| 5: =>#f
| 2: [let (let # #) (# # #)]
| 2: [let (let # #) (# # #)]
-| 2: =>(#@@let* (x 1) #@@let (quote this-is-a-matric))
-this-is-a-matric
+| 2: =>(#@@let* (x 1) #@@let (quote hi!))
+hi!
guile> (do-main 4)
| 2: [mkmatrix]
-| 2: (letrec ((yy 23)) (let* ((x 1)) (quote this-is-a-matric)))
-| 2: (let* ((x 1)) (quote this-is-a-matric))
-| 2: (quote this-is-a-matric)
-| 2: =>this-is-a-matric
-this-is-a-matric
+| 2: (letrec ((yy 23)) (let* ((x 1)) (quote hi!)))
+| 2: (let* ((x 1)) (quote hi!))
+| 2: (quote hi!)
+| 2: =>hi!
+hi!
guile>
@end lisp
@@ -1881,11 +1881,11 @@ each trace line instead of the stack depth.
guile> (set-trace-layout "|~16@@a: ~a\n" trace/source trace/info)
guile> (do-main 4)
| matrix.scm:7:2: [mkmatrix]
-| : (letrec ((yy 23)) (let* ((x 1)) (quote this-is-a-matric)))
-| matrix.scm:3:2: (let* ((x 1)) (quote this-is-a-matric))
-| matrix.scm:4:4: (quote this-is-a-matric)
-| matrix.scm:4:4: =>this-is-a-matric
-this-is-a-matric
+| : (letrec ((yy 23)) (let* ((x 1)) (quote hi!)))
+| matrix.scm:3:2: (let* ((x 1)) (quote hi!))
+| matrix.scm:4:4: (quote hi!)
+| matrix.scm:4:4: =>hi!
+hi!
guile>
@end lisp
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index b0b57412a..96cd147f3 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -424,9 +424,9 @@ the current size, but this is not mandatory in the POSIX standard.
The delimited-I/O module can be accessed with:
-@smalllisp
+@lisp
(use-modules (ice-9 rdelim))
-@end smalllisp
+@end lisp
It can be used to read or write lines of text, or read text delimited by
a specified set of characters. It's similar to the @code{(scsh rdelim)}
@@ -536,9 +536,9 @@ delimiter may be either a newline or the @var{eof-object}; if
The Block-string-I/O module can be accessed with:
-@smalllisp
+@lisp
(use-modules (ice-9 rw))
-@end smalllisp
+@end lisp
It currently contains procedures that help to implement the
@code{(scsh rw)} module in guile-scsh.
@@ -795,17 +795,17 @@ current interfaces.
@rnindex open-input-file
@deffn {Scheme Procedure} open-input-file filename
Open @var{filename} for input. Equivalent to
-@smalllisp
+@lisp
(open-file @var{filename} "r")
-@end smalllisp
+@end lisp
@end deffn
@rnindex open-output-file
@deffn {Scheme Procedure} open-output-file filename
Open @var{filename} for output. Equivalent to
-@smalllisp
+@lisp
(open-file @var{filename} "w")
-@end smalllisp
+@end lisp
@end deffn
@deffn {Scheme Procedure} call-with-input-file filename proc
diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi
index 9aeb08a44..02e260d7e 100644
--- a/doc/ref/api-modules.texi
+++ b/doc/ref/api-modules.texi
@@ -60,15 +60,15 @@ Library files in SLIB @emph{provide} a feature, and when user programs
For example, the file @file{random.scm} in the SLIB package contains the
line
-@smalllisp
+@lisp
(provide 'random)
-@end smalllisp
+@end lisp
so to use its procedures, a user would type
-@smalllisp
+@lisp
(require 'random)
-@end smalllisp
+@end lisp
and they would magically become available, @emph{but still have the same
names!} So this method is nice, but not as good as a full-featured
@@ -99,9 +99,9 @@ i.e., passed as the second argument to @code{eval}.
Note: the following two procedures are available only when the
@code{(ice-9 r5rs)} module is loaded:
-@smalllisp
+@lisp
(use-modules (ice-9 r5rs))
-@end smalllisp
+@end lisp
@deffn {Scheme Procedure} scheme-report-environment version
@deffnx {Scheme Procedure} null-environment version
@@ -224,9 +224,9 @@ An @dfn{interface specification} has one of two forms. The first
variation is simply to name the module, in which case its public
interface is the one accessed. For example:
-@smalllisp
+@lisp
(use-modules (ice-9 popen))
-@end smalllisp
+@end lisp
Here, the interface specification is @code{(ice-9 popen)}, and the
result is that the current module now has access to @code{open-pipe},
@@ -241,11 +241,11 @@ module to be accessed, but also selects bindings from it and renames
them to suit the current module's needs. For example:
@cindex binding renamer
-@smalllisp
+@lisp
(use-modules ((ice-9 popen)
- :select ((open-pipe . pipe-open) close-pipe)
- :renamer (symbol-prefix-proc 'unixy:)))
-@end smalllisp
+ #:select ((open-pipe . pipe-open) close-pipe)
+ #:renamer (symbol-prefix-proc 'unixy:)))
+@end lisp
Here, the interface specification is more complex than before, and the
result is that a custom interface with only two bindings is created and
@@ -270,10 +270,10 @@ You can also directly refer to bindings in a module by using the
open-pipe)}. Thus an alternative to the complete @code{use-modules}
statement would be
-@smalllisp
+@lisp
(define unixy:pipe-open (@@ (ice-9 popen) open-pipe))
(define unixy:close-pipe (@@ (ice-9 popen) close-pipe))
-@end smalllisp
+@end lisp
There is also @code{@@@@}, which can be used like @code{@@}, but does
not check whether the variable that is being accessed is actually
@@ -307,9 +307,9 @@ whose public interface is found and used.
@var{spec} can also be of the form:
@cindex binding renamer
-@smalllisp
+@lisp
(MODULE-NAME [:select SELECTION] [:renamer RENAMER])
-@end smalllisp
+@end lisp
in which case a custom interface is newly created and used.
@var{module-name} is a list of symbols, as above; @var{selection} is a
@@ -373,9 +373,9 @@ by using @code{define-public} or @code{export} (both documented below).
@var{module-name} is of the form @code{(hierarchy file)}. One
example of this is
-@smalllisp
+@lisp
(define-module (ice-9 popen))
-@end smalllisp
+@end lisp
@code{define-module} makes this module available to Guile programs under
the given @var{module-name}.
@@ -541,9 +541,9 @@ duplication to the next handler in @var{list}.
The default duplicate binding resolution policy is given by the
@code{default-duplicate-binding-handler} procedure, and is
-@smalllisp
+@lisp
(replace warn-override-core warn last)
-@end smalllisp
+@end lisp
@item #:no-backtrace
@cindex no backtrace
@@ -1138,12 +1138,12 @@ gcc -shared -o libbessel.so -fPIC bessel.c
Now fire up Guile:
-@smalllisp
+@lisp
(define bessel-lib (dynamic-link "./libbessel.so"))
(dynamic-call "init_math_bessel" bessel-lib)
(j0 2)
@result{} 0.223890779141236
-@end smalllisp
+@end lisp
The filename @file{./libbessel.so} should be pointing to the shared
library produced with the @code{gcc} command above, of course. The
diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi
index 20e32c51c..f7d0962df 100644
--- a/doc/ref/api-options.texi
+++ b/doc/ref/api-options.texi
@@ -82,10 +82,11 @@ general are stored. On Unix-like systems, this is usually
@deffnx {C Function} scm_sys_library_dir ()
Return the name of the directory where the Guile Scheme files that
belong to the core Guile installation (as opposed to files from a 3rd
-party package) are installed. On Unix-like systems, this is usually
+party package) are installed. On Unix-like systems this is usually
@file{/usr/local/share/guile/<GUILE_EFFECTIVE_VERSION>} or
-@file{/usr/share/guile/<GUILE_EFFECTIVE_VERSION>}, for example:
-@file{/usr/local/share/guile/1.6}.
+@file{/usr/share/guile/<GUILE_EFFECTIVE_VERSION>};
+
+@noindent for example @file{/usr/local/share/guile/1.6}.
@end deffn
@deffn {Scheme Procedure} %site-dir
@@ -503,9 +504,9 @@ Guile is case-sensitive by default.
To make Guile case insensitive, you can type
-@smalllisp
+@lisp
(read-enable 'case-insensitive)
-@end smalllisp
+@end lisp
@node Printing options
@subsubsection Printing options
@@ -680,7 +681,8 @@ the maximum stack size, use @code{debug-set!}, for example:
@lisp
(debug-set! stack 200000)
@result{}
-(show-file-name #t stack 200000 debug backtrace depth 20 maxdepth 1000 frames 3 indent 10 width 79 procnames cheap)
+(show-file-name #t stack 200000 debug backtrace depth 20
+ maxdepth 1000 frames 3 indent 10 width 79 procnames cheap)
(non-tail-recursive-factorial 500)
@result{}
@@ -717,7 +719,6 @@ backtrace. Need to give a better example, possibly putting debugging
option examples in a separate session.]
@end enumerate
-
@smalllisp
guile> (define abc "hello")
guile> abc
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index 3b622868c..521369619 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -8,14 +8,9 @@
@node Scheduling
@section Threads, Mutexes, Asyncs and Dynamic Roots
-[FIXME: This is pasted in from Tom Lord's original guile.texi chapter
-plus the Cygnus programmer's manual; it should be *very* carefully
-reviewed and largely reorganized.]
-
@menu
* Arbiters:: Synchronization primitives.
* Asyncs:: Asynchronous procedure invocation.
-* Continuation Barriers:: Protection from non-local control flow.
* Threads:: Multiple threads of execution.
* Mutexes and Condition Variables:: Synchronization primitives.
* Blocking:: How to block properly in guile mode.
@@ -47,7 +42,6 @@ process synchronization.
@deffn {Scheme Procedure} try-arbiter arb
@deffnx {C Function} scm_try_arbiter (arb)
-@deffnx {C Function} scm_try_arbiter (arb)
If @var{arb} is unlocked, then lock it and return @code{#t}.
If @var{arb} is already locked, then do nothing and return
@code{#f}.
@@ -70,7 +64,7 @@ release it, but that's not required, any thread can release it.
@cindex user asyncs
@cindex system asyncs
-Asyncs are a means of deferring the excution of Scheme code until it is
+Asyncs are a means of deferring the execution of Scheme code until it is
safe to do so.
Guile provides two kinds of asyncs that share the basic concept but are
@@ -132,43 +126,42 @@ This procedure is not safe to be called from signal handlers. Use
signal handlers.
@end deffn
-@c FIXME: The use of @deffnx for scm_c_call_with_blocked_asyncs and
-@c scm_c_call_with_unblocked_asyncs puts "void" into the function
-@c index. Would prefer to use @deftypefnx if makeinfo allowed that,
-@c or a @deftypefn with an empty return type argument if it didn't
-@c introduce an extra space.
-
@deffn {Scheme Procedure} call-with-blocked-asyncs proc
@deffnx {C Function} scm_call_with_blocked_asyncs (proc)
-@deffnx {C Function} {void *} scm_c_call_with_blocked_asyncs (void * (*proc) (void *data), void *data)
-@findex scm_c_call_with_blocked_asyncs
Call @var{proc} and block the execution of system asyncs by one level
for the current thread while it is running. Return the value returned
by @var{proc}. For the first two variants, call @var{proc} with no
arguments; for the third, call it with @var{data}.
@end deffn
+@deftypefn {C Function} {void *} scm_c_call_with_blocked_asyncs (void * (*proc) (void *data), void *data)
+The same but with a C function @var{proc} instead of a Scheme thunk.
+@end deftypefn
+
@deffn {Scheme Procedure} call-with-unblocked-asyncs proc
@deffnx {C Function} scm_call_with_unblocked_asyncs (proc)
-@deffnx {C Function} {void *} scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d)
-@findex scm_c_call_with_unblocked_asyncs
Call @var{proc} and unblock the execution of system asyncs by one
level for the current thread while it is running. Return the value
returned by @var{proc}. For the first two variants, call @var{proc}
with no arguments; for the third, call it with @var{data}.
@end deffn
+@deftypefn {C Function} {void *} scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data)
+The same but with a C function @var{proc} instead of a Scheme thunk.
+@end deftypefn
+
@deftypefn {C Function} void scm_dynwind_block_asyncs ()
-This function must be used inside a pair of calls to
+During the current dynwind context, increase the blocking of asyncs by
+one level. This function must be used inside a pair of calls to
@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic
-Wind}). During the dynwind context, asyncs are blocked by one level.
+Wind}).
@end deftypefn
@deftypefn {C Function} void scm_dynwind_unblock_asyncs ()
-This function must be used inside a pair of calls to
+During the current dynwind context, decrease the blocking of asyncs by
+one level. This function must be used inside a pair of calls to
@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic
-Wind}). During the dynwind context, asyncs are unblocked by one
-level.
+Wind}).
@end deftypefn
@node User asyncs
@@ -197,32 +190,6 @@ Mark the user async @var{a} for future execution.
Execute all thunks from the marked asyncs of the list @var{list_of_a}.
@end deffn
-@node Continuation Barriers
-@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.
-
-@deffn {Scheme Procedure} with-continuation-barrier proc
-@deffnx {C Function} scm_with_continuation_barrier (proc)
-Call @var{proc} and return its result. Do not allow the invocation of
-continuations that would leave or enter the dynamic extent of the call
-to @code{with-continuation-barrier}. Such an attempt causes an error
-to be signaled.
-
-Throws (such as errors) that are not caught from within @var{proc} are
-caught by @code{with-continuation-barrier}. In that case, a short
-message is printed to the current error port and @code{#f} is returned.
-
-Thus, @code{with-continuation-barrier} returns exactly once.
-@end deffn
-
-@deftypefn {C Function} {void *} scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
-Like @code{scm_with_continuation_barrier} but call @var{func} on
-@var{data}. When an error is caught, @code{NULL} is returned.
-@end deftypefn
-
@node Threads
@subsection Threads
@cindex threads
diff --git a/doc/ref/autoconf.texi b/doc/ref/autoconf.texi
index 83686dada..ae807c276 100644
--- a/doc/ref/autoconf.texi
+++ b/doc/ref/autoconf.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.
@@ -48,19 +48,18 @@ checks.
@cindex pkg-config
@cindex autoconf
-GNU Guile provides a @dfn{pkg-config} description file, installed as
-@file{@var{prefix}/lib/pkgconfig/guile-1.8.pc}, which contains all the
-information necessary to compile and link C applications that use Guile.
-The @code{pkg-config} program is able to read this file and provide this
-information to application programmers; it can be obtained at
-@url{http://pkg-config.freedesktop.org/}.
+GNU Guile provides a @dfn{pkg-config} description file, which contains
+all the information necessary to compile and link C applications that
+use Guile. The @code{pkg-config} program is able to read this file
+and provide this information to application programmers; it can be
+obtained at @url{http://pkg-config.freedesktop.org/}.
The following command lines give respectively the C compilation and link
flags needed to build Guile-using programs:
@example
-pkg-config guile-1.8 --cflags
-pkg-config guile-1.8 --libs
+pkg-config guile-@value{EFFECTIVE-VERSION} --cflags
+pkg-config guile-@value{EFFECTIVE-VERSION} --libs
@end example
To ease use of pkg-config with Autoconf, pkg-config comes with a
@@ -71,7 +70,7 @@ accordingly, or prints an error and exits if Guile was not found:
@findex PKG_CHECK_MODULES
@example
-PKG_CHECK_MODULES([GUILE], [guile-1.8])
+PKG_CHECK_MODULES([GUILE], [guile-@value{EFFECTIVE-VERSION}])
@end example
Guile comes with additional Autoconf macros providing more information,
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index f8d0895d9..d749fc1f3 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -17,7 +17,7 @@ This section aims to pay attention to the small man behind the
curtain.
@xref{Read/Load/Eval/Compile}, if you're lost and you just wanted to
-know how to compile your .scm file.
+know how to compile your @code{.scm} file.
@menu
* Compiler Tower::
@@ -67,8 +67,7 @@ for Scheme:
#:title "Guile Scheme"
#:version "0.5"
#:reader read
- #:compilers `((tree-il . ,compile-tree-il)
- (ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il))
#:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write)
@@ -220,13 +219,13 @@ Note however that @code{sc-expand} does not have the same signature as
around @code{sc-expand}, to make it conform to the general form of
compiler procedures in Guile's language tower.
-Compiler procedures take two arguments, an expression and an
-environment. They return three values: the compiled expression, the
-corresponding environment for the target language, and a
-``continuation environment''. The compiled expression and environment
-will serve as input to the next language's compiler. The
-``continuation environment'' can be used to compile another expression
-from the same source language within the same module.
+Compiler procedures take three arguments: an expression, an
+environment, and a keyword list of options. They return three values:
+the compiled expression, the corresponding environment for the target
+language, and a ``continuation environment''. The compiled expression
+and environment will serve as input to the next language's compiler.
+The ``continuation environment'' can be used to compile another
+expression from the same source language within the same module.
For example, you might compile the expression, @code{(define-module
(foo))}. This will result in a Tree-IL expression and environment. But
@@ -292,6 +291,14 @@ tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10))
The @code{src} fields are left out of the external representation.
+One may create Tree-IL objects from their external representations via
+calling @code{parse-tree-il}, the reader for Tree-IL. If any source
+information is attached to the input S-expression, it will be
+propagated to the resulting Tree-IL expressions. This is probably the
+easiest way to compile to Tree-IL: just make the appropriate external
+representations in S-expression format, and let @code{parse-tree-il}
+take care of the rest.
+
@deftp {Scheme Variable} <void> src
@deftpx {External Representation} (void)
An empty expression. In practice, equivalent to Scheme's @code{(if #f
@@ -384,12 +391,29 @@ A version of @code{<let>} that creates recursive bindings, like
Scheme's @code{letrec}.
@end deftp
-@c FIXME -- need to revive this one
-@c @deftp {Scheme Variable} <ghil-mv-bind> src vars rest producer . body
-@c Like Scheme's @code{receive} -- binds the values returned by
-@c applying @code{producer}, which should be a thunk, to the
-@c @code{lambda}-like bindings described by @var{vars} and @var{rest}.
-@c @end deftp
+There are two Tree-IL constructs that are not normally produced by
+higher-level compilers, but instead are generated during the
+source-to-source optimization and analysis passes that the Tree-IL
+compiler does. Users should not generate these expressions directly,
+unless they feel very clever, as the default analysis pass will
+generate them as necessary.
+
+@deftp {Scheme Variable} <let-values> src names vars exp body
+@deftpx {External Representation} (let-values @var{names} @var{vars} @var{exp} @var{body})
+Like Scheme's @code{receive} -- binds the values returned by
+evaluating @code{exp} to the @code{lambda}-like bindings described by
+@var{vars}. That is to say, @var{vars} may be an improper list.
+
+@code{<let-values>} is an optimization of @code{<application>} of the
+primitive, @code{call-with-values}.
+@end deftp
+@deftp {Scheme Variable} <fix> src names vars vals body
+@deftpx {External Representation} (fix @var{names} @var{vars} @var{vals} @var{body})
+Like @code{<letrec>}, but only for @var{vals} that are unset
+@code{lambda} expressions.
+
+@code{fix} is an optimization of @code{letrec} (and @code{let}).
+@end deftp
Tree-IL implements a compiler to GLIL that recursively traverses
Tree-IL expressions, writing out GLIL expressions into a linear list.
@@ -399,9 +423,9 @@ future computations. This state allows the compiler not to emit code
for constant expressions that will not be used (e.g. docstrings), and
to perform tail calls when in tail position.
-In the future, there will be a pass at the beginning of the
-Tree-IL->GLIL compilation step to perform inlining, copy propagation,
-dead code elimination, and constant folding.
+Most optimization, such as it currently is, is performed on Tree-IL
+expressions as source-to-source transformations. There will be more
+optimizations added in the future.
Interested readers are encouraged to read the implementation in
@code{(language tree-il compile-glil)} for more details.
@@ -411,18 +435,16 @@ Interested readers are encouraged to read the implementation in
Guile Low Intermediate Language (GLIL) is a structured intermediate
language whose expressions more closely approximate Guile's VM
-instruction set.
+instruction set. Its expression types are defined in @code{(language
+glil)}.
-Its expression types are defined in @code{(language glil)}, and as
-with GHIL, some of its fields parse as rest arguments.
-
-@deftp {Scheme Variable} <glil-program> nargs nrest nlocs nexts meta . body
+@deftp {Scheme Variable} <glil-program> nargs nrest nlocs meta . body
A unit of code that at run-time will correspond to a compiled
-procedure. @var{nargs} @var{nrest} @var{nlocs}, and @var{nexts}
-collectively define the program's arity; see @ref{Compiled
-Procedures}, for more information. @var{meta} should be an alist of
-properties, as in Tree IL's @code{<lambda>}. @var{body} is a list of
-GLIL expressions.
+procedure. @var{nargs} @var{nrest} and @var{nlocs} collectively define
+the program's arity; see @ref{Compiled Procedures}, for more
+information. @var{meta} should be an alist of properties, as in
+Tree-IL's @code{<lambda>}. @var{body} is an ordered list of GLIL
+expressions.
@end deftp
@deftp {Scheme Variable} <glil-bind> . vars
An advisory expression that notes a liveness extent for a set of
@@ -461,23 +483,21 @@ and @code{filename} keys, e.g. as returned by
@code{source-properties}.
@end deftp
@deftp {Scheme Variable} <glil-void>
-Pushes the unspecified value on the stack.
+Pushes ``the unspecified value'' on the stack.
@end deftp
@deftp {Scheme Variable} <glil-const> obj
Pushes a constant value onto the stack. @var{obj} must be a number,
-string, symbol, keyword, boolean, character, the empty list, or a pair
-or vector of constants.
-@end deftp
-@deftp {Scheme Variable} <glil-local> op index
-Accesses a lexically bound variable from the stack. If @var{op} is
-@code{ref}, the value is pushed onto the stack; if it is @code{set},
-the variable is set from the top value on the stack, which is popped
-off. @xref{Stack Layout}, for more information.
+string, symbol, keyword, boolean, character, uniform array, the empty
+list, or a pair or vector of constants.
@end deftp
-@deftp {Scheme Variable} <glil-external> op depth index
-Accesses a heap-allocated variable, addressed by @var{depth}, the nth
-enclosing environment, and @var{index}, the variable's position within
-the environment. @var{op} is @code{ref} or @code{set}.
+@deftp {Scheme Variable} <glil-lexical> local? boxed? op index
+Accesses a lexically bound variable. If the variable is not
+@var{local?} it is free. All variables may have @code{ref} and
+@code{set} as their @var{op}. Boxed variables may also have the
+@var{op}s @code{box}, @code{empty-box}, and @code{fix}, which
+correspond in semantics to the VM instructions @code{box},
+@code{empty-box}, and @code{fix-closure}. @xref{Stack Layout}, for
+more information.
@end deftp
@deftp {Scheme Variable} <glil-toplevel> op name
Accesses a toplevel variable. @var{op} may be @code{ref}, @code{set},
@@ -516,11 +536,12 @@ be wrapped in a thunk that declares the arity of the expression:
@example
scheme@@(guile-user)> ,language glil
-Guile Lowlevel Intermediate Language (GLIL) interpreter 0.3 on Guile 1.9.0
+Guile Lowlevel Intermediate Language (GLIL) interpreter 0.3 on
+ Guile 1.9.0
Copyright (C) 2001-2008 Free Software Foundation, Inc.
Enter `,help' for help.
-glil@@(guile-user)> (program 0 0 0 0 () (const 3) (call return 0))
+glil@@(guile-user)> (program 0 0 0 () (const 3) (call return 1))
@result{} 3
@end example
@@ -542,12 +563,12 @@ differs from GLIL in four main ways:
@itemize
@item Labels have been resolved to byte offsets in the program.
@item Constants inside procedures have either been expressed as inline
-instructions, and possibly cached in object arrays.
+instructions or cached in object arrays.
@item Procedures with metadata (source location information, liveness
extents, procedure names, generic properties, etc) have had their
metadata serialized out to thunks.
@item All expressions correspond directly to VM instructions -- i.e.,
-there is no @code{<glil-local>} which can be a ref or a set.
+there is no @code{<glil-lexical>} which can be a ref or a set.
@end itemize
Assembly is isomorphic to the bytecode that it compiles to. You can
@@ -567,10 +588,11 @@ example:
@example
scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly)
-(load-program 0 0 0 0
+(load-program 0 0 0
() ; Labels
- 60 ; Length
+ 70 ; Length
#f ; Metadata
+ (make-false)
(make-false) ; object table for the returned lambda
(nop)
(nop) ; Alignment. Since assembly has already resolved its labels
@@ -578,11 +600,12 @@ scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly)
(nop) ; object code is mmap'd directly to structures, assembly
(nop) ; has to have the alignment embedded in it.
(nop)
- (load-program 1 0 0 0
+ (load-program
+ 1
+ 0
()
- 6
- ; This is the metadata thunk for the returned procedure.
- (load-program 0 0 0 0 () 21 #f
+ 8
+ (load-program 0 0 0 () 21 #f
(load-symbol "x") ; Name and liveness extent for @code{x}.
(make-false)
(make-int8:0) ; Some instruction+arg combinations
@@ -597,7 +620,9 @@ scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly)
(local-ref 0)
(local-ref 0)
(add)
- (return))
+ (return)
+ (nop)
+ (nop))
; Return our new procedure.
(return))
@end example
@@ -618,10 +643,10 @@ the next step down from assembly:
@example
scheme@@(guile-user)> (compile '(+ 32 10) #:to 'assembly)
-@result{} (load-program 0 0 0 0 () 6 #f
+@result{} (load-program 0 0 0 () 6 #f
(make-int8 32) (make-int8 10) (add) (return))
scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode)
-@result{} #u8(0 0 0 0 6 0 0 0 0 0 0 0 10 32 10 10 100 48)
+@result{} #u8(0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 10 32 10 10 120 52)
@end example
``Objcode'' is bytecode, but mapped directly to a C structure,
@@ -631,8 +656,7 @@ scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode)
struct scm_objcode @{
scm_t_uint8 nargs;
scm_t_uint8 nrest;
- scm_t_uint8 nlocs;
- scm_t_uint8 nexts;
+ scm_t_uint16 nlocs;
scm_t_uint32 len;
scm_t_uint32 metalen;
scm_t_uint8 base[0];
@@ -642,7 +666,7 @@ struct scm_objcode @{
As one might imagine, objcode imposes a minimum length on the
bytecode. Also, the multibyte fields are in native endianness, which
makes objcode (and bytecode) system-dependent. Indeed, in the short
-example above, all but the last 5 bytes were the program's header.
+example above, all but the last 6 bytes were the program's header.
Objcode also has a couple of important efficiency hacks. First,
objcode may be mapped directly from disk, allowing compiled code to be
@@ -672,7 +696,7 @@ Makes a bytecode object from @var{bytecode}, which should be a
Load object code from a file named @var{file}. The file will be mapped
into memory via @code{mmap}, so this is a very fast operation.
-On disk, object code has an eight-byte cookie prepended to it, to
+On disk, object code has an sixteen-byte cookie prepended to it, to
prevent accidental loading of arbitrary garbage.
@end deffn
@@ -689,11 +713,11 @@ Copy object code out to a @code{u8vector} for analysis by Scheme.
The following procedure is actually in @code{(system vm program)}, but
we'll mention it here:
-@deffn {Scheme Variable} make-program objcode objtable [external='()]
-@deffnx {C Function} scm_make_program (objcode, objtable, external)
+@deffn {Scheme Variable} make-program objcode objtable [free-vars=#f]
+@deffnx {C Function} scm_make_program (objcode, objtable, free_vars)
Load up object code into a Scheme program. The resulting program will
have @var{objtable} as its object table, which should be a vector or
-@code{#f}, and will capture the closure variables from @var{external}.
+@code{#f}, and will capture the free variables from @var{free-vars}.
@end deffn
Object code from a file may be disassembled at the REPL via the
@@ -707,9 +731,9 @@ respect to the compilation environment. Normally the environment
propagates through the compiler transparently, but users may specify
the compilation environment manually as well:
-@deffn {Scheme Procedure} make-objcode-env module externals
+@deffn {Scheme Procedure} make-objcode-env module free-vars
Make an object code environment. @var{module} should be a Scheme
-module, and @var{externals} should be a list of external variables.
+module, and @var{free-vars} should be a vector of free variables.
@code{#f} is also a valid object code environment.
@end deffn
@@ -748,12 +772,14 @@ procedure is called a certain number of times.
The name of the game is a profiling-based harvest of the low-hanging
fruit, running programs of interest under a system-level profiler and
determining which improvements would give the most bang for the buck.
-There are many well-known efficiency hacks in the literature: Dybvig's
-letrec optimization, individual boxing of heap-allocated values (and
-then store the boxes on the stack directly), optimized case-lambda
-expressions, stack underflow and overflow handlers, etc. Highly
-recommended papers: Dybvig's HOCS, Ghuloum's compiler paper.
+It's really getting to the point though that native compilation is the
+next step.
The compiler also needs help at the top end, enhancing the Scheme that
-it knows to also understand R6RS, and adding new high-level compilers:
-Emacs Lisp, Lua, JavaScript...
+it knows to also understand R6RS, and adding new high-level compilers.
+We have JavaScript and Emacs Lisp mostly complete, but they could use
+some love; Lua would be nice as well, butq whatever language it is
+that strikes your fancy would be welcome too.
+
+Compilers are for hacking, not for admiring or for complaining about.
+Get to it!
diff --git a/doc/ref/effective-version.texi.in b/doc/ref/effective-version.texi.in
new file mode 100644
index 000000000..80b56b751
--- /dev/null
+++ b/doc/ref/effective-version.texi.in
@@ -0,0 +1 @@
+@set EFFECTIVE-VERSION @GUILE_EFFECTIVE_VERSION@
diff --git a/doc/ref/expect.texi b/doc/ref/expect.texi
index 05c766999..71e9a385b 100644
--- a/doc/ref/expect.texi
+++ b/doc/ref/expect.texi
@@ -10,9 +10,9 @@
The macros in this section are made available with:
-@smalllisp
+@lisp
(use-modules (ice-9 expect))
-@end smalllisp
+@end lisp
@code{expect} is a macro for selecting actions based on the output from
a port. The name comes from a tool of similar functionality by Don Libes.
@@ -30,14 +30,14 @@ which is matched against each of the patterns. When a
pattern matches, the remaining expression(s) in
the clause are evaluated and the value of the last is returned. For example:
-@smalllisp
+@lisp
(with-input-from-file "/etc/passwd"
(lambda ()
(expect-strings
("^nobody" (display "Got a nobody user.\n")
(display "That's no problem.\n"))
("^daemon" (display "Got a daemon user.\n")))))
-@end smalllisp
+@end lisp
The regular expression is compiled with the @code{REG_NEWLINE} flag, so
that the ^ and $ anchors will match at any newline, not just at the start
@@ -54,13 +54,13 @@ The symbol @code{=>} can be used to indicate that the expression is a
procedure which will accept the result of a successful regular expression
match. E.g.,
-@smalllisp
+@lisp
("^daemon" => write)
("^d(aemon)" => (lambda args (for-each write args)))
("^da(em)on" => (lambda (all sub)
(write all) (newline)
(write sub) (newline)))
-@end smalllisp
+@end lisp
The order of the substrings corresponds to the order in which the
opening brackets occur.
@@ -135,12 +135,12 @@ expression.
In the following example, a string will only be matched at the beginning
of the file:
-@smalllisp
+@lisp
(let ((expect-port (open-input-file "/etc/passwd")))
(expect
((lambda (s eof?) (string=? s "fnord!"))
(display "Got a nobody user!\n"))))
-@end smalllisp
+@end lisp
The control variables described for @code{expect-strings} also
influence the behaviour of @code{expect}, with the exception of
diff --git a/doc/goops/goops-tutorial.texi b/doc/ref/goops-tutorial.texi
index 11155dfae..600be7730 100644
--- a/doc/goops/goops-tutorial.texi
+++ b/doc/ref/goops-tutorial.texi
@@ -1,3 +1,9 @@
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 2008, 2009
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
@c Original attribution:
@c
@@ -24,19 +30,33 @@
@c Guile
@c @end macro
-This is chapter was originally written by Erick Gallesio as an appendix
-for the STk reference manual, and subsequently adapted to @goops{}.
+This section introduces the @goops{} package in more detail. It was
+originally written by Erick Gallesio as an appendix for the STk
+reference manual, and subsequently adapted to @goops{}.
+
+The procedures and syntax described in this tutorial are provided by
+Guile modules that may need to be imported before being available.
+The main @goops{} module is imported by evaluating:
+
+@lisp
+(use-modules (oop goops))
+@end lisp
+@findex (oop goops)
+@cindex main module
+@cindex loading
+@cindex preparing
@menu
* Copyright::
-* Intro::
-* Class definition and instantiation::
+* Class definition::
+* Instance creation and slot access::
+* Slot description::
* Inheritance::
* Generic functions::
@end menu
-@node Copyright, Intro, Tutorial, Tutorial
-@section Copyright
+@node Copyright
+@subsection Copyright
Original attribution:
@@ -52,52 +72,13 @@ required for any of the authorized uses.
This software is provided ``AS IS'' without express or implied
warranty.
-Adapted for use in Guile with the authors permission
-
-@node Intro, Class definition and instantiation, Copyright, Tutorial
-@section Introduction
-
-@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 the Gregor Kiczales @cite{Tiny-Clos}. It is very close
-to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is adapted for
-the Scheme language.
-
-Briefly stated, the @goops{} extension gives the user a full object
-oriented system with multiple inheritance and generic functions with
-multi-method dispatch. Furthermore, the implementation relies on a true
-meta object protocol, in the spirit of the one defined for CLOS
-(@cite{Gregor Kiczales: A Metaobject Protocol}).
-
-The purpose of this tutorial is to introduce briefly the @goops{}
-package and in no case will it replace the @goops{} reference manual
-(which needs to be urgently written now@ @dots{}).
+Adapted for use in Guile with the author's permission
-Note that the operations described in this tutorial resides in modules
-that may need to be imported before being available. The main module is
-imported by evaluating:
-
-@lisp
-(use-modules (oop goops))
-@end lisp
-@findex (oop goops)
-@cindex main module
-@cindex loading
-@cindex preparing
-
-@node Class definition and instantiation, Inheritance, Intro, Tutorial
-@section Class definition and instantiation
-
-@menu
-* Class definition::
-@end menu
-
-@node Class definition, , Class definition and instantiation, Class definition and instantiation
+@node Class definition
@subsection Class definition
-A new class is defined with the @code{define-class}@footnote{Don't
-forget to import the @code{(oop goops)} module} macro. The syntax of
-@code{define-class} is close to CLOS @code{defclass}:
+A new class is defined with the @code{define-class} macro. The syntax
+of @code{define-class} is close to CLOS @code{defclass}:
@findex define-class
@cindex class
@@ -107,105 +88,36 @@ forget to import the @code{(oop goops)} module} macro. The syntax of
@var{class-option} @dots{})
@end lisp
-Class options will not be discussed in this tutorial. The list of
-@var{superclass}es specifies which classes to inherit properties from
-@var{class} (see @ref{Inheritance} for more details). A
-@var{slot-description} gives the name of a slot and, eventually, some
-``properties'' of this slot (such as its initial value, the function
-which permit to access its value, @dots{}). Slot descriptions will be
-discussed in @ref{Slot description}.
+@var{class} is the class being defined. The list of
+@var{superclass}es specifies which existing classes, if any, to
+inherit slots and properties from. Each @var{slot-description} gives
+the name of a slot and optionally some ``properties'' of this slot;
+for example its initial value, the name of a function which will
+access its value, and so on. Slot descriptions and inheritance are
+discussed more below. For class options, see @ref{Class Options}.
@cindex slot
-As an example, let us define a type for representation of complex
-numbers in terms of real numbers. This can be done with the following
-class definition:
+As an example, let us define a type for representing a complex number
+in terms of two real numbers.@footnote{Of course Guile already
+provides complex numbers, and @code{<complex>} is in fact a predefined
+class in GOOPS; but the definition here is still useful as an
+example.} This can be done with the following class definition:
@lisp
-(define-class <complex> (<number>)
+(define-class <my-complex> (<number>)
r i)
@end lisp
-This binds the variable @code{<complex>}@footnote{@code{<complex>} is in
-fact a builtin class in GOOPS. Because of this, GOOPS will create a new
-class. The old class will still serve as the type for Guile's native
-complex numbers.} to a new class whose instances contain two
-slots. These slots are called @code{r} an @code{i} and we suppose here
-that they contain respectively the real part and the imaginary part of a
-complex number. Note that this class inherits from @code{<number>} which
-is a pre-defined class. (@code{<number>} is the direct super class of
-the pre-defined class @code{<complex>} which, in turn, is the super
-class of @code{<real>} which is the super of
-@code{<integer>}.)@footnote{With the new definition of @code{<complex>},
-a @code{<real>} is not a @code{<complex>} since @code{<real>} inherits
-from @code{ <number>} rather than @code{<complex>}. In practice,
-inheritance could be modified @emph{a posteriori}, if needed. However,
-this necessitates some knowledge of the meta object protocol and it will
-not be shown in this document}.
-
-@node Inheritance, Generic functions, Class definition and instantiation, Tutorial
-@section Inheritance
-@c \label{inheritance}
-
-@menu
-* Class hierarchy and inheritance of slots::
-* Instance creation and slot access::
-* Slot description::
-* Class precedence list::
-@end menu
-
-@node Class hierarchy and inheritance of slots, Instance creation and slot access, Inheritance, Inheritance
-@subsection Class hierarchy and inheritance of slots
-Inheritance is specified upon class definition. As said in the
-introduction, @goops{} supports multiple inheritance. Here are some
-class definitions:
-
-@lisp
-(define-class A () a)
-(define-class B () b)
-(define-class C () c)
-(define-class D (A B) d a)
-(define-class E (A C) e c)
-(define-class F (D E) f)
-@end lisp
-
-@code{A}, @code{B}, @code{C} have a null list of super classes. In this
-case, the system will replace it by the list which only contains
-@code{<object>}, the root of all the classes defined by
-@code{define-class}. @code{D}, @code{E}, @code{F} use multiple
-inheritance: each class inherits from two previously defined classes.
-Those class definitions define a hierarchy which is shown in Figure@ 1.
-In this figure, the class @code{<top>} is also shown; this class is the
-super class of all Scheme objects. In particular, @code{<top>} is the
-super class of all standard Scheme types.
-
-@example
-@group
-@image{hierarchy}
-@center @emph{Fig 1: A class hierarchy}
-@iftex
-@emph{(@code{<complex>} which is the direct subclass of @code{<number>}
-and the direct superclass of @code{<real>} has been omitted in this
-figure.)}
-@end iftex
-@end group
-@end example
-
-The set of slots of a given class is calculated by taking the union of the
-slots of all its super class. For instance, each instance of the class
-D, defined before will have three slots (@code{a}, @code{b} and
-@code{d}). The slots of a class can be obtained by the @code{class-slots}
-primitive. For instance,
-
-@lisp
-(class-slots A) @result{} ((a))
-(class-slots E) @result{} ((a) (e) (c))
-(class-slots F) @result{} ((e) (c) (b) (d) (a) (f))
-@c used to be ((d) (a) (b) (c) (f))
-@end lisp
-
-@emph{Note: } The order of slots is not significant.
+This binds the variable @code{<my-complex>} to a new class whose
+instances will contain two slots. These slots are called @code{r} and
+@code{i} and will hold the real and imaginary parts of a complex
+number. Note that this class inherits from @code{<number>}, which is a
+predefined class.@footnote{@code{<number>} is the direct superclass of
+the predefined class @code{<complex>}; @code{<complex>} is the
+superclass of @code{<real>}, and @code{<real>} is the superclass of
+@code{<integer>}.}
-@node Instance creation and slot access, Slot description, Class hierarchy and inheritance of slots, Inheritance
+@node Instance creation and slot access
@subsection Instance creation and slot access
Creation of an instance of a previously defined
@@ -218,16 +130,16 @@ slots of the newly created instance. For instance, the following form
@findex make
@cindex instance
@lisp
-(define c (make <complex>))
+(define c (make <my-complex>))
@end lisp
-will create a new @code{<complex>} object and will bind it to the @code{c}
+@noindent
+will create a new @code{<my-complex>} object and will bind it to the @code{c}
Scheme variable.
Accessing the slots of the new complex number can be done with the
-@code{slot-ref} and the @code{slot-set!} primitives. @code{Slot-set!}
-primitive permits to set the value of an object slot and @code{slot-ref}
-permits to get its value.
+@code{slot-ref} and the @code{slot-set!} primitives. @code{slot-set!}
+sets the value of an object slot and @code{slot-ref} retrieves it.
@findex slot-set!
@findex slot-ref
@@ -250,52 +162,60 @@ First load the module @code{(oop goops describe)}:
@code{(use-modules (oop goops describe))}
@end example
-The expression
+@noindent
+Then the expression
-@smalllisp
+@lisp
(describe c)
-@end smalllisp
+@end lisp
-will now print the following information on the standard output:
+@noindent
+will print the following information on the standard output:
-@lisp
-#<<complex> 401d8638> is an instance of class <complex>
+@smalllisp
+#<<my-complex> 401d8638> is an instance of class <my-complex>
Slots are:
r = 10
i = 3
-@end lisp
+@end smalllisp
-@node Slot description, Class precedence list, Instance creation and slot access, Inheritance
+@node Slot description
@subsection Slot description
@c \label{slot-description}
-When specifying a slot, a set of options can be given to the
-system. Each option is specified with a keyword. The list of authorized
-keywords is given below:
+When specifying a slot (in a @code{(define-class @dots{})} form),
+various options can be specified in addition to the slot's name. Each
+option is specified by a keyword. The list of authorized keywords is
+given below:
@cindex keyword
@itemize @bullet
@item
-@code{#:init-value} permits to supply a default value for the slot. This
-default value is obtained by evaluating the form given after the
-@code{#:init-form} in the global environment, at class definition time.
+@code{#:init-value} permits to supply a constant default value for the
+slot. The value is obtained by evaluating the form given after the
+@code{#:init-value} at class definition time.
@cindex default slot value
@findex #:init-value
-@cindex top level environment
+
+@item
+@code{#:init-form} specifies a form that, when evaluated, will return
+an initial value for the slot. The form is evaluated each time that
+an instance of the class is created, in the lexical environment of the
+containing @code{define-class} expression.
+@cindex default slot value
+@findex #:init-form
@item
@code{#:init-thunk} permits to supply a thunk that will provide a
-default value for the slot. The value is obtained by evaluating the
-thunk a instance creation time.
-@c CHECKME: in the global environment?
+default value for the slot. The value is obtained by invoking the
+thunk at instance creation time.
@findex default slot value
@findex #:init-thunk
-@cindex top level environment
@item
-@code{#:init-keyword} permits to specify the keyword for initializing a
-slot. The init-keyword may be provided during instance creation (i.e. in
-the @code{make} optional parameter list). Specifying such a keyword
+@code{#:init-keyword} permits to specify a keyword for initializing the
+slot. The init-keyword may be provided during instance creation (i.e. in
+the @code{make} optional parameter list). Specifying such a keyword
during instance initialization will supersede the default slot
initialization possibly given with @code{#:init-form}.
@findex #:init-keyword
@@ -361,11 +281,11 @@ and @code{#:slot-set!} options. See the example below.
@end itemize
@end itemize
-To illustrate slot description, we shall redefine the @code{<complex>} class
+To illustrate slot description, we shall redefine the @code{<my-complex>} class
seen before. A definition could be:
@lisp
-(define-class <complex> (<number>)
+(define-class <my-complex> (<number>)
(r #:init-value 0 #:getter get-r #:setter set-r! #:init-keyword #:r)
(i #:init-value 0 #:getter get-i #:setter set-i! #:init-keyword #:i))
@end lisp
@@ -378,11 +298,11 @@ functions @code{get-r} and @code{set-r!} (resp. @code{get-i} and
the @code{r} (resp. @code{i}) slot.
@lisp
-(define c1 (make <complex> #:r 1 #:i 2))
+(define c1 (make <my-complex> #:r 1 #:i 2))
(get-r c1) @result{} 1
(set-r! c1 12)
(get-r c1) @result{} 12
-(define c2 (make <complex> #:r 2))
+(define c2 (make <my-complex> #:r 2))
(get-r c2) @result{} 2
(get-i c2) @result{} 0
@end lisp
@@ -390,12 +310,12 @@ the @code{r} (resp. @code{i}) slot.
Accessors provide an uniform access for reading and writing an object
slot. Writing a slot is done with an extended form of @code{set!}
which is close to the Common Lisp @code{setf} macro. So, another
-definition of the previous @code{<complex>} class, using the
+definition of the previous @code{<my-complex>} class, using the
@code{#:accessor} option, could be:
@findex set!
@lisp
-(define-class <complex> (<number>)
+(define-class <my-complex> (<number>)
(r #:init-value 0 #:accessor real-part #:init-keyword #:r)
(i #:init-value 0 #:accessor imag-part #:init-keyword #:i))
@end lisp
@@ -416,13 +336,13 @@ coordinates as well as with polar coordinates. One solution could be to
have a definition of complex numbers which uses one particular
representation and some conversion functions to pass from one
representation to the other. A better solution uses virtual slots. A
-complete definition of the @code{<complex>} class using virtual slots is
+complete definition of the @code{<my-complex>} class using virtual slots is
given in Figure@ 2.
@example
@group
@lisp
-(define-class <complex> (<number>)
+(define-class <my-complex> (<number>)
;; True slots use rectangular coordinates
(r #:init-value 0 #:accessor real-part #:init-keyword #:r)
(i #:init-value 0 #:accessor imag-part #:init-keyword #:i)
@@ -446,7 +366,7 @@ given in Figure@ 2.
(slot-set! o 'i (* m (sin a)))))))
@end lisp
-@center @emph{Fig 2: A @code{<complex>} number class definition using virtual slots}
+@center @emph{Fig 2: A @code{<my-complex>} number class definition using virtual slots}
@end group
@end example
@@ -480,20 +400,21 @@ A more complete example is given below:
@example
@group
-@lisp
-(define c (make <complex> #:r 12 #:i 20))
+@smalllisp
+(define c (make <my-complex> #:r 12 #:i 20))
(real-part c) @result{} 12
(angle c) @result{} 1.03037682652431
(slot-set! c 'i 10)
(set! (real-part c) 1)
-(describe c) @result{}
- #<<complex> 401e9b58> is an instance of class <complex>
- Slots are:
- r = 1
- i = 10
- m = 10.0498756211209
- a = 1.47112767430373
-@end lisp
+(describe c)
+@print{}
+#<<my-complex> 401e9b58> is an instance of class <my-complex>
+Slots are:
+ r = 1
+ i = 10
+ m = 10.0498756211209
+ a = 1.47112767430373
+@end smalllisp
@end group
@end example
@@ -503,14 +424,75 @@ Scheme primitives.
@lisp
(define make-rectangular
- (lambda (x y) (make <complex> #:r x #:i y)))
+ (lambda (x y) (make <my-complex> #:r x #:i y)))
(define make-polar
- (lambda (x y) (make <complex> #:magn x #:angle y)))
+ (lambda (x y) (make <my-complex> #:magn x #:angle y)))
+@end lisp
+
+@node Inheritance
+@subsection Inheritance
+@c \label{inheritance}
+
+@menu
+* Class hierarchy and inheritance of slots::
+* Class precedence list::
+@end menu
+
+@node Class hierarchy and inheritance of slots
+@subsubsection Class hierarchy and inheritance of slots
+Inheritance is specified upon class definition. As said in the
+introduction, @goops{} supports multiple inheritance. Here are some
+class definitions:
+
+@lisp
+(define-class A () a)
+(define-class B () b)
+(define-class C () c)
+(define-class D (A B) d a)
+(define-class E (A C) e c)
+(define-class F (D E) f)
@end lisp
-@node Class precedence list, , Slot description, Inheritance
-@subsection Class precedence list
+@code{A}, @code{B}, @code{C} have a null list of super classes. In this
+case, the system will replace it by the list which only contains
+@code{<object>}, the root of all the classes defined by
+@code{define-class}. @code{D}, @code{E}, @code{F} use multiple
+inheritance: each class inherits from two previously defined classes.
+Those class definitions define a hierarchy which is shown in Figure@ 1.
+In this figure, the class @code{<top>} is also shown; this class is the
+super class of all Scheme objects. In particular, @code{<top>} is the
+super class of all standard Scheme types.
+
+@example
+@group
+@image{hierarchy}
+@center @emph{Fig 1: A class hierarchy}
+@iftex
+@emph{(@code{<complex>} which is the direct subclass of @code{<number>}
+and the direct superclass of @code{<real>} has been omitted in this
+figure.)}
+@end iftex
+@end group
+@end example
+
+The set of slots of a given class is calculated by taking the union of the
+slots of all its super class. For instance, each instance of the class
+D, defined before will have three slots (@code{a}, @code{b} and
+@code{d}). The slots of a class can be obtained by the @code{class-slots}
+primitive. For instance,
+
+@lisp
+(class-slots A) @result{} ((a))
+(class-slots E) @result{} ((a) (e) (c))
+(class-slots F) @result{} ((e) (c) (b) (d) (a) (f))
+@c used to be ((d) (a) (b) (c) (f))
+@end lisp
+
+@emph{Note: } The order of slots is not significant.
+
+@node Class precedence list
+@subsubsection Class precedence list
A class may have more than one superclass. @footnote{This section is an
adaptation of Jeff Dalton's (J.Dalton@@ed.ac.uk) @cite{Brief
@@ -587,8 +569,8 @@ However, this result is not too much readable; using the function
(map class-name (class-precedence-list B)) @result{} (B <object> <top>)
@end lisp
-@node Generic functions, , Inheritance, Tutorial
-@section Generic functions
+@node Generic functions
+@subsection Generic functions
@menu
* Generic functions and methods::
@@ -596,8 +578,8 @@ However, this result is not too much readable; using the function
* Example::
@end menu
-@node Generic functions and methods, Next-method, Generic functions, Generic functions
-@subsection Generic functions and methods
+@node Generic functions and methods
+@subsubsection Generic functions and methods
@c \label{gf-n-methods}
Neither @goops{} nor CLOS use the message mechanism for methods as most
@@ -687,8 +669,8 @@ In this case,
(G 'a 1) @result{} top-number
@end lisp
-@node Next-method, Example, Generic functions and methods, Generic functions
-@subsection Next-method
+@node Next-method
+@subsubsection Next-method
When you call a generic function, with a particular set of arguments,
GOOPS builds a list of all the methods that are applicable to those
@@ -737,16 +719,16 @@ Number is in range
lead to an infinite recursion, but this consideration is just the same
as in Scheme code in general.)
-@node Example, , Next-method, Generic functions
-@subsection Example
+@node Example
+@subsubsection Example
-In this section we shall continue to define operations on the @code{<complex>}
+In this section we shall continue to define operations on the @code{<my-complex>}
class defined in Figure@ 2. Suppose that we want to use it to implement
complex numbers completely. For instance a definition for the addition of
two complexes could be
@lisp
-(define-method (new-+ (a <complex>) (b <complex>))
+(define-method (new-+ (a <my-complex>) (b <my-complex>))
(make-rectangular (+ (real-part a) (real-part b))
(+ (imag-part a) (imag-part b))))
@end lisp
@@ -758,7 +740,7 @@ addition we can do:
(define-generic new-+)
(let ((+ +))
- (define-method (new-+ (a <complex>) (b <complex>))
+ (define-method (new-+ (a <my-complex>) (b <my-complex>))
(make-rectangular (+ (real-part a) (real-part b))
(+ (imag-part a) (imag-part b)))))
@end lisp
@@ -778,13 +760,13 @@ Figure@ 3.
(define-method (new-+ (a <real>) (b <real>)) (+ a b))
- (define-method (new-+ (a <real>) (b <complex>))
+ (define-method (new-+ (a <real>) (b <my-complex>))
(make-rectangular (+ a (real-part b)) (imag-part b)))
- (define-method (new-+ (a <complex>) (b <real>))
+ (define-method (new-+ (a <my-complex>) (b <real>))
(make-rectangular (+ (real-part a) b) (imag-part a)))
- (define-method (new-+ (a <complex>) (b <complex>))
+ (define-method (new-+ (a <my-complex>) (b <my-complex>))
(make-rectangular (+ (real-part a) (real-part b))
(+ (imag-part a) (imag-part b))))
@@ -823,7 +805,7 @@ To terminate our implementation (integration?) of complex numbers, we can
redefine standard Scheme predicates in the following manner:
@lisp
-(define-method (complex? c <complex>) #t)
+(define-method (complex? c <my-complex>) #t)
(define-method (complex? c) #f)
(define-method (number? n <number>) #t)
diff --git a/doc/goops/goops.texi b/doc/ref/goops.texi
index d6d8e595d..c0a828f71 100644
--- a/doc/goops/goops.texi
+++ b/doc/ref/goops.texi
@@ -1,19 +1,8 @@
-\input texinfo
@c -*-texinfo-*-
-@c %**start of header
-@setfilename goops.info
-@settitle Goops Manual
-@set goops
-@setchapternewpage odd
-@paragraphindent 0
-@c %**end of header
-
-@set VERSION 0.3
-
-@dircategory The Algorithmic Language Scheme
-@direntry
-* GOOPS: (goops). The GOOPS reference manual.
-@end direntry
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 2008, 2009
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
@macro goops
GOOPS
@@ -23,77 +12,8 @@ GOOPS
Guile
@end macro
-@ifinfo
-This file documents GOOPS, an object oriented extension for Guile.
-
-Copyright (C) 1999, 2000, 2001, 2003, 2006 Free Software Foundation
-
-Permission is granted to make and distribute verbatim copies of
-this manual provided the copyright notice and this permission notice
-are preserved on all copies.
-
-@end ifinfo
-
-@c This title page illustrates only one of the
-@c two methods of forming a title page.
-
-@titlepage
-@title Goops Manual
-@subtitle For use with GOOPS @value{VERSION}
-
-@c AUTHORS
-
-@c The GOOPS tutorial was written by Christian Lynbech and Mikael
-@c Djurfeldt, who also wrote GOOPS itself. The GOOPS reference manual
-@c and MOP documentation were written by Neil Jerram and reviewed by
-@c Mikael Djurfeldt.
-
-@author Christian Lynbech
-@author @email{chl@@tbit.dk}
-@author
-@author Mikael Djurfeldt
-@author @email{djurfeldt@@nada.kth.se}
-@author
-@author Neil Jerram
-@author @email{neil@@ossau.uklinux.net}
-
-@c The following two commands
-@c start the copyright page.
-@page
-@vskip 0pt plus 1filll
-Copyright @copyright{} 1999, 2006 Free Software Foundation
-
-Permission is granted to make and distribute verbatim copies of
-this manual provided the copyright notice and this permission notice
-are preserved on all copies.
-
-@end titlepage
-
-@node Top, Introduction, (dir), (dir)
-
-@menu
-* Introduction::
-* Getting Started::
-* Reference Manual::
-* MOP Specification::
-
-* Tutorial::
-
-* Concept Index::
-* Function and Variable Index::
-@end menu
-
-@iftex
-@chapter Preliminaries
-@end iftex
-
-@node Introduction, Getting Started, Top, Top
-@iftex
-@section Introduction
-@end iftex
-@ifnottex
-@chapter Introduction
-@end ifnottex
+@node GOOPS
+@chapter GOOPS
@goops{} is the object oriented extension to @guile{}. Its
implementation is derived from @w{STk-3.99.3} by Erick Gallesio and
@@ -109,71 +29,58 @@ multi-method dispatch. Furthermore, the implementation relies on a true
meta object protocol, in the spirit of the one defined for CLOS
(@cite{Gregor Kiczales: A Metaobject Protocol}).
-@node Getting Started, Reference Manual, Introduction, Top
-@iftex
-@section Getting Started
-@end iftex
-@ifnottex
-@chapter Getting Started
-@end ifnottex
-
@menu
-* Running GOOPS::
-
-Examples of some basic GOOPS functionality.
-
-* Methods::
-* User-defined types::
-* Asking for the type of an object::
-
-See further in the GOOPS tutorial available in this distribution in
-info (goops.info) and texinfo format.
+* Quick Start::
+* Tutorial::
+* Reference Manual::
+* MOP Specification::
@end menu
-@node Running GOOPS, Methods, Getting Started, Getting Started
-@subsection Running GOOPS
-
-@enumerate
-@item
-Type
-
-@smalllisp
-guile-oops
-@end smalllisp
+@node Quick Start
+@section Quick Start
-You should now be at the Guile prompt ("guile> ").
+To give an immediate flavour of what GOOPS can do, here is a very
+brief introduction to its main operations.
-@item
-Type
+To start using GOOPS, load the @code{(oop goops)} module:
-@smalllisp
+@lisp
(use-modules (oop goops))
-@end smalllisp
-
-to load GOOPS. (If your system supports dynamic loading, you
-should be able to do this not only from `guile-oops' but from an
-arbitrary Guile interpreter.)
-@end enumerate
+@end lisp
We're now ready to try some basic GOOPS functionality.
-@node Methods, User-defined types, Running GOOPS, Getting Started
+@menu
+* Methods::
+* User-defined types::
+* Asking for the type of an object::
+@end menu
+
+@node Methods
@subsection Methods
-@smalllisp
-@group
+A GOOPS method is like a Scheme procedure except that it is
+specialized for a particular set of argument types.
+
+@lisp
(define-method (+ (x <string>) (y <string>))
(string-append x y))
-(+ 1 2) --> 3
-(+ "abc" "de") --> "abcde"
-@end group
-@end smalllisp
+(+ "abc" "de") @result{} "abcde"
+@end lisp
-@node User-defined types, Asking for the type of an object, Methods, Getting Started
+If @code{+} is used with arguments that do not match the method's
+types, Guile falls back to using the normal Scheme @code{+} procedure.
+
+@lisp
+(+ 1 2) @result{} 3
+@end lisp
+
+
+@node User-defined types
@subsection User-defined types
-@smalllisp
+@lisp
(define-class <2D-vector> ()
(x #:init-value 0 #:accessor x-component #:init-keyword #:x)
(y #:init-value 0 #:accessor y-component #:init-keyword #:y))
@@ -182,12 +89,11 @@ We're now ready to try some basic GOOPS functionality.
(use-modules (ice-9 format))
(define-method (write (obj <2D-vector>) port)
- (display (format #f "<~S, ~S>" (x-component obj) (y-component obj))
- port))
+ (format port "<~S, ~S>" (x-component obj) (y-component obj)))
(define v (make <2D-vector> #:x 3 #:y 4))
-v --> <3, 4>
+v @result{} <3, 4>
@end group
@group
@@ -196,24 +102,28 @@ v --> <3, 4>
#:x (+ (x-component x) (x-component y))
#:y (+ (y-component x) (y-component y))))
-(+ v v) --> <6, 8>
+(+ v v) @result{} <6, 8>
@end group
-@end smalllisp
+@end lisp
-@node Asking for the type of an object, , User-defined types, Getting Started
+@node Asking for the type of an object
@subsection Types
@example
-(class-of v) --> #<<class> <2D-vector> 40241ac0>
-<2D-vector> --> #<<class> <2D-vector> 40241ac0>
-(class-of 1) --> #<<class> <integer> 401b2a98>
-<integer> --> #<<class> <integer> 401b2a98>
+(class-of v) @result{} #<<class> <2D-vector> 40241ac0>
+<2D-vector> @result{} #<<class> <2D-vector> 40241ac0>
+(class-of 1) @result{} #<<class> <integer> 401b2a98>
+<integer> @result{} #<<class> <integer> 401b2a98>
-(is-a? v <2D-vector>) --> #t
+(is-a? v <2D-vector>) @result{} #t
@end example
-@node Reference Manual, MOP Specification, Getting Started, Top
-@chapter Reference Manual
+@node Tutorial
+@section Tutorial
+@include goops-tutorial.texi
+
+@node Reference Manual
+@section Reference Manual
This chapter is the GOOPS reference manual. It aims to describe all the
syntax, procedures, options and associated concepts that a typical
@@ -241,7 +151,7 @@ For a detailed specification of the GOOPS metaobject protocol, see
@end menu
@node Introductory Remarks
-@section Introductory Remarks
+@subsection Introductory Remarks
GOOPS is an object-oriented programming system based on a ``metaobject
protocol'' derived from the ones used in CLOS (the Common Lisp Object
@@ -261,19 +171,19 @@ GOOPS' power, by customizing the behaviour of GOOPS itself.
Each of the following sections of the reference manual is arranged
such that the most basic usage is introduced first, and then subsequent
-subsections discuss the related internal functions and metaobject
+subsubsections discuss the related internal functions and metaobject
protocols, finishing with a description of how to customize that area of
functionality.
These introductory remarks continue with a few words about metaobjects
and the MOP. Readers who do not want to be bothered yet with the MOP
-and customization could safely skip this subsection on a first reading,
-and should correspondingly skip subsequent subsections that are
+and customization could safely skip this subsubsection on a first reading,
+and should correspondingly skip subsequent subsubsections that are
concerned with internals and customization.
In general, this reference manual assumes familiarity with standard
object oriented concepts and terminology. However, some of the terms
-used in GOOPS are less well known, so the Terminology subsection
+used in GOOPS are less well known, so the Terminology subsubsection
provides definitions for these terms.
@menu
@@ -282,7 +192,7 @@ provides definitions for these terms.
@end menu
@node Metaobjects and the Metaobject Protocol
-@subsection Metaobjects and the Metaobject Protocol
+@subsubsection Metaobjects and the Metaobject Protocol
The conceptual building blocks of GOOPS are classes, slot definitions,
instances, generic functions and methods. A class is a grouping of
@@ -377,7 +287,7 @@ Each subsequent section of the reference manual covers a particular area
of GOOPS functionality, and describes the generic functions that are
relevant for customization of that area.
-We conclude this subsection by emphasizing a point that may seem
+We conclude this subsubsection by emphasizing a point that may seem
obvious, but contrasts with the corresponding situation in some other
MOP implementations, such as CLOS. The point is simply that an
identifier which represents a GOOPS class or generic function is a
@@ -392,7 +302,7 @@ class names), but it is worth noting that GOOPS conforms fully to this
Schemely principle.
@node Terminology
-@subsection Terminology
+@subsubsection Terminology
It is assumed that the reader is already familiar with standard object
orientation concepts such as classes, objects/instances,
@@ -403,14 +313,7 @@ This section explains some of the less well known concepts and
terminology that GOOPS uses, which are assumed by the following sections
of the reference manual.
-@menu
-* Metaclass::
-* Class Precedence List::
-* Accessor::
-@end menu
-
-@node Metaclass
-@subsubsection Metaclass
+@subsubheading Metaclass
A @dfn{metaclass} is the class of an object which represents a GOOPS
class. Put more succinctly, a metaclass is a class's class.
@@ -517,8 +420,7 @@ The metaclass of @code{<my-metaclass>} is @code{<class>}.
@code{<class>}.
@end itemize
-@node Class Precedence List
-@subsubsection Class Precedence List
+@subsubheading Class Precedence List
The @dfn{class precedence list} of a class is the list of all direct and
indirect superclasses of that class, including the class itself.
@@ -548,8 +450,7 @@ precedence list}.
``Class precedence list'' is often abbreviated, in documentation and
Scheme variable names, to @dfn{cpl}.
-@node Accessor
-@subsubsection Accessor
+@subsubheading Accessor
An @dfn{accessor} is a generic function with both reference and setter
methods.
@@ -583,7 +484,7 @@ be invoked using the generalized @code{set!} syntax, as in:
@end example
@node Defining New Classes
-@section Defining New Classes
+@subsection Defining New Classes
[ *fixme* Somewhere in this manual there needs to be an introductory
discussion about GOOPS classes, generic functions and methods, covering
@@ -622,7 +523,7 @@ the discussion there. ]
@end menu
@node Basic Class Definition
-@subsection Basic Class Definition
+@subsubsection Basic Class Definition
New classes are defined using the @code{define-class} syntax, with
arguments that specify the classes that the new class should inherit
@@ -651,7 +552,7 @@ keywords and corresponding values.
@end deffn
The standard GOOPS class and slot options are described in the following
-subsections: see @ref{Class Options} and @ref{Slot Options}.
+subsubsections: see @ref{Class Options} and @ref{Slot Options}.
Example 1. Define a class that combines two pre-existing classes by
inheritance but adds no new slots.
@@ -681,13 +582,13 @@ customized via an application-defined metaclass.
@end example
@node Class Options
-@subsection Class Options
+@subsubsection Class Options
@deffn {class option} #:metaclass metaclass
The @code{#:metaclass} class option specifies the metaclass of the class
being defined. @var{metaclass} must be a class that inherits from
@code{<class>}. For an introduction to the use of metaclasses, see
-@ref{Metaobjects and the Metaobject Protocol} and @ref{Metaclass}.
+@ref{Metaobjects and the Metaobject Protocol} and @ref{Terminology}.
If the @code{#:metaclass} option is absent, GOOPS reuses or constructs a
metaclass for the new class by calling @code{ensure-metaclass}
@@ -714,7 +615,7 @@ environment defaults to the top-level environment in which the
@end deffn
@node Slot Options
-@subsection Slot Options
+@subsubsection Slot Options
@deffn {slot option} #:allocation allocation
The @code{#:allocation} option tells GOOPS how to allocate storage for
@@ -917,7 +818,7 @@ classes.
@end deffn
@node Class Definition Internals
-@subsection Class Definition Internals
+@subsubsection Class Definition Internals
Implementation notes: @code{define-class} expands to an expression which
@@ -1030,7 +931,7 @@ class object, are described in @ref{Customizing Instance Creation},
which covers the creation and initialization of instances in general.
@node Customizing Class Definition
-@subsection Customizing Class Definition
+@subsubsection Customizing Class Definition
During the initialization of a new class, GOOPS calls a number of generic
functions with the newly allocated class instance as the first
@@ -1124,7 +1025,8 @@ allocation to do this.
(let ((batch-allocation-count 0)
(batch-get-n-set #f))
- (define-method (compute-get-n-set (class <batched-allocation-metaclass>) s)
+ (define-method (compute-get-n-set
+ (class <batched-allocation-metaclass>) s)
(case (slot-definition-allocation s)
((#:batched)
;; If we've already used the same slot storage for 10 instances,
@@ -1165,7 +1067,7 @@ typically it would perform additional class initialization steps before
and/or after calling @code{(next-method)} for the standard behaviour.
@node STKlos Compatibility
-@subsection STKlos Compatibility
+@subsubsection STKlos Compatibility
If the STKlos compatibility module is loaded, @code{define-class} is
overwritten by a STKlos-specific definition; the standard GOOPS
@@ -1178,7 +1080,7 @@ definition of @code{define-class} remains available in
@end deffn
@node Creating Instances
-@section Creating Instances
+@subsection Creating Instances
@menu
* Basic Instance Creation::
@@ -1186,7 +1088,7 @@ definition of @code{define-class} remains available in
@end menu
@node Basic Instance Creation
-@subsection Basic Instance Creation
+@subsubsection Basic Instance Creation
To create a new instance of any GOOPS class, use the generic function
@code{make} or @code{make-instance}, passing the required class and any
@@ -1223,7 +1125,7 @@ instance's class. Any unprocessed keyword value pairs are ignored.
@end deffn
@node Customizing Instance Creation
-@subsection Customizing Instance Creation
+@subsubsection Customizing Instance Creation
@code{make} itself is a generic function. Hence the @code{make}
invocation itself can be customized in the case where the new instance's
@@ -1290,7 +1192,7 @@ and closures in the slot definitions, it is neater to write an
and initializes all the dependent slot values according to the results.
@node Accessing Slots
-@section Accessing Slots
+@subsection Accessing Slots
The definition of a slot contains at the very least a slot name, and may
also contain various slot options, including getter, setter and/or
@@ -1298,7 +1200,7 @@ accessor functions for the slot.
It is always possible to access slots by name, using the various
``slot-ref'' and ``slot-set!'' procedures described in the following
-subsections. For example,
+subsubsections. For example,
@example
(define-class <my-class> () ;; Define a class with slots
@@ -1354,7 +1256,7 @@ closures, see @ref{Customizing Class Definition,, compute-get-n-set}.)
@end menu
@node Instance Slots
-@subsection Instance Slots
+@subsubsection Instance Slots
Any slot, regardless of its allocation, can be queried, referenced and
set using the following four primitive procedures.
@@ -1451,7 +1353,7 @@ slot-missing}).
@end deffn
@node Class Slots
-@subsection Class Slots
+@subsubsection Class Slots
Slots whose allocation is per-class rather than per-instance can be
referenced and set without needing to specify any particular instance.
@@ -1479,7 +1381,7 @@ function with arguments @var{class} and @var{slot-name}.
@end deffn
@node Handling Slot Access Errors
-@subsection Handling Slot Access Errors
+@subsubsection Handling Slot Access Errors
GOOPS calls one of the following generic functions when a ``slot-ref''
or ``slot-set!'' call specifies a non-existent slot name, or tries to
@@ -1510,7 +1412,7 @@ message.
@end deffn
@node Creating Generic Functions
-@section Creating Generic Functions
+@subsection Creating Generic Functions
A generic function is a collection of methods, with rules for
determining which of the methods should be applied for any given
@@ -1526,7 +1428,7 @@ GOOPS represents generic functions as metaobjects of the class
@end menu
@node Basic Generic Function Creation
-@subsection Basic Generic Function Creation
+@subsubsection Basic Generic Function Creation
The following forms may be used to bind a variable to a generic
function. Depending on that variable's pre-existing value, the generic
@@ -1586,20 +1488,20 @@ This can be resolved automagically with the duplicates handler
@code{merge-generics} which gives the module system license to merge
all generic functions sharing a common name:
-@smalllisp
+@lisp
(define-module (math 2D-vectors)
- :use-module (oop goops)
- :export (x y ...))
+ #:use-module (oop goops)
+ #:export (x y ...))
(define-module (math 3D-vectors)
- :use-module (oop goops)
- :export (x y z ...))
+ #:use-module (oop goops)
+ #:export (x y z ...))
(define-module (my-module)
- :use-module (math 2D-vectors)
- :use-module (math 3D-vectors)
- :duplicates merge-generics)
-@end smalllisp
+ #:use-module (math 2D-vectors)
+ #:use-module (math 3D-vectors)
+ #:duplicates merge-generics)
+@end lisp
The generic function @code{x} in @code{(my-module)} will now share
methods with @code{x} in both imported modules.
@@ -1629,14 +1531,14 @@ Sharing is dynamic, so that adding new methods to a descendant implies
adding it to the ancestor.
If duplicates checking is desired in the above example, the following
-form of the @code{:duplicates} option can be used instead:
+form of the @code{#:duplicates} option can be used instead:
-@smalllisp
- :duplicates (merge-generics check)
-@end smalllisp
+@lisp
+ #:duplicates (merge-generics check)
+@end lisp
@node Generic Function Internals
-@subsection Generic Function Internals
+@subsubsection Generic Function Internals
@code{define-generic} calls @code{ensure-generic} to upgrade a
pre-existing procedure value, or @code{make} with metaclass
@@ -1705,7 +1607,7 @@ accessor, passing the setter generic function as the value of the
@code{#:setter} keyword.
@node Extending Guiles Primitives
-@subsection Extending Guile's Primitives
+@subsubsection Extending Guile's Primitives
When GOOPS is loaded, many of Guile's primitive procedures can be
extended by giving them a generic function definition that operates
@@ -1752,7 +1654,7 @@ integrated into the core of Guile. Consequently, the
procedures described in this section may disappear as well.
@node Adding Methods to Generic Functions
-@section Adding Methods to Generic Functions
+@subsection Adding Methods to Generic Functions
@menu
* Basic Method Definition::
@@ -1760,7 +1662,7 @@ procedures described in this section may disappear as well.
@end menu
@node Basic Method Definition
-@subsection Basic Method Definition
+@subsubsection Basic Method Definition
To add a method to a generic function, use the @code{define-method} form.
@@ -1819,7 +1721,7 @@ invocation error handling, and generic function invocation in general,
see @ref{Invoking Generic Functions}.
@node Method Definition Internals
-@subsection Method Definition Internals
+@subsubsection Method Definition Internals
@code{define-method}
@@ -1906,7 +1808,7 @@ function.
@end deffn
@node Invoking Generic Functions
-@section Invoking Generic Functions
+@subsection Invoking Generic Functions
When a variable with a generic function definition appears as the first
element of a list that is being evaluated, the Guile evaluator tries
@@ -1928,7 +1830,7 @@ may be applied subsequently if a method that is being applied calls
@end menu
@node Determining Which Methods to Apply
-@subsection Determining Which Methods to Apply
+@subsubsection Determining Which Methods to Apply
[ *fixme* Sorry - this is the area of GOOPS that I understand least of
all, so I'm afraid I have to pass on this section. Would some other
@@ -1959,7 +1861,7 @@ kind person consider filling it in? ]
@end deffn
@node Handling Invocation Errors
-@subsection Handling Invocation Errors
+@subsubsection Handling Invocation Errors
@deffn generic no-method
@deffnx method no-method (gf <generic>) args
@@ -1987,7 +1889,7 @@ default method calls @code{goops-error} with an appropriate message.
@end deffn
@node Redefining a Class
-@section Redefining a Class
+@subsection Redefining a Class
Suppose that a class @code{<my-class>} is defined using @code{define-class}
(@pxref{Basic Class Definition,, define-class}), with slots that have
@@ -2002,7 +1904,7 @@ make}). What then happens if @code{<my-class>} is redefined by calling
@end menu
@node Default Class Redefinition Behaviour
-@subsection Default Class Redefinition Behaviour
+@subsubsection Default Class Redefinition Behaviour
GOOPS' default answer to this question is as follows.
@@ -2055,7 +1957,7 @@ Also bear in mind that, like most of GOOPS' default behaviour, it can
be customized@dots{}
@node Customizing Class Redefinition
-@subsection Customizing Class Redefinition
+@subsubsection Customizing Class Redefinition
When @code{define-class} notices that a class is being redefined,
it constructs the new class metaobject as usual, and then invokes the
@@ -2092,7 +1994,8 @@ is specialized for this metaclass:
@example
(define-class <can-be-nameless> (<class>))
-(define-method (class-redefinition (old <can-be-nameless>) (new <class>))
+(define-method (class-redefinition (old <can-be-nameless>)
+ (new <class>))
new)
@end example
@@ -2119,7 +2022,7 @@ generic functions, and so on@dots{} The detailed protocol for all of these
is described in @ref{MOP Specification}.
@node Changing the Class of an Instance
-@section Changing the Class of an Instance
+@subsection Changing the Class of an Instance
You can change the class of an existing instance by invoking the
generic function @code{change-class} with two arguments: the instance
@@ -2158,7 +2061,7 @@ invokes the @code{change-class} generic function for each existing
instance of the redefined class.
@node Introspection
-@section Introspection
+@subsection Introspection
@dfn{Introspection}, also known as @dfn{reflection}, is the name given
to the ability to obtain information dynamically about GOOPS metaobjects.
@@ -2197,7 +2100,7 @@ GOOPS equivalents --- to be obtained dynamically, at run time.
@end menu
@node Classes
-@subsection Classes
+@subsubsection Classes
@deffn {primitive procedure} class-name class
Return the name of class @var{class}.
@@ -2257,7 +2160,7 @@ Return a list of all methods that use @var{class} or a subclass of
@end deffn
@node Slots
-@subsection Slots
+@subsubsection Slots
@deffn procedure class-slot-definition class slot-name
Return the slot definition for the slot named @var{slot-name} in class
@@ -2338,7 +2241,7 @@ see @ref{Slot Options,, init-value}.
@end deffn
@node Instances
-@subsection Instances
+@subsubsection Instances
@deffn {primitive procedure} class-of value
Return the GOOPS class of any Scheme @var{value}.
@@ -2359,7 +2262,7 @@ Implementation notes: @code{is-a?} uses @code{class-of} and
@var{object}.
@node Generic Functions
-@subsection Generic Functions
+@subsubsection Generic Functions
@deffn {primitive procedure} generic-function-name gf
Return the name of generic function @var{gf}.
@@ -2371,7 +2274,7 @@ This is the value of the @var{gf} metaobject's @code{methods} slot.
@end deffn
@node Generic Function Methods
-@subsection Generic Function Methods
+@subsubsection Generic Function Methods
@deffn {primitive procedure} method-generic-function method
Return the generic function that @var{method} belongs to.
@@ -2409,18 +2312,18 @@ Return an expression that prints to show the definition of method
@end deffn
@node Miscellaneous Functions
-@section Miscellaneous Functions
+@subsection Miscellaneous Functions
@menu
* Administrative Functions::
-* Error Handling::
+* GOOPS Error Handling::
* Object Comparisons::
* Cloning Objects::
* Write and Display::
@end menu
@node Administrative Functions
-@subsection Administration Functions
+@subsubsection Administration Functions
This section describes administrative, non-technical GOOPS functions.
@@ -2428,8 +2331,8 @@ This section describes administrative, non-technical GOOPS functions.
Return the current GOOPS version as a string, for example ``0.2''.
@end deffn
-@node Error Handling
-@subsection Error Handling
+@node GOOPS Error Handling
+@subsubsection Error Handling
The procedure @code{goops-error} is called to raise an appropriate error
by the default methods of the following generic functions:
@@ -2464,7 +2367,7 @@ as done by @code{scm-error}.
@end deffn
@node Object Comparisons
-@subsection Object Comparisons
+@subsubsection Object Comparisons
@deffn generic eqv?
@deffnx method eqv? ((x <top>) (y <top>))
@@ -2493,7 +2396,7 @@ and the Guile reference manual.
@end deffn
@node Cloning Objects
-@subsection Cloning Objects
+@subsubsection Cloning Objects
@deffn generic shallow-clone
@deffnx method shallow-clone (self <object>)
@@ -2514,7 +2417,7 @@ or by reference.
@end deffn
@node Write and Display
-@subsection Write and Display
+@subsubsection Write and Display
@deffn {primitive generic} write object port
@deffnx {primitive generic} display object port
@@ -2542,8 +2445,8 @@ methods - instances of the class @code{<method>}.
as the Guile primitive @code{write} and @code{display} functions.
@end deffn
-@node MOP Specification, Tutorial, Reference Manual, Top
-@chapter MOP Specification
+@node MOP Specification
+@section MOP Specification
For an introduction to metaobjects and the metaobject protocol,
see @ref{Metaobjects and the Metaobject Protocol}.
@@ -2598,7 +2501,7 @@ what the caller expects to get as the applied method's return value.
@end menu
@node Class Definition
-@section Class Definition
+@subsection Class Definition
@code{define-class} (syntax)
@@ -2731,7 +2634,7 @@ or @code{#:accessor} option.
@end itemize
@node Instance Creation
-@section Instance Creation
+@subsection Instance Creation
@code{make <class> . @var{initargs}} (method)
@@ -2752,13 +2655,13 @@ return value is ignored.
@end itemize
@node Class Redefinition
-@section Class Redefinition
+@subsection Class Redefinition
The default @code{class-redefinition} method, specialized for classes
with the default metaclass @code{<class>}, has the following internal
protocol.
-@code{class-redefinition @var{(old <class>)} @var{(new <class>)}}
+@code{class-redefinition (@var{old <class>}) (@var{new <class>})}
(method)
@itemize @bullet
@@ -2797,7 +2700,7 @@ to the modified instance, and initializes new slots, as described in
generic function invocation that can be used to customize the instance
update algorithm.
-@code{change-class @var{(old-instance <object>)} @var{(new <class>)}} (method)
+@code{change-class (@var{old-instance <object>}) (@var{new <class>})} (method)
@itemize @bullet
@item
@@ -2814,7 +2717,7 @@ nothing.
@end itemize
@node Method Definition
-@section Method Definition
+@subsection Method Definition
@code{define-method} (syntax)
@@ -2842,7 +2745,7 @@ theoretically handle adding methods to further types of target.
@end itemize
@node Generic Function Invocation
-@section Generic Function Invocation
+@subsection Generic Function Invocation
[ *fixme* Description required here. ]
@@ -2885,21 +2788,3 @@ theoretically handle adding methods to further types of target.
@item
@code{no-next-method}
@end itemize
-
-@node Tutorial, Concept Index, MOP Specification, Top
-@chapter Tutorial
-@include goops-tutorial.texi
-
-@node Concept Index, Function and Variable Index, Tutorial, Top
-@unnumberedsec Concept Index
-
-@printindex cp
-
-@node Function and Variable Index, , Concept Index, Top
-@unnumberedsec Function and Variable Index
-
-@printindex fn
-
-@summarycontents
-@contents
-@bye
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index a67589915..332be361b 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -4,22 +4,21 @@
@setfilename guile.info
@settitle Guile Reference Manual
@set guile
-@set MANUAL-EDITION 1.1
+@set MANUAL-REVISION 1
@c %**end of header
@include version.texi
@include lib-version.texi
+@include effective-version.texi
@copying
-This reference manual documents Guile, GNU's Ubiquitous Intelligent
-Language for Extensions. This is edition @value{MANUAL-EDITION}
-corresponding to Guile @value{VERSION}.
+This manual documents Guile version @value{VERSION}.
-Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005 Free
+Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009 Free
Software Foundation.
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.2 or
-any later version published by the Free Software Foundation; with the
+any later version published by the Free Software Foundation; with
no Invariant Sections, with the Front-Cover Texts being ``A GNU
Manual,'' and with the Back-Cover Text ``You are free to copy and
modify this GNU Manual.''. A copy of the license is included in the
@@ -137,7 +136,7 @@ x
@sp 10
@comment The title is printed in a large font.
@title Guile Reference Manual
-@subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION}
+@subtitle Edition @value{EDITION}, revision @value{MANUAL-REVISION}, for use with Guile @value{VERSION}
@c @subtitle $Id: guile.texi,v 1.49 2008-03-19 22:51:23 ossau Exp $
@c See preface.texi for the list of authors
@@ -177,6 +176,8 @@ x
* Guile Modules::
+* GOOPS::
+
* Guile Implementation::
* Autoconf Support::
@@ -365,6 +366,8 @@ available through both Scheme and C interfaces.
@include scsh.texi
@include scheme-debugging.texi
+@include goops.texi
+
@node Guile Implementation
@chapter Guile Implementation
diff --git a/doc/goops/hierarchy.eps b/doc/ref/hierarchy.eps
index 7b1a98605..7b1a98605 100644
--- a/doc/goops/hierarchy.eps
+++ b/doc/ref/hierarchy.eps
diff --git a/doc/goops/hierarchy.pdf b/doc/ref/hierarchy.pdf
index 3a19ba4eb..3a19ba4eb 100644
--- a/doc/goops/hierarchy.pdf
+++ b/doc/ref/hierarchy.pdf
diff --git a/doc/goops/hierarchy.png b/doc/ref/hierarchy.png
index 46f58b051..46f58b051 100644
--- a/doc/goops/hierarchy.png
+++ b/doc/ref/hierarchy.png
Binary files differ
diff --git a/doc/goops/hierarchy.txt b/doc/ref/hierarchy.txt
index c7992df7b..c7992df7b 100644
--- a/doc/goops/hierarchy.txt
+++ b/doc/ref/hierarchy.txt
diff --git a/doc/ref/intro.texi b/doc/ref/intro.texi
index b0c4c1263..7e248e0e8 100644
--- a/doc/ref/intro.texi
+++ b/doc/ref/intro.texi
@@ -80,6 +80,7 @@ To unbundle Guile use the instruction
zcat guile-@value{VERSION}.tar.gz | tar xvf -
@end example
+@noindent
which will create a directory called @file{guile-@value{VERSION}} with
all the sources. You can look at the file @file{INSTALL} for detailed
instructions on how to build and install Guile, but you should be able
@@ -93,7 +94,7 @@ make install
@end example
This will install the Guile executable @file{guile}, the Guile library
-@file{-lguile} and various associated header files and support
+@file{libguile} and various associated header files and support
libraries. It will also install the Guile tutorial and reference
manual.
@@ -101,14 +102,14 @@ manual.
Since this manual frequently refers to the Scheme ``standard'', also
known as R5RS, or the
-@iftex
+@tex
``Revised$^5$ Report on the Algorithmic Language Scheme'',
-@end iftex
+@end tex
@ifnottex
``Revised^5 Report on the Algorithmic Language Scheme'',
@end ifnottex
-we have included the report in the Guile distribution;
-@xref{Top, , Introduction, r5rs, Revised(5) Report on the Algorithmic
+we have included the report in the Guile distribution; see
+@ref{Top, , Introduction, r5rs, Revised(5) Report on the Algorithmic
Language Scheme}.
This will also be installed in your info directory.
@@ -471,11 +472,12 @@ You can get the version number by invoking the command
@example
$ guile --version
Guile 1.9.0
-Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation
+Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004,
+2005, 2006, 2007, 2008, 2009 Free Software Foundation
Guile may be distributed under the terms of the GNU Lesser General
Public Licence. For details, see the files `COPYING.LESSER' and
-`COPYING', which are included in the Guile distribution. There is no
-warranty, to the extent permitted by law.
+`COPYING', which are included in the Guile distribution. There is
+no warranty, to the extent permitted by law.
@end example
@item
diff --git a/doc/ref/libguile-extensions.texi b/doc/ref/libguile-extensions.texi
index 77762b5c5..78871c6ca 100644
--- a/doc/ref/libguile-extensions.texi
+++ b/doc/ref/libguile-extensions.texi
@@ -94,11 +94,11 @@ we are going to call the function @code{init_bessel} which will make
@file{.so} when invoking @code{load-extension}. The right extension for
the host platform will be provided automatically.
-@smalllisp
+@lisp
(load-extension "libguile-bessel" "init_bessel")
(j0 2)
@result{} 0.223890779141236
-@end smalllisp
+@end lisp
For this to work, @code{load-extension} must be able to find
@file{libguile-bessel}, of course. It will look in the places that
diff --git a/doc/ref/libguile-linking.texi b/doc/ref/libguile-linking.texi
index 8869c46d5..72b59bbba 100644
--- a/doc/ref/libguile-linking.texi
+++ b/doc/ref/libguile-linking.texi
@@ -173,7 +173,8 @@ creating ./config.status
creating Makefile
$ make
gcc -c -I/usr/local/include simple-guile.c
-gcc simple-guile.o -L/usr/local/lib -lguile -lqthreads -lpthread -lm -o simple-guile
+gcc simple-guile.o -L/usr/local/lib -lguile -lqthreads -lpthread -lm
+ -o simple-guile
$ ./simple-guile
guile> (+ 1 2 3)
6
diff --git a/doc/ref/libguile-smobs.texi b/doc/ref/libguile-smobs.texi
index 09b5446cd..738809d7a 100644
--- a/doc/ref/libguile-smobs.texi
+++ b/doc/ref/libguile-smobs.texi
@@ -28,7 +28,7 @@ datatypes described here.)
@menu
* Describing a New Type::
-* Creating Instances::
+* Creating Smob Instances::
* Type checking::
* Garbage Collecting Smobs::
* Garbage Collecting Simple Smobs::
@@ -132,8 +132,8 @@ init_image_type (void)
@end example
-@node Creating Instances
-@subsection Creating Instances
+@node Creating Smob Instances
+@subsection Creating Smob Instances
Normally, smobs can have one @emph{immediate} word of data. This word
stores either a pointer to an additional memory block that holds the
@@ -211,7 +211,8 @@ make_image (SCM name, SCM s_width, SCM s_height)
/* Step 1: Allocate the memory block.
*/
- image = (struct image *) scm_gc_malloc (sizeof (struct image), "image");
+ image = (struct image *)
+ scm_gc_malloc (sizeof (struct image), "image");
/* Step 2: Initialize it with straight code.
*/
@@ -228,7 +229,8 @@ make_image (SCM name, SCM s_width, SCM s_height)
/* Step 4: Finish the initialization.
*/
image->name = name;
- image->pixels = scm_gc_malloc (width * height, "image pixels");
+ image->pixels =
+ scm_gc_malloc (width * height, "image pixels");
return smob;
@}
@@ -404,7 +406,9 @@ free_image (SCM image_smob)
@{
struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
- scm_gc_free (image->pixels, image->width * image->height, "image pixels");
+ scm_gc_free (image->pixels,
+ image->width * image->height,
+ "image pixels");
scm_gc_free (image, sizeof (struct image), "image");
return 0;
@@ -583,7 +587,8 @@ make_image (SCM name, SCM s_width, SCM s_height)
/* Step 1: Allocate the memory block.
*/
- image = (struct image *) scm_gc_malloc (sizeof (struct image), "image");
+ image = (struct image *)
+ scm_gc_malloc (sizeof (struct image), "image");
/* Step 2: Initialize it with straight code.
*/
@@ -600,7 +605,8 @@ make_image (SCM name, SCM s_width, SCM s_height)
/* Step 4: Finish the initialization.
*/
image->name = name;
- image->pixels = scm_gc_malloc (width * height, "image pixels");
+ image->pixels =
+ scm_gc_malloc (width * height, "image pixels");
return smob;
@}
@@ -642,7 +648,9 @@ free_image (SCM image_smob)
@{
struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
- scm_gc_free (image->pixels, image->width * image->height, "image pixels");
+ scm_gc_free (image->pixels,
+ image->width * image->height,
+ "image pixels");
scm_gc_free (image, sizeof (struct image), "image");
return 0;
diff --git a/doc/goops/mop.text b/doc/ref/mop.text
index 0180f2c1e..0180f2c1e 100644
--- a/doc/goops/mop.text
+++ b/doc/ref/mop.text
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 2d64919a5..d568af23d 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -2072,9 +2072,9 @@ The following procedures are similar to the @code{popen} and
@code{pclose} system routines. The code is in a separate ``popen''
module:
-@smalllisp
+@lisp
(use-modules (ice-9 popen))
-@end smalllisp
+@end lisp
@findex popen
@deffn {Scheme Procedure} open-pipe command mode
diff --git a/doc/ref/preface.texi b/doc/ref/preface.texi
index 7fa85811b..8552d388b 100644
--- a/doc/ref/preface.texi
+++ b/doc/ref/preface.texi
@@ -7,12 +7,9 @@
@node Preface
@chapter Preface
-This reference manual documents Guile, GNU's Ubiquitous Intelligent
-Language for Extensions. It describes how to use Guile in many useful
-and interesting ways.
-
-This is edition @value{MANUAL-EDITION} of the reference manual, and
-corresponds to Guile version @value{VERSION}.
+This manual documents version @value{VERSION} of Guile, GNU's
+Ubiquitous Intelligent Language for Extensions. It describes how to
+use Guile in many useful and interesting ways.
@menu
* Manual Layout::
@@ -25,7 +22,7 @@ corresponds to Guile version @value{VERSION}.
@node Manual Layout
@section Layout of this Manual
-The manual is divided into five chapters.
+The manual is divided into the following chapters.
@table @strong
@item Chapter 1: Introduction to Guile
@@ -38,7 +35,7 @@ the later parts of the manual. This part also explains how to obtain
and install new versions of Guile, and how to report bugs effectively.
@item Chapter 2: Programming in Scheme
-This part provides an overview over programming in Scheme with Guile.
+This part provides an overview of programming in Scheme with Guile.
It covers how to invoke the @code{guile} program from the command-line
and how to write scripts in Scheme. It also gives an introduction
into the basic ideas of Scheme itself and to the various extensions
@@ -61,6 +58,10 @@ Describes some important modules, distributed as part of the Guile
distribution, that extend the functionality provided by the Guile
Scheme core.
+@item Chapter 6: GOOPS
+Describes GOOPS, an object oriented extension to Guile that provides
+classes, multiple inheritance and generic functions.
+
@end table
@@ -72,7 +73,7 @@ We use some conventions in this manual.
@itemize @bullet
@item
-For some procedures, notably type predicates, we use @dfn{iff} to mean
+For some procedures, notably type predicates, we use ``iff'' to mean
``if and only if''. The construct is usually something like: `Return
@var{val} iff @var{condition}', where @var{val} is usually
``@nicode{#t}'' or ``non-@nicode{#f}''. This typically means that
@@ -144,6 +145,9 @@ filling out a lot of the documentation of Scheme data types, control
mechanisms and procedures. In addition, he wrote the documentation
for Guile's SRFI modules and modules associated with the Guile REPL.
+The chapter on GOOPS was written by Christian Lynbech, Mikael
+Djurfeldt and Neil Jerram.
+
@node Guile License
@section The Guile License
@cindex copying
@@ -179,7 +183,7 @@ C code linking to the Guile readline module is subject to the terms of
that module. Basically such code must be published on Free terms.
Scheme level code written to be run by Guile (but not derived from
-Guile itself) is not resticted in any way, and may be published on any
+Guile itself) is not restricted in any way, and may be published on any
terms. We encourage authors to publish on Free terms.
You must be aware there is no warranty whatsoever for Guile. This is
diff --git a/doc/ref/scheme-debugging.texi b/doc/ref/scheme-debugging.texi
index 07511263b..bcd9f2df3 100644
--- a/doc/ref/scheme-debugging.texi
+++ b/doc/ref/scheme-debugging.texi
@@ -14,9 +14,9 @@ call to that procedure is reported to the user during a program run.
The idea is that you can mark a collection of procedures for tracing,
and Guile will subsequently print out a line of the form
-@smalllisp
+@lisp
| | [@var{procedure} @var{args} @dots{}]
-@end smalllisp
+@end lisp
whenever a marked procedure is about to be applied to its arguments.
This can help a programmer determine whether a function is being called
@@ -27,7 +27,7 @@ how the traced applications are or are not tail recursive with respect
to each other. Thus, a trace of a non-tail recursive factorial
implementation looks like this:
-@smalllisp
+@lisp
[fact1 4]
| [fact1 3]
| | [fact1 2]
@@ -38,11 +38,11 @@ implementation looks like this:
| | 2
| 6
24
-@end smalllisp
+@end lisp
While a typical tail recursive implementation would look more like this:
-@smalllisp
+@lisp
[fact2 4]
[facti 1 4]
[facti 4 3]
@@ -50,7 +50,7 @@ While a typical tail recursive implementation would look more like this:
[facti 24 1]
[facti 24 0]
24
-@end smalllisp
+@end lisp
@deffn {Scheme Procedure} trace procedure
Enable tracing for @code{procedure}. While a program is being run,
diff --git a/doc/ref/scheme-ideas.texi b/doc/ref/scheme-ideas.texi
index 38b105b94..55093cf92 100644
--- a/doc/ref/scheme-ideas.texi
+++ b/doc/ref/scheme-ideas.texi
@@ -390,7 +390,11 @@ this:
@noindent
This is a valid procedure invocation expression, and its result is the
-string @code{"Name=FSF:Address=Cambridge"}.
+string:
+
+@lisp
+"Name=FSF:Address=Cambridge"
+@end lisp
It is more common, though, to store the procedure value in a variable ---
diff --git a/doc/ref/scsh.texi b/doc/ref/scsh.texi
index 0f869ecd7..b1af1a443 100644
--- a/doc/ref/scsh.texi
+++ b/doc/ref/scsh.texi
@@ -19,8 +19,8 @@ For information about scsh see
The closest emulation of scsh can be obtained by running:
-@smalllisp
+@lisp
(load-from-path "scsh/init")
-@end smalllisp
+@end lisp
See the USAGE file supplied with guile-scsh for more details.
diff --git a/doc/ref/slib.texi b/doc/ref/slib.texi
index fc8f91933..d3357c97f 100644
--- a/doc/ref/slib.texi
+++ b/doc/ref/slib.texi
@@ -4,7 +4,6 @@
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
-@page
@node SLIB
@section SLIB
@cindex SLIB
@@ -12,9 +11,9 @@
Before the SLIB facilities can be used, the following Scheme expression
must be executed:
-@smalllisp
+@lisp
(use-modules (ice-9 slib))
-@end smalllisp
+@end lisp
@findex require
@code{require} can then be used in the usual way (@pxref{Require,,,
@@ -64,7 +63,7 @@ Alternatively, you can create a symlink in the Guile directory to SLIB,
e.g.:
@example
-ln -s /usr/local/lib/slib /usr/local/share/guile/1.8/slib
+ln -s /usr/local/lib/slib /usr/local/share/guile/@value{EFFECTIVE-VERSION}/slib
@end example
@item
@@ -78,7 +77,7 @@ guile> (quit)
@end example
The catalog data should now be in
-@file{/usr/local/share/guile/1.8/slibcat}.
+@file{/usr/local/share/guile/@value{EFFECTIVE-VERSION}/slibcat}.
If instead you get an error such as:
@@ -104,11 +103,11 @@ It is usually installed as an extra package in SLIB.
You can use Guile's interface to SLIB to invoke Jacal:
-@smalllisp
+@lisp
(use-modules (ice-9 slib))
(slib:load "math")
(math)
-@end smalllisp
+@end lisp
@noindent
For complete documentation on Jacal, please read the Jacal manual. If
diff --git a/doc/ref/tools.texi b/doc/ref/tools.texi
index f2116dd71..8b0d3a3bb 100644
--- a/doc/ref/tools.texi
+++ b/doc/ref/tools.texi
@@ -232,8 +232,8 @@ is a expression suitable for initializing a new variable.
For procedures, you can use @code{SCM_DEFINE} for most purposes. Use
@code{SCM_PROC} along with @code{SCM_REGISTER_PROC} when you don't
want to be bothered with docstrings. Use @code{SCM_GPROC} for generic
-functions (@pxref{Creating Generic Functions,,, goops, GOOPS}). All
-procedures are declared with return type @code{SCM}.
+functions (@pxref{Creating Generic Functions}). All procedures are
+declared with return type @code{SCM}.
For everything else, use the appropriate macro (@code{SCM_SYMBOL} for
symbols, and so on). Without "_GLOBAL_", the declarations are
@@ -364,7 +364,7 @@ of the form:
@example
(define-module (scripts PROGRAM)
- :export (PROGRAM))
+ #:export (PROGRAM))
@end example
Feel free to export other definitions useful in the module context.
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index dd0c1ebed..fe5c1eeb4 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -13,8 +13,8 @@ procedures can call each other as they please.
The difference is that the compiler creates and interprets bytecode
for a custom virtual machine, instead of interpreting the
-S-expressions directly. Running compiled code is faster than running
-interpreted code.
+S-expressions directly. Loading and running compiled code is faster
+than loading and running source code.
The virtual machine that does the bytecode interpretation is a part of
Guile itself. This section describes the nature of Guile's virtual
@@ -134,7 +134,7 @@ compiled to object code, one might never leave the virtual machine.
@subsection Stack Layout
While not strictly necessary to understand how to work with the VM, it
-is instructive and sometimes entertaining to consider the struture of
+is instructive and sometimes entertaining to consider the structure of
the VM stack.
Logically speaking, a VM stack is composed of ``frames''. Each frame
@@ -159,18 +159,19 @@ The structure of the fixed part of an application frame is as follows:
@example
Stack
- | | <- fp + bp->nargs + bp->nlocs + 4
- +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
- | Return address |
- | MV return address|
- | Dynamic link |
- | External link | <- fp + bp->nargs + bp->nlocs
- | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
+ | ... |
+ | Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs = SCM_FRAME_UPPER_ADDRESS (fp)
+ +==================+
+ | Local variable 1 |
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
- +------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
+ +------------------+
+ | Return address |
+ | MV return address|
+ | Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp)
+ +==================+
| |
@end example
@@ -201,25 +202,17 @@ values being returned.
@item Dynamic link
This is the @code{fp} in effect before this program was applied. In
effect, this and the return address are the registers that are always
-``saved''.
-
-@item External link
-This field is a reference to the list of heap-allocated variables
-associated with this frame. For a discussion of heap versus stack
-allocation, @xref{Variables and the VM}.
+``saved''. The dynamic link links the current frame to the previous
+frame; computing a stack trace involves traversing these frames.
@item Local variable @var{n}
-Lambda-local variables that are allocated on the stack are all
-allocated as part of the frame. This makes access to non-captured,
-non-mutated variables very cheap.
+Lambda-local variables that are all allocated as part of the frame.
+This makes access to variables very cheap.
@item Argument @var{n}
The calling convention of the VM requires arguments of a function
-application to be pushed on the stack, and here they are. Normally
-references to arguments dispatch to these locations on the stack.
-However if an argument has to be stored on the heap, it will be copied
-from its initial value here onto a location in the heap, and
-thereafter only referenced on the heap.
+application to be pushed on the stack, and here they are. References
+to arguments dispatch to these locations on the stack.
@item Program
This is the program being applied. For more information on how
@@ -236,26 +229,44 @@ Consider the following Scheme code as an example:
(lambda (b) (list foo a b)))
@end example
-Within the lambda expression, "foo" is a top-level variable, "a" is a
-lexically captured variable, and "b" is a local variable.
-
-@code{b} may safely be allocated on the stack, as there is no enclosed
-procedure that references it, nor is it ever mutated.
-
-@code{a}, on the other hand, is referenced by an enclosed procedure,
-that of the lambda. Thus it must be allocated on the heap, as it may
-(and will) outlive the dynamic extent of the invocation of @code{foo}.
-
-@code{foo} is a top-level variable, because it names the procedure
-@code{foo}, which is here defined at the top-level.
-
-Note that variables that are mutated (via @code{set!}) must be
-allocated on the heap, even if they are local variables. This is
-because any called subprocedure might capture the continuation, which
-would need to capture locations instead of values. Thus perhaps
-counterintuitively, what would seem ``closer to the metal'', viz
-@code{set!}, actually forces heap allocation instead of stack
-allocation.
+Within the lambda expression, @code{foo} is a top-level variable, @code{a} is a
+lexically captured variable, and @code{b} is a local variable.
+
+Another way to refer to @code{a} and @code{b} is to say that @code{a}
+is a ``free'' variable, since it is not defined within the lambda, and
+@code{b} is a ``bound'' variable. These are the terms used in the
+@dfn{lambda calculus}, a mathematical notation for describing
+functions. The lambda calculus is useful because it allows one to
+prove statements about functions. It is especially good at describing
+scope relations, and it is for that reason that we mention it here.
+
+Guile allocates all variables on the stack. When a lexically enclosed
+procedure with free variables---a @dfn{closure}---is created, it
+copies those variables its free variable vector. References to free
+variables are then redirected through the free variable vector.
+
+If a variable is ever @code{set!}, however, it will need to be
+heap-allocated instead of stack-allocated, so that different closures
+that capture the same variable can see the same value. Also, this
+allows continuations to capture a reference to the variable, instead
+of to its value at one point in time. For these reasons, @code{set!}
+variables are allocated in ``boxes''---actually, in variable cells.
+@xref{Variables}, for more information. References to @code{set!}
+variables are indirected through the boxes.
+
+Thus perhaps counterintuitively, what would seem ``closer to the
+metal'', viz @code{set!}, actually forces an extra memory allocation
+and indirection.
+
+Going back to our example, @code{b} may be allocated on the stack, as
+it is never mutated.
+
+@code{a} may also be allocated on the stack, as it too is never
+mutated. Within the enclosed lambda, its value will be copied into
+(and referenced from) the free variables vector.
+
+@code{foo} is a top-level variable, because @code{foo} is not
+lexically bound in this example.
@node VM Programs
@subsection Compiled Procedures are VM Programs
@@ -297,27 +308,26 @@ scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b)))
scheme@@(guile-user)> ,x foo
Disassembly of #<program foo (a)>:
- 0 (local-ref 0) ;; `a' (arg)
- 2 (external-set 0) ;; `a' (arg)
- 4 (object-ref 1) ;; #<program b70d2910 at <unknown port>:0:16 (b)>
- 6 (make-closure)
- 7 (return)
+ 0 (object-ref 1) ;; #<program b7e478b0 at <unknown port>:0:16 (b)>
+ 2 (local-ref 0) ;; `a' (arg)
+ 4 (vector 0 1) ;; 1 element
+ 7 (make-closure)
+ 8 (return)
----------------------------------------
-Disassembly of #<program b70d2910 at <unknown port>:0:16 (b)>:
+Disassembly of #<program b7e478b0 at <unknown port>:0:16 (b)>:
- 0 (toplevel-ref 1) ;; `foo'
- 2 (external-ref 0) ;; (closure variable)
- 4 (local-ref 0) ;; `b' (arg)
- 6 (list 0 3) ;; 3 elements at (unknown file):0:28
+ 0 (toplevel-ref 1) ;; `foo'
+ 2 (free-ref 0) ;; (closure variable)
+ 4 (local-ref 0) ;; `b' (arg)
+ 6 (list 0 3) ;; 3 elements at (unknown file):0:28
9 (return)
@end smallexample
-At @code{ip} 0 and 2, we do the copy from argument to heap for
-@code{a}. @code{Ip} 4 loads up the compiled lambda, and then at
-@code{ip} 6 we make a closure---binding code (from the compiled
-lambda) with data (the heap-allocated variables). Finally we return
-the closure.
+At @code{ip} 0, we load up the compiled lambda. @code{Ip} 2 and 4
+create the free variables vector, and @code{ip} 7 makes the
+closure---binding code (from the compiled lambda) with data (the
+free-variable vector). Finally we return the closure.
The second stanza disassembles the compiled lambda. Toplevel variables
are resolved relative to the module that was current when the
@@ -336,7 +346,7 @@ routine.
@node Instruction Set
@subsection Instruction Set
-There are about 100 instructions in Guile's virtual machine. These
+There are about 150 instructions in Guile's virtual machine. These
instructions represent atomic units of a program's execution. Ideally,
they perform one task without conditional branches, then dispatch to
the next instruction in the stream.
@@ -376,16 +386,22 @@ instructions. More instructions may be added over time.
* Miscellaneous Instructions::
* Inlined Scheme Instructions::
* Inlined Mathematical Instructions::
+* Inlined Bytevector Instructions::
@end menu
@node Environment Control Instructions
@subsubsection Environment Control Instructions
These instructions access and mutate the environment of a compiled
-procedure---the local bindings, the ``external'' bindings, and the
+procedure---the local bindings, the free (captured) bindings, and the
toplevel bindings.
+Some of these instructions have @code{long-} variants, the difference
+being that they take 16-bit arguments, encoded in big-endianness,
+instead of the normal 8-bit range.
+
@deffn Instruction local-ref index
+@deffnx Instruction long-local-ref index
Push onto the stack the value of the local variable located at
@var{index} within the current stack frame.
@@ -395,26 +411,62 @@ arguments.
@end deffn
@deffn Instruction local-set index
+@deffnx Instruction long-local-ref index
Pop the Scheme object located on top of the stack and make it the new
value of the local variable located at @var{index} within the current
stack frame.
@end deffn
-@deffn Instruction external-ref index
-Push the value of the closure variable located at position
-@var{index} within the program's list of external variables.
+@deffn Instruction free-ref index
+Push the value of the captured variable located at position
+@var{index} within the program's vector of captured variables.
@end deffn
-@deffn Instruction external-set index
-Pop the Scheme object located on top of the stack and make it the new
-value of the closure variable located at @var{index} within the
-program's list of external variables.
+@deffn Instruction free-boxed-ref index
+@deffnx Instruction free-boxed-set index
+Get or set a boxed free variable. Note that there is no free-set
+instruction, as variables that are @code{set!} must be boxed.
+
+These instructions assume that the value at position @var{index} in
+the free variables vector is a variable.
+@end deffn
+
+@deffn Instruction make-closure
+Pop a vector and a program object off the stack, in that order, and
+push a new program object with the given free variables vector. The
+new program object shares state with the original program.
+
+At the time of this writing, the space overhead of closures is 4 words
+per closure.
@end deffn
-The external variable lookup algorithm should probably be made more
-efficient in the future via addressing by frame and index. Currently,
-external variables are all consed onto a list, which results in O(N)
-lookup time.
+@deffn Instruction fix-closure index
+Pop a vector off the stack, and set it as the @var{index}th local
+variable's free variable vector. The @var{index}th local variable is
+assumed to be a procedure.
+
+This instruction is part of a hack for allocating mutually recursive
+procedures. The hack is to first perform a @code{local-set} for all of
+the recursive procedures, then fix up the procedures' free variable
+bindings in place. This allows most @code{letrec}-bound procedures to
+be allocated unboxed on the stack.
+
+One could of course do a @code{local-ref}, then @code{make-closure},
+then @code{local-set}, but this macroinstruction helps to speed up the
+common case.
+@end deffn
+
+@deffn Instruction box index
+Pop a value off the stack, and set the @var{index}nth local variable
+to a box containing that value. A shortcut for @code{make-variable}
+then @code{local-set}, used when binding boxed variables.
+@end deffn
+
+@deffn Instruction empty-box index
+Set the @var{indext}h local variable to a box containing a variable
+whose value is unbound. Used when compiling some @code{letrec}
+expressions.
+@end deffn
@deffn Instruction toplevel-ref index
@deffnx Instruction long-toplevel-ref index
@@ -442,9 +494,6 @@ in-place mutation of the object table. This mechanism provides for
lazy variable resolution, and an important cached fast-path once the
variable has been successfully resolved.
-The ``long'' variant has a 16-bit index instead of an 8-bit index,
-with the most significant byte first.
-
This instruction pushes the value of the variable onto the stack.
@end deffn
@@ -453,8 +502,13 @@ This instruction pushes the value of the variable onto the stack.
Pop a value off the stack, and set it as the value of the toplevel
variable stored at @var{index} in the object table. If the variable
has not yet been looked up, we do the lookup as in
-@code{toplevel-ref}. The ``long'' variant has a 16-bit index instead
-of an 8-bit index.
+@code{toplevel-ref}.
+@end deffn
+
+@deffn Instruction define
+Pop a symbol and a value from the stack, in that order. Look up its
+binding in the current toplevel environment, creating the binding if
+necessary. Set the variable to the value.
@end deffn
@deffn Instruction link-now
@@ -476,6 +530,11 @@ Pop off two objects from the stack, a variable and a value, and set
the variable to the value.
@end deffn
+@deffn Instruction make-variable
+Replace the top object on the stack with a variable containing it.
+Used in some circumstances when compiling @code{letrec} expressions.
+@end deffn
+
@deffn Instruction object-ref n
@deffnx Instruction long-object-ref n
Push @var{n}th value from the current program's object vector. The
@@ -499,7 +558,10 @@ the one to which the instruction pointer points).
@end itemize
Note that the offset passed to the instruction is encoded on two 8-bit
-integers which are then combined by the VM as one 16-bit integer.
+integers which are then combined by the VM as one 16-bit integer. Note
+also that jump targets in Guile are aligned on 8-byte boundaries, and
+that the offset refers to the @var{n}th 8-byte boundary, effectively
+giving Guile a 19-bit relative address space.
@deffn Instruction br offset
Jump to @var{offset}.
@@ -550,19 +612,21 @@ Load an arbitrary number from the instruction stream. The number is
embedded in the stream as a string.
@end deffn
@deffn Instruction load-string length
-Load a string from the instruction stream.
+Load a string from the instruction stream. The string is assumed to be
+encoded in the ``latin1'' locale.
@end deffn
-@deffn Instruction load-symbol length
-Load a symbol from the instruction stream.
+@deffn Instruction load-wide-string length
+Load a UTF-32 string from the instruction stream. @var{length} is the
+length in bytes, not in codepoints
@end deffn
-@deffn Instruction load-keyword length
-Load a keyword from the instruction stream.
+@deffn Instruction load-symbol length
+Load a symbol from the instruction stream. The symbol is assumed to be
+encoded in the ``latin1'' locale. Symbols backed by wide strings may
+be loaded via @code{load-wide-string} then @code{make-symbol}.
@end deffn
-
-@deffn Instruction define length
-Load a symbol from the instruction stream, and look up its binding in
-the current toplevel environment, creating the binding if necessary.
-Push the variable corresponding to the binding.
+@deffn Instruction load-array length
+Load a uniform array from the instruction stream. The shape and type
+of the array are popped off the stack, in that order.
@end deffn
@deffn Instruction load-program
@@ -579,54 +643,38 @@ because instead of parsing its data, it directly maps the instruction
stream onto a C structure, @code{struct scm_objcode}. @xref{Bytecode
and Objcode}, for more information.
-The resulting compiled procedure will not have any ``external''
-variables captured, so it may be loaded only once but used many times
-to create closures.
-@end deffn
-
-Finally, while this instruction is not strictly a ``loading''
-instruction, it's useful to wind up the @code{load-program} discussion
-here:
-
-@deffn Instruction make-closure
-Pop the program object from the stack, capture the current set of
-``external'' variables, and assign those external variables to a copy
-of the program. Push the new program object, which shares state with
-the original program.
-
-At the time of this writing, the space overhead of closures is 4 words
-per closure.
+The resulting compiled procedure will not have any free variables
+captured, so it may be loaded only once but used many times to create
+closures.
@end deffn
@node Procedural Instructions
@subsubsection Procedural Instructions
-@deffn Instruction return
-Free the program's frame, returning the top value from the stack to
-the current continuation. (The stack should have exactly one value on
-it.)
-
-Specifically, the @code{sp} is decremented to one below the current
-@code{fp}, the @code{ip} is reset to the current return address, the
-@code{fp} is reset to the value of the current dynamic link, and then
-the top item on the stack (formerly the procedure being applied) is
-set to the returned value.
+@deffn Instructions new-frame
+Push a new frame on the stack, reserving space for the dynamic link,
+return address, and the multiple-values return address. The frame
+pointer is not yet updated, because the frame is not yet active -- it
+has to be patched by a @code{call} instruction to get the return
+address.
@end deffn
@deffn Instruction call nargs
Call the procedure located at @code{sp[-nargs]} with the @var{nargs}
arguments located from @code{sp[-nargs + 1]} to @code{sp[0]}.
-For compiled procedures, this instruction sets up a new stack frame,
-as described in @ref{Stack Layout}, and then dispatches to the first
-instruction in the called procedure, relying on the called procedure
-to return one value to the newly-created continuation. Because the new
-frame pointer will point to sp[-nargs + 1], the arguments don't have
-to be shuffled around -- they are already in place.
+This instruction requires that a new frame be pushed on the stack
+before the procedure, via @code{new-frame}. @xref{Stack Layout}, for
+more information. It patches up that frame with the current @code{ip}
+as the return address, then dispatches to the first instruction in the
+called procedure, relying on the called procedure to return one value
+to the newly-created continuation. Because the new frame pointer will
+point to sp[-nargs + 1], the arguments don't have to be shuffled
+around -- they are already in place.
For non-compiled procedures (continuations, primitives, and
-interpreted procedures), @code{call} will pop the procedure and
-arguments off the stack, and push the result of calling
+interpreted procedures), @code{call} will pop the frame, procedure,
+and arguments off the stack, and push the result of calling
@code{scm_apply}.
@end deffn
@@ -634,10 +682,10 @@ arguments off the stack, and push the result of calling
Like @code{call}, but reusing the current continuation. This
instruction implements tail calls as required by RnRS.
-For compiled procedures, that means that @code{goto/args} reuses the
-current frame instead of building a new one. The @code{goto/*}
-instruction family is named as it is because tail calls are equivalent
-to @code{goto}, along with relabeled variables.
+For compiled procedures, that means that @code{goto/args} simply
+shuffles down the procedure and arguments to the current stack frame.
+The @code{goto/*} instruction family is named as it is because tail
+calls are equivalent to @code{goto}, along with relabeled variables.
For non-VM procedures, the result is the same, but the current VM
invocation remains on the C stack. True tail calls are not currently
@@ -660,15 +708,6 @@ These instructions are used in the implementation of multiple value
returns, where the actual number of values is pushed on the stack.
@end deffn
-@deffn Instruction call/cc
-@deffnx Instruction goto/cc
-Capture the current continuation, and then call (or tail-call) the
-procedure on the top of the stack, with the continuation as the
-argument.
-
-Both the VM continuation and the C continuation are captured.
-@end deffn
-
@deffn Instruction mv-call nargs offset
Like @code{call}, except that a multiple-value continuation is created
in addition to a single-value continuation.
@@ -681,6 +720,18 @@ the stack to be the number of values, and below that values
themselves, pushed separately.
@end deffn
+@deffn Instruction return
+Free the program's frame, returning the top value from the stack to
+the current continuation. (The stack should have exactly one value on
+it.)
+
+Specifically, the @code{sp} is decremented to one below the current
+@code{fp}, the @code{ip} is reset to the current return address, the
+@code{fp} is reset to the value of the current dynamic link, and then
+the top item on the stack (formerly the procedure being applied) is
+set to the returned value.
+@end deffn
+
@deffn Instruction return/values nvalues
Return the top @var{nvalues} to the current continuation.
@@ -715,6 +766,19 @@ be 1 (to indicate that one of the bindings was a rest argument).
Signals an error if there is an insufficient number of values.
@end deffn
+@deffn Instruction call/cc
+@deffnx Instruction goto/cc
+Capture the current continuation, and then call (or tail-call) the
+procedure on the top of the stack, with the continuation as the
+argument.
+
+@code{call/cc} does not require a @code{new-frame} to be pushed on the
+stack, as @code{call} does, because it needs to capture the stack
+before the frame is pushed.
+
+Both the VM continuation and the C continuation are captured.
+@end deffn
+
@node Data Control Instructions
@subsubsection Data Control Instructions
@@ -768,6 +832,19 @@ Push @code{'()} onto the stack.
Push @var{value}, an 8-bit character, onto the stack.
@end deffn
+@deffn Instruction make-char32 value
+Push @var{value}, an 32-bit character, onto the stack. The value is
+encoded in big-endian order.
+@end deffn
+
+@deffn Instruction make-symbol
+Pops a string off the stack, and pushes a symbol.
+@end deffn
+
+@deffn Instruction make-keyword value
+Pops a symbol off the stack, and pushes a keyword.
+@end deffn
+
@deffn Instruction list n
Pops off the top @var{n} values off of the stack, consing them up into
a list, then pushes that list on the stack. What was the topmost value
@@ -781,37 +858,12 @@ popping off those values and pushing on the resulting vector. @var{n}
is a two-byte value, like in @code{vector}.
@end deffn
-@deffn Instruction mark
-Pushes a special value onto the stack that other stack instructions
-like @code{list-mark} can use.
-@end deffn
-
-@deffn Instruction list-mark
-Create a list from values from the stack, as in @code{list}, but
-instead of knowing beforehand how many there will be, keep going until
-we see a @code{mark} value.
-@end deffn
-
-@deffn Instruction cons-mark
-As the scheme procedure @code{cons*} is to the scheme procedure
-@code{list}, so the instruction @code{cons-mark} is to the instruction
-@code{list-mark}.
-@end deffn
-
-@deffn Instruction vector-mark
-Like @code{list-mark}, but makes a vector instead of a list.
-@end deffn
-
-@deffn Instruction list-break
-The opposite of @code{list}: pops a value, which should be a list, and
-pushes its elements on the stack.
-@end deffn
-
@node Miscellaneous Instructions
@subsubsection Miscellaneous Instructions
@deffn Instruction nop
-Does nothing!
+Does nothing! Used for padding other instructions to certain
+alignments.
@end deffn
@deffn Instruction halt
@@ -877,6 +929,8 @@ stream.
@deffnx Instruction cons x y
@deffnx Instruction car x
@deffnx Instruction cdr x
+@deffnx Instruction vector-ref x y
+@deffnx Instruction vector-set x n y
Inlined implementations of their Scheme equivalents.
@end deffn
@@ -897,7 +951,9 @@ As in the previous section, the definitions below show stack
parameters instead of instruction stream parameters.
@deffn Instruction add x y
+@deffnx Instruction add1 x
@deffnx Instruction sub x y
+@deffnx Instruction sub1 x
@deffnx Instruction mul x y
@deffnx Instruction div x y
@deffnx Instruction quo x y
@@ -910,3 +966,58 @@ parameters instead of instruction stream parameters.
@deffnx Instruction ge? x y
Inlined implementations of the corresponding mathematical operations.
@end deffn
+
+@node Inlined Bytevector Instructions
+@subsubsection Inlined Bytevector Instructions
+
+Bytevector operations correspond closely to what the current hardware
+can do, so it makes sense to inline them to VM instructions, providing
+a clear path for eventual native compilation. Without this, Scheme
+programs would need other primitives for accessing raw bytes -- but
+these primitives are as good as any.
+
+As in the previous section, the definitions below show stack
+parameters instead of instruction stream parameters.
+
+The multibyte formats (@code{u16}, @code{f64}, etc) take an extra
+endianness argument. Only aligned native accesses are currently
+fast-pathed in Guile's VM.
+
+@deffn Instruction bv-u8-ref bv n
+@deffnx Instruction bv-s8-ref bv n
+@deffnx Instruction bv-u16-native-ref bv n
+@deffnx Instruction bv-s16-native-ref bv n
+@deffnx Instruction bv-u32-native-ref bv n
+@deffnx Instruction bv-s32-native-ref bv n
+@deffnx Instruction bv-u64-native-ref bv n
+@deffnx Instruction bv-s64-native-ref bv n
+@deffnx Instruction bv-f32-native-ref bv n
+@deffnx Instruction bv-f64-native-ref bv n
+@deffnx Instruction bv-u16-ref bv n endianness
+@deffnx Instruction bv-s16-ref bv n endianness
+@deffnx Instruction bv-u32-ref bv n endianness
+@deffnx Instruction bv-s32-ref bv n endianness
+@deffnx Instruction bv-u64-ref bv n endianness
+@deffnx Instruction bv-s64-ref bv n endianness
+@deffnx Instruction bv-f32-ref bv n endianness
+@deffnx Instruction bv-f64-ref bv n endianness
+@deffnx Instruction bv-u8-set bv n val
+@deffnx Instruction bv-s8-set bv n val
+@deffnx Instruction bv-u16-native-set bv n val
+@deffnx Instruction bv-s16-native-set bv n val
+@deffnx Instruction bv-u32-native-set bv n val
+@deffnx Instruction bv-s32-native-set bv n val
+@deffnx Instruction bv-u64-native-set bv n val
+@deffnx Instruction bv-s64-native-set bv n val
+@deffnx Instruction bv-f32-native-set bv n val
+@deffnx Instruction bv-f64-native-set bv n val
+@deffnx Instruction bv-u16-set bv n val endianness
+@deffnx Instruction bv-s16-set bv n val endianness
+@deffnx Instruction bv-u32-set bv n val endianness
+@deffnx Instruction bv-s32-set bv n val endianness
+@deffnx Instruction bv-u64-set bv n val endianness
+@deffnx Instruction bv-s64-set bv n val endianness
+@deffnx Instruction bv-f32-set bv n val endianness
+@deffnx Instruction bv-f64-set bv n val endianness
+Inlined implementations of the corresponding bytevector operations.
+@end deffn
diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am
index 9df82bcb1..efdcd7523 100644
--- a/guile-readline/Makefile.am
+++ b/guile-readline/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
##
## This file is part of guile-readline.
##
@@ -19,15 +19,24 @@
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
-SUBDIRS = ice-9
-
## Prevent automake from adding extra -I options
DEFS = @DEFS@ @EXTRA_DEFS@
+
+if HAVE_READLINE
+
+# `ice-9' subdirectory.
+ice9dir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)
+nobase_ice9_DATA = ice-9/readline.scm
+EXTRA_DIST = $(nobase_ice9_DATA)
+
+
## Check for headers in $(srcdir)/.., so that #include
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
## building. Also look for Gnulib headers in `lib'.
-INCLUDES = -I. -I.. -I$(srcdir)/.. \
- -I$(top_srcdir)/lib -I$(top_builddir)/lib
+AM_CPPFLAGS = -I. -I.. -I$(srcdir)/.. \
+ -I$(top_srcdir)/lib -I$(top_builddir)/lib
+
+AM_CFLAGS = $(GCC_CFLAGS)
GUILE_SNARF = ../libguile/guile-snarf
@@ -35,25 +44,33 @@ lib_LTLIBRARIES = libguilereadline-v-@LIBGUILEREADLINE_MAJOR@.la
libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES = readline.c
libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LIBADD = \
- ../libguile/libguile.la ../lib/libgnu.la
-libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LDFLAGS = -version-info @LIBGUILEREADLINE_INTERFACE@ -export-dynamic -no-undefined
+ $(READLINE_LIBS) \
+ ../libguile/libguile.la ../lib/libgnu.la
+
+libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LDFLAGS = \
+ -version-info @LIBGUILEREADLINE_INTERFACE@ -export-dynamic \
+ -no-undefined
BUILT_SOURCES = readline.x
pkginclude_HEADERS = readline.h
-snarfcppopts = $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+snarfcppopts = $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS)
SUFFIXES = .x
.c.x:
$(GUILE_SNARF) -o $@ $< $(snarfcppopts)
-EXTRA_DIST = LIBGUILEREADLINE-VERSION ChangeLog-2008
+EXTRA_DIST += LIBGUILEREADLINE-VERSION ChangeLog-2008
-MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+ETAGS_ARGS = \
+ $(nobase_ice9_DATA) \
+ $(libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES)
CLEANFILES = *.x
+endif HAVE_READLINE
+
dist-hook:
(temp="/tmp/mangle-deps.$$$$"; \
trap "rm -f $$temp" 0 1 2 15; \
diff --git a/guile-readline/autogen.sh b/guile-readline/autogen.sh
deleted file mode 100755
index 76149ba31..000000000
--- a/guile-readline/autogen.sh
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/sh
-
-[ -f readline-activator.scm ] || {
- echo "autogen.sh: run this command only in the guile-readline directory."
- exit 1
-}
-
-autoreconf -i --force
diff --git a/guile-readline/configure.in b/guile-readline/configure.in
deleted file mode 100644
index f24fc9418..000000000
--- a/guile-readline/configure.in
+++ /dev/null
@@ -1,88 +0,0 @@
-AC_PREREQ(2.50)
-
-dnl Don't use "echo -n", which is not portable (e.g., not available on
-dnl MacOS X). Instead, use `patsubst' to remove the newline.
-AC_INIT(guile-readline,
- patsubst(m4_esyscmd(. ../GUILE-VERSION && echo ${GUILE_VERSION}), [
-]),
- [bug-guile@gnu.org])
-
-AC_CONFIG_AUX_DIR([../build-aux])
-AC_CONFIG_SRCDIR(readline.c)
-AM_CONFIG_HEADER([guile-readline-config.h])
-AM_INIT_AUTOMAKE([foreign no-define])
-
-. $srcdir/../GUILE-VERSION
-
-AC_PROG_INSTALL
-AC_PROG_CC
-AM_PROG_CC_STDC
-AC_LIBTOOL_WIN32_DLL
-AC_PROG_LIBTOOL
-
-dnl
-dnl Check for Winsock and other functionality on Win32 (*not* CygWin)
-dnl
-AC_CYGWIN
-AC_MINGW32
-EXTRA_DEFS=""
-if test "$MINGW32" = "yes" ; then
- if test $enable_shared = yes ; then
- EXTRA_DEFS="-DSCM_IMPORT"
- fi
-fi
-AC_SUBST(EXTRA_DEFS)
-
-for termlib in ncurses curses termcap terminfo termlib ; do
- AC_CHECK_LIB(${termlib}, tgoto,
- [LIBS="-l${termlib} $LIBS"; break])
-done
-
-AC_LIB_LINKFLAGS(readline)
-AC_CHECK_LIB(readline, readline)
-if test $ac_cv_lib_readline_readline = no; then
- AC_MSG_WARN([libreadline was not found on your system.])
-fi
-
-AC_CHECK_FUNCS(siginterrupt rl_clear_signals rl_cleanup_after_signal)
-
-dnl Check for modern readline naming
-AC_CHECK_FUNCS(rl_filename_completion_function)
-
-dnl Check for rl_get_keymap. We only use this for deciding whether to
-dnl install paren matching on the Guile command line (when using
-dnl readline for input), so it's completely optional.
-AC_CHECK_FUNCS(rl_get_keymap)
-
-AC_CACHE_CHECK([for rl_getc_function pointer in readline],
- ac_cv_var_rl_getc_function,
- [AC_TRY_LINK([
-#include <stdio.h>
-#include <readline/readline.h>],
- [printf ("%ld", (long) rl_getc_function)],
- [ac_cv_var_rl_getc_function=yes],
- [ac_cv_var_rl_getc_function=no])])
-if test "${ac_cv_var_rl_getc_function}" = "yes"; then
- AC_DEFINE(HAVE_RL_GETC_FUNCTION, 1,
- [Define if your readline library has the rl_getc_function variable.])
-fi
-
-if test $ac_cv_lib_readline_readline = yes \
- -a $ac_cv_var_rl_getc_function = no; then
- AC_MSG_WARN([*** libreadline is too old on your system.])
- AC_MSG_WARN([*** You need readline version 2.1 or later.])
-fi
-
-AC_CHECK_FUNCS(strdup)
-
-. $srcdir/LIBGUILEREADLINE-VERSION
-AC_SUBST(LIBGUILEREADLINE_MAJOR)
-AC_SUBST(LIBGUILEREADLINE_INTERFACE_CURRENT)
-AC_SUBST(LIBGUILEREADLINE_INTERFACE_REVISION)
-AC_SUBST(LIBGUILEREADLINE_INTERFACE_AGE)
-AC_SUBST(LIBGUILEREADLINE_INTERFACE)
-
-AC_SUBST(GUILE_EFFECTIVE_VERSION)
-
-AC_CONFIG_FILES(Makefile ice-9/Makefile)
-AC_OUTPUT
diff --git a/guile-readline/ice-9/Makefile.am b/guile-readline/ice-9/Makefile.am
deleted file mode 100644
index ffa767e99..000000000
--- a/guile-readline/ice-9/Makefile.am
+++ /dev/null
@@ -1,28 +0,0 @@
-## Process this file with Automake to create Makefile.in
-##
-## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
-##
-## This file is part of guile-readline.
-##
-## guile-readline is free software; you can redistribute it and/or
-## modify it under the terms of the GNU General Public License as
-## published by the Free Software Foundation; either version 3, or
-## (at your option) any later version.
-##
-## guile-readline is distributed in the hope that it will be useful,
-## but WITHOUT ANY WARRANTY; without even the implied warranty of
-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-## General Public License for more details.
-##
-## You should have received a copy of the GNU General Public License
-## along with guile-readline; see the file COPYING. If not, write
-## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-## Floor, Boston, MA 02110-1301 USA
-
-# Guile's `pkgdatadir'.
-guile_pdd = $(datadir)/guile
-
-ice9dir = $(guile_pdd)/$(GUILE_EFFECTIVE_VERSION)/ice-9
-ice9_DATA = readline.scm
-ETAGS_ARGS = $(ice9_DATA)
-EXTRA_DIST = $(ice9_DATA)
diff --git a/guile-readline/readline.c b/guile-readline/readline.c
index 7f86ceb3d..cbf4051cc 100644
--- a/guile-readline/readline.c
+++ b/guile-readline/readline.c
@@ -1,6 +1,6 @@
/* readline.c --- line editing support for Guile */
-/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -21,9 +21,9 @@
-
-/* Include private, configure generated header (i.e. config.h). */
-#include "guile-readline-config.h"
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
#ifdef HAVE_RL_GETC_FUNCTION
#include "libguile.h"
diff --git a/lang/elisp/interface.scm b/lang/elisp/interface.scm
index fcd748f65..31864cc8e 100644
--- a/lang/elisp/interface.scm
+++ b/lang/elisp/interface.scm
@@ -20,7 +20,10 @@
(define (eval-elisp x)
"Evaluate the Elisp expression @var{x}."
- (eval x the-elisp-module))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module the-elisp-module)
+ (primitive-eval x))))
(define (translate-elisp x)
"Translate the Elisp expression @var{x} to equivalent Scheme code."
diff --git a/lib/Makefile.am b/lib/Makefile.am
index 424e5906a..0f74b5170 100644
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -9,7 +9,7 @@
# the same distribution terms as the rest of that program.
#
# Generated by gnulib-tool.
-# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf
+# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-versions lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf
AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
@@ -896,6 +896,7 @@ time.h: time.in.h
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@NEXT_TIME_H''@|$(NEXT_TIME_H)|g' \
-e 's|@REPLACE_LOCALTIME_R''@|$(REPLACE_LOCALTIME_R)|g' \
+ -e 's|@REPLACE_MKTIME''@|$(REPLACE_MKTIME)|g' \
-e 's|@REPLACE_NANOSLEEP''@|$(REPLACE_NANOSLEEP)|g' \
-e 's|@REPLACE_STRPTIME''@|$(REPLACE_STRPTIME)|g' \
-e 's|@REPLACE_TIMEGM''@|$(REPLACE_TIMEGM)|g' \
@@ -972,6 +973,7 @@ unistd.h: unistd.in.h
-e 's|@''HAVE_SYS_PARAM_H''@|$(HAVE_SYS_PARAM_H)|g' \
-e 's|@''REPLACE_CHOWN''@|$(REPLACE_CHOWN)|g' \
-e 's|@''REPLACE_CLOSE''@|$(REPLACE_CLOSE)|g' \
+ -e 's|@''REPLACE_DUP2''@|$(REPLACE_DUP2)|g' \
-e 's|@''REPLACE_FCHDIR''@|$(REPLACE_FCHDIR)|g' \
-e 's|@''REPLACE_GETCWD''@|$(REPLACE_GETCWD)|g' \
-e 's|@''REPLACE_GETPAGESIZE''@|$(REPLACE_GETPAGESIZE)|g' \
diff --git a/lib/iconv_open-aix.h b/lib/iconv_open-aix.h
index 0ffc3fef1..a598e819d 100644
--- a/lib/iconv_open-aix.h
+++ b/lib/iconv_open-aix.h
@@ -229,7 +229,7 @@ static const struct mapping mappings[] =
#ifdef __GNUC__
__inline
-#ifdef __GNUC_STDC_INLINE__
+#if defined __GNUC_STDC_INLINE__ || defined __GNUC_GNU_INLINE__
__attribute__ ((__gnu_inline__))
#endif
#endif
diff --git a/lib/time.in.h b/lib/time.in.h
index 7da429a54..cef4e0546 100644
--- a/lib/time.in.h
+++ b/lib/time.in.h
@@ -1,6 +1,6 @@
/* A more-standard <time.h>.
- Copyright (C) 2007-2008 Free Software Foundation, Inc.
+ Copyright (C) 2007-2009 Free Software Foundation, Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@@ -66,6 +66,12 @@ struct timespec
int nanosleep (struct timespec const *__rqtp, struct timespec *__rmtp);
# endif
+/* Return the 'time_t' representation of TP and normalize TP. */
+# if @REPLACE_MKTIME@
+# define mktime rpl_mktime
+extern time_t mktime (struct tm *__tp);
+# endif
+
/* Convert TIMER to RESULT, assuming local time and UTC respectively. See
<http://www.opengroup.org/susv3xsh/localtime_r.html> and
<http://www.opengroup.org/susv3xsh/gmtime_r.html>. */
diff --git a/lib/unistd.in.h b/lib/unistd.in.h
index 2e42c0b89..e2545cbca 100644
--- a/lib/unistd.in.h
+++ b/lib/unistd.in.h
@@ -150,10 +150,13 @@ extern int close (int);
#if @GNULIB_DUP2@
-# if !@HAVE_DUP2@
+# if @REPLACE_DUP2@
+# define dup2 rpl_dup2
+# endif
+# if !@HAVE_DUP2@ || @REPLACE_DUP2@
/* Copy the file descriptor OLDFD into file descriptor NEWFD. Do nothing if
NEWFD = OLDFD, otherwise close NEWFD first if it is open.
- Return 0 if successful, otherwise -1 and errno set.
+ Return newfd if successful, otherwise -1 and errno set.
See the POSIX:2001 specification
<http://www.opengroup.org/susv3xsh/dup2.html>. */
extern int dup2 (int oldfd, int newfd);
@@ -214,7 +217,11 @@ extern int fchdir (int /*fd*/);
# define dup rpl_dup
extern int dup (int);
-# define dup2 rpl_dup2
+
+# if @REPLACE_DUP2@
+# undef dup2
+# endif
+# define dup2 rpl_dup2_fchdir
extern int dup2 (int, int);
# endif
diff --git a/libguile.h b/libguile.h
index 7b5649b8f..74674d5b9 100644
--- a/libguile.h
+++ b/libguile.h
@@ -31,8 +31,12 @@ extern "C" {
#include "libguile/__scm.h"
#include "libguile/alist.h"
#include "libguile/arbiters.h"
+#include "libguile/array-handle.h"
+#include "libguile/array-map.h"
+#include "libguile/arrays.h"
#include "libguile/async.h"
#include "libguile/boolean.h"
+#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
#include "libguile/chars.h"
#include "libguile/continuations.h"
@@ -50,6 +54,8 @@ extern "C" {
#include "libguile/futures.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
+#include "libguile/generalized-arrays.h"
+#include "libguile/generalized-vectors.h"
#include "libguile/goops.h"
#include "libguile/gsubr.h"
#include "libguile/guardians.h"
@@ -78,7 +84,6 @@ extern "C" {
#include "libguile/properties.h"
#include "libguile/procs.h"
#include "libguile/r6rs-ports.h"
-#include "libguile/ramap.h"
#include "libguile/random.h"
#include "libguile/read.h"
#include "libguile/root.h"
@@ -101,7 +106,7 @@ extern "C" {
#include "libguile/symbols.h"
#include "libguile/tags.h"
#include "libguile/throw.h"
-#include "libguile/unif.h"
+#include "libguile/uniform.h"
#include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/variable.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 8c9c598bf..d4d1a549f 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -105,27 +105,109 @@ guile_LDFLAGS = $(GUILE_CFLAGS)
libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
-libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
- bytevectors.c chars.c continuations.c \
- convert.c debug.c deprecation.c \
- deprecated.c discouraged.c dynwind.c eq.c error.c \
- eval.c evalext.c extensions.c feature.c fluids.c fports.c \
- futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \
- gc-freelist.c gc_os_dep.c gdbint.c gettext.c gc-segment-table.c \
- goops.c gsubr.c \
- guardians.c hash.c hashtab.c hooks.c init.c inline.c \
- ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \
- modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \
- print.c procprop.c procs.c properties.c \
- r6rs-ports.c random.c rdelim.c read.c \
- root.c rw.c scmsigs.c script.c simpos.c smob.c sort.c srcprop.c \
- stackchk.c stacks.c stime.c strings.c srfi-4.c srfi-13.c srfi-14.c \
- strorder.c strports.c struct.c symbols.c threads.c null-threads.c \
- throw.c values.c variable.c vectors.c version.c vports.c weaks.c \
- ramap.c unif.c
-
-# vm-related sources
-libguile_la_SOURCES += frames.c instructions.c objcodes.c programs.c vm.c
+libguile_la_SOURCES = \
+ alist.c \
+ arbiters.c \
+ array-handle.c \
+ array-map.c \
+ arrays.c \
+ async.c \
+ backtrace.c \
+ boolean.c \
+ bitvectors.c \
+ bytevectors.c \
+ chars.c \
+ continuations.c \
+ debug.c \
+ deprecated.c \
+ deprecation.c \
+ discouraged.c \
+ dynwind.c \
+ eq.c \
+ error.c \
+ eval.c \
+ evalext.c \
+ extensions.c \
+ feature.c \
+ fluids.c \
+ fports.c \
+ frames.c \
+ futures.c \
+ gc-card.c \
+ gc-freelist.c \
+ gc-malloc.c \
+ gc-mark.c \
+ gc-segment-table.c \
+ gc-segment.c \
+ gc.c \
+ gc_os_dep.c \
+ gdbint.c \
+ gettext.c \
+ generalized-arrays.c \
+ generalized-vectors.c \
+ goops.c \
+ gsubr.c \
+ guardians.c \
+ hash.c \
+ hashtab.c \
+ hooks.c \
+ init.c \
+ inline.c \
+ instructions.c \
+ ioext.c \
+ keywords.c \
+ lang.c \
+ list.c \
+ load.c \
+ macros.c \
+ mallocs.c \
+ modules.c \
+ null-threads.c \
+ numbers.c \
+ objcodes.c \
+ objects.c \
+ objprop.c \
+ options.c \
+ pairs.c \
+ ports.c \
+ print.c \
+ procprop.c \
+ procs.c \
+ programs.c \
+ properties.c \
+ r6rs-ports.c \
+ random.c \
+ rdelim.c \
+ read.c \
+ root.c \
+ rw.c \
+ scmsigs.c \
+ script.c \
+ simpos.c \
+ smob.c \
+ sort.c \
+ srcprop.c \
+ srfi-13.c \
+ srfi-14.c \
+ srfi-4.c \
+ stackchk.c \
+ stacks.c \
+ stime.c \
+ strings.c \
+ strorder.c \
+ strports.c \
+ struct.c \
+ symbols.c \
+ threads.c \
+ throw.c \
+ uniform.c \
+ values.c \
+ variable.c \
+ vectors.c \
+ version.c \
+ vm.c \
+ vports.c \
+ weaks.c
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
@@ -136,48 +218,202 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
-module -L$(builddir) -lguile \
-version-info @LIBGUILE_I18N_INTERFACE@
-DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x \
- bytevectors.x chars.x \
- continuations.x debug.x deprecation.x deprecated.x discouraged.x \
- dynl.x dynwind.x eq.x error.x eval.x evalext.x \
- extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \
- gc-segment.x gc-malloc.x gc-card.x gettext.x goops.x \
- gsubr.x guardians.x gc-segment-table.x \
- hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \
- list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \
- objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \
- properties.x r6rs-ports.x random.x rdelim.x \
- read.x root.x rw.x scmsigs.x \
- script.x simpos.x smob.x sort.x srcprop.x stackchk.x stacks.x \
- stime.x strings.x srfi-4.x srfi-13.x srfi-14.x strorder.x \
- strports.x struct.x symbols.x threads.x throw.x values.x \
- variable.x vectors.x version.x vports.x weaks.x ramap.x unif.x
+DOT_X_FILES = \
+ alist.x \
+ arbiters.x \
+ array-handle.x \
+ array-map.x \
+ arrays.x \
+ async.x \
+ backtrace.x \
+ boolean.x \
+ bitvectors.x \
+ bytevectors.x \
+ chars.x \
+ continuations.x \
+ debug.x \
+ deprecated.x \
+ deprecation.x \
+ discouraged.x \
+ dynl.x \
+ dynwind.x \
+ eq.x \
+ error.x \
+ eval.x \
+ evalext.x \
+ extensions.x \
+ feature.x \
+ fluids.x \
+ fports.x \
+ futures.x \
+ gc-card.x \
+ gc-malloc.x \
+ gc-mark.x \
+ gc-segment-table.x \
+ gc-segment.x \
+ gc.x \
+ gettext.x \
+ generalized-arrays.x \
+ generalized-vectors.x \
+ goops.x \
+ gsubr.x \
+ guardians.x \
+ hash.x \
+ hashtab.x \
+ hooks.x \
+ i18n.x \
+ init.x \
+ ioext.x \
+ keywords.x \
+ lang.x \
+ list.x \
+ load.x \
+ macros.x \
+ mallocs.x \
+ modules.x \
+ numbers.x \
+ objects.x \
+ objprop.x \
+ options.x \
+ pairs.x \
+ ports.x \
+ print.x \
+ procprop.x \
+ procs.x \
+ properties.x \
+ r6rs-ports.x \
+ random.x \
+ rdelim.x \
+ read.x \
+ root.x \
+ rw.x \
+ scmsigs.x \
+ script.x \
+ simpos.x \
+ smob.x \
+ sort.x \
+ srcprop.x \
+ srfi-13.x \
+ srfi-14.x \
+ srfi-4.x \
+ stackchk.x \
+ stacks.x \
+ stime.x \
+ strings.x \
+ strorder.x \
+ strports.x \
+ struct.x \
+ symbols.x \
+ threads.x \
+ throw.x \
+ uniform.x \
+ values.x \
+ variable.x \
+ vectors.x \
+ version.x \
+ vports.x \
+ weaks.x
# vm-related snarfs
DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
-DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
- boolean.doc bytevectors.doc chars.doc \
- continuations.doc debug.doc deprecation.doc \
- deprecated.doc discouraged.doc dynl.doc dynwind.doc \
- eq.doc error.doc eval.doc evalext.doc \
- extensions.doc feature.doc fluids.doc fports.doc futures.doc \
- gc.doc goops.doc gsubr.doc gc-mark.doc gc-segment.doc \
- gc-malloc.doc gc-card.doc gettext.doc gc-segment-table.doc \
- guardians.doc hash.doc hashtab.doc \
- hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \
- list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \
- objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \
- procprop.doc procs.doc properties.doc r6rs-ports.doc \
- random.doc rdelim.doc \
- read.doc root.doc rw.doc scmsigs.doc script.doc simpos.doc \
- smob.doc sort.doc srcprop.doc stackchk.doc stacks.doc stime.doc \
- strings.doc srfi-4.doc srfi-13.doc srfi-14.doc strorder.doc \
- strports.doc struct.doc symbols.doc threads.doc throw.doc \
- values.doc variable.doc vectors.doc version.doc vports.doc \
- weaks.doc ramap.doc unif.doc
+DOT_DOC_FILES = \
+ alist.doc \
+ arbiters.doc \
+ array-handle.doc \
+ array-map.doc \
+ arrays.doc \
+ async.doc \
+ backtrace.doc \
+ boolean.doc \
+ bitvectors.doc \
+ bytevectors.doc \
+ chars.doc \
+ continuations.doc \
+ debug.doc \
+ deprecated.doc \
+ deprecation.doc \
+ discouraged.doc \
+ dynl.doc \
+ dynwind.doc \
+ eq.doc \
+ error.doc \
+ eval.doc \
+ evalext.doc \
+ extensions.doc \
+ feature.doc \
+ fluids.doc \
+ fports.doc \
+ futures.doc \
+ gc-card.doc \
+ gc-malloc.doc \
+ gc-mark.doc \
+ gc-segment-table.doc \
+ gc-segment.doc \
+ gc.doc \
+ gettext.doc \
+ generalized-arrays.doc \
+ generalized-vectors.doc \
+ goops.doc \
+ gsubr.doc \
+ guardians.doc \
+ hash.doc \
+ hashtab.doc \
+ hooks.doc \
+ i18n.doc \
+ init.doc \
+ ioext.doc \
+ keywords.doc \
+ lang.doc \
+ list.doc \
+ load.doc \
+ macros.doc \
+ mallocs.doc \
+ modules.doc \
+ numbers.doc \
+ objects.doc \
+ objprop.doc \
+ options.doc \
+ pairs.doc \
+ ports.doc \
+ print.doc \
+ procprop.doc \
+ procs.doc \
+ properties.doc \
+ r6rs-ports.doc \
+ random.doc \
+ rdelim.doc \
+ read.doc \
+ root.doc \
+ rw.doc \
+ scmsigs.doc \
+ script.doc \
+ simpos.doc \
+ smob.doc \
+ sort.doc \
+ srcprop.doc \
+ srfi-13.doc \
+ srfi-14.doc \
+ srfi-4.doc \
+ stackchk.doc \
+ stacks.doc \
+ stime.doc \
+ strings.doc \
+ strorder.doc \
+ strports.doc \
+ struct.doc \
+ symbols.doc \
+ threads.doc \
+ throw.doc \
+ uniform.doc \
+ values.doc \
+ variable.doc \
+ vectors.doc \
+ version.doc \
+ vports.doc \
+ weaks.doc
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
@@ -208,10 +444,9 @@ install-exec-hook:
## compile, since they are #included. So instead we list them here.
## Perhaps we can deal with them normally once the merge seems to be
## working.
-noinst_HEADERS = convert.i.c \
- conv-integer.i.c conv-uinteger.i.c \
+noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
eval.i.c ieee-754.h \
- srfi-4.i.c \
+ srfi-4.i.c srfi-14.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
private-gc.h private-options.h
@@ -220,36 +455,134 @@ noinst_HEADERS = convert.i.c \
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)
+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
+if HAVE_LD_VERSION_SCRIPT
+
+libguile_la_LDFLAGS += -Wl,--version-script="$(srcdir)/libguile.map"
+
+endif HAVE_LD_VERSION_SCRIPT
+
+
# These are headers visible as <guile/mumble.h>
pkginclude_HEADERS =
# These are headers visible as <libguile/mumble.h>.
modincludedir = $(includedir)/libguile
-modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
- boolean.h bytevectors.h chars.h continuations.h convert.h \
- debug.h debug-malloc.h \
- deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \
- eq.h error.h eval.h evalext.h extensions.h \
- feature.h filesys.h fluids.h fports.h futures.h gc.h \
- gdb_interface.h gdbint.h gettext.h goops.h \
- gsubr.h guardians.h hash.h \
- hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \
- keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \
- net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \
- posix.h r6rs-ports.h regex-posix.h print.h \
- procprop.h procs.h properties.h \
- random.h ramap.h rdelim.h read.h root.h rw.h scmsigs.h validate.h \
- script.h simpos.h smob.h snarf.h socket.h sort.h srcprop.h \
- stackchk.h stacks.h stime.h strings.h srfi-4.h srfi-13.h srfi-14.h \
- strorder.h strports.h struct.h symbols.h tags.h threads.h \
- pthread-threads.h null-threads.h throw.h unif.h values.h \
- variable.h vectors.h vports.h weaks.h
-
-modinclude_HEADERS += vm-bootstrap.h frames.h instructions.h objcodes.h \
- programs.h vm.h vm-engine.h vm-expand.h
+modinclude_HEADERS = \
+ __scm.h \
+ alist.h \
+ arbiters.h \
+ array-handle.h \
+ array-map.h \
+ arrays.h \
+ async.h \
+ backtrace.h \
+ boolean.h \
+ bitvectors.h \
+ bytevectors.h \
+ chars.h \
+ continuations.h \
+ debug-malloc.h \
+ debug.h \
+ deprecated.h \
+ deprecation.h \
+ discouraged.h \
+ dynl.h \
+ dynwind.h \
+ eq.h \
+ error.h \
+ eval.h \
+ evalext.h \
+ extensions.h \
+ feature.h \
+ filesys.h \
+ fluids.h \
+ fports.h \
+ frames.h \
+ futures.h \
+ gc.h \
+ gdb_interface.h \
+ gdbint.h \
+ gettext.h \
+ generalized-arrays.h \
+ generalized-vectors.h \
+ goops.h \
+ gsubr.h \
+ guardians.h \
+ hash.h \
+ hashtab.h \
+ hooks.h \
+ i18n.h \
+ init.h \
+ inline.h \
+ instructions.h \
+ ioext.h \
+ iselect.h \
+ keywords.h \
+ lang.h \
+ list.h \
+ load.h \
+ macros.h \
+ mallocs.h \
+ modules.h \
+ net_db.h \
+ null-threads.h \
+ numbers.h \
+ objcodes.h \
+ objects.h \
+ objprop.h \
+ options.h \
+ pairs.h \
+ ports.h \
+ posix.h \
+ print.h \
+ procprop.h \
+ procs.h \
+ programs.h \
+ properties.h \
+ pthread-threads.h \
+ r6rs-ports.h \
+ random.h \
+ rdelim.h \
+ read.h \
+ regex-posix.h \
+ root.h \
+ rw.h \
+ scmsigs.h \
+ script.h \
+ simpos.h \
+ smob.h \
+ snarf.h \
+ socket.h \
+ sort.h \
+ srcprop.h \
+ srfi-13.h \
+ srfi-14.h \
+ srfi-4.h \
+ stackchk.h \
+ stacks.h \
+ stime.h \
+ strings.h \
+ strorder.h \
+ strports.h \
+ struct.h \
+ symbols.h \
+ tags.h \
+ threads.h \
+ throw.h \
+ validate.h \
+ uniform.h \
+ values.h \
+ variable.h \
+ vectors.h \
+ vm-bootstrap.h \
+ vm-engine.h \
+ vm-expand.h \
+ vm.h \
+ vports.h \
+ weaks.h
nodist_modinclude_HEADERS = version.h scmconfig.h
@@ -264,7 +597,7 @@ EXTRA_DIST = ChangeLog-scm ChangeLog-threads \
cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \
cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \
c-tokenize.lex version.h.in \
- scmconfig.h.top libgettext.h
+ scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map
# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
# guile-procedures.txt guile.texi
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 29b371d16..791150d46 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -423,19 +423,28 @@
typedef struct {
ucontext_t ctx;
int fresh;
- } jmp_buf;
-# define setjmp(JB) \
+ } scm_i_jmp_buf;
+# define SCM_I_SETJMP(JB) \
( (JB).fresh = 1, \
getcontext (&((JB).ctx)), \
((JB).fresh ? ((JB).fresh = 0, 0) : 1) )
-# define longjmp(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
- void scm_ia64_longjmp (jmp_buf *, int);
+# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
+ void scm_ia64_longjmp (scm_i_jmp_buf *, int);
# else /* ndef __ia64__ */
# include <setjmp.h>
# endif /* ndef __ia64__ */
# endif /* ndef _CRAY1 */
#endif /* ndef vms */
+/* For any platform where SCM_I_SETJMP hasn't been defined in some
+ special way above, map SCM_I_SETJMP, SCM_I_LONGJMP and
+ scm_i_jmp_buf to setjmp, longjmp and jmp_buf. */
+#ifndef SCM_I_SETJMP
+#define scm_i_jmp_buf jmp_buf
+#define SCM_I_SETJMP setjmp
+#define SCM_I_LONGJMP longjmp
+#endif
+
/* James Clark came up with this neat one instruction fix for
* continuations on the SPARC. It flushes the register windows so
* that all the state of the process is contained in the stack.
@@ -556,6 +565,13 @@ SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
return (SCM_UNPACK (gf) \
? scm_call_generic_1 ((gf), (a1)) \
: (scm_wrong_type_arg ((subr), (pos), (a1)), SCM_UNSPECIFIED))
+
+/* This form is for dispatching a subroutine. */
+#define SCM_WTA_DISPATCH_1_SUBR(subr, a1, pos) \
+ return (SCM_UNPACK ((*SCM_SUBR_GENERIC (subr))) \
+ ? scm_call_generic_1 ((*SCM_SUBR_GENERIC (subr)), (a1)) \
+ : (scm_i_wrong_type_arg_symbol (SCM_SUBR_NAME (subr), (pos), (a1)), SCM_UNSPECIFIED))
+
#define SCM_GASSERT1(cond, gf, a1, pos, subr) \
if (SCM_UNLIKELY (!(cond))) \
SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr))
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 429e87b7d..8a9a21161 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -3,7 +3,7 @@
#ifndef SCM__SCM_H
#define SCM__SCM_H
-/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,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
@@ -59,6 +59,7 @@
#endif
#include <errno.h>
+#include <verify.h>
#include "libguile/__scm.h"
/* Include headers for those files central to the implementation. The
@@ -156,6 +157,36 @@
#define scm_from_off64_t scm_from_int64
+/* The endianness marker in objcode. */
+#ifdef WORDS_BIGENDIAN
+# define SCM_OBJCODE_ENDIANNESS "BE"
+#else
+# define SCM_OBJCODE_ENDIANNESS "LE"
+#endif
+
+#define _SCM_CPP_STRINGIFY(x) # x
+#define SCM_CPP_STRINGIFY(x) _SCM_CPP_STRINGIFY (x)
+
+/* The word size marker in objcode. */
+#define SCM_OBJCODE_WORD_SIZE SCM_CPP_STRINGIFY (SIZEOF_VOID_P)
+
+/* Major and minor versions must be single characters. */
+#define SCM_OBJCODE_MAJOR_VERSION 0
+#define SCM_OBJCODE_MINOR_VERSION D
+#define SCM_OBJCODE_MAJOR_VERSION_STRING \
+ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
+#define SCM_OBJCODE_MINOR_VERSION_STRING \
+ SCM_CPP_STRINGIFY(SCM_OBJCODE_MINOR_VERSION)
+#define SCM_OBJCODE_VERSION_STRING \
+ SCM_OBJCODE_MAJOR_VERSION_STRING "." SCM_OBJCODE_MINOR_VERSION_STRING
+#define SCM_OBJCODE_MACHINE_VERSION_STRING \
+ SCM_OBJCODE_VERSION_STRING "-" SCM_OBJCODE_ENDIANNESS "-" SCM_OBJCODE_WORD_SIZE
+
+/* The objcode magic header. */
+#define SCM_OBJCODE_COOKIE \
+ "GOOF-" SCM_OBJCODE_MACHINE_VERSION_STRING "---"
+
+
#endif /* SCM__SCM_H */
/*
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
new file mode 100644
index 000000000..cd5a46698
--- /dev/null
+++ b/libguile/array-handle.c
@@ -0,0 +1,162 @@
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 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/__scm.h"
+
+#include "libguile/array-handle.h"
+
+
+SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];
+
+
+#define ARRAY_IMPLS_N_STATIC_ALLOC 7
+static scm_t_array_implementation array_impls[ARRAY_IMPLS_N_STATIC_ALLOC];
+static int num_array_impls_registered = 0;
+
+
+void
+scm_i_register_array_implementation (scm_t_array_implementation *impl)
+{
+ if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC)
+ /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */
+ abort ();
+ else
+ array_impls[num_array_impls_registered++] = *impl;
+}
+
+scm_t_array_implementation*
+scm_i_array_implementation_for_obj (SCM obj)
+{
+ int i;
+ for (i = 0; i < num_array_impls_registered; i++)
+ if (SCM_NIMP (obj)
+ && (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag)
+ return &array_impls[i];
+ return NULL;
+}
+
+void
+scm_array_get_handle (SCM array, scm_t_array_handle *h)
+{
+ scm_t_array_implementation *impl = scm_i_array_implementation_for_obj (array);
+ if (!impl)
+ scm_wrong_type_arg_msg (NULL, 0, array, "array");
+ h->array = array;
+ h->impl = impl;
+ h->base = 0;
+ h->ndims = 0;
+ h->dims = NULL;
+ h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to
+ something... */
+ h->elements = NULL;
+ h->writable_elements = NULL;
+ h->impl->get_handle (array, h);
+}
+
+ssize_t
+scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
+{
+ scm_t_array_dim *s = scm_array_handle_dims (h);
+ ssize_t pos = 0, i;
+ size_t k = scm_array_handle_rank (h);
+
+ while (k > 0 && scm_is_pair (indices))
+ {
+ i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
+ pos += (i - s->lbnd) * s->inc;
+ k--;
+ s++;
+ indices = SCM_CDR (indices);
+ }
+ if (k > 0 || !scm_is_null (indices))
+ scm_misc_error (NULL, "wrong number of indices, expecting ~a",
+ scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
+ return pos;
+}
+
+SCM
+scm_array_handle_element_type (scm_t_array_handle *h)
+{
+ if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST)
+ abort (); /* guile programming error */
+ return scm_i_array_element_types[h->element_type];
+}
+
+void
+scm_array_handle_release (scm_t_array_handle *h)
+{
+ /* Nothing to do here until arrays need to be reserved for real.
+ */
+}
+
+const SCM *
+scm_array_handle_elements (scm_t_array_handle *h)
+{
+ if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
+ return ((const SCM*)h->elements) + h->base;
+}
+
+SCM *
+scm_array_handle_writable_elements (scm_t_array_handle *h)
+{
+ if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
+ return ((SCM*)h->elements) + h->base;
+}
+
+void
+scm_init_array_handle (void)
+{
+#define DEFINE_ARRAY_TYPE(tag, TAG) \
+ scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] \
+ = (scm_permanent_object (scm_from_locale_symbol (#tag)))
+
+ scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
+ DEFINE_ARRAY_TYPE (a, CHAR);
+ DEFINE_ARRAY_TYPE (b, BIT);
+ DEFINE_ARRAY_TYPE (vu8, VU8);
+ DEFINE_ARRAY_TYPE (u8, U8);
+ DEFINE_ARRAY_TYPE (s8, S8);
+ DEFINE_ARRAY_TYPE (u16, U16);
+ DEFINE_ARRAY_TYPE (s16, S16);
+ DEFINE_ARRAY_TYPE (u32, U32);
+ DEFINE_ARRAY_TYPE (s32, S32);
+ DEFINE_ARRAY_TYPE (u64, U64);
+ DEFINE_ARRAY_TYPE (s64, S64);
+ DEFINE_ARRAY_TYPE (f32, F32);
+ DEFINE_ARRAY_TYPE (f64, F64);
+ DEFINE_ARRAY_TYPE (c32, C32);
+ DEFINE_ARRAY_TYPE (c64, C64);
+
+#include "libguile/array-handle.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/array-handle.h b/libguile/array-handle.h
new file mode 100644
index 000000000..caf9cefbf
--- /dev/null
+++ b/libguile/array-handle.h
@@ -0,0 +1,129 @@
+/* classes: h_files */
+
+#ifndef SCM_ARRAY_HANDLE_H
+#define SCM_ARRAY_HANDLE_H
+
+/* Copyright (C) 1995,1996,1997,1999,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
+ * 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"
+
+
+
+struct scm_t_array_handle;
+
+typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, size_t);
+typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, size_t, SCM);
+
+typedef struct
+{
+ scm_t_bits tag;
+ scm_t_bits mask;
+ scm_i_t_array_ref vref;
+ scm_i_t_array_set vset;
+ void (*get_handle)(SCM, struct scm_t_array_handle*);
+} scm_t_array_implementation;
+
+#define SCM_ARRAY_IMPLEMENTATION(tag_,mask_,vref_,vset_,handle_) \
+ SCM_SNARF_INIT ({ \
+ scm_t_array_implementation impl; \
+ impl.tag = tag_; impl.mask = mask_; \
+ impl.vref = vref_; impl.vset = vset_; \
+ impl.get_handle = handle_; \
+ scm_i_register_array_implementation (&impl); \
+ })
+
+
+SCM_INTERNAL void scm_i_register_array_implementation (scm_t_array_implementation *impl);
+SCM_INTERNAL scm_t_array_implementation* scm_i_array_implementation_for_obj (SCM obj);
+
+
+
+
+typedef struct scm_t_array_dim
+{
+ ssize_t lbnd;
+ ssize_t ubnd;
+ ssize_t inc;
+} scm_t_array_dim;
+
+typedef enum {
+ SCM_ARRAY_ELEMENT_TYPE_SCM = 0, /* SCM values */
+ SCM_ARRAY_ELEMENT_TYPE_CHAR = 1, /* characters */
+ SCM_ARRAY_ELEMENT_TYPE_BIT = 2, /* packed numeric values */
+ SCM_ARRAY_ELEMENT_TYPE_VU8 = 3,
+ SCM_ARRAY_ELEMENT_TYPE_U8 = 4,
+ SCM_ARRAY_ELEMENT_TYPE_S8 = 5,
+ SCM_ARRAY_ELEMENT_TYPE_U16 = 6,
+ SCM_ARRAY_ELEMENT_TYPE_S16 = 7,
+ SCM_ARRAY_ELEMENT_TYPE_U32 = 8,
+ SCM_ARRAY_ELEMENT_TYPE_S32 = 9,
+ SCM_ARRAY_ELEMENT_TYPE_U64 = 10,
+ SCM_ARRAY_ELEMENT_TYPE_S64 = 11,
+ SCM_ARRAY_ELEMENT_TYPE_F32 = 12,
+ SCM_ARRAY_ELEMENT_TYPE_F64 = 13,
+ SCM_ARRAY_ELEMENT_TYPE_C32 = 14,
+ SCM_ARRAY_ELEMENT_TYPE_C64 = 15,
+ SCM_ARRAY_ELEMENT_TYPE_LAST = 15,
+} scm_t_array_element_type;
+
+SCM_INTERNAL SCM scm_i_array_element_types[];
+
+
+typedef struct scm_t_array_handle {
+ SCM array;
+ scm_t_array_implementation *impl;
+ /* `Base' is an offset into elements or writable_elements, corresponding to
+ the first element in the array. It would be nicer just to adjust the
+ elements/writable_elements pointer, but we can't because that element might
+ not even be byte-addressable, as is the case with bitvectors. A nicer
+ solution would be, well, nice.
+ */
+ size_t base;
+ size_t ndims; /* ndims == the rank of the array */
+ scm_t_array_dim *dims;
+ scm_t_array_dim dim0;
+ scm_t_array_element_type element_type;
+ const void *elements;
+ void *writable_elements;
+} scm_t_array_handle;
+
+#define scm_array_handle_rank(h) ((h)->ndims)
+#define scm_array_handle_dims(h) ((h)->dims)
+
+SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h);
+SCM_API ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices);
+SCM_API SCM scm_array_handle_element_type (scm_t_array_handle *h);
+SCM_API void scm_array_handle_release (scm_t_array_handle *h);
+SCM_API const SCM* scm_array_handle_elements (scm_t_array_handle *h);
+SCM_API SCM* scm_array_handle_writable_elements (scm_t_array_handle *h);
+
+/* See inline.h for scm_array_handle_ref and scm_array_handle_set */
+
+SCM_INTERNAL void scm_init_array_handle (void);
+
+
+#endif /* SCM_ARRAY_HANDLE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/ramap.c b/libguile/array-map.c
index e141c18b7..fb9ceea37 100644
--- a/libguile/ramap.c
+++ b/libguile/array-map.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1998,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
@@ -17,10 +17,6 @@
*/
-/*
- HWN:FIXME::
- Someone should rename this to arraymap.c; that would reflect the
- contents better. */
@@ -31,7 +27,7 @@
#include "libguile/_scm.h"
#include "libguile/strings.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/smob.h"
#include "libguile/chars.h"
#include "libguile/eq.h"
@@ -39,11 +35,14 @@
#include "libguile/feature.h"
#include "libguile/root.h"
#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"
#include "libguile/validate.h"
-#include "libguile/ramap.h"
+#include "libguile/array-map.h"
typedef struct
@@ -223,7 +222,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
if (!SCM_I_ARRAYP (vra0))
{
size_t length = scm_c_generalized_vector_length (vra0);
- vra1 = scm_i_make_ra (1, 0);
+ vra1 = scm_i_make_array (1);
SCM_I_ARRAY_BASE (vra1) = 0;
SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
@@ -236,7 +235,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
{
ra1 = SCM_CAR (z);
- vra1 = scm_i_make_ra (1, 0);
+ vra1 = scm_i_make_array (1);
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
if (!SCM_I_ARRAYP (ra1))
@@ -259,7 +258,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
case 1:
gencase: /* Have to loop over all dimensions. */
- vra0 = scm_i_make_ra (1, 0);
+ vra0 = scm_i_make_array (1);
if (SCM_I_ARRAYP (ra0))
{
kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
@@ -294,7 +293,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
{
ra1 = SCM_CAR (z);
- vra1 = scm_i_make_ra (1, 0);
+ vra1 = scm_i_make_array (1);
SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
if (SCM_I_ARRAYP (ra1))
@@ -1222,13 +1221,13 @@ init_raprocs (ra_iproc *subra)
void
-scm_init_ramap ()
+scm_init_array_map (void)
{
init_raprocs (ra_rpsubrs);
init_raprocs (ra_asubrs);
scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
-#include "libguile/ramap.x"
+#include "libguile/array-map.x"
scm_add_feature (s_scm_array_for_each);
}
diff --git a/libguile/ramap.h b/libguile/array-map.h
index d6cb19166..a198099f3 100644
--- a/libguile/ramap.h
+++ b/libguile/array-map.h
@@ -1,9 +1,9 @@
/* classes: h_files */
-#ifndef SCM_RAMAP_H
-#define SCM_RAMAP_H
+#ifndef SCM_ARRAY_MAP_H
+#define SCM_ARRAY_MAP_H
-/* Copyright (C) 1995,1996,1997,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,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
@@ -48,9 +48,9 @@ SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
SCM_API SCM scm_raequal (SCM ra0, SCM ra1);
SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
-SCM_INTERNAL void scm_init_ramap (void);
+SCM_INTERNAL void scm_init_array_map (void);
-#endif /* SCM_RAMAP_H */
+#endif /* SCM_ARRAY_MAP_H */
/*
Local Variables:
diff --git a/libguile/arrays.c b/libguile/arrays.c
new file mode 100644
index 000000000..2be9ec3f0
--- /dev/null
+++ b/libguile/arrays.c
@@ -0,0 +1,1156 @@
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 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 <stdio.h>
+#include <errno.h>
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/__scm.h"
+#include "libguile/eq.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/fports.h"
+#include "libguile/smob.h"
+#include "libguile/feature.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/srfi-13.h"
+#include "libguile/srfi-4.h"
+#include "libguile/vectors.h"
+#include "libguile/bitvectors.h"
+#include "libguile/bytevectors.h"
+#include "libguile/list.h"
+#include "libguile/dynwind.h"
+#include "libguile/read.h"
+
+#include "libguile/validate.h"
+#include "libguile/arrays.h"
+#include "libguile/array-map.h"
+#include "libguile/generalized-vectors.h"
+#include "libguile/generalized-arrays.h"
+#include "libguile/uniform.h"
+
+
+scm_t_bits scm_i_tc16_array;
+#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
+ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
+#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
+ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
+
+
+SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
+ (SCM ra),
+ "Return the root vector of a shared array.")
+#define FUNC_NAME s_scm_shared_array_root
+{
+ if (SCM_I_ARRAYP (ra))
+ return SCM_I_ARRAY_V (ra);
+ else if (scm_is_generalized_vector (ra))
+ return ra;
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
+ (SCM ra),
+ "Return the root vector index of the first element in the array.")
+#define FUNC_NAME s_scm_shared_array_offset
+{
+ scm_t_array_handle handle;
+ SCM res;
+
+ scm_array_get_handle (ra, &handle);
+ res = scm_from_size_t (handle.base);
+ scm_array_handle_release (&handle);
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
+ (SCM ra),
+ "For each dimension, return the distance between elements in the root vector.")
+#define FUNC_NAME s_scm_shared_array_increments
+{
+ scm_t_array_handle handle;
+ SCM res = SCM_EOL;
+ size_t k;
+ scm_t_array_dim *s;
+
+ scm_array_get_handle (ra, &handle);
+ k = scm_array_handle_rank (&handle);
+ s = scm_array_handle_dims (&handle);
+ while (k--)
+ res = scm_cons (scm_from_ssize_t (s[k].inc), res);
+ scm_array_handle_release (&handle);
+ return res;
+}
+#undef FUNC_NAME
+
+SCM
+scm_i_make_array (int ndim)
+{
+ SCM ra;
+ SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_i_tc16_array,
+ scm_gc_malloc ((sizeof (scm_i_t_array) +
+ ndim * sizeof (scm_t_array_dim)),
+ "array"));
+ SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
+ return ra;
+}
+
+static char s_bad_spec[] = "Bad scm_array dimension";
+
+
+/* Increments will still need to be set. */
+
+static SCM
+scm_i_shap2ra (SCM args)
+{
+ scm_t_array_dim *s;
+ SCM ra, spec, sp;
+ int ndim = scm_ilength (args);
+ if (ndim < 0)
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
+
+ ra = scm_i_make_array (ndim);
+ SCM_I_ARRAY_BASE (ra) = 0;
+ s = SCM_I_ARRAY_DIMS (ra);
+ for (; !scm_is_null (args); s++, args = SCM_CDR (args))
+ {
+ spec = SCM_CAR (args);
+ if (scm_is_integer (spec))
+ {
+ if (scm_to_long (spec) < 0)
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
+ s->lbnd = 0;
+ s->ubnd = scm_to_long (spec) - 1;
+ s->inc = 1;
+ }
+ else
+ {
+ if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
+ s->lbnd = scm_to_long (SCM_CAR (spec));
+ sp = SCM_CDR (spec);
+ if (!scm_is_pair (sp)
+ || !scm_is_integer (SCM_CAR (sp))
+ || !scm_is_null (SCM_CDR (sp)))
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
+ s->ubnd = scm_to_long (SCM_CAR (sp));
+ s->inc = 1;
+ }
+ }
+ return ra;
+}
+
+SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
+ (SCM type, SCM fill, SCM bounds),
+ "Create and return an array of type @var{type}.")
+#define FUNC_NAME s_scm_make_typed_array
+{
+ size_t k, rlen = 1;
+ scm_t_array_dim *s;
+ SCM ra;
+
+ ra = scm_i_shap2ra (bounds);
+ SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
+ s = SCM_I_ARRAY_DIMS (ra);
+ k = SCM_I_ARRAY_NDIM (ra);
+
+ while (k--)
+ {
+ s[k].inc = rlen;
+ SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
+ rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
+ }
+
+ if (scm_is_eq (fill, SCM_UNSPECIFIED))
+ fill = SCM_UNDEFINED;
+
+ SCM_I_ARRAY_V (ra) =
+ scm_make_generalized_vector (type, scm_from_size_t (rlen), fill);
+
+ if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
+ if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ return SCM_I_ARRAY_V (ra);
+ return ra;
+}
+#undef FUNC_NAME
+
+SCM
+scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
+ size_t byte_len)
+#define FUNC_NAME "scm_from_contiguous_typed_array"
+{
+ size_t k, rlen = 1;
+ scm_t_array_dim *s;
+ SCM ra;
+ scm_t_array_handle h;
+ void *base;
+ size_t sz;
+
+ ra = scm_i_shap2ra (bounds);
+ SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
+ s = SCM_I_ARRAY_DIMS (ra);
+ k = SCM_I_ARRAY_NDIM (ra);
+
+ while (k--)
+ {
+ s[k].inc = rlen;
+ SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
+ rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
+ }
+ SCM_I_ARRAY_V (ra) =
+ scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED);
+
+
+ scm_array_get_handle (ra, &h);
+ base = scm_array_handle_uniform_writable_elements (&h);
+ sz = scm_array_handle_uniform_element_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);
+
+ memcpy (base, 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))
+ return SCM_I_ARRAY_V (ra);
+ return ra;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
+ (SCM fill, SCM bounds),
+ "Create and return an array.")
+#define FUNC_NAME s_scm_make_array
+{
+ return scm_make_typed_array (SCM_BOOL_T, fill, bounds);
+}
+#undef FUNC_NAME
+
+static void
+scm_i_ra_set_contp (SCM ra)
+{
+ size_t k = SCM_I_ARRAY_NDIM (ra);
+ if (k)
+ {
+ long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
+ while (k--)
+ {
+ if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
+ {
+ SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
+ return;
+ }
+ inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
+ - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
+ }
+ }
+ SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
+}
+
+
+SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
+ (SCM oldra, SCM mapfunc, SCM dims),
+ "@code{make-shared-array} can be used to create shared subarrays of other\n"
+ "arrays. The @var{mapper} is a function that translates coordinates in\n"
+ "the new array into coordinates in the old array. A @var{mapper} must be\n"
+ "linear, and its range must stay within the bounds of the old array, but\n"
+ "it can be otherwise arbitrary. A simple example:\n"
+ "@lisp\n"
+ "(define fred (make-array #f 8 8))\n"
+ "(define freds-diagonal\n"
+ " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
+ "(array-set! freds-diagonal 'foo 3)\n"
+ "(array-ref fred 3 3) @result{} foo\n"
+ "(define freds-center\n"
+ " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
+ "(array-ref freds-center 0 0) @result{} foo\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_make_shared_array
+{
+ scm_t_array_handle old_handle;
+ SCM ra;
+ SCM inds, indptr;
+ SCM imap;
+ size_t k;
+ ssize_t i;
+ long old_base, old_min, new_min, old_max, new_max;
+ scm_t_array_dim *s;
+
+ SCM_VALIDATE_REST_ARGUMENT (dims);
+ SCM_VALIDATE_PROC (2, mapfunc);
+ ra = scm_i_shap2ra (dims);
+
+ scm_array_get_handle (oldra, &old_handle);
+
+ if (SCM_I_ARRAYP (oldra))
+ {
+ SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
+ old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
+ s = scm_array_handle_dims (&old_handle);
+ k = scm_array_handle_rank (&old_handle);
+ while (k--)
+ {
+ if (s[k].inc > 0)
+ old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
+ else
+ old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
+ }
+ }
+ else
+ {
+ SCM_I_ARRAY_V (ra) = oldra;
+ old_base = old_min = 0;
+ old_max = scm_c_generalized_vector_length (oldra) - 1;
+ }
+
+ inds = SCM_EOL;
+ s = SCM_I_ARRAY_DIMS (ra);
+ for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
+ {
+ inds = scm_cons (scm_from_long (s[k].lbnd), inds);
+ if (s[k].ubnd < s[k].lbnd)
+ {
+ if (1 == SCM_I_ARRAY_NDIM (ra))
+ ra = scm_make_generalized_vector (scm_array_type (ra),
+ SCM_INUM0, SCM_UNDEFINED);
+ else
+ SCM_I_ARRAY_V (ra) =
+ scm_make_generalized_vector (scm_array_type (ra),
+ SCM_INUM0, SCM_UNDEFINED);
+ scm_array_handle_release (&old_handle);
+ return ra;
+ }
+ }
+
+ imap = scm_apply_0 (mapfunc, scm_reverse (inds));
+ i = scm_array_handle_pos (&old_handle, imap);
+ SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
+ indptr = inds;
+ k = SCM_I_ARRAY_NDIM (ra);
+ while (k--)
+ {
+ if (s[k].ubnd > s[k].lbnd)
+ {
+ SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
+ imap = scm_apply_0 (mapfunc, scm_reverse (inds));
+ s[k].inc = scm_array_handle_pos (&old_handle, imap) - i;
+ i += s[k].inc;
+ if (s[k].inc > 0)
+ new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
+ else
+ new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
+ }
+ else
+ s[k].inc = new_max - new_min + 1; /* contiguous by default */
+ indptr = SCM_CDR (indptr);
+ }
+
+ scm_array_handle_release (&old_handle);
+
+ if (old_min > new_min || old_max < new_max)
+ SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
+ if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
+ {
+ SCM v = SCM_I_ARRAY_V (ra);
+ size_t length = scm_c_generalized_vector_length (v);
+ if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
+ return v;
+ if (s->ubnd < s->lbnd)
+ return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
+ SCM_UNDEFINED);
+ }
+ scm_i_ra_set_contp (ra);
+ return ra;
+}
+#undef FUNC_NAME
+
+
+/* args are RA . DIMS */
+SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
+ (SCM ra, SCM args),
+ "Return an array sharing contents with @var{array}, but with\n"
+ "dimensions arranged in a different order. There must be one\n"
+ "@var{dim} argument for each dimension of @var{array}.\n"
+ "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
+ "and the rank of the array to be returned. Each integer in that\n"
+ "range must appear at least once in the argument list.\n"
+ "\n"
+ "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
+ "dimensions in the array to be returned, their positions in the\n"
+ "argument list to dimensions of @var{array}. Several @var{dim}s\n"
+ "may have the same value, in which case the returned array will\n"
+ "have smaller rank than @var{array}.\n"
+ "\n"
+ "@lisp\n"
+ "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
+ "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
+ "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
+ " #2((a 4) (b 5) (c 6))\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_transpose_array
+{
+ SCM res, vargs;
+ scm_t_array_dim *s, *r;
+ int ndim, i, k;
+
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
+
+ if (scm_is_generalized_vector (ra))
+ {
+ /* Make sure that we are called with a single zero as
+ arguments.
+ */
+ if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
+ SCM_WRONG_NUM_ARGS ();
+ SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
+ SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
+ return ra;
+ }
+
+ if (SCM_I_ARRAYP (ra))
+ {
+ vargs = scm_vector (args);
+ if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
+ SCM_WRONG_NUM_ARGS ();
+ ndim = 0;
+ for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
+ {
+ i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
+ 0, SCM_I_ARRAY_NDIM(ra));
+ if (ndim < i)
+ ndim = i;
+ }
+ ndim++;
+ res = scm_i_make_array (ndim);
+ SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
+ SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
+ for (k = ndim; k--;)
+ {
+ SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
+ SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
+ }
+ for (k = SCM_I_ARRAY_NDIM (ra); k--;)
+ {
+ i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
+ s = &(SCM_I_ARRAY_DIMS (ra)[k]);
+ r = &(SCM_I_ARRAY_DIMS (res)[i]);
+ if (r->ubnd < r->lbnd)
+ {
+ r->lbnd = s->lbnd;
+ r->ubnd = s->ubnd;
+ r->inc = s->inc;
+ ndim--;
+ }
+ else
+ {
+ if (r->ubnd > s->ubnd)
+ r->ubnd = s->ubnd;
+ if (r->lbnd < s->lbnd)
+ {
+ SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
+ r->lbnd = s->lbnd;
+ }
+ r->inc += s->inc;
+ }
+ }
+ if (ndim > 0)
+ SCM_MISC_ERROR ("bad argument list", SCM_EOL);
+ scm_i_ra_set_contp (res);
+ return res;
+ }
+
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+}
+#undef FUNC_NAME
+
+/* attempts to unroll an array into a one-dimensional array.
+ returns the unrolled array or #f if it can't be done. */
+ /* if strict is not SCM_UNDEFINED, return #f if returned array
+ wouldn't have contiguous elements. */
+SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
+ (SCM ra, SCM strict),
+ "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
+ "without changing their order (last subscript changing fastest), then\n"
+ "@code{array-contents} returns that shared array, otherwise it returns\n"
+ "@code{#f}. All arrays made by @var{make-array} and\n"
+ "@var{make-uniform-array} may be unrolled, some arrays made by\n"
+ "@var{make-shared-array} may not be.\n\n"
+ "If the optional argument @var{strict} is provided, a shared array will\n"
+ "be returned only if its elements are stored internally contiguous in\n"
+ "memory.")
+#define FUNC_NAME s_scm_array_contents
+{
+ SCM sra;
+
+ if (scm_is_generalized_vector (ra))
+ return ra;
+
+ if (SCM_I_ARRAYP (ra))
+ {
+ size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
+ if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
+ return SCM_BOOL_F;
+ for (k = 0; k < ndim; k++)
+ len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ if (!SCM_UNBNDP (strict) && scm_is_true (strict))
+ {
+ if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
+ return SCM_BOOL_F;
+ if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
+ {
+ if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
+ SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+ len % SCM_LONG_BIT)
+ return SCM_BOOL_F;
+ }
+ }
+
+ {
+ SCM v = SCM_I_ARRAY_V (ra);
+ size_t length = scm_c_generalized_vector_length (v);
+ if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
+ return v;
+ }
+
+ sra = scm_i_make_array (1);
+ SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
+ SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
+ SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
+ SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
+ return sra;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_ra2contig (SCM ra, int copy)
+{
+ SCM ret;
+ long inc = 1;
+ size_t k, len = 1;
+ for (k = SCM_I_ARRAY_NDIM (ra); k--;)
+ len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ k = SCM_I_ARRAY_NDIM (ra);
+ if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
+ {
+ if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
+ return ra;
+ if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
+ 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
+ 0 == len % SCM_LONG_BIT))
+ return ra;
+ }
+ ret = scm_i_make_array (k);
+ SCM_I_ARRAY_BASE (ret) = 0;
+ while (k--)
+ {
+ SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
+ SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
+ inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ }
+ SCM_I_ARRAY_V (ret) = scm_make_generalized_vector (scm_array_type (ra),
+ scm_from_long (inc),
+ SCM_UNDEFINED);
+ if (copy)
+ scm_array_copy_x (ra, ret);
+ return ret;
+}
+
+
+
+SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
+ (SCM ura, SCM port_or_fd, SCM start, SCM end),
+ "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
+ "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
+ "binary objects from @var{port-or-fdes}.\n"
+ "If an end of file is encountered,\n"
+ "the objects up to that point are put into @var{ura}\n"
+ "(starting at the beginning) and the remainder of the array is\n"
+ "unchanged.\n\n"
+ "The optional arguments @var{start} and @var{end} allow\n"
+ "a specified region of a vector (or linearized array) to be read,\n"
+ "leaving the remainder of the vector unchanged.\n\n"
+ "@code{uniform-array-read!} returns the number of objects read.\n"
+ "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
+ "returned by @code{(current-input-port)}.")
+#define FUNC_NAME s_scm_uniform_array_read_x
+{
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_input_port ();
+
+ if (scm_is_uniform_vector (ura))
+ {
+ return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
+ }
+ else if (SCM_I_ARRAYP (ura))
+ {
+ size_t base, vlen, cstart, cend;
+ SCM cra, ans;
+
+ cra = scm_ra2contig (ura, 0);
+ base = SCM_I_ARRAY_BASE (cra);
+ vlen = SCM_I_ARRAY_DIMS (cra)->inc *
+ (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
+
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
+
+ ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
+ scm_from_size_t (base + cstart),
+ scm_from_size_t (base + cend));
+
+ if (!scm_is_eq (cra, ura))
+ scm_array_copy_x (cra, ura);
+ return ans;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ura, "array");
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
+ (SCM ura, SCM port_or_fd, SCM start, SCM end),
+ "Writes all elements of @var{ura} as binary objects to\n"
+ "@var{port-or-fdes}.\n\n"
+ "The optional arguments @var{start}\n"
+ "and @var{end} allow\n"
+ "a specified region of a vector (or linearized array) to be written.\n\n"
+ "The number of objects actually written is returned.\n"
+ "@var{port-or-fdes} may be\n"
+ "omitted, in which case it defaults to the value returned by\n"
+ "@code{(current-output-port)}.")
+#define FUNC_NAME s_scm_uniform_array_write
+{
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_output_port ();
+
+ if (scm_is_uniform_vector (ura))
+ {
+ return scm_uniform_vector_write (ura, port_or_fd, start, end);
+ }
+ else if (SCM_I_ARRAYP (ura))
+ {
+ size_t base, vlen, cstart, cend;
+ SCM cra, ans;
+
+ cra = scm_ra2contig (ura, 1);
+ base = SCM_I_ARRAY_BASE (cra);
+ vlen = SCM_I_ARRAY_DIMS (cra)->inc *
+ (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
+
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
+
+ ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
+ scm_from_size_t (base + cstart),
+ scm_from_size_t (base + cend));
+
+ return ans;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ura, "array");
+}
+#undef FUNC_NAME
+
+
+static void
+list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
+{
+ if (k == scm_array_handle_rank (handle))
+ scm_array_handle_set (handle, pos, lst);
+ else
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
+ ssize_t inc = dim->inc;
+ size_t len = 1 + dim->ubnd - dim->lbnd, n;
+ char *errmsg = NULL;
+
+ n = len;
+ while (n > 0 && scm_is_pair (lst))
+ {
+ list_to_array (SCM_CAR (lst), handle, pos, k + 1);
+ pos += inc;
+ lst = SCM_CDR (lst);
+ n -= 1;
+ }
+ if (n != 0)
+ errmsg = "too few elements for array dimension ~a, need ~a";
+ if (!scm_is_null (lst))
+ errmsg = "too many elements for array dimension ~a, want ~a";
+ if (errmsg)
+ scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
+ scm_from_size_t (len)));
+ }
+}
+
+
+SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
+ (SCM type, SCM shape, SCM lst),
+ "Return an array of the type @var{type}\n"
+ "with elements the same as those of @var{lst}.\n"
+ "\n"
+ "The argument @var{shape} determines the number of dimensions\n"
+ "of the array and their shape. It is either an exact integer,\n"
+ "giving the\n"
+ "number of dimensions directly, or a list whose length\n"
+ "specifies the number of dimensions and each element specified\n"
+ "the lower and optionally the upper bound of the corresponding\n"
+ "dimension.\n"
+ "When the element is list of two elements, these elements\n"
+ "give the lower and upper bounds. When it is an exact\n"
+ "integer, it gives only the lower bound.")
+#define FUNC_NAME s_scm_list_to_typed_array
+{
+ SCM row;
+ SCM ra;
+ scm_t_array_handle handle;
+
+ row = lst;
+ if (scm_is_integer (shape))
+ {
+ size_t k = scm_to_size_t (shape);
+ shape = SCM_EOL;
+ while (k-- > 0)
+ {
+ shape = scm_cons (scm_length (row), shape);
+ if (k > 0 && !scm_is_null (row))
+ row = scm_car (row);
+ }
+ }
+ else
+ {
+ SCM shape_spec = shape;
+ shape = SCM_EOL;
+ while (1)
+ {
+ SCM spec = scm_car (shape_spec);
+ if (scm_is_pair (spec))
+ shape = scm_cons (spec, shape);
+ else
+ shape = scm_cons (scm_list_2 (spec,
+ scm_sum (scm_sum (spec,
+ scm_length (row)),
+ scm_from_int (-1))),
+ shape);
+ shape_spec = scm_cdr (shape_spec);
+ if (scm_is_pair (shape_spec))
+ {
+ if (!scm_is_null (row))
+ row = scm_car (row);
+ }
+ else
+ break;
+ }
+ }
+
+ ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
+ scm_reverse_x (shape, SCM_EOL));
+
+ scm_array_get_handle (ra, &handle);
+ list_to_array (lst, &handle, 0, 0);
+ scm_array_handle_release (&handle);
+
+ return ra;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
+ (SCM ndim, SCM lst),
+ "Return an array with elements the same as those of @var{lst}.")
+#define FUNC_NAME s_scm_list_to_array
+{
+ return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst);
+}
+#undef FUNC_NAME
+
+/* Print dimension DIM of ARRAY.
+ */
+
+static int
+scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
+ SCM port, scm_print_state *pstate)
+{
+ if (dim == h->ndims)
+ scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate);
+ else
+ {
+ ssize_t i;
+ scm_putc ('(', port);
+ for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
+ i++, pos += h->dims[dim].inc)
+ {
+ scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
+ if (i < h->dims[dim].ubnd)
+ scm_putc (' ', port);
+ }
+ scm_putc (')', port);
+ }
+ return 1;
+}
+
+/* Print an array.
+*/
+
+static int
+scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
+{
+ scm_t_array_handle h;
+ long i;
+ int print_lbnds = 0, zero_size = 0, print_lens = 0;
+
+ scm_array_get_handle (array, &h);
+
+ scm_putc ('#', port);
+ if (h.ndims != 1 || h.dims[0].lbnd != 0)
+ scm_intprint (h.ndims, 10, port);
+ if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
+ scm_write (scm_array_handle_element_type (&h), port);
+
+ for (i = 0; i < h.ndims; i++)
+ {
+ if (h.dims[i].lbnd != 0)
+ print_lbnds = 1;
+ if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0)
+ zero_size = 1;
+ else if (zero_size)
+ print_lens = 1;
+ }
+
+ if (print_lbnds || print_lens)
+ for (i = 0; i < h.ndims; i++)
+ {
+ if (print_lbnds)
+ {
+ scm_putc ('@', port);
+ scm_intprint (h.dims[i].lbnd, 10, port);
+ }
+ if (print_lens)
+ {
+ scm_putc (':', port);
+ scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
+ 10, port);
+ }
+ }
+
+ if (h.ndims == 0)
+ {
+ /* Rank zero arrays, which are really just scalars, are printed
+ specially. The consequent way would be to print them as
+
+ #0 OBJ
+
+ where OBJ is the printed representation of the scalar, but we
+ print them instead as
+
+ #0(OBJ)
+
+ to make them look less strange.
+
+ Just printing them as
+
+ OBJ
+
+ would be correct in a way as well, but zero rank arrays are
+ not really the same as Scheme values since they are boxed and
+ can be modified with array-set!, say.
+ */
+ scm_putc ('(', port);
+ scm_i_print_array_dimension (&h, 0, 0, port, pstate);
+ scm_putc (')', port);
+ return 1;
+ }
+ else
+ return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
+}
+
+/* Read an array. This function can also read vectors and uniform
+ vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
+ handled here.
+
+ C is the first character read after the '#'.
+*/
+
+static SCM
+tag_to_type (const char *tag, SCM port)
+{
+ if (*tag == '\0')
+ return SCM_BOOL_T;
+ else
+ return scm_from_locale_symbol (tag);
+}
+
+static int
+read_decimal_integer (SCM port, int c, ssize_t *resp)
+{
+ ssize_t sign = 1;
+ ssize_t res = 0;
+ int got_it = 0;
+
+ if (c == '-')
+ {
+ sign = -1;
+ c = scm_getc (port);
+ }
+
+ while ('0' <= c && c <= '9')
+ {
+ res = 10*res + c-'0';
+ got_it = 1;
+ c = scm_getc (port);
+ }
+
+ if (got_it)
+ *resp = sign * res;
+ return c;
+}
+
+SCM
+scm_i_read_array (SCM port, int c)
+{
+ ssize_t rank;
+ int got_rank;
+ char tag[80];
+ int tag_len;
+
+ SCM shape = SCM_BOOL_F, elements;
+
+ /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
+ the array code can not deal with zero-length dimensions yet, and
+ we want to allow zero-length vectors, of course.
+ */
+ if (c == '(')
+ {
+ scm_ungetc (c, port);
+ return scm_vector (scm_read (port));
+ }
+
+ /* Disambiguate between '#f' and uniform floating point vectors.
+ */
+ if (c == 'f')
+ {
+ c = scm_getc (port);
+ if (c != '3' && c != '6')
+ {
+ if (c != EOF)
+ scm_ungetc (c, port);
+ return SCM_BOOL_F;
+ }
+ rank = 1;
+ got_rank = 1;
+ tag[0] = 'f';
+ tag_len = 1;
+ goto continue_reading_tag;
+ }
+
+ /* Read rank.
+ */
+ rank = 1;
+ c = read_decimal_integer (port, c, &rank);
+ if (rank < 0)
+ scm_i_input_error (NULL, port, "array rank must be non-negative",
+ SCM_EOL);
+
+ /* Read tag.
+ */
+ tag_len = 0;
+ continue_reading_tag:
+ while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
+ {
+ tag[tag_len++] = c;
+ c = scm_getc (port);
+ }
+ tag[tag_len] = '\0';
+
+ /* Read shape.
+ */
+ if (c == '@' || c == ':')
+ {
+ shape = SCM_EOL;
+
+ do
+ {
+ ssize_t lbnd = 0, len = 0;
+ SCM s;
+
+ if (c == '@')
+ {
+ c = scm_getc (port);
+ c = read_decimal_integer (port, c, &lbnd);
+ }
+
+ s = scm_from_ssize_t (lbnd);
+
+ if (c == ':')
+ {
+ c = scm_getc (port);
+ c = read_decimal_integer (port, c, &len);
+ if (len < 0)
+ scm_i_input_error (NULL, port,
+ "array length must be non-negative",
+ SCM_EOL);
+
+ s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
+ }
+
+ shape = scm_cons (s, shape);
+ } while (c == '@' || c == ':');
+
+ shape = scm_reverse_x (shape, SCM_EOL);
+ }
+
+ /* Read nested lists of elements.
+ */
+ if (c != '(')
+ scm_i_input_error (NULL, port,
+ "missing '(' in vector or array literal",
+ SCM_EOL);
+ scm_ungetc (c, port);
+ elements = scm_read (port);
+
+ if (scm_is_false (shape))
+ shape = scm_from_ssize_t (rank);
+ else if (scm_ilength (shape) != rank)
+ scm_i_input_error
+ (NULL, port,
+ "the number of shape specifications must match the array rank",
+ SCM_EOL);
+
+ /* Handle special print syntax of rank zero arrays; see
+ scm_i_print_array for a rationale.
+ */
+ if (rank == 0)
+ {
+ if (!scm_is_pair (elements))
+ scm_i_input_error (NULL, port,
+ "too few elements in array literal, need 1",
+ SCM_EOL);
+ if (!scm_is_null (SCM_CDR (elements)))
+ scm_i_input_error (NULL, port,
+ "too many elements in array literal, want 1",
+ SCM_EOL);
+ elements = SCM_CAR (elements);
+ }
+
+ /* Construct array.
+ */
+ return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
+}
+
+
+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);
+}
+
+static void
+array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
+{
+ scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
+}
+
+/* FIXME: should be handle for vect? maybe not, because of dims */
+static void
+array_get_handle (SCM array, scm_t_array_handle *h)
+{
+ scm_t_array_handle vh;
+ scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
+ h->element_type = vh.element_type;
+ h->elements = vh.elements;
+ h->writable_elements = vh.writable_elements;
+ scm_array_handle_release (&vh);
+
+ h->dims = SCM_I_ARRAY_DIMS (array);
+ h->ndims = SCM_I_ARRAY_NDIM (array);
+ h->base = SCM_I_ARRAY_BASE (array);
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array, 0xffff,
+ array_handle_ref, array_handle_set,
+ array_get_handle);
+
+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);
+
+ scm_add_feature ("array");
+
+#include "libguile/arrays.x"
+
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/arrays.h b/libguile/arrays.h
new file mode 100644
index 000000000..35e5471bf
--- /dev/null
+++ b/libguile/arrays.h
@@ -0,0 +1,91 @@
+/* classes: h_files */
+
+#ifndef SCM_ARRAY_H
+#define SCM_ARRAY_H
+
+/* Copyright (C) 1995,1996,1997,1999,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
+ * 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"
+#include "libguile/print.h"
+
+
+
+/* Multidimensional arrays. Woo hoo!
+ Also see ....
+ */
+
+
+/** Arrays */
+
+SCM_API SCM scm_make_array (SCM fill, SCM bounds);
+SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
+SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
+ const void *bytes,
+ size_t byte_len);
+SCM_API SCM scm_shared_array_root (SCM ra);
+SCM_API SCM scm_shared_array_offset (SCM ra);
+SCM_API SCM scm_shared_array_increments (SCM ra);
+SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
+SCM_API SCM scm_transpose_array (SCM ra, SCM args);
+SCM_API SCM scm_array_contents (SCM ra, SCM strict);
+SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
+ SCM start, SCM end);
+SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
+ SCM start, SCM end);
+SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
+SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
+
+SCM_API SCM scm_ra2contig (SCM ra, int copy);
+
+/* internal. */
+
+typedef struct scm_i_t_array
+{
+ SCM v; /* the contents of the array, e.g., a vector or uniform vector. */
+ unsigned long base;
+} scm_i_t_array;
+
+SCM_API scm_t_bits scm_i_tc16_array;
+
+#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 16)
+
+#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a)
+#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17))
+#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
+
+#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
+#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v)
+#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
+#define SCM_I_ARRAY_DIMS(a) \
+ ((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array)))
+
+SCM_INTERNAL SCM scm_i_make_array (int ndim);
+SCM_INTERNAL SCM scm_i_read_array (SCM port, int c);
+
+SCM_INTERNAL void scm_init_arrays (void);
+
+#endif /* SCM_ARRAYS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c
new file mode 100644
index 000000000..f1d8473d9
--- /dev/null
+++ b/libguile/bitvectors.c
@@ -0,0 +1,910 @@
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 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 <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/__scm.h"
+#include "libguile/smob.h"
+#include "libguile/strings.h"
+#include "libguile/array-handle.h"
+#include "libguile/bitvectors.h"
+#include "libguile/arrays.h"
+#include "libguile/generalized-vectors.h"
+#include "libguile/srfi-4.h"
+
+/* Bit vectors. Would be nice if they were implemented on top of bytevectors,
+ * but alack, all we have is this crufty C.
+ */
+
+static scm_t_bits scm_tc16_bitvector;
+
+#define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
+#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)
+{
+ size_t bit_len = BITVECTOR_LENGTH (vec);
+ size_t word_len = (bit_len+31)/32;
+ scm_t_uint32 *bits = BITVECTOR_BITS (vec);
+ size_t i, j;
+
+ scm_puts ("#*", port);
+ for (i = 0; i < word_len; i++, bit_len -= 32)
+ {
+ scm_t_uint32 mask = 1;
+ for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
+ scm_putc ((bits[i] & mask)? '1' : '0', port);
+ }
+
+ return 1;
+}
+
+static SCM
+bitvector_equalp (SCM vec1, SCM vec2)
+{
+ size_t bit_len = BITVECTOR_LENGTH (vec1);
+ size_t word_len = (bit_len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len);
+ scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1);
+ scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2);
+
+ /* compare lengths */
+ if (BITVECTOR_LENGTH (vec2) != bit_len)
+ return SCM_BOOL_F;
+ /* avoid underflow in word_len-1 below. */
+ if (bit_len == 0)
+ return SCM_BOOL_T;
+ /* compare full words */
+ if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1)))
+ return SCM_BOOL_F;
+ /* compare partial last words */
+ if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask))
+ return SCM_BOOL_F;
+ return SCM_BOOL_T;
+}
+
+int
+scm_is_bitvector (SCM vec)
+{
+ return IS_BITVECTOR (vec);
+}
+
+SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} when @var{obj} is a bitvector, else\n"
+ "return @code{#f}.")
+#define FUNC_NAME s_scm_bitvector_p
+{
+ return scm_from_bool (scm_is_bitvector (obj));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_bitvector (size_t len, SCM fill)
+{
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 *bits;
+ SCM res;
+
+ bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len,
+ "bitvector");
+ SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
+
+ if (!SCM_UNBNDP (fill))
+ scm_bitvector_fill_x (res, fill);
+
+ return res;
+}
+
+SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0,
+ (SCM len, SCM fill),
+ "Create a new bitvector of length @var{len} and\n"
+ "optionally initialize all elements to @var{fill}.")
+#define FUNC_NAME s_scm_make_bitvector
+{
+ return scm_c_make_bitvector (scm_to_size_t (len), fill);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1,
+ (SCM bits),
+ "Create a new bitvector with the arguments as elements.")
+#define FUNC_NAME s_scm_bitvector
+{
+ return scm_list_to_bitvector (bits);
+}
+#undef FUNC_NAME
+
+size_t
+scm_c_bitvector_length (SCM vec)
+{
+ scm_assert_smob_type (scm_tc16_bitvector, vec);
+ return BITVECTOR_LENGTH (vec);
+}
+
+SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0,
+ (SCM vec),
+ "Return the length of the bitvector @var{vec}.")
+#define FUNC_NAME s_scm_bitvector_length
+{
+ return scm_from_size_t (scm_c_bitvector_length (vec));
+}
+#undef FUNC_NAME
+
+const scm_t_uint32 *
+scm_array_handle_bit_elements (scm_t_array_handle *h)
+{
+ return scm_array_handle_bit_writable_elements (h);
+}
+
+scm_t_uint32 *
+scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
+{
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (IS_BITVECTOR (vec))
+ return BITVECTOR_BITS (vec) + h->base/32;
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
+}
+
+size_t
+scm_array_handle_bit_elements_offset (scm_t_array_handle *h)
+{
+ return h->base % 32;
+}
+
+const scm_t_uint32 *
+scm_bitvector_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *offp,
+ size_t *lenp,
+ ssize_t *incp)
+{
+ return scm_bitvector_writable_elements (vec, h, offp, lenp, incp);
+}
+
+
+scm_t_uint32 *
+scm_bitvector_writable_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *offp,
+ size_t *lenp,
+ ssize_t *incp)
+{
+ scm_generalized_vector_get_handle (vec, h);
+ if (offp)
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+ *offp = scm_array_handle_bit_elements_offset (h);
+ *lenp = dim->ubnd - dim->lbnd + 1;
+ *incp = dim->inc;
+ }
+ return scm_array_handle_bit_writable_elements (h);
+}
+
+SCM
+scm_c_bitvector_ref (SCM vec, size_t idx)
+{
+ scm_t_array_handle handle;
+ const scm_t_uint32 *bits;
+
+ if (IS_BITVECTOR (vec))
+ {
+ if (idx >= BITVECTOR_LENGTH (vec))
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ bits = BITVECTOR_BITS(vec);
+ return scm_from_bool (bits[idx/32] & (1L << (idx%32)));
+ }
+ else
+ {
+ SCM res;
+ size_t len, off;
+ ssize_t inc;
+
+ bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
+ if (idx >= len)
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ idx = idx*inc + off;
+ res = scm_from_bool (bits[idx/32] & (1L << (idx%32)));
+ scm_array_handle_release (&handle);
+ return res;
+ }
+}
+
+SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0,
+ (SCM vec, SCM idx),
+ "Return the element at index @var{idx} of the bitvector\n"
+ "@var{vec}.")
+#define FUNC_NAME s_scm_bitvector_ref
+{
+ return scm_c_bitvector_ref (vec, scm_to_size_t (idx));
+}
+#undef FUNC_NAME
+
+void
+scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
+{
+ scm_t_array_handle handle;
+ scm_t_uint32 *bits, mask;
+
+ if (IS_BITVECTOR (vec))
+ {
+ if (idx >= BITVECTOR_LENGTH (vec))
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ bits = BITVECTOR_BITS(vec);
+ }
+ else
+ {
+ size_t len, off;
+ ssize_t inc;
+
+ bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
+ if (idx >= len)
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ idx = idx*inc + off;
+ }
+
+ mask = 1L << (idx%32);
+ if (scm_is_true (val))
+ bits[idx/32] |= mask;
+ else
+ bits[idx/32] &= ~mask;
+
+ if (!IS_BITVECTOR (vec))
+ scm_array_handle_release (&handle);
+}
+
+SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0,
+ (SCM vec, SCM idx, SCM val),
+ "Set the element at index @var{idx} of the bitvector\n"
+ "@var{vec} when @var{val} is true, else clear it.")
+#define FUNC_NAME s_scm_bitvector_set_x
+{
+ scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0,
+ (SCM vec, SCM val),
+ "Set all elements of the bitvector\n"
+ "@var{vec} when @var{val} is true, else clear them.")
+#define FUNC_NAME s_scm_bitvector_fill_x
+{
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
+
+ bits = scm_bitvector_writable_elements (vec, &handle,
+ &off, &len, &inc);
+
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ /* the usual case
+ */
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+
+ if (scm_is_true (val))
+ {
+ memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1));
+ bits[word_len-1] |= last_mask;
+ }
+ else
+ {
+ memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1));
+ bits[word_len-1] &= ~last_mask;
+ }
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ scm_array_handle_set (&handle, i*inc, val);
+ }
+
+ scm_array_handle_release (&handle);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0,
+ (SCM list),
+ "Return a new bitvector initialized with the elements\n"
+ "of @var{list}.")
+#define FUNC_NAME s_scm_list_to_bitvector
+{
+ size_t bit_len = scm_to_size_t (scm_length (list));
+ SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED);
+ size_t word_len = (bit_len+31)/32;
+ scm_t_array_handle handle;
+ scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle,
+ NULL, NULL, NULL);
+ size_t i, j;
+
+ for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32)
+ {
+ scm_t_uint32 mask = 1;
+ bits[i] = 0;
+ for (j = 0; j < 32 && j < bit_len;
+ j++, mask <<= 1, list = SCM_CDR (list))
+ if (scm_is_true (SCM_CAR (list)))
+ bits[i] |= mask;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return vec;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0,
+ (SCM vec),
+ "Return a new list initialized with the elements\n"
+ "of the bitvector @var{vec}.")
+#define FUNC_NAME s_scm_bitvector_to_list
+{
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
+ SCM res = SCM_EOL;
+
+ bits = scm_bitvector_writable_elements (vec, &handle,
+ &off, &len, &inc);
+
+ if (off == 0 && inc == 1)
+ {
+ /* the usual case
+ */
+ size_t word_len = (len + 31) / 32;
+ size_t i, j;
+
+ for (i = 0; i < word_len; i++, len -= 32)
+ {
+ scm_t_uint32 mask = 1;
+ for (j = 0; j < 32 && j < len; j++, mask <<= 1)
+ res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res);
+ }
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
+ }
+
+ scm_array_handle_release (&handle);
+
+ return scm_reverse_x (res, SCM_EOL);
+}
+#undef FUNC_NAME
+
+/* From mmix-arith.w by Knuth.
+
+ Here's a fun way to count the number of bits in a tetrabyte.
+
+ [This classical trick is called the ``Gillies--Miller method for
+ sideways addition'' in {\sl The Preparation of Programs for an
+ Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
+ edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
+ the tricks used here were suggested by Balbir Singh, Peter
+ Rossmanith, and Stefan Schwoon.]
+*/
+
+static size_t
+count_ones (scm_t_uint32 x)
+{
+ x=x-((x>>1)&0x55555555);
+ x=(x&0x33333333)+((x>>2)&0x33333333);
+ x=(x+(x>>4))&0x0f0f0f0f;
+ x=x+(x>>8);
+ return (x+(x>>16)) & 0xff;
+}
+
+SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
+ (SCM b, SCM bitvector),
+ "Return the number of occurrences of the boolean @var{b} in\n"
+ "@var{bitvector}.")
+#define FUNC_NAME s_scm_bit_count
+{
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
+ int bit = scm_to_bool (b);
+ size_t count = 0;
+
+ bits = scm_bitvector_writable_elements (bitvector, &handle,
+ &off, &len, &inc);
+
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ /* the usual case
+ */
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+ size_t i;
+
+ for (i = 0; i < word_len-1; i++)
+ count += count_ones (bits[i]);
+ count += count_ones (bits[i] & last_mask);
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ if (scm_is_true (scm_array_handle_ref (&handle, i*inc)))
+ count++;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return scm_from_size_t (bit? count : len-count);
+}
+#undef FUNC_NAME
+
+/* returns 32 for x == 0.
+*/
+static size_t
+find_first_one (scm_t_uint32 x)
+{
+ size_t pos = 0;
+ /* do a binary search in x. */
+ if ((x & 0xFFFF) == 0)
+ x >>= 16, pos += 16;
+ if ((x & 0xFF) == 0)
+ x >>= 8, pos += 8;
+ if ((x & 0xF) == 0)
+ x >>= 4, pos += 4;
+ if ((x & 0x3) == 0)
+ x >>= 2, pos += 2;
+ if ((x & 0x1) == 0)
+ pos += 1;
+ return pos;
+}
+
+SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
+ (SCM item, SCM v, SCM k),
+ "Return the index of the first occurrance of @var{item} in bit\n"
+ "vector @var{v}, starting from @var{k}. If there is no\n"
+ "@var{item} entry between @var{k} and the end of\n"
+ "@var{bitvector}, then return @code{#f}. For example,\n"
+ "\n"
+ "@example\n"
+ "(bit-position #t #*000101 0) @result{} 3\n"
+ "(bit-position #f #*0001111 3) @result{} #f\n"
+ "@end example")
+#define FUNC_NAME s_scm_bit_position
+{
+ scm_t_array_handle handle;
+ size_t off, len, first_bit;
+ ssize_t inc;
+ const scm_t_uint32 *bits;
+ int bit = scm_to_bool (item);
+ SCM res = SCM_BOOL_F;
+
+ bits = scm_bitvector_elements (v, &handle, &off, &len, &inc);
+ first_bit = scm_to_unsigned_integer (k, 0, len);
+
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ size_t i, word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+ size_t first_word = first_bit / 32;
+ scm_t_uint32 first_mask =
+ ((scm_t_uint32)-1) << (first_bit - 32*first_word);
+ scm_t_uint32 w;
+
+ for (i = first_word; i < word_len; i++)
+ {
+ w = (bit? bits[i] : ~bits[i]);
+ if (i == first_word)
+ w &= first_mask;
+ if (i == word_len-1)
+ w &= last_mask;
+ if (w)
+ {
+ res = scm_from_size_t (32*i + find_first_one (w));
+ break;
+ }
+ }
+ }
+ else
+ {
+ size_t i;
+ for (i = first_bit; i < len; i++)
+ {
+ SCM elt = scm_array_handle_ref (&handle, i*inc);
+ if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
+ {
+ res = scm_from_size_t (i);
+ break;
+ }
+ }
+ }
+
+ scm_array_handle_release (&handle);
+
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
+ (SCM v, SCM kv, SCM obj),
+ "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
+ "selecting the entries to change. The return value is\n"
+ "unspecified.\n"
+ "\n"
+ "If @var{kv} is a bit vector, then those entries where it has\n"
+ "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
+ "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
+ "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
+ "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
+ "\n"
+ "@example\n"
+ "(define bv #*01000010)\n"
+ "(bit-set*! bv #*10010001 #t)\n"
+ "bv\n"
+ "@result{} #*11010011\n"
+ "@end example\n"
+ "\n"
+ "If @var{kv} is a u32vector, then its elements are\n"
+ "indices into @var{v} which are set to @var{obj}.\n"
+ "\n"
+ "@example\n"
+ "(define bv #*01000010)\n"
+ "(bit-set*! bv #u32(5 2 7) #t)\n"
+ "bv\n"
+ "@result{} #*01100111\n"
+ "@end example")
+#define FUNC_NAME s_scm_bit_set_star_x
+{
+ scm_t_array_handle v_handle;
+ size_t v_off, v_len;
+ ssize_t v_inc;
+ scm_t_uint32 *v_bits;
+ int bit;
+
+ /* Validate that OBJ is a boolean so this is done even if we don't
+ need BIT.
+ */
+ bit = scm_to_bool (obj);
+
+ v_bits = scm_bitvector_writable_elements (v, &v_handle,
+ &v_off, &v_len, &v_inc);
+
+ if (scm_is_bitvector (kv))
+ {
+ scm_t_array_handle kv_handle;
+ size_t kv_off, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_bits;
+
+ kv_bits = scm_bitvector_elements (v, &kv_handle,
+ &kv_off, &kv_len, &kv_inc);
+
+ if (v_len != kv_len)
+ scm_misc_error (NULL,
+ "bit vectors must have equal length",
+ SCM_EOL);
+
+ if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
+ {
+ size_t word_len = (kv_len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
+ size_t i;
+
+ if (bit == 0)
+ {
+ for (i = 0; i < word_len-1; i++)
+ v_bits[i] &= ~kv_bits[i];
+ v_bits[i] &= ~(kv_bits[i] & last_mask);
+ }
+ else
+ {
+ for (i = 0; i < word_len-1; i++)
+ v_bits[i] |= kv_bits[i];
+ v_bits[i] |= kv_bits[i] & last_mask;
+ }
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < kv_len; i++)
+ if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc)))
+ scm_array_handle_set (&v_handle, i*v_inc, obj);
+ }
+
+ scm_array_handle_release (&kv_handle);
+
+ }
+ else if (scm_is_true (scm_u32vector_p (kv)))
+ {
+ scm_t_array_handle kv_handle;
+ size_t i, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_elts;
+
+ kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
+ for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
+ scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj);
+
+ scm_array_handle_release (&kv_handle);
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
+
+ scm_array_handle_release (&v_handle);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
+ (SCM v, SCM kv, SCM obj),
+ "Return a count of how many entries in bit vector @var{v} are\n"
+ "equal to @var{obj}, with @var{kv} selecting the entries to\n"
+ "consider.\n"
+ "\n"
+ "If @var{kv} is a bit vector, then those entries where it has\n"
+ "@code{#t} are the ones in @var{v} which are considered.\n"
+ "@var{kv} and @var{v} must be the same length.\n"
+ "\n"
+ "If @var{kv} is a u32vector, then it contains\n"
+ "the indexes in @var{v} to consider.\n"
+ "\n"
+ "For example,\n"
+ "\n"
+ "@example\n"
+ "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
+ "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
+ "@end example")
+#define FUNC_NAME s_scm_bit_count_star
+{
+ scm_t_array_handle v_handle;
+ size_t v_off, v_len;
+ ssize_t v_inc;
+ const scm_t_uint32 *v_bits;
+ size_t count = 0;
+ int bit;
+
+ /* Validate that OBJ is a boolean so this is done even if we don't
+ need BIT.
+ */
+ bit = scm_to_bool (obj);
+
+ v_bits = scm_bitvector_elements (v, &v_handle,
+ &v_off, &v_len, &v_inc);
+
+ if (scm_is_bitvector (kv))
+ {
+ scm_t_array_handle kv_handle;
+ size_t kv_off, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_bits;
+
+ kv_bits = scm_bitvector_elements (v, &kv_handle,
+ &kv_off, &kv_len, &kv_inc);
+
+ if (v_len != kv_len)
+ scm_misc_error (NULL,
+ "bit vectors must have equal length",
+ SCM_EOL);
+
+ if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
+ {
+ size_t i, word_len = (kv_len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
+ scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1);
+
+ for (i = 0; i < word_len-1; i++)
+ count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]);
+ count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask);
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < kv_len; i++)
+ if (scm_is_true (scm_array_handle_ref (&kv_handle, i)))
+ {
+ SCM elt = scm_array_handle_ref (&v_handle, i*v_inc);
+ if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
+ count++;
+ }
+ }
+
+ scm_array_handle_release (&kv_handle);
+
+ }
+ else if (scm_is_true (scm_u32vector_p (kv)))
+ {
+ scm_t_array_handle kv_handle;
+ size_t i, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_elts;
+
+ kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
+ for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
+ {
+ SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc);
+ if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
+ count++;
+ }
+
+ scm_array_handle_release (&kv_handle);
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
+
+ scm_array_handle_release (&v_handle);
+
+ return scm_from_size_t (count);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
+ (SCM v),
+ "Modify the bit vector @var{v} by replacing each element with\n"
+ "its negation.")
+#define FUNC_NAME s_scm_bit_invert_x
+{
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
+
+ bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc);
+
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+ size_t i;
+
+ for (i = 0; i < word_len-1; i++)
+ bits[i] = ~bits[i];
+ bits[i] = bits[i] ^ last_mask;
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ scm_array_handle_set (&handle, i*inc,
+ scm_not (scm_array_handle_ref (&handle, i*inc)));
+ }
+
+ scm_array_handle_release (&handle);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_istr2bve (SCM str)
+{
+ scm_t_array_handle handle;
+ size_t len = scm_i_string_length (str);
+ SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED);
+ SCM res = vec;
+
+ scm_t_uint32 mask;
+ size_t k, j;
+ const char *c_str;
+ scm_t_uint32 *data;
+
+ data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
+ c_str = scm_i_string_chars (str);
+
+ for (k = 0; k < (len + 31) / 32; k++)
+ {
+ data[k] = 0L;
+ j = len - k * 32;
+ if (j > 32)
+ j = 32;
+ for (mask = 1L; j--; mask <<= 1)
+ switch (*c_str++)
+ {
+ case '0':
+ break;
+ case '1':
+ data[k] |= mask;
+ break;
+ default:
+ res = SCM_BOOL_F;
+ goto exit;
+ }
+ }
+
+ exit:
+ scm_array_handle_release (&handle);
+ scm_remember_upto_here_1 (str);
+ return res;
+}
+
+/* FIXME: h->array should be h->vector */
+static SCM
+bitvector_handle_ref (scm_t_array_handle *h, size_t pos)
+{
+ return scm_c_bitvector_ref (h->array, pos);
+}
+
+static void
+bitvector_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
+{
+ scm_c_bitvector_set_x (h->array, pos, val);
+}
+
+static void
+bitvector_get_handle (SCM bv, scm_t_array_handle *h)
+{
+ h->array = bv;
+ h->ndims = 1;
+ h->dims = &h->dim0;
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = BITVECTOR_LENGTH (bv) - 1;
+ h->dim0.inc = 1;
+ h->element_type = SCM_ARRAY_ELEMENT_TYPE_BIT;
+ h->elements = h->writable_elements = BITVECTOR_BITS (bv);
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_tc16_bitvector, 0xffff,
+ bitvector_handle_ref, bitvector_handle_set,
+ bitvector_get_handle);
+SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector);
+
+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);
+
+#include "libguile/bitvectors.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/bitvectors.h b/libguile/bitvectors.h
new file mode 100644
index 000000000..b6cf38357
--- /dev/null
+++ b/libguile/bitvectors.h
@@ -0,0 +1,81 @@
+/* classes: h_files */
+
+#ifndef SCM_BITVECTORS_H
+#define SCM_BITVECTORS_H
+
+/* Copyright (C) 1995,1996,1997,1999,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
+ * 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"
+#include "libguile/array-handle.h"
+
+
+
+/* Bitvectors. Exciting stuff, maybe!
+ */
+
+
+/** Bit vectors */
+
+SCM_API SCM scm_bitvector_p (SCM vec);
+SCM_API SCM scm_bitvector (SCM bits);
+SCM_API SCM scm_make_bitvector (SCM len, SCM fill);
+SCM_API SCM scm_bitvector_length (SCM vec);
+SCM_API SCM scm_bitvector_ref (SCM vec, SCM idx);
+SCM_API SCM scm_bitvector_set_x (SCM vec, SCM idx, SCM val);
+SCM_API SCM scm_list_to_bitvector (SCM list);
+SCM_API SCM scm_bitvector_to_list (SCM vec);
+SCM_API SCM scm_bitvector_fill_x (SCM vec, SCM val);
+
+SCM_API SCM scm_bit_count (SCM item, SCM seq);
+SCM_API SCM scm_bit_position (SCM item, SCM v, SCM k);
+SCM_API SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj);
+SCM_API SCM scm_bit_count_star (SCM v, SCM kv, SCM obj);
+SCM_API SCM scm_bit_invert_x (SCM v);
+SCM_API SCM scm_istr2bve (SCM str);
+
+SCM_API int scm_is_bitvector (SCM obj);
+SCM_API SCM scm_c_make_bitvector (size_t len, SCM fill);
+SCM_API size_t scm_c_bitvector_length (SCM vec);
+SCM_API SCM scm_c_bitvector_ref (SCM vec, size_t idx);
+SCM_API void scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val);
+SCM_API const scm_t_uint32 *scm_array_handle_bit_elements (scm_t_array_handle *h);
+SCM_API scm_t_uint32 *scm_array_handle_bit_writable_elements (scm_t_array_handle *h);
+SCM_API size_t scm_array_handle_bit_elements_offset (scm_t_array_handle *h);
+SCM_API const scm_t_uint32 *scm_bitvector_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *offp,
+ size_t *lenp,
+ ssize_t *incp);
+SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *offp,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_INTERNAL void scm_init_bitvectors (void);
+
+#endif /* SCM_BITVECTORS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 24afd2414..9c2b11910 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -31,7 +31,9 @@
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/ieee-754.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
+#include "libguile/array-handle.h"
+#include "libguile/uniform.h"
#include "libguile/srfi-4.h"
#include <byteswap.h>
@@ -175,47 +177,99 @@
scm_t_bits scm_tc16_bytevector;
-#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
+#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
+#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
+ ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
+#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
-#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
+#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
+#define SCM_BYTEVECTOR_SET_INLINE(bv) \
+ SCM_SET_SMOB_FLAGS (bv, SCM_SMOB_FLAGS (bv) | SCM_F_BYTEVECTOR_INLINE)
+#define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \
+ SCM_SET_SMOB_FLAGS (bv, (SCM_SMOB_FLAGS (bv) & 0xFF) | (hint << 8))
+#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
+ (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
+#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
+ SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var)
/* The empty bytevector. */
SCM scm_null_bytevector = SCM_UNSPECIFIED;
static inline SCM
-make_bytevector_from_buffer (size_t len, signed char *contents)
+make_bytevector_from_buffer (size_t len, void *contents,
+ scm_t_array_element_type element_type)
{
- /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
- SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents);
+ SCM ret;
+ size_t c_len;
+
+ if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
+ || scm_i_array_element_type_sizes[element_type] < 8
+ || len >= (SCM_I_SIZE_MAX
+ / (scm_i_array_element_type_sizes[element_type]/8))))
+ /* This would be an internal Guile programming error */
+ abort ();
+
+ c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
+ if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_len))
+ SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, contents);
+ else
+ {
+ SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, NULL);
+ SCM_BYTEVECTOR_SET_INLINE (ret);
+ if (contents)
+ {
+ memcpy (SCM_BYTEVECTOR_CONTENTS (ret), contents, c_len);
+ scm_gc_free (contents, c_len, SCM_GC_BYTEVECTOR);
+ }
+ }
+ SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
+ return ret;
}
static inline SCM
-make_bytevector (size_t len)
+make_bytevector (size_t len, scm_t_array_element_type element_type)
{
- SCM bv;
+ size_t c_len;
- if (SCM_UNLIKELY (len == 0))
- bv = scm_null_bytevector;
+ if (SCM_UNLIKELY (len == 0 && element_type == 0))
+ return scm_null_bytevector;
+ else if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
+ || scm_i_array_element_type_sizes[element_type] < 8
+ || len >= (SCM_I_SIZE_MAX
+ / (scm_i_array_element_type_sizes[element_type]/8))))
+ /* This would be an internal Guile programming error */
+ abort ();
+
+ c_len = len * (scm_i_array_element_type_sizes[element_type]/8);
+ if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_len))
+ {
+ SCM ret;
+ SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, NULL);
+ SCM_BYTEVECTOR_SET_INLINE (ret);
+ SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
+ return ret;
+ }
else
{
- signed char *contents = NULL;
-
- if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))
- contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR);
-
- bv = make_bytevector_from_buffer (len, contents);
+ void *buf = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ return make_bytevector_from_buffer (len, buf, element_type);
}
-
- return bv;
}
/* Return a new bytevector of size LEN octets. */
SCM
scm_c_make_bytevector (size_t len)
{
- return (make_bytevector (len));
+ return make_bytevector (len, SCM_ARRAY_ELEMENT_TYPE_VU8);
+}
+
+/* Return a new bytevector of size LEN elements. */
+SCM
+scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type)
+{
+ return make_bytevector (len, element_type);
}
/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
@@ -223,22 +277,14 @@ scm_c_make_bytevector (size_t len)
SCM
scm_c_take_bytevector (signed char *contents, size_t len)
{
- SCM bv;
-
- if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)))
- {
- /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
- signed char *c_bv;
-
- bv = make_bytevector (len);
- c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
- memcpy (c_bv, contents, len);
- scm_gc_free (contents, len, SCM_GC_BYTEVECTOR);
- }
- else
- bv = make_bytevector_from_buffer (len, contents);
+ return make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
+}
- return bv;
+SCM
+scm_c_take_typed_bytevector (signed char *contents, size_t len,
+ scm_t_array_element_type element_type)
+{
+ return make_bytevector_from_buffer (len, contents, element_type);
}
/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
@@ -246,6 +292,10 @@ scm_c_take_bytevector (signed char *contents, size_t len)
SCM
scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
{
+ if (SCM_UNLIKELY (c_new_len % SCM_BYTEVECTOR_TYPE_SIZE (bv)))
+ /* This would be an internal Guile programming error */
+ abort ();
+
if (!SCM_BYTEVECTOR_INLINE_P (bv))
{
size_t c_len;
@@ -259,6 +309,7 @@ scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len))
{
/* Copy to the in-line buffer and free the current buffer. */
+ SCM_BYTEVECTOR_SET_INLINE (bv);
c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv);
memcpy (c_new_bv, c_bv, c_new_len);
scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
@@ -271,6 +322,8 @@ scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv);
}
}
+ else
+ SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
return bv;
}
@@ -329,38 +382,30 @@ scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value)
}
#undef FUNC_NAME
-/* This procedure is used by `scm_c_generalized_vector_set_x ()'. */
-void
-scm_i_bytevector_generalized_set_x (SCM bv, size_t index, SCM value)
-#define FUNC_NAME "scm_i_bytevector_generalized_set_x"
-{
- scm_c_bytevector_set_x (bv, index, scm_to_uint8 (value));
-}
-#undef FUNC_NAME
+
+
+
static int
-print_bytevector (SCM bv, SCM port, scm_print_state *pstate)
+print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- unsigned c_len, i;
- unsigned char *c_bv;
-
- c_len = SCM_BYTEVECTOR_LENGTH (bv);
- c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ ssize_t ubnd, inc, i;
+ scm_t_array_handle h;
+
+ scm_array_get_handle (bv, &h);
- scm_puts ("#vu8(", port);
- for (i = 0; i < c_len; i++)
+ scm_putc ('#', port);
+ scm_write (scm_array_handle_element_type (&h), port);
+ scm_putc ('(', port);
+ for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc;
+ i <= ubnd; i += inc)
{
if (i > 0)
scm_putc (' ', port);
-
- scm_uintprint (c_bv[i], 10, port);
+ scm_write (scm_array_handle_ref (&h, i), port);
}
-
scm_putc (')', port);
- /* Make GCC think we use it. */
- scm_remember_upto_here ((SCM) pstate);
-
return 1;
}
@@ -448,7 +493,7 @@ SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
c_fill = (signed char) value;
}
- bv = make_bytevector (c_len);
+ bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
if (fill != SCM_UNDEFINED)
{
unsigned i;
@@ -574,7 +619,7 @@ SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
c_len = SCM_BYTEVECTOR_LENGTH (bv);
c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
- copy = make_bytevector (c_len);
+ copy = make_bytevector (c_len, SCM_BYTEVECTOR_ELEMENT_TYPE (bv));
c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
memcpy (c_copy, c_bv, c_len);
@@ -604,7 +649,7 @@ SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
sz = scm_array_handle_uniform_element_size (&h);
- ret = make_bytevector (len * sz);
+ ret = make_bytevector (len * sz, SCM_ARRAY_ELEMENT_TYPE_VU8);
memcpy (SCM_BYTEVECTOR_CONTENTS (ret), base, len * sz);
scm_array_handle_release (&h);
@@ -693,7 +738,7 @@ SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
- bv = make_bytevector (c_len);
+ bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
@@ -1130,7 +1175,7 @@ SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
scm_out_of_range (FUNC_NAME, size); \
\
- bv = make_bytevector (c_len * c_size); \
+ bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
\
for (c_bv_ptr = c_bv; \
@@ -1629,6 +1674,12 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
_c_type ## _to_foreign_endianness
+/* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */
+#define VALIDATE_REAL(pos, v) \
+ do { \
+ SCM_ASSERT_TYPE (scm_is_true (scm_rational_p (v)), v, pos, FUNC_NAME, "real"); \
+ } while (0)
+
/* Templace getters and setters. */
#define IEEE754_ACCESSOR_PROLOGUE(_type) \
@@ -1665,7 +1716,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
_type c_value; \
\
IEEE754_ACCESSOR_PROLOGUE (_type); \
- SCM_VALIDATE_REAL (3, value); \
+ VALIDATE_REAL (3, value); \
SCM_VALIDATE_SYMBOL (4, endianness); \
c_value = IEEE754_FROM_SCM (_type) (value); \
\
@@ -1685,7 +1736,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
_type c_value; \
\
IEEE754_ACCESSOR_PROLOGUE (_type); \
- SCM_VALIDATE_REAL (3, value); \
+ VALIDATE_REAL (3, value); \
c_value = IEEE754_FROM_SCM (_type) (value); \
\
memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
@@ -1896,8 +1947,7 @@ utf_encoding_name (char *name, size_t utf_width, SCM endianness)
scm_list_1 (str), err); \
else \
/* C_UTF is null-terminated. */ \
- utf = scm_c_take_bytevector ((signed char *) c_utf, \
- c_utf_len); \
+ utf = scm_c_take_bytevector ((signed char *) c_utf, c_utf_len); \
\
return (utf);
@@ -2059,6 +2109,127 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
+/* Bytevectors as generalized vectors & arrays. */
+
+
+static SCM
+bytevector_ref_c32 (SCM bv, SCM idx)
+{ /* FIXME add some checks */
+ const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv);
+ size_t i = scm_to_size_t (idx);
+ return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]);
+}
+
+static SCM
+bytevector_ref_c64 (SCM bv, SCM idx)
+{ /* FIXME add some checks */
+ const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv);
+ size_t i = scm_to_size_t (idx);
+ return scm_c_make_rectangular (contents[i/16], contents[i/16 + 1]);
+}
+
+typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
+
+const scm_t_bytevector_ref_fn bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
+{
+ NULL, /* SCM */
+ NULL, /* CHAR */
+ NULL, /* BIT */
+ scm_bytevector_u8_ref, /* VU8 */
+ scm_bytevector_u8_ref, /* U8 */
+ scm_bytevector_s8_ref,
+ scm_bytevector_u16_native_ref,
+ scm_bytevector_s16_native_ref,
+ scm_bytevector_u32_native_ref,
+ scm_bytevector_s32_native_ref,
+ scm_bytevector_u64_native_ref,
+ scm_bytevector_s64_native_ref,
+ scm_bytevector_ieee_single_native_ref,
+ scm_bytevector_ieee_double_native_ref,
+ bytevector_ref_c32,
+ bytevector_ref_c64
+};
+
+static SCM
+bv_handle_ref (scm_t_array_handle *h, size_t index)
+{
+ SCM byte_index;
+ scm_t_bytevector_ref_fn ref_fn;
+
+ ref_fn = bytevector_ref_fns[h->element_type];
+ byte_index =
+ scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
+ return ref_fn (h->array, byte_index);
+}
+
+static SCM
+bytevector_set_c32 (SCM bv, SCM idx, SCM val)
+{ /* checks are unnecessary here */
+ float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
+ size_t i = scm_to_size_t (idx);
+ contents[i/8] = scm_c_real_part (val);
+ contents[i/8 + 1] = scm_c_imag_part (val);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+bytevector_set_c64 (SCM bv, SCM idx, SCM val)
+{ /* checks are unnecessary here */
+ double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv);
+ size_t i = scm_to_size_t (idx);
+ contents[i/16] = scm_c_real_part (val);
+ contents[i/16 + 1] = scm_c_imag_part (val);
+ return SCM_UNSPECIFIED;
+}
+
+typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);
+
+const scm_t_bytevector_set_fn bytevector_set_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
+{
+ NULL, /* SCM */
+ NULL, /* CHAR */
+ NULL, /* BIT */
+ scm_bytevector_u8_set_x, /* VU8 */
+ scm_bytevector_u8_set_x, /* U8 */
+ scm_bytevector_s8_set_x,
+ scm_bytevector_u16_native_set_x,
+ scm_bytevector_s16_native_set_x,
+ scm_bytevector_u32_native_set_x,
+ scm_bytevector_s32_native_set_x,
+ scm_bytevector_u64_native_set_x,
+ scm_bytevector_s64_native_set_x,
+ scm_bytevector_ieee_single_native_set_x,
+ scm_bytevector_ieee_double_native_set_x,
+ bytevector_set_c32,
+ bytevector_set_c64
+};
+
+static void
+bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val)
+{
+ SCM byte_index;
+ scm_t_bytevector_set_fn set_fn;
+
+ set_fn = bytevector_set_fns[h->element_type];
+ byte_index =
+ scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
+ set_fn (h->array, byte_index, val);
+}
+
+static void
+bytevector_get_handle (SCM v, scm_t_array_handle *h)
+{
+ h->array = v;
+ h->ndims = 1;
+ h->dims = &h->dim0;
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = SCM_BYTEVECTOR_TYPED_LENGTH (v) - 1;
+ h->dim0.inc = 1;
+ h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v);
+ h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v);
+}
+
+
/* Initialization. */
void
@@ -2073,7 +2244,8 @@ scm_bootstrap_bytevectors (void)
scm_set_smob_equalp (scm_tc16_bytevector, bytevector_equal_p);
scm_null_bytevector =
- scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
+ scm_gc_protect_object
+ (make_bytevector_from_buffer (0, NULL, SCM_ARRAY_ELEMENT_TYPE_VU8));
#ifdef WORDS_BIGENDIAN
scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("big"));
@@ -2084,6 +2256,20 @@ scm_bootstrap_bytevectors (void)
scm_c_register_extension ("libguile", "scm_init_bytevectors",
(scm_t_extension_init_func) scm_init_bytevectors,
NULL);
+
+ {
+ scm_t_array_implementation impl;
+
+ impl.tag = scm_tc16_bytevector;
+ impl.mask = 0xffff;
+ impl.vref = bv_handle_ref;
+ impl.vset = bv_handle_set_x;
+ impl.get_handle = bytevector_get_handle;
+ scm_i_register_array_implementation (&impl);
+ scm_i_register_vector_constructor
+ (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8],
+ scm_make_bytevector);
+ }
}
void
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index cb2726251..e29fe6d11 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -116,17 +116,21 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
i.e., without allocating memory beside the SMOB itself (a double cell).
This optimization is necessary since small bytevectors are expected to be
common. */
-#define SCM_BYTEVECTOR_P(_bv) \
+#define SCM_BYTEVECTOR_P(_bv) \
SCM_SMOB_PREDICATE (scm_tc16_bytevector, _bv)
-#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
-#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
- ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
-#define SCM_BYTEVECTOR_INLINE_P(_bv) \
- (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (SCM_BYTEVECTOR_LENGTH (_bv)))
+#define SCM_F_BYTEVECTOR_INLINE 0x1
+#define SCM_BYTEVECTOR_INLINE_P(_bv) \
+ (SCM_SMOB_FLAGS (_bv) & SCM_F_BYTEVECTOR_INLINE)
+#define SCM_BYTEVECTOR_ELEMENT_TYPE(_bv) \
+ (SCM_SMOB_FLAGS (_bv) >> 8)
/* Hint that is passed to `scm_gc_malloc ()' and friends. */
#define SCM_GC_BYTEVECTOR "bytevector"
+SCM_INTERNAL SCM scm_i_make_typed_bytevector (size_t, scm_t_array_element_type);
+SCM_INTERNAL SCM scm_c_take_typed_bytevector (signed char *, size_t,
+ scm_t_array_element_type);
+
SCM_INTERNAL void scm_bootstrap_bytevectors (void);
SCM_INTERNAL void scm_init_bytevectors (void);
diff --git a/libguile/chars.c b/libguile/chars.c
index 2103c540c..c7cb09c47 100644
--- a/libguile/chars.c
+++ b/libguile/chars.c
@@ -296,14 +296,14 @@ TODO: change name to scm_i_.. ? --hwn
scm_t_wchar
scm_c_upcase (scm_t_wchar c)
{
- return uc_toupper (c);
+ return uc_toupper ((int) c);
}
scm_t_wchar
scm_c_downcase (scm_t_wchar c)
{
- return uc_tolower (c);
+ return uc_tolower ((int) c);
}
@@ -357,7 +357,7 @@ static const scm_t_uint32 const scm_alt_charnums[] = {
const char *
scm_i_charname (SCM chr)
{
- int c;
+ size_t c;
scm_t_uint32 i = SCM_CHAR (chr);
for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
@@ -379,7 +379,7 @@ scm_i_charname (SCM chr)
SCM
scm_i_charname_to_char (const char *charname, size_t charname_len)
{
- int c;
+ size_t c;
/* The R5RS charnames. These are supposed to be case
insensitive. */
diff --git a/libguile/chars.h b/libguile/chars.h
index 4d1be1db9..85b16739a 100644
--- a/libguile/chars.h
+++ b/libguile/chars.h
@@ -24,7 +24,11 @@
#include "libguile/__scm.h"
-#include "libguile/numbers.h"
+
+#ifndef SCM_T_WCHAR_DEFINED
+typedef scm_t_int32 scm_t_wchar;
+#define SCM_T_WCHAR_DEFINED
+#endif /* SCM_T_WCHAR_DEFINED */
/* Immediate Characters
@@ -32,10 +36,16 @@
#define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char)
#define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x))
-#define SCM_MAKE_CHAR(x) \
- (x < 0 \
- ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) x, scm_tc8_char) \
- : SCM_MAKE_ITAG8 ((scm_t_bits) x, scm_tc8_char))
+/* SCM_MAKE_CHAR maps signed chars (-128 to 127) and unsigned chars (0
+ to 255) to Latin-1 codepoints (0 to 255) while allowing higher
+ codepoints (256 to 1114111) to pass through unchanged.
+
+ This macro evaluates x twice, which may lead to side effects if not
+ used properly. */
+#define SCM_MAKE_CHAR(x) \
+ ((x) <= 1 \
+ ? 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_MAX (0x10ffff)
#define SCM_IS_UNICODE_CHAR(c) \
diff --git a/libguile/continuations.c b/libguile/continuations.c
index f85647684..347bd8027 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -131,7 +131,7 @@ scm_make_continuation (int *first)
SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
- *first = !setjmp (continuation->jmpbuf);
+ *first = !SCM_I_SETJMP (continuation->jmpbuf);
if (*first)
{
#ifdef __ia64__
@@ -229,12 +229,12 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val,
scm_i_set_last_debug_frame (continuation->dframe);
continuation->throw_value = val;
- longjmp (continuation->jmpbuf, 1);
+ SCM_I_LONGJMP (continuation->jmpbuf, 1);
}
#ifdef __ia64__
void
-scm_ia64_longjmp (jmp_buf *JB, int VAL)
+scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL)
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
diff --git a/libguile/continuations.h b/libguile/continuations.h
index 08eec8f54..82cf178b0 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -44,7 +44,7 @@ SCM_API scm_t_bits scm_tc16_continuation;
typedef struct
{
SCM throw_value;
- jmp_buf jmpbuf;
+ scm_i_jmp_buf jmpbuf;
SCM dynenv;
#ifdef __ia64__
void *backing_store;
diff --git a/libguile/conv-uinteger.i.c b/libguile/conv-uinteger.i.c
index ff0d28012..52f49f772 100644
--- a/libguile/conv-uinteger.i.c
+++ b/libguile/conv-uinteger.i.c
@@ -53,10 +53,17 @@ SCM_TO_TYPE_PROTO (SCM val)
#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SCM_SIZEOF_LONG
return n;
#else
- if (n >= TYPE_MIN && n <= TYPE_MAX)
- return n;
- else
- goto out_of_range;
+
+#if TYPE_MIN == 0
+ if (n <= TYPE_MAX)
+ return n;
+#else /* TYPE_MIN != 0 */
+ if (n >= TYPE_MIN && n <= TYPE_MAX)
+ return n;
+#endif /* TYPE_MIN != 0 */
+ else
+ goto out_of_range;
+
#endif
}
else
@@ -76,10 +83,16 @@ SCM_TO_TYPE_PROTO (SCM val)
mpz_export (&n, &count, 1, sizeof (TYPE), 0, 0, SCM_I_BIG_MPZ (val));
+#if TYPE_MIN == 0
+ if (n <= TYPE_MAX)
+ return n;
+#else /* TYPE_MIN != 0 */
if (n >= TYPE_MIN && n <= TYPE_MAX)
return n;
- else
- goto out_of_range;
+#endif /* TYPE_MIN != 0 */
+ else
+ goto out_of_range;
+
}
}
else
diff --git a/libguile/convert.c b/libguile/convert.c
deleted file mode 100644
index d87d72464..000000000
--- a/libguile/convert.c
+++ /dev/null
@@ -1,147 +0,0 @@
-/* Copyright (C) 2002, 2006 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 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/validate.h"
-#include "libguile/strings.h"
-#include "libguile/vectors.h"
-#include "libguile/pairs.h"
-#include "libguile/unif.h"
-#include "libguile/srfi-4.h"
-
-#include "libguile/convert.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-/* char *scm_c_scm2chars (SCM obj, char *dst);
- SCM scm_c_chars2scm (const char *src, long n);
- SCM scm_c_chars2byvect (const char *src, long n);
-*/
-
-#define CTYPE char
-#define FROM_CTYPE scm_from_char
-#define SCM2CTYPES scm_c_scm2chars
-#define CTYPES2SCM scm_c_chars2scm
-#define CTYPES2UVECT scm_c_chars2byvect
-#if CHAR_MIN == 0
-/* 'char' is unsigned. */
-#define UVEC_TAG u8
-#define UVEC_CTYPE scm_t_uint8
-#else
-/* 'char' is signed. */
-#define UVEC_TAG s8
-#define UVEC_CTYPE scm_t_int8
-#endif
-#include "libguile/convert.i.c"
-
-/* short *scm_c_scm2shorts (SCM obj, short *dst);
- SCM scm_c_shorts2scm (const short *src, long n);
- SCM scm_c_shorts2svect (const short *src, long n);
-*/
-
-#define CTYPE short
-#define FROM_CTYPE scm_from_short
-#define SCM2CTYPES scm_c_scm2shorts
-#define CTYPES2SCM scm_c_shorts2scm
-#define CTYPES2UVECT scm_c_shorts2svect
-#define UVEC_TAG s16
-#define UVEC_CTYPE scm_t_int16
-#include "libguile/convert.i.c"
-
-/* int *scm_c_scm2ints (SCM obj, int *dst);
- SCM scm_c_ints2scm (const int *src, long n);
- SCM scm_c_ints2ivect (const int *src, long n);
- SCM scm_c_uints2uvect (const unsigned int *src, long n);
-*/
-
-#define CTYPE int
-#define FROM_CTYPE scm_from_int
-#define SCM2CTYPES scm_c_scm2ints
-#define CTYPES2SCM scm_c_ints2scm
-#define CTYPES2UVECT scm_c_ints2ivect
-#define UVEC_TAG s32
-#define UVEC_CTYPE scm_t_int32
-
-#define CTYPES2UVECT_2 scm_c_uints2uvect
-#define CTYPE_2 unsigned int
-#define UVEC_TAG_2 u32
-#define UVEC_CTYPE_2 scm_t_uint32
-
-#include "libguile/convert.i.c"
-
-/* long *scm_c_scm2longs (SCM obj, long *dst);
- SCM scm_c_longs2scm (const long *src, long n);
- SCM scm_c_longs2ivect (const long *src, long n);
- SCM scm_c_ulongs2uvect (const unsigned long *src, long n);
-*/
-
-#define CTYPE long
-#define FROM_CTYPE scm_from_long
-#define SCM2CTYPES scm_c_scm2longs
-#define CTYPES2SCM scm_c_longs2scm
-#define CTYPES2UVECT scm_c_longs2ivect
-#define UVEC_TAG s32
-#define UVEC_CTYPE scm_t_int32
-
-#define CTYPES2UVECT_2 scm_c_ulongs2uvect
-#define CTYPE_2 unsigned int
-#define UVEC_TAG_2 u32
-#define UVEC_CTYPE_2 scm_t_uint32
-
-#include "libguile/convert.i.c"
-
-/* float *scm_c_scm2floats (SCM obj, float *dst);
- SCM scm_c_floats2scm (const float *src, long n);
- SCM scm_c_floats2fvect (const float *src, long n);
-*/
-
-#define CTYPE float
-#define FROM_CTYPE scm_from_double
-#define SCM2CTYPES scm_c_scm2floats
-#define CTYPES2SCM scm_c_floats2scm
-#define CTYPES2UVECT scm_c_floats2fvect
-#define UVEC_TAG f32
-#define UVEC_CTYPE float
-#include "libguile/convert.i.c"
-
-/* double *scm_c_scm2doubles (SCM obj, double *dst);
- SCM scm_c_doubles2scm (const double *src, long n);
- SCM scm_c_doubles2dvect (const double *src, long n);
-*/
-
-#define CTYPE double
-#define FROM_CTYPE scm_from_double
-#define SCM2CTYPES scm_c_scm2doubles
-#define CTYPES2SCM scm_c_doubles2scm
-#define CTYPES2UVECT scm_c_doubles2dvect
-#define UVEC_TAG f64
-#define UVEC_CTYPE double
-#include "libguile/convert.i.c"
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/convert.h b/libguile/convert.h
deleted file mode 100644
index 6ce7c2274..000000000
--- a/libguile/convert.h
+++ /dev/null
@@ -1,51 +0,0 @@
-/* classes: h_files */
-
-#ifndef SCM_CONVERT_H
-#define SCM_CONVERT_H
-
-/* Copyright (C) 2002, 2006 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 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"
-
-SCM_API char *scm_c_scm2chars (SCM obj, char *dst);
-SCM_API short *scm_c_scm2shorts (SCM obj, short *dst);
-SCM_API int *scm_c_scm2ints (SCM obj, int *dst);
-SCM_API long *scm_c_scm2longs (SCM obj, long *dst);
-SCM_API float *scm_c_scm2floats (SCM obj, float *dst);
-SCM_API double *scm_c_scm2doubles (SCM obj, double *dst);
-
-SCM_API SCM scm_c_chars2scm (const char *src, long n);
-SCM_API SCM scm_c_shorts2scm (const short *src, long n);
-SCM_API SCM scm_c_ints2scm (const int *src, long n);
-SCM_API SCM scm_c_longs2scm (const long *src, long n);
-SCM_API SCM scm_c_floats2scm (const float *src, long n);
-SCM_API SCM scm_c_doubles2scm (const double *src, long n);
-
-SCM_API SCM scm_c_chars2byvect (const char *src, long n);
-SCM_API SCM scm_c_shorts2svect (const short *src, long n);
-SCM_API SCM scm_c_ints2ivect (const int *src, long n);
-SCM_API SCM scm_c_uints2uvect (const unsigned int *src, long n);
-SCM_API SCM scm_c_longs2ivect (const long *src, long n);
-SCM_API SCM scm_c_ulongs2uvect (const unsigned long *src, long n);
-SCM_API SCM scm_c_floats2fvect (const float *src, long n);
-SCM_API SCM scm_c_doubles2dvect (const double *src, long n);
-
-#endif /* SCM_CONVERT_H */
diff --git a/libguile/convert.i.c b/libguile/convert.i.c
deleted file mode 100644
index 4e73bf970..000000000
--- a/libguile/convert.i.c
+++ /dev/null
@@ -1,171 +0,0 @@
-/* this file is #include'd (x times) by convert.c */
-
-/* You need to define the following macros before including this
- template. They are undefined at the end of this file to give a
- clean slate for the next inclusion.
-
- - CTYPE
-
- The type of an element of the C array, for example 'char'.
-
- - FROM_CTYPE
-
- The function that converts a CTYPE to a SCM, for example
- scm_from_char.
-
- - UVEC_TAG
-
- The tag of a suitable uniform vector that can hold the CTYPE, for
- example 's8'.
-
- - UVEC_CTYPE
-
- The C type of an element of the uniform vector, for example
- scm_t_int8.
-
- - SCM2CTYPES
-
- The name of the 'SCM-to-C' function, for example scm_c_scm2chars.
-
- - CTYPES2SCM
-
- The name of the 'C-to-SCM' function, for example, scm_c_chars2scm.
-
- - CTYPES2UVECT
-
- The name of the 'C-to-uniform-vector' function, for example
- scm_c_chars2byvect. It will create a uniform vector of kind
- UVEC_TAG.
-
- - CTYPES2UVECT_2
-
- The name of a second 'C-to-uniform-vector' function. Leave
- undefined if you want only one such function.
-
- - CTYPE_2
- - UVEC_TAG_2
- - UVEC_CTYPE_2
-
- The tag and C type of the second kind of uniform vector, for use
- with the function described above.
-
-*/
-
-/* The first level does not expand macros in the arguments. */
-#define paste(a1,a2,a3) a1##a2##a3
-#define stringify(a) #a
-
-/* But the second level does. */
-#define F(pre,T,suf) paste(pre,T,suf)
-#define S(T) stringify(T)
-
-/* Convert a vector, list or uniform vector into a C array. If the
- result array in argument 2 is NULL, malloc() a new one.
-*/
-
-CTYPE *
-SCM2CTYPES (SCM obj, CTYPE *data)
-{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- const UVEC_CTYPE *uvec_elements;
-
- obj = F(scm_any_to_,UVEC_TAG,vector) (obj);
- uvec_elements = F(scm_,UVEC_TAG,vector_elements) (obj, &handle, &len, &inc);
-
- if (data == NULL)
- data = scm_malloc (len * sizeof (CTYPE));
- for (i = 0; i < len; i++, uvec_elements += inc)
- data[i] = uvec_elements[i];
-
- scm_array_handle_release (&handle);
-
- return data;
-}
-
-/* Converts a C array into a vector. */
-
-SCM
-CTYPES2SCM (const CTYPE *data, long n)
-{
- long i;
- SCM v;
-
- v = scm_c_make_vector (n, SCM_UNSPECIFIED);
-
- for (i = 0; i < n; i++)
- SCM_SIMPLE_VECTOR_SET (v, i, FROM_CTYPE (data[i]));
-
- return v;
-}
-
-/* Converts a C array into a uniform vector. */
-
-SCM
-CTYPES2UVECT (const CTYPE *data, long n)
-{
- scm_t_array_handle handle;
- long i;
- SCM uvec;
- UVEC_CTYPE *uvec_elements;
-
- uvec = F(scm_make_,UVEC_TAG,vector) (scm_from_long (n), SCM_UNDEFINED);
- uvec_elements = F(scm_,UVEC_TAG,vector_writable_elements) (uvec, &handle,
- NULL, NULL);
- for (i = 0; i < n; i++)
- uvec_elements[i] = data[i];
-
- scm_array_handle_release (&handle);
-
- return uvec;
-}
-
-#ifdef CTYPE2UVECT_2
-
-SCM
-CTYPES2UVECT_2 (const CTYPE_2 *data, long n)
-{
- scm_t_array_handle handle;
- long i;
- SCM uvec;
- UVEC_CTYPE_2 *uvec_elements;
-
- uvec = F(scm_make_,UVEC_TAG_2,vector) (scm_from_long (n), SCM_UNDEFINED);
- uvec_elements = F(scm_,UVEC_TAG_2,vector_writable_elements) (uvec, &handle,
- NULL, NULL);
-
- for (i = 0; i < n; i++)
- uvec_elements[i] = data[i];
-
- scm_array_handle_release (&handle);
-
- return uvec;
-}
-
-#endif
-
-#undef paste
-#undef stringify
-#undef F
-#undef S
-
-#undef CTYPE
-#undef FROM_CTYPE
-#undef UVEC_TAG
-#undef UVEC_CTYPE
-#undef SCM2CTYPES
-#undef CTYPES2SCM
-#undef CTYPES2UVECT
-#ifdef CTYPES2UVECT_2
-#undef CTYPES2UVECT_2
-#undef CTYPE_2
-#undef UVEC_TAG_2
-#undef UVEC_CTYPE_2
-#endif
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/debug.c b/libguile/debug.c
index 71278c5e4..4bf311136 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -363,6 +363,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
if (!SCM_SMOB_DESCRIPTOR (proc).apply)
break;
case scm_tcs_subrs:
+ case scm_tc7_program:
procprop:
/* It would indeed be a nice thing if we supplied source even for
built in procedures! */
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 57a2f0657..6ecef3b4b 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -34,6 +34,7 @@
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/modules.h"
+#include "libguile/generalized-arrays.h"
#include "libguile/eval.h"
#include "libguile/smob.h"
#include "libguile/procprop.h"
@@ -749,17 +750,13 @@ scm_sym2ovcell (SCM sym, SCM obarray)
return (SYMBOL . SCM_UNDEFINED). */
-SCM
-scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int softness)
+static SCM
+intern_obarray_soft (SCM symbol, SCM obarray, unsigned int softness)
{
- SCM symbol = scm_from_locale_symboln (name, len);
size_t raw_hash = scm_i_symbol_hash (symbol);
size_t hash;
SCM lsym;
- scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
- "Use hashtables instead.");
-
if (scm_is_false (obarray))
{
if (softness)
@@ -795,6 +792,18 @@ scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int so
}
+SCM
+scm_intern_obarray_soft (const char *name, size_t len, SCM obarray,
+ unsigned int softness)
+{
+ SCM symbol = scm_from_locale_symboln (name, len);
+
+ scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
+ "Use hashtables instead.");
+
+ return intern_obarray_soft (symbol, obarray, softness);
+}
+
SCM
scm_intern_obarray (const char *name,size_t len,SCM obarray)
{
@@ -850,10 +859,7 @@ SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0,
else if (scm_is_eq (o, SCM_BOOL_T))
o = SCM_BOOL_F;
- vcell = scm_intern_obarray_soft (scm_i_string_chars (s),
- scm_i_string_length (s),
- o,
- softness);
+ vcell = intern_obarray_soft (scm_string_to_symbol (s), o, softness);
if (scm_is_false (vcell))
return vcell;
answer = SCM_CAR (vcell);
@@ -1070,7 +1076,8 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
{
char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN];
char *name = buf;
- int len, n_digits;
+ int n_digits;
+ size_t len;
scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
"Use `gensym' instead.");
@@ -1084,9 +1091,8 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
{
SCM_VALIDATE_STRING (1, prefix);
len = scm_i_string_length (prefix);
- if (len > MAX_PREFIX_LENGTH)
- name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN);
- strncpy (name, scm_i_string_chars (prefix), len);
+ name = scm_to_locale_stringn (prefix, &len);
+ name = scm_realloc (name, len + SCM_INTBUFLEN);
}
if (SCM_UNBNDP (obarray))
@@ -1108,7 +1114,7 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
obarray,
0);
if (name != buf)
- scm_must_free (name);
+ free (name);
return SCM_CAR (vcell);
}
}
@@ -1309,7 +1315,7 @@ scm_i_arrayp (SCM a)
{
scm_c_issue_deprecation_warning
("SCM_ARRAYP is deprecated. Use scm_is_array instead.");
- return SCM_I_ARRAYP(a) || SCM_I_ENCLOSED_ARRAYP(a);
+ return SCM_I_ARRAYP(a);
}
size_t
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 5b443c761..ad62a2bad 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -5,7 +5,7 @@
#ifndef SCM_DEPRECATED_H
#define SCM_DEPRECATED_H
-/* Copyright (C) 2003,2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 2003,2004, 2005, 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
@@ -24,6 +24,7 @@
*/
#include "libguile/__scm.h"
+#include "libguile/arrays.h"
#include "libguile/strings.h"
#if (SCM_ENABLE_DEPRECATED == 1)
diff --git a/libguile/discouraged.c b/libguile/discouraged.c
index 357cac875..262142890 100644
--- a/libguile/discouraged.c
+++ b/libguile/discouraged.c
@@ -265,7 +265,7 @@ SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol",
SCM dash_string, non_dash_symbol;
SCM_ASSERT (scm_is_symbol (symbol)
- && ('-' == scm_i_symbol_chars(symbol)[0]),
+ && (scm_i_symbol_ref (symbol, 0) == '-'),
symbol, SCM_ARG1, FUNC_NAME);
dash_string = scm_symbol_to_string (symbol);
diff --git a/libguile/eq.c b/libguile/eq.c
index 255c381a0..11dee2793 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -22,13 +22,13 @@
#endif
#include "libguile/_scm.h"
-#include "libguile/ramap.h"
+#include "libguile/array-map.h"
#include "libguile/stackchk.h"
#include "libguile/strorder.h"
#include "libguile/async.h"
#include "libguile/root.h"
#include "libguile/smob.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/vectors.h"
#include "libguile/struct.h"
diff --git a/libguile/error.c b/libguile/error.c
index eb513a74a..bcbcd9cd1 100644
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -233,6 +233,19 @@ scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
}
void
+scm_i_wrong_type_arg_symbol (SCM symbol, int pos, SCM bad_value)
+{
+ scm_error_scm (scm_arg_type_key,
+ scm_symbol_to_string (symbol),
+ (pos == 0) ? scm_from_locale_string ("Wrong type: ~S")
+ : scm_from_locale_string ("Wrong type argument in position ~A: ~S"),
+ (pos == 0) ? scm_list_1 (bad_value)
+ : scm_list_2 (scm_from_int (pos), bad_value),
+ scm_list_1 (bad_value));
+ scm_remember_upto_here_2 (symbol, bad_value);
+}
+
+void
scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
{
SCM msg = scm_from_locale_string (szMessage);
diff --git a/libguile/error.h b/libguile/error.h
index c777a7f44..8cc68b752 100644
--- a/libguile/error.h
+++ b/libguile/error.h
@@ -53,6 +53,8 @@ SCM_API void scm_wrong_num_args (SCM proc) SCM_NORETURN;
SCM_API void scm_error_num_args_subr (const char* subr) SCM_NORETURN;
SCM_API void scm_wrong_type_arg (const char *subr, int pos,
SCM bad_value) SCM_NORETURN;
+SCM_INTERNAL void scm_i_wrong_type_arg_symbol (SCM symbol, int pos,
+ SCM bad_value) SCM_NORETURN;
SCM_API void scm_wrong_type_arg_msg (const char *subr, int pos,
SCM bad_value, const char *sz) SCM_NORETURN;
SCM_API void scm_memory_error (const char *subr) SCM_NORETURN;
diff --git a/libguile/eval.c b/libguile/eval.c
index f7f3f27df..eeafb0b9d 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -710,6 +710,101 @@ is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env)
return 0;
}
+static SCM
+macroexp (SCM x, SCM env)
+{
+ SCM res, proc, orig_sym;
+
+ /* Don't bother to produce error messages here. We get them when we
+ eventually execute the code for real. */
+
+ macro_tail:
+ orig_sym = SCM_CAR (x);
+ if (!scm_is_symbol (orig_sym))
+ return x;
+
+ {
+ SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
+ if (proc_ptr == NULL)
+ {
+ /* We have lost the race. */
+ goto macro_tail;
+ }
+ proc = *proc_ptr;
+ }
+
+ /* Only handle memoizing macros. `Acros' and `macros' are really
+ special forms and should not be evaluated here. */
+
+ if (!SCM_MACROP (proc)
+ || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
+ return x;
+
+ SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
+ res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
+
+ if (scm_ilength (res) <= 0)
+ /* Result of expansion is not a list. */
+ return (scm_list_2 (SCM_IM_BEGIN, res));
+ else
+ {
+ /* njrev: Several queries here: (1) I don't see how it can be
+ correct that the SCM_SETCAR 2 lines below this comment needs
+ protection, but the SCM_SETCAR 6 lines above does not, so
+ something here is probably wrong. (2) macroexp() is now only
+ used in one place - scm_m_generalized_set_x - whereas all other
+ macro expansion happens through expand_user_macros. Therefore
+ (2.1) perhaps macroexp() could be eliminated completely now?
+ (2.2) Does expand_user_macros need any critical section
+ protection? */
+
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCAR (x, SCM_CAR (res));
+ SCM_SETCDR (x, SCM_CDR (res));
+ SCM_CRITICAL_SECTION_END;
+
+ goto macro_tail;
+ }
+}
+
+
+/* Start of the memoizers for the standard R5RS builtin macros. */
+
+static SCM scm_m_quote (SCM xorig, SCM env);
+static SCM scm_m_begin (SCM xorig, SCM env);
+static SCM scm_m_if (SCM xorig, SCM env);
+static SCM scm_m_set_x (SCM xorig, SCM env);
+static SCM scm_m_and (SCM xorig, SCM env);
+static SCM scm_m_or (SCM xorig, SCM env);
+static SCM scm_m_case (SCM xorig, SCM env);
+static SCM scm_m_cond (SCM xorig, SCM env);
+static SCM scm_m_lambda (SCM xorig, SCM env);
+static SCM scm_m_letstar (SCM xorig, SCM env);
+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);
+static SCM scm_m_at (SCM xorig, SCM env);
+static SCM scm_m_atat (SCM xorig, SCM env);
+static SCM scm_m_atslot_ref (SCM xorig, SCM env);
+static SCM scm_m_atslot_set_x (SCM xorig, SCM env);
+static SCM scm_m_apply (SCM xorig, SCM env);
+static SCM scm_m_cont (SCM xorig, SCM env);
+#if SCM_ENABLE_ELISP
+static SCM scm_m_nil_cond (SCM xorig, SCM env);
+static SCM scm_m_atfop (SCM xorig, SCM env);
+#endif /* SCM_ENABLE_ELISP */
+static SCM scm_m_atbind (SCM xorig, SCM env);
+static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
+static SCM scm_m_eval_when (SCM xorig, SCM env);
+
+
static void
m_expand_body (const SCM forms, const SCM env)
{
@@ -832,70 +927,10 @@ m_expand_body (const SCM forms, const SCM env)
}
}
-static SCM
-macroexp (SCM x, SCM env)
-{
- SCM res, proc, orig_sym;
-
- /* Don't bother to produce error messages here. We get them when we
- eventually execute the code for real. */
-
- macro_tail:
- orig_sym = SCM_CAR (x);
- if (!scm_is_symbol (orig_sym))
- return x;
-
- {
- SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
- if (proc_ptr == NULL)
- {
- /* We have lost the race. */
- goto macro_tail;
- }
- proc = *proc_ptr;
- }
-
- /* Only handle memoizing macros. `Acros' and `macros' are really
- special forms and should not be evaluated here. */
-
- if (!SCM_MACROP (proc)
- || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
- return x;
-
- SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
- res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
-
- if (scm_ilength (res) <= 0)
- /* Result of expansion is not a list. */
- return (scm_list_2 (SCM_IM_BEGIN, res));
- else
- {
- /* njrev: Several queries here: (1) I don't see how it can be
- correct that the SCM_SETCAR 2 lines below this comment needs
- protection, but the SCM_SETCAR 6 lines above does not, so
- something here is probably wrong. (2) macroexp() is now only
- used in one place - scm_m_generalized_set_x - whereas all other
- macro expansion happens through expand_user_macros. Therefore
- (2.1) perhaps macroexp() could be eliminated completely now?
- (2.2) Does expand_user_macros need any critical section
- protection? */
-
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (res));
- SCM_SETCDR (x, SCM_CDR (res));
- SCM_CRITICAL_SECTION_END;
-
- goto macro_tail;
- }
-}
-
-/* Start of the memoizers for the standard R5RS builtin macros. */
-
-
SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
-SCM
+static SCM
scm_m_and (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -925,7 +960,7 @@ unmemoize_and (const SCM expr, const SCM env)
SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
-SCM
+static SCM
scm_m_begin (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -949,7 +984,7 @@ SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
-SCM
+static SCM
scm_m_case (SCM expr, SCM env)
{
SCM clauses;
@@ -1045,7 +1080,7 @@ SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
-SCM
+static SCM
scm_m_cond (SCM expr, SCM env)
{
/* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
@@ -1207,7 +1242,7 @@ canonicalize_define (const SCM expr)
operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
bound. This means that EXPRESSION won't necessarily be able to assign
values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
-SCM
+static SCM
scm_m_define (SCM expr, SCM env)
{
ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
@@ -1262,7 +1297,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
* (delay <expression>) is transformed into (#@delay '() <expression>), where
* the empty list represents the empty parameter list. This representation
* allows for easy creation of the closure during evaluation. */
-SCM
+static SCM
scm_m_delay (SCM expr, SCM env)
{
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
@@ -1305,7 +1340,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
(<body>)
<step1> <step2> ... <stepn>) ;; missing steps replaced by var
*/
-SCM
+static SCM
scm_m_do (SCM expr, SCM env SCM_UNUSED)
{
SCM variables = SCM_EOL;
@@ -1403,7 +1438,7 @@ unmemoize_do (const SCM expr, const SCM env)
SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
-SCM
+static SCM
scm_m_if (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -1453,7 +1488,7 @@ c_improper_memq (SCM obj, SCM list)
return scm_is_eq (list, obj);
}
-SCM
+static SCM
scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
{
SCM formals;
@@ -1623,7 +1658,7 @@ memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
* i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
-SCM
+static SCM
scm_m_let (SCM expr, SCM env)
{
SCM bindings;
@@ -1697,7 +1732,7 @@ unmemoize_let (const SCM expr, const SCM env)
SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
-SCM
+static SCM
scm_m_letrec (SCM expr, SCM env)
{
SCM bindings;
@@ -1748,7 +1783,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
* i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
-SCM
+static SCM
scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
{
SCM binding_idx;
@@ -1821,7 +1856,7 @@ unmemoize_letstar (const SCM expr, const SCM env)
SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
-SCM
+static SCM
scm_m_or (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -1905,7 +1940,7 @@ iqq (SCM form, SCM env, unsigned long int depth)
return form;
}
-SCM
+static SCM
scm_m_quasiquote (SCM expr, SCM env)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -1918,7 +1953,7 @@ scm_m_quasiquote (SCM expr, SCM env)
SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
-SCM
+static SCM
scm_m_quote (SCM expr, SCM env SCM_UNUSED)
{
SCM quotee;
@@ -1947,7 +1982,7 @@ SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
static const char s_set_x[] = "set!";
SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
-SCM
+static SCM
scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
{
SCM variable;
@@ -1977,13 +2012,14 @@ unmemoize_set_x (const SCM expr, const SCM env)
}
+
/* Start of the memoizers for non-R5RS builtin macros. */
SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at);
SCM_GLOBAL_SYMBOL (scm_sym_at, s_at);
-SCM
+static SCM
scm_m_at (SCM expr, SCM env SCM_UNUSED)
{
SCM mod, var;
@@ -2004,7 +2040,7 @@ scm_m_at (SCM expr, SCM env SCM_UNUSED)
SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat);
SCM_GLOBAL_SYMBOL (scm_sym_atat, s_atat);
-SCM
+static SCM
scm_m_atat (SCM expr, SCM env SCM_UNUSED)
{
SCM mod, var;
@@ -2026,7 +2062,7 @@ SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
-SCM
+static SCM
scm_m_apply (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -2063,7 +2099,7 @@ SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
*
* FIXME - also implement `@bind*'.
*/
-SCM
+static SCM
scm_m_atbind (SCM expr, SCM env)
{
SCM bindings;
@@ -2102,7 +2138,7 @@ scm_m_atbind (SCM expr, SCM env)
SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
-SCM
+static SCM
scm_m_cont (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -2123,7 +2159,7 @@ unmemoize_atcall_cc (const SCM expr, const SCM env)
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
-SCM
+static SCM
scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -2147,7 +2183,7 @@ SCM_SYMBOL (sym_eval, "eval");
SCM_SYMBOL (sym_load, "load");
-SCM
+static SCM
scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
{
ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
@@ -2173,7 +2209,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
* (#@future '() <expression>), where the empty list represents the
* empty parameter list. This representation allows for easy creation
* of the closure during evaluation. */
-SCM
+static SCM
scm_m_future (SCM expr, SCM env)
{
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
@@ -2193,7 +2229,7 @@ unmemoize_future (const SCM expr, const SCM env)
SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
SCM_SYMBOL (scm_sym_setter, "setter");
-SCM
+static SCM
scm_m_generalized_set_x (SCM expr, SCM env)
{
SCM target, exp_target;
@@ -2250,9 +2286,11 @@ scm_m_generalized_set_x (SCM expr, SCM env)
* arbitrary modules during the startup phase, the code from goops.c should be
* moved here. */
+SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
+SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
SCM_SYMBOL (sym_atslot_ref, "@slot-ref");
-SCM
+static SCM
scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
{
SCM slot_nr;
@@ -2285,7 +2323,7 @@ unmemoize_atslot_ref (const SCM expr, const SCM env)
SCM_SYMBOL (sym_atslot_set_x, "@slot-set!");
-SCM
+static SCM
scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
{
SCM slot_nr;
@@ -2323,7 +2361,7 @@ SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
/* nil-cond expressions have the form
* (nil-cond COND VAL COND VAL ... ELSEVAL) */
-SCM
+static SCM
scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED)
{
const long length = scm_ilength (SCM_CDR (expr));
@@ -2346,7 +2384,7 @@ SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
* if the value of var (across all aliasing) is not a macro, or
* (<un-aliased var> <expr> ...)
* if var is a macro. */
-SCM
+static SCM
scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
{
SCM location;
@@ -2517,20 +2555,11 @@ scm_i_unmemocopy_body (SCM forms, SCM env)
#if (SCM_ENABLE_DEPRECATED == 1)
-/* Deprecated in guile 1.7.0 on 2003-11-09. */
-SCM
-scm_m_expand_body (SCM exprs, SCM env)
-{
- scm_c_issue_deprecation_warning
- ("`scm_m_expand_body' is deprecated.");
- m_expand_body (exprs, env);
- return exprs;
-}
-
+static SCM scm_m_undefine (SCM expr, SCM env);
SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
-SCM
+static SCM
scm_m_undefine (SCM expr, SCM env)
{
SCM variable;
@@ -2554,55 +2583,10 @@ scm_m_undefine (SCM expr, SCM env)
return SCM_UNSPECIFIED;
}
-SCM
-scm_macroexp (SCM x, SCM env)
-{
- scm_c_issue_deprecation_warning
- ("`scm_macroexp' is deprecated.");
- return macroexp (x, env);
-}
-
-#endif
-
+#endif /* SCM_ENABLE_DEPRECATED */
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-SCM
-scm_unmemocar (SCM form, SCM env)
-{
- scm_c_issue_deprecation_warning
- ("`scm_unmemocar' is deprecated.");
-
- if (!scm_is_pair (form))
- return form;
- else
- {
- SCM c = SCM_CAR (form);
- if (SCM_VARIABLEP (c))
- {
- SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
- if (scm_is_false (sym))
- sym = sym_three_question_marks;
- SCM_SETCAR (form, sym);
- }
- else if (SCM_ILOCP (c))
- {
- unsigned long int ir;
-
- for (ir = SCM_IFRAME (c); ir != 0; --ir)
- env = SCM_CDR (env);
- env = SCM_CAAR (env);
- for (ir = SCM_IDIST (c); ir != 0; --ir)
- env = SCM_CDR (env);
-
- SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
- }
- return form;
- }
-}
-
-#endif
+
/*****************************************************************************/
/*****************************************************************************/
/* The definitions for execution start here. */
@@ -3344,6 +3328,7 @@ scm_trampoline_0 (SCM proc)
case scm_tc7_rpsubr:
case scm_tc7_gsubr:
case scm_tc7_pws:
+ case scm_tc7_program:
trampoline = scm_call_0;
break;
default:
@@ -3396,8 +3381,7 @@ call_dsubr_1 (SCM proc, SCM arg1)
{
return (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
+ SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
}
static SCM
@@ -3470,6 +3454,7 @@ scm_trampoline_1 (SCM proc)
case scm_tc7_rpsubr:
case scm_tc7_gsubr:
case scm_tc7_pws:
+ case scm_tc7_program:
trampoline = scm_call_1;
break;
default:
@@ -3564,6 +3549,7 @@ scm_trampoline_2 (SCM proc)
break;
case scm_tc7_gsubr:
case scm_tc7_pws:
+ case scm_tc7_program:
trampoline = scm_call_2;
break;
default:
diff --git a/libguile/eval.h b/libguile/eval.h
index 0d4223837..4467358f5 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -3,7 +3,7 @@
#ifndef SCM_EVAL_H
#define SCM_EVAL_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -115,40 +115,6 @@ SCM_API SCM * scm_lookupcar (SCM vloc, SCM genv, int check);
SCM_API SCM scm_eval_car (SCM pair, SCM env);
SCM_API SCM scm_eval_body (SCM code, SCM env);
SCM_API SCM scm_eval_args (SCM i, SCM env, SCM proc);
-SCM_API SCM scm_m_quote (SCM xorig, SCM env);
-SCM_API SCM scm_m_begin (SCM xorig, SCM env);
-SCM_API SCM scm_m_if (SCM xorig, SCM env);
-SCM_API SCM scm_m_set_x (SCM xorig, SCM env);
-SCM_API SCM scm_m_vref (SCM xorig, SCM env);
-SCM_API SCM scm_m_vset (SCM xorig, SCM env);
-SCM_API SCM scm_m_and (SCM xorig, SCM env);
-SCM_API SCM scm_m_or (SCM xorig, SCM env);
-SCM_API SCM scm_m_case (SCM xorig, SCM env);
-SCM_API SCM scm_m_cond (SCM xorig, SCM env);
-SCM_API SCM scm_m_lambda (SCM xorig, SCM env);
-SCM_API SCM scm_m_letstar (SCM xorig, SCM env);
-SCM_API SCM scm_m_do (SCM xorig, SCM env);
-SCM_API SCM scm_m_quasiquote (SCM xorig, SCM env);
-SCM_API SCM scm_m_delay (SCM xorig, SCM env);
-SCM_API SCM scm_m_generalized_set_x (SCM xorig, SCM env);
-SCM_API SCM scm_m_future (SCM xorig, SCM env);
-SCM_API SCM scm_m_define (SCM x, SCM env);
-SCM_API SCM scm_m_letrec (SCM xorig, SCM env);
-SCM_API SCM scm_m_let (SCM xorig, SCM env);
-SCM_API SCM scm_m_at (SCM xorig, SCM env);
-SCM_API SCM scm_m_atat (SCM xorig, SCM env);
-SCM_API SCM scm_m_apply (SCM xorig, SCM env);
-SCM_API SCM scm_m_cont (SCM xorig, SCM env);
-#if SCM_ENABLE_ELISP
-SCM_API SCM scm_m_nil_cond (SCM xorig, SCM env);
-SCM_API SCM scm_m_atfop (SCM xorig, SCM env);
-#endif /* SCM_ENABLE_ELISP */
-SCM_API SCM scm_m_atbind (SCM xorig, SCM env);
-SCM_API SCM scm_m_atslot_ref (SCM xorig, SCM env);
-SCM_API SCM scm_m_atslot_set_x (SCM xorig, SCM env);
-SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env);
-SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env);
-SCM_API SCM scm_m_eval_when (SCM xorig, SCM env);
SCM_API int scm_badargsp (SCM formals, SCM args);
SCM_API SCM scm_call_0 (SCM proc);
SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
@@ -190,15 +156,6 @@ SCM_INTERNAL void scm_init_eval (void);
#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_API SCM scm_m_undefine (SCM x, SCM env);
-
-/* Deprecated in guile 1.7.0 on 2003-11-09. */
-SCM_API SCM scm_m_expand_body (SCM xorig, SCM env);
-
-/* Deprecated in guile 1.7.0 on 2003-11-16. */
-SCM_API SCM scm_unmemocar (SCM form, SCM env);
-SCM_API SCM scm_macroexp (SCM x, SCM env);
-
/* 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);
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index 99aa265de..25abf6cb9 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -1132,6 +1132,8 @@ dispatch:
RETURN (SCM_BOOL_T);
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
+ case scm_tc7_program:
+ RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
@@ -1236,13 +1238,13 @@ dispatch:
{
RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1,
- scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
+ SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
case scm_tc7_cxr:
RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
case scm_tc7_rpsubr:
RETURN (SCM_BOOL_T);
+ case scm_tc7_program:
+ RETURN (scm_c_vm_run (scm_the_vm (), proc, &arg1, 1));
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
case scm_tc7_lsubr:
@@ -1353,6 +1355,12 @@ dispatch:
case scm_tc7_rpsubr:
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (arg1, arg2));
+ case scm_tc7_program:
+ { SCM args[2];
+ args[0] = arg1;
+ args[1] = arg2;
+ RETURN (scm_c_vm_run (scm_the_vm (), proc, args, 2));
+ }
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
goto badfun;
@@ -1492,6 +1500,8 @@ dispatch:
SCM_CDDR (debug.info->a.args)));
case scm_tc7_gsubr:
RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
+ case scm_tc7_program:
+ RETURN (scm_vm_apply (scm_the_vm (), proc, debug.info->a.args));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
debug.info->a.proc = proc;
@@ -1563,6 +1573,11 @@ dispatch:
scm_cons2 (arg1, arg2,
scm_ceval_args (x, env,
proc))));
+ case scm_tc7_program:
+ RETURN (scm_vm_apply
+ (scm_the_vm (), proc,
+ scm_cons (arg1, scm_cons (arg2,
+ scm_ceval_args (x, env, proc)))));
case scm_tc7_pws:
proc = SCM_PROCEDURE (proc);
if (!SCM_CLOSUREP (proc))
@@ -1764,8 +1779,7 @@ tail:
{
RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
- SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
+ SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
case scm_tc7_cxr:
if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
scm_wrong_num_args (proc);
@@ -1798,6 +1812,11 @@ tail:
args = SCM_CDR (args);
}
RETURN (arg1);
+ case scm_tc7_program:
+ if (SCM_UNBNDP (arg1))
+ RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0));
+ else
+ RETURN (scm_vm_apply (scm_the_vm (), proc, scm_cons (arg1, args)));
case scm_tc7_rpsubr:
if (scm_is_null (args))
RETURN (SCM_BOOL_T);
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 56f74e213..b1f185cc5 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -31,49 +31,23 @@
#include "libguile/evalext.h"
SCM_DEFINE (scm_defined_p, "defined?", 1, 1, 0,
- (SCM sym, SCM env),
- "Return @code{#t} if @var{sym} is defined in the lexical "
- "environment @var{env}. When @var{env} is not specified, "
- "look in the top-level environment as defined by the "
- "current module.")
+ (SCM sym, SCM module),
+ "Return @code{#t} if @var{sym} is defined in the module "
+ "@var{module} or the current module when @var{module} is not"
+ "specified.")
#define FUNC_NAME s_scm_defined_p
{
SCM var;
SCM_VALIDATE_SYMBOL (1, sym);
- if (SCM_UNBNDP (env))
- var = scm_sym2var (sym, scm_current_module_lookup_closure (),
- SCM_BOOL_F);
+ if (SCM_UNBNDP (module))
+ module = scm_current_module ();
else
- {
- SCM frames = env;
- register SCM b;
- for (; SCM_NIMP (frames); frames = SCM_CDR (frames))
- {
- SCM_ASSERT (scm_is_pair (frames), env, SCM_ARG2, FUNC_NAME);
- b = SCM_CAR (frames);
- if (scm_is_true (scm_procedure_p (b)))
- break;
- SCM_ASSERT (scm_is_pair (b), env, SCM_ARG2, FUNC_NAME);
- for (b = SCM_CAR (b); SCM_NIMP (b); b = SCM_CDR (b))
- {
- if (!scm_is_pair (b))
- {
- if (scm_is_eq (b, sym))
- return SCM_BOOL_T;
- else
- break;
- }
- if (scm_is_eq (SCM_CAR (b), sym))
- return SCM_BOOL_T;
- }
- }
- var = scm_sym2var (sym,
- SCM_NIMP (frames) ? SCM_CAR (frames) : SCM_BOOL_F,
- SCM_BOOL_F);
- }
-
+ SCM_VALIDATE_MODULE (2, module);
+
+ var = scm_module_variable (module, sym);
+
return (scm_is_false (var) || SCM_UNBNDP (SCM_VARIABLE_REF (var))
? SCM_BOOL_F
: SCM_BOOL_T);
@@ -108,6 +82,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
case scm_tc7_string:
case scm_tc7_smob:
case scm_tc7_pws:
+ case scm_tc7_program:
case scm_tcs_subrs:
case scm_tcs_struct:
return SCM_BOOL_T;
diff --git a/libguile/extensions.c b/libguile/extensions.c
index 54351dd9c..d01e9c656 100644
--- a/libguile/extensions.c
+++ b/libguile/extensions.c
@@ -1,6 +1,6 @@
/* extensions.c - registering and loading extensions.
*
- * 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 License
@@ -41,7 +41,7 @@ typedef struct extension_t
void *data;
} extension_t;
-static extension_t *registered_extensions;
+static extension_t *registered_extensions = NULL;
/* Register a LIB/INIT pair for use by `scm_load_extension'. LIB is
allowed to be NULL and then only INIT is used to identify the
@@ -157,7 +157,6 @@ SCM_DEFINE (scm_load_extension, "load-extension", 2, 0, 0,
void
scm_init_extensions ()
{
- registered_extensions = NULL;
#include "libguile/extensions.x"
}
diff --git a/libguile/filesys.c b/libguile/filesys.c
index a2db6996f..c602f6735 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1573,31 +1573,39 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
"component, @code{.} is returned.")
#define FUNC_NAME s_scm_dirname
{
- const char *s;
long int i;
unsigned long int len;
SCM_VALIDATE_STRING (1, filename);
- s = scm_i_string_chars (filename);
len = scm_i_string_length (filename);
i = len - 1;
#ifdef __MINGW32__
- while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i;
- while (i >= 0 && (s[i] != '/' && s[i] != '\\')) --i;
- while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i;
+ while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
+ || scm_i_string_ref (filename, i) == '\\'))
+ --i;
+ while (i >= 0 && (scm_i_string_ref (filename, i) != '/'
+ && scm_i_string_ref (filename, i) != '\\'))
+ --i;
+ while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
+ || scm_i_string_ref (filename, i) == '\\'))
+ --i;
#else
- while (i >= 0 && s[i] == '/') --i;
- while (i >= 0 && s[i] != '/') --i;
- while (i >= 0 && s[i] == '/') --i;
+ while (i >= 0 && scm_i_string_ref (filename, i) == '/')
+ --i;
+ while (i >= 0 && scm_i_string_ref (filename, i) != '/')
+ --i;
+ while (i >= 0 && scm_i_string_ref (filename, i) == '/')
+ --i;
#endif /* ndef __MINGW32__ */
if (i < 0)
{
#ifdef __MINGW32__
- if (len > 0 && (s[0] == '/' || s[0] == '\\'))
+ if (len > 0 && (scm_i_string_ref (filename, 0) == '/'
+ || scm_i_string_ref (filename, 0) == '\\'))
#else
- if (len > 0 && s[0] == '/')
+ if (len > 0 && scm_i_string_ref (filename, 0) == '/')
#endif /* ndef __MINGW32__ */
return scm_c_substring (filename, 0, 1);
else
@@ -1616,11 +1624,9 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
"@var{basename}, it is removed also.")
#define FUNC_NAME s_scm_basename
{
- const char *f, *s = 0;
int i, j, len, end;
SCM_VALIDATE_STRING (1, filename);
- f = scm_i_string_chars (filename);
len = scm_i_string_length (filename);
if (SCM_UNBNDP (suffix))
@@ -1628,32 +1634,44 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
else
{
SCM_VALIDATE_STRING (2, suffix);
- s = scm_i_string_chars (suffix);
j = scm_i_string_length (suffix) - 1;
}
i = len - 1;
#ifdef __MINGW32__
- while (i >= 0 && (f[i] == '/' || f[i] == '\\')) --i;
+ while (i >= 0 && (scm_i_string_ref (filename, i) == '/'
+ || scm_i_string_ref (filename, i) == '\\'))
+ --i;
#else
- while (i >= 0 && f[i] == '/') --i;
+ while (i >= 0 && scm_i_string_ref (filename, i) == '/')
+ --i;
#endif /* ndef __MINGW32__ */
end = i;
- while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j;
+ while (i >= 0 && j >= 0
+ && (scm_i_string_ref (filename, i)
+ == scm_i_string_ref (suffix, j)))
+ {
+ --i;
+ --j;
+ }
if (j == -1)
end = i;
#ifdef __MINGW32__
- while (i >= 0 && f[i] != '/' && f[i] != '\\') --i;
+ while (i >= 0 && (scm_i_string_ref (filename, i) != '/'
+ && scm_i_string_ref (filename, i) != '\\'))
+ --i;
#else
- while (i >= 0 && f[i] != '/') --i;
+ while (i >= 0 && scm_i_string_ref (filename, i) != '/')
+ --i;
#endif /* ndef __MINGW32__ */
if (i == end)
{
#ifdef __MINGW32__
- if (len > 0 && (f[0] == '/' || f[0] == '\\'))
+ if (len > 0 && (scm_i_string_ref (filename, 0) == '/'
+ || scm_i_string_ref (filename, 0) == '\\'))
#else
- if (len > 0 && f[0] == '/')
+ if (len > 0 && scm_i_string_ref (filename, 0) == '/')
#endif /* ndef __MINGW32__ */
- return scm_c_substring (filename, 0, 1);
+ return scm_c_substring (filename, 0, 1);
else
return scm_dot_string;
}
diff --git a/libguile/fports.c b/libguile/fports.c
index cfb8b25b6..8e25ebdd5 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -587,7 +587,7 @@ static void fport_flush (SCM port);
/* fill a port's read-buffer with a single read. returns the first
char or EOF if end of file. */
-static int
+static scm_t_wchar
fport_fill_input (SCM port)
{
long count;
@@ -601,7 +601,7 @@ fport_fill_input (SCM port)
if (count == -1)
scm_syserror ("fport_fill_input");
if (count == 0)
- return EOF;
+ return (scm_t_wchar) EOF;
else
{
pt->read_pos = pt->read_buf;
diff --git a/libguile/frames.c b/libguile/frames.c
index e89184d79..737babc1a 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -33,7 +33,7 @@ scm_t_bits scm_tc16_vm_frame;
SCM
scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_byte_t *ip, scm_t_ptrdiff offset)
+ scm_t_uint8 *ip, scm_t_ptrdiff offset)
{
struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
"vmframe");
@@ -111,12 +111,12 @@ SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
if (!bp->nargs)
return SCM_EOL;
else if (bp->nrest)
- ret = fp[bp->nargs - 1];
+ ret = SCM_FRAME_VARIABLE (fp, bp->nargs - 1);
else
- ret = scm_cons (fp[bp->nargs - 1], SCM_EOL);
+ ret = scm_cons (SCM_FRAME_VARIABLE (fp, bp->nargs - 1), SCM_EOL);
for (i = bp->nargs - 2; i >= 0; i--)
- ret = scm_cons (fp[i], ret);
+ ret = scm_cons (SCM_FRAME_VARIABLE (fp, i), ret);
return ret;
}
diff --git a/libguile/frames.h b/libguile/frames.h
index 1b3153a3e..0165924a7 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -30,39 +30,46 @@
/* VM Frame Layout
---------------
- | | <- fp + bp->nargs + bp->nlocs + 3
- +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
- | Return address |
- | MV return address|
- | Dynamic link | <- fp + bp->nargs + bp->blocs
- | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
+ | ... |
+ | Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs = SCM_FRAME_UPPER_ADDRESS (fp)
+ +==================+
+ | Local variable 1 |
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
| Argument 0 | <- fp
| Program | <- fp - 1
- +------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
+ +------------------+
+ | Return address |
+ | MV return address|
+ | Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp)
+ +==================+
| |
As can be inferred from this drawing, it is assumed that
`sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
assumed to be as long as SCM objects. */
-#define SCM_FRAME_DATA_ADDRESS(fp) \
- (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
- + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
-#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 3)
-#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
+#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_LOWER_ADDRESS(fp) (fp - 4)
-#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
+#define SCM_FRAME_BYTE_CAST(x) ((scm_t_uint8 *) SCM_UNPACK (x))
#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
#define SCM_FRAME_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) \
+ ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(ra);
#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
+#define SCM_FRAME_SET_MV_RETURN_ADDRESS(fp, mvra) \
+ ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(mvra);
#define SCM_FRAME_DYNAMIC_LINK(fp) \
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
-#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
+#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]
@@ -79,7 +86,7 @@ struct scm_vm_frame
SCM stack_holder;
SCM *fp;
SCM *sp;
- scm_byte_t *ip;
+ scm_t_uint8 *ip;
scm_t_ptrdiff offset;
};
@@ -92,9 +99,8 @@ struct scm_vm_frame
#define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
-/* FIXME rename scm_byte_t */
SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_byte_t *ip, scm_t_ptrdiff offset);
+ scm_t_uint8 *ip, scm_t_ptrdiff offset);
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);
diff --git a/libguile/gc-card.c b/libguile/gc-card.c
index 85520f8e4..aa4031238 100644
--- a/libguile/gc-card.c
+++ b/libguile/gc-card.c
@@ -43,7 +43,7 @@
#include "libguile/strings.h"
#include "libguile/struct.h"
#include "libguile/tags.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/validate.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
@@ -162,6 +162,8 @@ scm_i_sweep_card (scm_t_cell *card, SCM *free_list, scm_t_heap_segment *seg)
break;
case scm_tc7_variable:
break;
+ case scm_tc7_program:
+ break;
case scm_tcs_subrs:
/* the various "subrs" (primitives) are never freed */
continue;
@@ -386,6 +388,8 @@ scm_i_tag_name (scm_t_bits tag)
return "closures";
case scm_tc7_pws:
return "pws";
+ case scm_tc7_program:
+ return "program";
case scm_tc7_wvect:
return "weak vector";
case scm_tc7_vector:
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index d6973d3ac..6e9120e8e 100644
--- a/libguile/gc-malloc.c
+++ b/libguile/gc-malloc.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 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
@@ -37,7 +37,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
#include "libguile/stackchk.h"
#include "libguile/struct.h"
#include "libguile/smob.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
@@ -83,7 +83,7 @@ static int scm_i_minyield_malloc;
void
scm_gc_init_malloc (void)
{
- scm_mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT",
+ int mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT",
SCM_DEFAULT_INIT_MALLOC_LIMIT);
scm_i_minyield_malloc = scm_getenv_int ("GUILE_MIN_YIELD_MALLOC",
SCM_DEFAULT_MALLOC_MINYIELD);
@@ -93,8 +93,10 @@ scm_gc_init_malloc (void)
if (scm_i_minyield_malloc < 1)
scm_i_minyield_malloc = 1;
- if (scm_mtrigger < 0)
+ if (mtrigger < 0)
scm_mtrigger = SCM_DEFAULT_INIT_MALLOC_LIMIT;
+ else
+ scm_mtrigger = mtrigger;
}
diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c
index 84714507b..cc881e8a4 100644
--- a/libguile/gc-mark.c
+++ b/libguile/gc-mark.c
@@ -38,8 +38,9 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
#include "libguile/stackchk.h"
#include "libguile/struct.h"
#include "libguile/smob.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/async.h"
+#include "libguile/programs.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
@@ -247,7 +248,6 @@ scm_gc_mark_dependencies (SCM p)
scm_t_bits * vtable_data = (scm_t_bits *) word0;
SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
long len = scm_i_symbol_length (layout);
- const char *fields_desc = scm_i_symbol_chars (layout);
scm_t_bits *struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
@@ -260,11 +260,12 @@ scm_gc_mark_dependencies (SCM p)
long x;
for (x = 0; x < len - 2; x += 2, ++struct_data)
- if (fields_desc[x] == 'p')
+ if (scm_i_symbol_ref (layout, x) == 'p')
scm_gc_mark (SCM_PACK (*struct_data));
- if (fields_desc[x] == 'p')
+ if (scm_i_symbol_ref (layout, x) == 'p')
{
- if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
+ scm_t_wchar ch = scm_i_symbol_ref (layout, x+1);
+ if (SCM_LAYOUT_TAILP (ch))
for (x = *struct_data++; x; --x, ++struct_data)
scm_gc_mark (SCM_PACK (*struct_data));
else
@@ -285,6 +286,13 @@ scm_gc_mark_dependencies (SCM p)
scm_gc_mark (SCM_CLOSCAR (ptr));
ptr = SCM_ENV (ptr);
goto gc_mark_nimp;
+ case scm_tc7_program:
+ if (SCM_PROGRAM_FREE_VARIABLES (ptr) != SCM_BOOL_F)
+ scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (ptr));
+ if (SCM_PROGRAM_OBJTABLE (ptr) != SCM_BOOL_F)
+ scm_gc_mark (SCM_PROGRAM_OBJTABLE (ptr));
+ ptr = SCM_PROGRAM_OBJCODE (ptr);
+ goto gc_mark_nimp;
case scm_tc7_vector:
i = SCM_SIMPLE_VECTOR_LENGTH (ptr);
if (i == 0)
diff --git a/libguile/gc.c b/libguile/gc.c
index b7a3bf091..01f5efff0 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,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
@@ -33,7 +33,7 @@
#include "libguile/stackchk.h"
#include "libguile/struct.h"
#include "libguile/smob.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index d5696381b..0e897ca8c 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -125,6 +125,7 @@
#include <stdio.h>
#include <string.h>
+#include <uniconv.h>
#define pf printf
@@ -424,6 +425,14 @@ main (int argc, char *argv[])
pf ("#define SCM_HAVE_ARRAYS 1 /* always true now */\n");
+ pf ("\n");
+ pf ("/* Constants from uniconv.h. */\n");
+ pf ("#define SCM_ICONVEH_ERROR %d\n", (int) iconveh_error);
+ pf ("#define SCM_ICONVEH_QUESTION_MARK %d\n",
+ (int) iconveh_question_mark);
+ pf ("#define SCM_ICONVEH_ESCAPE_SEQUENCE %d\n",
+ (int) iconveh_escape_sequence);
+
printf ("#endif\n");
return 0;
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
new file mode 100644
index 000000000..6394405dd
--- /dev/null
+++ b/libguile/generalized-arrays.c
@@ -0,0 +1,276 @@
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 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 <stdio.h>
+#include <errno.h>
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/__scm.h"
+#include "libguile/array-handle.h"
+#include "libguile/generalized-arrays.h"
+
+
+int
+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),
+ "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
+ "not.")
+#define FUNC_NAME s_scm_array_p
+{
+ return scm_from_bool (scm_is_array (obj));
+}
+#undef FUNC_NAME
+
+int
+scm_is_typed_array (SCM obj, SCM type)
+{
+ int ret = 0;
+ if (scm_i_array_implementation_for_obj (obj))
+ {
+ scm_t_array_handle h;
+
+ scm_array_get_handle (obj, &h);
+ ret = scm_is_eq (scm_array_handle_element_type (&h), type);
+ scm_array_handle_release (&h);
+ }
+
+ return ret;
+}
+
+SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
+ (SCM obj, SCM type),
+ "Return @code{#t} if the @var{obj} is an array of type\n"
+ "@var{type}, and @code{#f} if not.")
+#define FUNC_NAME s_scm_typed_array_p
+{
+ return scm_from_bool (scm_is_typed_array (obj, type));
+}
+#undef FUNC_NAME
+
+size_t
+scm_c_array_rank (SCM array)
+{
+ scm_t_array_handle handle;
+ size_t res;
+
+ scm_array_get_handle (array, &handle);
+ res = scm_array_handle_rank (&handle);
+ scm_array_handle_release (&handle);
+ return res;
+}
+
+SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
+ (SCM array),
+ "Return the number of dimensions of the array @var{array.}\n")
+#define FUNC_NAME s_scm_array_rank
+{
+ return scm_from_size_t (scm_c_array_rank (array));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
+ (SCM ra),
+ "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
+ "elements with a @code{0} minimum with one greater than the maximum. So:\n"
+ "@lisp\n"
+ "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_dimensions
+{
+ scm_t_array_handle handle;
+ scm_t_array_dim *s;
+ SCM res = SCM_EOL;
+ size_t k;
+
+ scm_array_get_handle (ra, &handle);
+ s = scm_array_handle_dims (&handle);
+ k = scm_array_handle_rank (&handle);
+
+ while (k--)
+ res = scm_cons (s[k].lbnd
+ ? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
+ scm_from_ssize_t (s[k].ubnd),
+ SCM_EOL)
+ : scm_from_ssize_t (1 + s[k].ubnd),
+ res);
+
+ scm_array_handle_release (&handle);
+ return res;
+}
+#undef FUNC_NAME
+
+/* HACK*/
+#include "libguile/bytevectors.h"
+
+SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
+ (SCM ra),
+ "")
+#define FUNC_NAME s_scm_array_type
+{
+ scm_t_array_handle h;
+ SCM type;
+
+ /* a hack, until srfi-4 and bytevectors are reunited */
+ if (scm_is_bytevector (ra))
+ return scm_from_locale_symbol ("vu8");
+
+ scm_array_get_handle (ra, &h);
+ type = scm_array_handle_element_type (&h);
+ scm_array_handle_release (&h);
+
+ return type;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
+ (SCM ra, SCM args),
+ "Return @code{#t} if its arguments would be acceptable to\n"
+ "@code{array-ref}.")
+#define FUNC_NAME s_scm_array_in_bounds_p
+{
+ SCM res = SCM_BOOL_T;
+ size_t k, ndim;
+ scm_t_array_dim *s;
+ scm_t_array_handle handle;
+
+ SCM_VALIDATE_REST_ARGUMENT (args);
+
+ scm_array_get_handle (ra, &handle);
+ s = scm_array_handle_dims (&handle);
+ ndim = scm_array_handle_rank (&handle);
+
+ for (k = 0; k < ndim; k++)
+ {
+ long ind;
+
+ if (!scm_is_pair (args))
+ SCM_WRONG_NUM_ARGS ();
+ ind = scm_to_long (SCM_CAR (args));
+ args = SCM_CDR (args);
+
+ if (ind < s[k].lbnd || ind > s[k].ubnd)
+ {
+ res = SCM_BOOL_F;
+ /* We do not stop the checking after finding a violation
+ since we want to validate the type-correctness and
+ number of arguments in any case.
+ */
+ }
+ }
+
+ scm_array_handle_release (&handle);
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
+ (SCM v, SCM args),
+ "Return the element at the @code{(index1, index2)} element in\n"
+ "@var{array}.")
+#define FUNC_NAME s_scm_array_ref
+{
+ scm_t_array_handle handle;
+ SCM res;
+
+ scm_array_get_handle (v, &handle);
+ res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
+ scm_array_handle_release (&handle);
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
+ (SCM v, SCM obj, SCM args),
+ "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
+ "@var{new-value}. The value returned by array-set! is unspecified.")
+#define FUNC_NAME s_scm_array_set_x
+{
+ scm_t_array_handle handle;
+
+ scm_array_get_handle (v, &handle);
+ scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
+ scm_array_handle_release (&handle);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static SCM
+array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
+{
+ if (dim == scm_array_handle_rank (h))
+ return scm_array_handle_ref (h, pos);
+ else
+ {
+ SCM res = SCM_EOL;
+ long inc;
+ size_t i, lbnd;
+
+ i = h->dims[dim].ubnd;
+ lbnd = h->dims[dim].lbnd;
+ inc = h->dims[dim].inc;
+ pos += (i - h->dims[dim].ubnd) * inc;
+
+ for (; i >= lbnd; i--, pos -= inc)
+ res = scm_cons (array_to_list (h, dim + 1, pos), res);
+ return res;
+ }
+}
+
+SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
+ (SCM array),
+ "FIXME description a list consisting of all the elements, in order, of\n"
+ "@var{array}.")
+#define FUNC_NAME s_scm_array_to_list
+{
+ scm_t_array_handle h;
+ SCM res;
+
+ scm_array_get_handle (array, &h);
+ res = array_to_list (&h, 0, 0);
+ scm_array_handle_release (&h);
+
+ return res;
+}
+#undef FUNC_NAME
+
+void
+scm_init_generalized_arrays ()
+{
+#include "libguile/generalized-arrays.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h
new file mode 100644
index 000000000..cc7214e8b
--- /dev/null
+++ b/libguile/generalized-arrays.h
@@ -0,0 +1,63 @@
+/* classes: h_files */
+
+#ifndef SCM_GENERALIZED_ARRAYS_H
+#define SCM_GENERALIZED_ARRAYS_H
+
+/* Copyright (C) 1995,1996,1997,1999,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
+ * 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"
+#include "libguile/array-handle.h"
+
+
+
+/* These functions operate on all kinds of arrays that Guile knows about.
+ */
+
+
+/** Arrays */
+
+SCM_API int scm_is_array (SCM obj);
+SCM_API SCM scm_array_p (SCM v);
+
+SCM_API int scm_is_typed_array (SCM obj, SCM type);
+SCM_API SCM scm_typed_array_p (SCM v, SCM type);
+
+SCM_API size_t scm_c_array_rank (SCM ra);
+SCM_API SCM scm_array_rank (SCM ra);
+
+SCM_API SCM scm_array_dimensions (SCM ra);
+SCM_API SCM scm_array_type (SCM ra);
+SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);
+
+SCM_API SCM scm_array_ref (SCM v, SCM args);
+SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
+SCM_API SCM scm_array_to_list (SCM v);
+
+SCM_INTERNAL void scm_init_generalized_arrays (void);
+
+
+#endif /* SCM_GENERALIZED_ARRAYS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c
new file mode 100644
index 000000000..2d437a475
--- /dev/null
+++ b/libguile/generalized-vectors.c
@@ -0,0 +1,201 @@
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 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/__scm.h"
+
+#include "libguile/array-handle.h"
+#include "libguile/generalized-arrays.h"
+#include "libguile/generalized-vectors.h"
+
+
+struct scm_t_vector_ctor
+{
+ SCM tag;
+ SCM (*ctor)(SCM, SCM);
+};
+
+#define VECTOR_CTORS_N_STATIC_ALLOC 20
+static struct scm_t_vector_ctor vector_ctors[VECTOR_CTORS_N_STATIC_ALLOC];
+static int num_vector_ctors_registered = 0;
+
+void
+scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM))
+{
+ if (num_vector_ctors_registered >= VECTOR_CTORS_N_STATIC_ALLOC)
+ /* need to increase VECTOR_CTORS_N_STATIC_ALLOC, buster */
+ abort ();
+ else
+ {
+ vector_ctors[num_vector_ctors_registered].tag = type;
+ vector_ctors[num_vector_ctors_registered].ctor = ctor;
+ num_vector_ctors_registered++;
+ }
+}
+
+SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0,
+ (SCM type, SCM len, SCM fill),
+ "Make a generalized vector")
+#define FUNC_NAME s_scm_make_generalized_vector
+{
+ int i;
+ for (i = 0; i < num_vector_ctors_registered; i++)
+ if (vector_ctors[i].tag == type)
+ return vector_ctors[i].ctor(len, fill);
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "array type");
+}
+#undef FUNC_NAME
+
+int
+scm_is_generalized_vector (SCM obj)
+{
+ int ret = 0;
+ if (scm_is_array (obj))
+ {
+ scm_t_array_handle h;
+ scm_array_get_handle (obj, &h);
+ ret = scm_array_handle_rank (&h) == 1;
+ scm_array_handle_release (&h);
+ }
+ return ret;
+}
+
+SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector, string,\n"
+ "bitvector, or uniform numeric vector.")
+#define FUNC_NAME s_scm_generalized_vector_p
+{
+ return scm_from_bool (scm_is_generalized_vector (obj));
+}
+#undef FUNC_NAME
+
+#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
+ scm_generalized_vector_get_handle (val, handle)
+
+
+void
+scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
+{
+ scm_array_get_handle (vec, h);
+ if (scm_array_handle_rank (h) != 1)
+ {
+ scm_array_handle_release (h);
+ scm_wrong_type_arg_msg (NULL, 0, vec, "vector");
+ }
+}
+
+size_t
+scm_c_generalized_vector_length (SCM v)
+{
+ scm_t_array_handle h;
+ size_t ret;
+ scm_generalized_vector_get_handle (v, &h);
+ ret = h.dims[0].ubnd - h.dims[0].lbnd + 1;
+ scm_array_handle_release (&h);
+ return ret;
+}
+
+SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
+ (SCM v),
+ "Return the length of the generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_length
+{
+ return scm_from_size_t (scm_c_generalized_vector_length (v));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_generalized_vector_ref (SCM v, size_t idx)
+{
+ scm_t_array_handle h;
+ SCM ret;
+ scm_generalized_vector_get_handle (v, &h);
+ ret = h.impl->vref (&h, idx);
+ scm_array_handle_release (&h);
+ return ret;
+}
+
+SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
+ (SCM v, SCM idx),
+ "Return the element at index @var{idx} of the\n"
+ "generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_ref
+{
+ return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
+}
+#undef FUNC_NAME
+
+void
+scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
+{
+ scm_t_array_handle h;
+ scm_generalized_vector_get_handle (v, &h);
+ h.impl->vset (&h, idx, val);
+ scm_array_handle_release (&h);
+}
+
+SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
+ (SCM v, SCM idx, SCM val),
+ "Set the element at index @var{idx} of the\n"
+ "generalized vector @var{v} to @var{val}.")
+#define FUNC_NAME s_scm_generalized_vector_set_x
+{
+ scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
+ (SCM v),
+ "Return a new list whose elements are the elements of the\n"
+ "generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_to_list
+{
+ SCM ret = SCM_EOL;
+ ssize_t pos, i = 0;
+ scm_t_array_handle h;
+ scm_generalized_vector_get_handle (v, &h);
+ // FIXME CHECKME
+ for (pos = h.dims[0].ubnd, i = (h.dims[0].ubnd - h.dims[0].lbnd + 1);
+ i >= 0;
+ pos += h.dims[0].inc)
+ ret = scm_cons (h.impl->vref (&h, pos), ret);
+ scm_array_handle_release (&h);
+ return ret;
+}
+#undef FUNC_NAME
+
+void
+scm_init_generalized_vectors ()
+{
+#include "libguile/generalized-vectors.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h
new file mode 100644
index 000000000..71b58d291
--- /dev/null
+++ b/libguile/generalized-vectors.h
@@ -0,0 +1,61 @@
+/* classes: h_files */
+
+#ifndef SCM_GENERALIZED_VECTORS_H
+#define SCM_GENERALIZED_VECTORS_H
+
+/* Copyright (C) 1995,1996,1997,1999,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
+ * 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"
+#include "libguile/array-handle.h"
+
+
+
+/* Generalized vectors */
+
+SCM_API SCM scm_generalized_vector_p (SCM v);
+SCM_API SCM scm_generalized_vector_length (SCM v);
+SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx);
+SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val);
+SCM_API SCM scm_generalized_vector_to_list (SCM v);
+
+SCM_API int scm_is_generalized_vector (SCM obj);
+SCM_API size_t scm_c_generalized_vector_length (SCM v);
+SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx);
+SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val);
+SCM_API void scm_generalized_vector_get_handle (SCM vec,
+ scm_t_array_handle *h);
+
+SCM_API SCM scm_make_generalized_vector (SCM type, SCM len, SCM fill);
+SCM_INTERNAL void scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM));
+
+#define SCM_VECTOR_IMPLEMENTATION(type, ctor) \
+ SCM_SNARF_INIT (scm_i_register_vector_constructor \
+ (scm_i_array_element_types[type], ctor))
+
+SCM_INTERNAL void scm_init_generalized_vectors (void);
+
+#endif /* SCM_GENERALIZED_VECTORS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/goops.c b/libguile/goops.c
index 1548472cb..d1beab3d6 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -176,6 +176,8 @@ static SCM scm_unbound_p (SCM obj);
static SCM scm_assert_bound (SCM value, SCM obj);
static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
static SCM scm_sys_goops_loaded (void);
+static SCM scm_make_extended_class_from_symbol (SCM type_name_sym,
+ int applicablep);
/* This function is used for efficient type dispatch. */
SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
@@ -241,6 +243,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
else
return scm_class_procedure;
case scm_tc7_gsubr:
+ case scm_tc7_program:
return scm_class_procedure;
case scm_tc7_pws:
return scm_class_procedure_with_setter;
@@ -280,9 +283,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
else
{
SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
- SCM class = scm_make_extended_class (scm_is_true (name)
- ? scm_i_symbol_chars (name)
- : 0,
+ SCM class = scm_make_extended_class_from_symbol (scm_is_true (name)
+ ? name
+ : scm_nullstr,
SCM_I_OPERATORP (x));
SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
return class;
@@ -1256,10 +1259,7 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
#undef FUNC_NAME
-SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
-SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
-
-
+
/** Utilities **/
/* In the future, this function will return the effective slot
@@ -1528,11 +1528,11 @@ wrap_init (SCM class, SCM *m, long n)
{
long i;
scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
- const char *layout = scm_i_symbol_chars (SCM_PACK (slayout));
+ SCM layout = SCM_PACK (slayout);
/* Set all SCM-holding slots to unbound */
for (i = 0; i < n; i++)
- if (layout[i*2] == 'p')
+ if (scm_i_symbol_ref (layout, i*2) == 'p')
m[i] = SCM_GOOPS_UNBOUND;
else
m[i] = 0;
@@ -2682,6 +2682,34 @@ make_class_from_template (char const *template, char const *type_name, SCM super
return class;
}
+static SCM
+make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
+{
+ SCM class, name;
+ if (type_name_sym != SCM_BOOL_F)
+ {
+ name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
+ scm_symbol_to_string (type_name_sym),
+ scm_from_locale_string (">")));
+ name = scm_string_to_symbol (name);
+ }
+ else
+ name = SCM_GOOPS_UNBOUND;
+
+ class = scm_permanent_object (scm_basic_make_class (applicablep
+ ? scm_class_procedure_class
+ : scm_class_class,
+ name,
+ supers,
+ SCM_EOL));
+
+ /* Only define name if doesn't already exist. */
+ if (!SCM_GOOPS_UNBOUNDP (name)
+ && scm_is_false (scm_module_variable (scm_module_goops, name)))
+ DEFVAR (name, class);
+ return class;
+}
+
SCM
scm_make_extended_class (char const *type_name, int applicablep)
{
@@ -2693,6 +2721,16 @@ scm_make_extended_class (char const *type_name, int applicablep)
applicablep);
}
+static SCM
+scm_make_extended_class_from_symbol (SCM type_name_sym, int applicablep)
+{
+ return make_class_from_symbol (type_name_sym,
+ scm_list_1 (applicablep
+ ? scm_class_applicable
+ : scm_class_top),
+ applicablep);
+}
+
void
scm_i_inherit_applicable (SCM c)
{
@@ -2785,11 +2823,16 @@ static SCM
make_struct_class (void *closure SCM_UNUSED,
SCM vtable, SCM data, SCM prev SCM_UNUSED)
{
- if (scm_is_true (SCM_STRUCT_TABLE_NAME (data)))
- SCM_SET_STRUCT_TABLE_CLASS (data,
- scm_make_extended_class
- (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)),
- SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR));
+ SCM sym = SCM_STRUCT_TABLE_NAME (data);
+ if (scm_is_true (sym))
+ {
+ int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR;
+
+ SCM_SET_STRUCT_TABLE_CLASS (data,
+ scm_make_extended_class_from_symbol (sym, applicablep));
+ }
+
+ scm_remember_upto_here_2 (data, vtable);
return SCM_UNSPECIFIED;
}
diff --git a/libguile/hash.c b/libguile/hash.c
index d2fe17706..e6e38ba50 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -50,6 +50,20 @@ scm_string_hash (const unsigned char *str, size_t len)
return h;
}
+unsigned long
+scm_i_string_hash (SCM str)
+{
+ size_t len = scm_i_string_length (str);
+ size_t i = 0;
+
+ unsigned long h = 0;
+ while (len-- > 0)
+ h = (unsigned long) scm_i_string_ref (str, i++) + h * 37;
+
+ scm_remember_upto_here_1 (str);
+ return h;
+}
+
/* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
/* Dirk:FIXME:: scm_hasher could be made static. */
@@ -115,8 +129,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
case scm_tc7_string:
{
unsigned long hash =
- scm_string_hash ((const unsigned char *) scm_i_string_chars (obj),
- scm_i_string_length (obj)) % n;
+ scm_i_string_hash (obj) % n;
scm_remember_upto_here_1 (obj);
return hash;
}
diff --git a/libguile/hash.h b/libguile/hash.h
index 789595b42..2ebc05352 100644
--- a/libguile/hash.h
+++ b/libguile/hash.h
@@ -28,6 +28,7 @@
SCM_API unsigned long scm_string_hash (const unsigned char *str, size_t len);
+SCM_INTERNAL unsigned long scm_i_string_hash (SCM str);
SCM_API unsigned long scm_hasher (SCM obj, unsigned long n, size_t d);
SCM_API unsigned long scm_ihashq (SCM obj, unsigned long n);
SCM_API SCM scm_hashq (SCM obj, SCM n);
diff --git a/libguile/init.c b/libguile/init.c
index 5ece01fb0..da3bc0af2 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -37,6 +37,7 @@
#include "libguile/arbiters.h"
#include "libguile/async.h"
#include "libguile/backtrace.h"
+#include "libguile/bitvectors.h"
#include "libguile/boolean.h"
#include "libguile/bytevectors.h"
#include "libguile/chars.h"
@@ -62,6 +63,8 @@
#include "libguile/futures.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
+#include "libguile/generalized-arrays.h"
+#include "libguile/generalized-vectors.h"
#include "libguile/goops.h"
#include "libguile/gsubr.h"
#include "libguile/hash.h"
@@ -92,7 +95,7 @@
#include "libguile/procprop.h"
#include "libguile/procs.h"
#include "libguile/properties.h"
-#include "libguile/ramap.h"
+#include "libguile/array-map.h"
#include "libguile/random.h"
#include "libguile/rdelim.h"
#include "libguile/read.h"
@@ -115,7 +118,7 @@
#include "libguile/struct.h"
#include "libguile/symbols.h"
#include "libguile/throw.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/values.h"
#include "libguile/variable.h"
#include "libguile/vectors.h"
@@ -125,6 +128,7 @@
#include "libguile/weaks.h"
#include "libguile/guardians.h"
#include "libguile/extensions.h"
+#include "libguile/uniform.h"
#include "libguile/srfi-4.h"
#include "libguile/discouraged.h"
#include "libguile/deprecated.h"
@@ -517,7 +521,19 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_sort ();
scm_init_srcprop ();
scm_init_stackchk ();
- scm_init_strings ();
+
+ scm_init_array_handle ();
+ scm_init_generalized_arrays ();
+ scm_init_generalized_vectors ();
+ scm_init_vectors ();
+ scm_init_uniform ();
+ scm_init_bitvectors ();
+ scm_bootstrap_bytevectors ();
+ scm_init_srfi_4 ();
+ scm_init_arrays ();
+ scm_init_array_map ();
+
+ scm_init_strings (); /* Requires array-handle */
scm_init_struct (); /* Requires strings */
scm_init_stacks (); /* Requires strings, struct */
scm_init_symbols ();
@@ -531,7 +547,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_srfi_13 ();
scm_init_srfi_14 ();
scm_init_throw ();
- scm_init_vectors ();
scm_init_version ();
scm_init_weaks ();
scm_init_guardians ();
@@ -540,8 +555,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_evalext ();
scm_init_debug (); /* Requires macro smobs */
scm_init_random ();
- scm_init_ramap ();
- scm_init_unif ();
scm_init_simpos ();
scm_init_load_path ();
scm_init_standard_ports (); /* Requires fports */
@@ -550,7 +563,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_lang ();
#endif /* SCM_ENABLE_ELISP */
scm_init_script ();
- scm_init_srfi_4 ();
scm_init_goops ();
@@ -574,7 +586,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_rw ();
scm_init_extensions ();
- scm_bootstrap_bytevectors ();
scm_bootstrap_vm ();
atexit (cleanup_for_exit);
diff --git a/libguile/inline.h b/libguile/inline.h
index cb908581d..574bbfcd3 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -3,7 +3,7 @@
#ifndef SCM_INLINE_H
#define SCM_INLINE_H
-/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2002, 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
@@ -34,8 +34,9 @@
#include "libguile/pairs.h"
#include "libguile/gc.h"
#include "libguile/threads.h"
-#include "libguile/unif.h"
+#include "libguile/array-handle.h"
#include "libguile/ports.h"
+#include "libguile/numbers.h"
#include "libguile/error.h"
@@ -86,7 +87,7 @@ SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);
SCM_API int scm_is_pair (SCM x);
-SCM_API int scm_getc (SCM port);
+SCM_API int scm_get_byte_or_eof (SCM port);
SCM_API void scm_putc (char c, SCM port);
SCM_API void scm_puts (const char *str_data, SCM port);
@@ -241,7 +242,11 @@ SCM_C_EXTERN_INLINE
SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
{
- return h->ref (h, p);
+ if (SCM_UNLIKELY (p < 0 && -p > h->base))
+ /* catch overflow */
+ scm_out_of_range (NULL, scm_from_ssize_t (p));
+ /* perhaps should catch overflow here too */
+ return h->impl->vref (h, h->base + p);
}
#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
@@ -250,7 +255,11 @@ SCM_C_EXTERN_INLINE
void
scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
{
- h->set (h, p, v);
+ if (SCM_UNLIKELY (p < 0 && -p > h->base))
+ /* catch overflow */
+ scm_out_of_range (NULL, scm_from_ssize_t (p));
+ /* perhaps should catch overflow here too */
+ h->impl->vset (h, h->base + p, v);
}
#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
@@ -290,7 +299,7 @@ scm_is_pair (SCM x)
SCM_C_EXTERN_INLINE
#endif
int
-scm_getc (SCM port)
+scm_get_byte_or_eof (SCM port)
{
int c;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -310,27 +319,6 @@ scm_getc (SCM port)
c = *(pt->read_pos++);
- switch (c)
- {
- case '\a':
- break;
- case '\b':
- SCM_DECCOL (port);
- break;
- case '\n':
- SCM_INCLINE (port);
- break;
- case '\r':
- SCM_ZEROCOL (port);
- break;
- case '\t':
- SCM_TABCOL (port);
- break;
- default:
- SCM_INCCOL (port);
- break;
- }
-
return c;
}
diff --git a/libguile/libguile.map b/libguile/libguile.map
new file mode 100644
index 000000000..2586e0abf
--- /dev/null
+++ b/libguile/libguile.map
@@ -0,0 +1,44 @@
+# Linker version script for libguile. -*- ld-script -*-
+#
+# Copyright (C) 2009 Free Software Foundation, Inc.
+#
+# This file is part of GUILE.
+#
+# GUILE is free software; you can redistribute it and/or modify it
+# under the terms of the GNU Lesser General Public License as
+# published by the Free Software Foundation; either version 3, or
+# (at your option) any later version.
+#
+# GUILE is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU Lesser General Public License for more details.
+#
+# You should have received a copy of the GNU Lesser General Public
+# License along with GUILE; see the file COPYING.LESSER. If not,
+# write to the Free Software Foundation, Inc., 51 Franklin Street,
+# Fifth Floor, Boston, MA 02110-1301 USA
+
+GUILE_2.0
+{
+ global:
+ # Note: This includes `scm_i_' symbols declared as `SCM_API' (e.g.,
+ # symbols from `deprecated.c' or symbols used by public inline
+ # functions or macros).
+ scm_*;
+
+ # GDB interface.
+ gdb_options;
+ gdb_language;
+ gdb_result;
+ gdb_output;
+ gdb_output_length;
+ gdb_maybe_valid_type_p;
+ gdb_read;
+ gdb_eval;
+ gdb_print;
+ gdb_binding;
+
+ local:
+ *;
+};
diff --git a/libguile/load.c b/libguile/load.c
index 890b0f824..e2c0dbf99 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -85,6 +85,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
#define FUNC_NAME s_scm_primitive_load
{
SCM hook = *scm_loc_load_hook;
+ char *encoding;
SCM_VALIDATE_STRING (1, filename);
if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f",
@@ -97,7 +98,15 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
SCM port = scm_open_file (filename, scm_from_locale_string ("r"));
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_i_dynwind_current_load_port (port);
-
+ encoding = scm_scan_for_encoding (port);
+ if (encoding)
+ {
+ scm_i_set_port_encoding_x (port, encoding);
+ free (encoding);
+ }
+ else
+ /* The file has no encoding declaraed. We'll presume Latin-1. */
+ scm_i_set_port_encoding_x (port, NULL);
while (1)
{
SCM reader, form;
@@ -253,10 +262,11 @@ scm_init_load_path ()
struct passwd *pwd;
#endif
-#define FALLBACK_DIR "guile/ccache/"SCM_EFFECTIVE_VERSION
+#define FALLBACK_DIR \
+ "guile/ccache/" SCM_EFFECTIVE_VERSION "-" SCM_OBJCODE_MACHINE_VERSION_STRING
if ((e = getenv ("XDG_CACHE_HOME")))
- snprintf (cachedir, sizeof(cachedir), "%s" FALLBACK_DIR, e);
+ snprintf (cachedir, sizeof(cachedir), "%s/" FALLBACK_DIR, e);
else if ((e = getenv ("HOME")))
snprintf (cachedir, sizeof(cachedir), "%s/.cache/" FALLBACK_DIR, e);
#ifdef HAVE_GETPWENT
@@ -638,14 +648,11 @@ autocompile_catch_handler (void *data, SCM tag, SCM throw_args)
return SCM_BOOL_F;
}
-static SCM
-scm_try_autocompile (SCM source)
+SCM_DEFINE (scm_sys_warn_autocompilation_enabled, "%warn-autocompilation-enabled", 0, 0, 0,
+ (void), "")
{
static int message_shown = 0;
- if (scm_is_false (*scm_loc_load_should_autocompile))
- return SCM_BOOL_F;
-
if (!message_shown)
{
scm_puts (";;; note: autocompilation is enabled, set GUILE_AUTO_COMPILE=0\n"
@@ -654,6 +661,17 @@ scm_try_autocompile (SCM source)
message_shown = 1;
}
+ return SCM_UNSPECIFIED;
+}
+
+
+static SCM
+scm_try_autocompile (SCM source)
+{
+ if (scm_is_false (*scm_loc_load_should_autocompile))
+ return SCM_BOOL_F;
+
+ scm_sys_warn_autocompilation_enabled ();
return scm_c_catch (SCM_BOOL_T,
do_try_autocompile,
SCM2PTR (source),
diff --git a/libguile/load.h b/libguile/load.h
index d5bc1b066..1a1a86528 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -36,6 +36,7 @@ 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_c_primitive_load_path (const char *filename);
+SCM_INTERNAL SCM scm_sys_warn_autocompilation_enabled (void);
SCM_INTERNAL void scm_init_load_path (void);
SCM_INTERNAL void scm_init_load (void);
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 5f56b7a29..58125763f 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -46,8 +46,9 @@
#endif
#include <math.h>
-#include <ctype.h>
#include <string.h>
+#include <unicase.h>
+#include <unictype.h>
#if HAVE_COMPLEX_H
#include <complex.h>
@@ -2437,7 +2438,7 @@ scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
SCM str;
str = scm_number_to_string (sexp, SCM_UNDEFINED);
- scm_lfwrite (scm_i_string_chars (str), scm_i_string_length (str), port);
+ scm_lfwrite_str (str, port);
scm_remember_upto_here_1 (str);
return !0;
}
@@ -2484,13 +2485,13 @@ enum t_exactness {NO_EXACTNESS, INEXACT, EXACT};
/* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
/* In non ASCII-style encodings the following macro might not work. */
-#define XDIGIT2UINT(d) \
- (isdigit ((int) (unsigned char) d) \
- ? (d) - '0' \
- : tolower ((int) (unsigned char) d) - 'a' + 10)
+#define XDIGIT2UINT(d) \
+ (uc_is_property_decimal_digit ((int) (unsigned char) d) \
+ ? (d) - '0' \
+ : uc_tolower ((int) (unsigned char) d) - 'a' + 10)
static SCM
-mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
+mem2uinteger (SCM mem, unsigned int *p_idx,
unsigned int radix, enum t_exactness *p_exactness)
{
unsigned int idx = *p_idx;
@@ -2500,12 +2501,13 @@ mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
unsigned int digit_value;
SCM result;
char c;
+ size_t len = scm_i_string_length (mem);
if (idx == len)
return SCM_BOOL_F;
- c = mem[idx];
- if (!isxdigit ((int) (unsigned char) c))
+ c = scm_i_string_ref (mem, idx);
+ if (!uc_is_property_ascii_hex_digit ((scm_t_uint32) c))
return SCM_BOOL_F;
digit_value = XDIGIT2UINT (c);
if (digit_value >= radix)
@@ -2515,8 +2517,8 @@ mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
result = SCM_I_MAKINUM (digit_value);
while (idx != len)
{
- char c = mem[idx];
- if (isxdigit ((int) (unsigned char) c))
+ scm_t_wchar c = scm_i_string_ref (mem, idx);
+ if (uc_is_property_ascii_hex_digit ((scm_t_uint32) c))
{
if (hash_seen)
break;
@@ -2569,20 +2571,20 @@ mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
* has already been seen in the digits before the point.
*/
-/* In non ASCII-style encodings the following macro might not work. */
-#define DIGIT2UINT(d) ((d) - '0')
+#define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
static SCM
-mem2decimal_from_point (SCM result, const char* mem, size_t len,
+mem2decimal_from_point (SCM result, SCM mem,
unsigned int *p_idx, enum t_exactness *p_exactness)
{
unsigned int idx = *p_idx;
enum t_exactness x = *p_exactness;
+ size_t len = scm_i_string_length (mem);
if (idx == len)
return result;
- if (mem[idx] == '.')
+ if (scm_i_string_ref (mem, idx) == '.')
{
scm_t_bits shift = 1;
scm_t_bits add = 0;
@@ -2592,8 +2594,8 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len,
idx++;
while (idx != len)
{
- char c = mem[idx];
- if (isdigit ((int) (unsigned char) c))
+ scm_t_wchar c = scm_i_string_ref (mem, idx);
+ if (uc_is_property_decimal_digit ((scm_t_uint32) c))
{
if (x == INEXACT)
return SCM_BOOL_F;
@@ -2643,13 +2645,13 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len,
{
int sign = 1;
unsigned int start;
- char c;
+ scm_t_wchar c;
int exponent;
SCM e;
/* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
- switch (mem[idx])
+ switch (scm_i_string_ref (mem, idx))
{
case 'd': case 'D':
case 'e': case 'E':
@@ -2657,32 +2659,41 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len,
case 'l': case 'L':
case 's': case 'S':
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
start = idx;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
if (c == '-')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
sign = -1;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
}
else if (c == '+')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
sign = 1;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
}
else
sign = 1;
- if (!isdigit ((int) (unsigned char) c))
+ if (!uc_is_property_decimal_digit ((scm_t_uint32) c))
return SCM_BOOL_F;
idx++;
exponent = DIGIT2UINT (c);
while (idx != len)
{
- char c = mem[idx];
- if (isdigit ((int) (unsigned char) c))
+ scm_t_wchar c = scm_i_string_ref (mem, idx);
+ if (uc_is_property_decimal_digit ((scm_t_uint32) c))
{
idx++;
if (exponent <= SCM_MAXEXP)
@@ -2695,7 +2706,7 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len,
if (exponent > SCM_MAXEXP)
{
size_t exp_len = idx - start;
- SCM exp_string = scm_from_locale_stringn (&mem[start], exp_len);
+ SCM exp_string = scm_i_substring_copy (mem, start, start + exp_len);
SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
scm_out_of_range ("string->number", exp_num);
}
@@ -2727,11 +2738,12 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len,
/* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
static SCM
-mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
+mem2ureal (SCM mem, unsigned int *p_idx,
unsigned int radix, enum t_exactness *p_exactness)
{
unsigned int idx = *p_idx;
SCM result;
+ size_t len = scm_i_string_length (mem);
/* Start off believing that the number will be exact. This changes
to INEXACT if we see a decimal point or a hash. */
@@ -2740,51 +2752,53 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
if (idx == len)
return SCM_BOOL_F;
- if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5))
+ if (idx+5 <= len && !scm_i_string_strcmp (mem, idx, "inf.0"))
{
*p_idx = idx+5;
return scm_inf ();
}
- if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
+ if (idx+4 < len && !scm_i_string_strcmp (mem, idx, "nan."))
{
/* Cobble up the fractional part. We might want to set the
NaN's mantissa from it. */
idx += 4;
- mem2uinteger (mem, len, &idx, 10, &x);
+ mem2uinteger (mem, &idx, 10, &x);
*p_idx = idx;
return scm_nan ();
}
- if (mem[idx] == '.')
+ if (scm_i_string_ref (mem, idx) == '.')
{
if (radix != 10)
return SCM_BOOL_F;
else if (idx + 1 == len)
return SCM_BOOL_F;
- else if (!isdigit ((int) (unsigned char) mem[idx + 1]))
+ else if (!uc_is_property_decimal_digit ((scm_t_uint32) scm_i_string_ref (mem, idx+1)))
return SCM_BOOL_F;
else
- result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem, len,
+ result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem,
p_idx, &x);
}
else
{
SCM uinteger;
- uinteger = mem2uinteger (mem, len, &idx, radix, &x);
+ uinteger = mem2uinteger (mem, &idx, radix, &x);
if (scm_is_false (uinteger))
return SCM_BOOL_F;
if (idx == len)
result = uinteger;
- else if (mem[idx] == '/')
+ else if (scm_i_string_ref (mem, idx) == '/')
{
SCM divisor;
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
- divisor = mem2uinteger (mem, len, &idx, radix, &x);
+ divisor = mem2uinteger (mem, &idx, radix, &x);
if (scm_is_false (divisor))
return SCM_BOOL_F;
@@ -2793,7 +2807,7 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
}
else if (radix == 10)
{
- result = mem2decimal_from_point (uinteger, mem, len, &idx, &x);
+ result = mem2decimal_from_point (uinteger, mem, &idx, &x);
if (scm_is_false (result))
return SCM_BOOL_F;
}
@@ -2824,17 +2838,18 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
static SCM
-mem2complex (const char* mem, size_t len, unsigned int idx,
+mem2complex (SCM mem, unsigned int idx,
unsigned int radix, enum t_exactness *p_exactness)
{
- char c;
+ scm_t_wchar c;
int sign = 0;
SCM ureal;
+ size_t len = scm_i_string_length (mem);
if (idx == len)
return SCM_BOOL_F;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
if (c == '+')
{
idx++;
@@ -2849,7 +2864,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
if (idx == len)
return SCM_BOOL_F;
- ureal = mem2ureal (mem, len, &idx, radix, p_exactness);
+ ureal = mem2ureal (mem, &idx, radix, p_exactness);
if (scm_is_false (ureal))
{
/* input must be either +i or -i */
@@ -2857,7 +2872,8 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
if (sign == 0)
return SCM_BOOL_F;
- if (mem[idx] == 'i' || mem[idx] == 'I')
+ if (scm_i_string_ref (mem, idx) == 'i'
+ || scm_i_string_ref (mem, idx) == 'I')
{
idx++;
if (idx != len)
@@ -2876,7 +2892,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
if (idx == len)
return ureal;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
switch (c)
{
case 'i': case 'I':
@@ -2901,21 +2917,25 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
SCM angle;
SCM result;
- c = mem[idx];
+ c = scm_i_string_ref (mem, idx);
if (c == '+')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
sign = 1;
}
else if (c == '-')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
sign = -1;
}
else
sign = 1;
- angle = mem2ureal (mem, len, &idx, radix, p_exactness);
+ angle = mem2ureal (mem, &idx, radix, p_exactness);
if (scm_is_false (angle))
return SCM_BOOL_F;
if (idx != len)
@@ -2937,7 +2957,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
else
{
int sign = (c == '+') ? 1 : -1;
- SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness);
+ SCM imag = mem2ureal (mem, &idx, radix, p_exactness);
if (scm_is_false (imag))
imag = SCM_I_MAKINUM (sign);
@@ -2946,7 +2966,8 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
if (idx == len)
return SCM_BOOL_F;
- if (mem[idx] != 'i' && mem[idx] != 'I')
+ if (scm_i_string_ref (mem, idx) != 'i'
+ && scm_i_string_ref (mem, idx) != 'I')
return SCM_BOOL_F;
idx++;
@@ -2967,19 +2988,19 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
SCM
-scm_c_locale_stringn_to_number (const char* mem, size_t len,
- unsigned int default_radix)
+scm_i_string_to_number (SCM mem, unsigned int default_radix)
{
unsigned int idx = 0;
unsigned int radix = NO_RADIX;
enum t_exactness forced_x = NO_EXACTNESS;
enum t_exactness implicit_x = EXACT;
SCM result;
+ size_t len = scm_i_string_length (mem);
/* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
- while (idx + 2 < len && mem[idx] == '#')
+ while (idx + 2 < len && scm_i_string_ref (mem, idx) == '#')
{
- switch (mem[idx + 1])
+ switch (scm_i_string_ref (mem, idx + 1))
{
case 'b': case 'B':
if (radix != NO_RADIX)
@@ -3019,9 +3040,9 @@ scm_c_locale_stringn_to_number (const char* mem, size_t len,
/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
if (radix == NO_RADIX)
- result = mem2complex (mem, len, idx, default_radix, &implicit_x);
+ result = mem2complex (mem, idx, default_radix, &implicit_x);
else
- result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x);
+ result = mem2complex (mem, idx, (unsigned int) radix, &implicit_x);
if (scm_is_false (result))
return SCM_BOOL_F;
@@ -3052,6 +3073,15 @@ scm_c_locale_stringn_to_number (const char* mem, size_t len,
}
}
+SCM
+scm_c_locale_stringn_to_number (const char* mem, size_t len,
+ unsigned int default_radix)
+{
+ SCM str = scm_from_locale_stringn (mem, len);
+
+ return scm_i_string_to_number (str, default_radix);
+}
+
SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
(SCM string, SCM radix),
@@ -3074,9 +3104,7 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
else
base = scm_to_unsigned_integer (radix, 2, INT_MAX);
- answer = scm_c_locale_stringn_to_number (scm_i_string_chars (string),
- scm_i_string_length (string),
- base);
+ answer = scm_i_string_to_number (string, base);
scm_remember_upto_here_1 (string);
return answer;
}
diff --git a/libguile/numbers.h b/libguile/numbers.h
index bb72d7ac8..9597afb8d 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -28,6 +28,11 @@
#include "libguile/__scm.h"
#include "libguile/print.h"
+#ifndef SCM_T_WCHAR_DEFINED
+typedef scm_t_int32 scm_t_wchar;
+#define SCM_T_WCHAR_DEFINED
+#endif /* SCM_T_WCHAR_DEFINED */
+
#if SCM_HAVE_FLOATINGPOINT_H
# include <floatingpoint.h>
#endif
@@ -174,7 +179,6 @@ typedef struct scm_t_complex
double imag;
} scm_t_complex;
-typedef scm_t_int32 scm_t_wchar;
@@ -212,6 +216,7 @@ SCM_API int scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate);
SCM_API int scm_bigprint (SCM exp, SCM port, scm_print_state *pstate);
SCM_API SCM scm_c_locale_stringn_to_number (const char *mem, size_t len,
unsigned int radix);
+SCM_INTERNAL SCM scm_i_string_to_number (SCM str, unsigned int radix);
SCM_API SCM scm_string_to_number (SCM str, SCM radix);
SCM_API SCM scm_bigequal (SCM x, SCM y);
SCM_API SCM scm_real_equalp (SCM x, SCM y);
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 91691a70a..5466ecc2c 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -28,33 +28,14 @@
#include <sys/types.h>
#include <assert.h>
-#include <verify.h>
-
#include "_scm.h"
#include "vm-bootstrap.h"
#include "programs.h"
#include "objcodes.h"
-/* The endianness marker in objcode. */
-#ifdef WORDS_BIGENDIAN
-# define OBJCODE_ENDIANNESS "BE"
-#else
-# define OBJCODE_ENDIANNESS "LE"
-#endif
-
-#define _OBJCODE_STRINGIFY(x) # x
-#define OBJCODE_STRINGIFY(x) _OBJCODE_STRINGIFY (x)
-
-/* The word size marker in objcode. */
-#define OBJCODE_WORD_SIZE OBJCODE_STRINGIFY (SIZEOF_VOID_P)
-
-/* The objcode magic header. */
-#define OBJCODE_COOKIE \
- "GOOF-0.9-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---"
-
+/* SCM_OBJCODE_COOKIE is defined in _scm.h */
/* The length of the header must be a multiple of 8 bytes. */
-verify (((sizeof (OBJCODE_COOKIE) - 1) & 7) == 0);
-
+verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
/*
@@ -77,7 +58,7 @@ make_objcode_by_mmap (int fd)
if (ret < 0)
SCM_SYSERROR;
- if (st.st_size <= sizeof (struct scm_objcode) + strlen (OBJCODE_COOKIE))
+ if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE))
scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
scm_list_1 (SCM_I_MAKINUM (st.st_size)));
@@ -88,18 +69,18 @@ make_objcode_by_mmap (int fd)
SCM_SYSERROR;
}
- if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
+ if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE)))
{
SCM args = scm_list_1 (scm_from_locale_stringn
- (addr, strlen (OBJCODE_COOKIE)));
+ (addr, strlen (SCM_OBJCODE_COOKIE)));
(void) close (fd);
(void) munmap (addr, st.st_size);
scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
}
- data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
+ data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE));
- if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
+ if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE)))
{
(void) close (fd);
(void) munmap (addr, st.st_size);
@@ -109,7 +90,7 @@ make_objcode_by_mmap (int fd)
+ data->metalen)));
}
- SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE),
+ SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (SCM_OBJCODE_COOKIE),
SCM_PACK (SCM_BOOL_F), fd);
SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
@@ -138,10 +119,10 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
scm_from_uint32 (parent_data->len),
scm_from_uint32 (parent_data->metalen)));
-#if 0
- /* FIXME: We currently generate bytecode where the objcode-meta isn't
- suitable aligned, which is an issue on some arches (e.g., SPARC). */
- assert ((((uintptr_t) ptr) & (__alignof__ (struct scm_objcode) - 1UL)) == 0);
+#ifdef __GNUC__ /* we need `__alignof__' */
+ /* Make sure bytecode for the objcode-meta is suitable aligned. Failing to
+ do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */
+ assert ((((scm_t_bits) ptr) & (__alignof__ (struct scm_objcode) - 1UL)) == 0);
#endif
data = (struct scm_objcode*)ptr;
@@ -270,7 +251,7 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
SCM_VALIDATE_OBJCODE (1, objcode);
SCM_VALIDATE_OUTPUT_PORT (2, port);
- scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
+ scm_c_write (port, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
scm_c_write (port, SCM_OBJCODE_DATA (objcode),
sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
diff --git a/libguile/ports.c b/libguile/ports.c
index 627fd3f00..749d97533 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -30,6 +30,9 @@
#include <errno.h>
#include <fcntl.h> /* for chsize on mingw */
#include <assert.h>
+#include <uniconv.h>
+#include <unistr.h>
+#include <striconveh.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
@@ -51,6 +54,7 @@
#include "libguile/vectors.h"
#include "libguile/weaks.h"
#include "libguile/fluids.h"
+#include "libguile/eq.h"
#ifdef HAVE_STRING_H
#include <string.h>
@@ -358,10 +362,10 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
/* Standard ports --- current input, output, error, and more(!). */
-static SCM cur_inport_fluid;
-static SCM cur_outport_fluid;
-static SCM cur_errport_fluid;
-static SCM cur_loadport_fluid;
+static SCM cur_inport_fluid = 0;
+static SCM cur_outport_fluid = 0;
+static SCM cur_errport_fluid = 0;
+static SCM cur_loadport_fluid = 0;
SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
(),
@@ -370,7 +374,10 @@ SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
"returns the @dfn{standard input} in Unix and C terminology.")
#define FUNC_NAME s_scm_current_input_port
{
- return scm_fluid_ref (cur_inport_fluid);
+ if (cur_inport_fluid)
+ return scm_fluid_ref (cur_inport_fluid);
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -382,7 +389,10 @@ SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
"Unix and C terminology.")
#define FUNC_NAME s_scm_current_output_port
{
- return scm_fluid_ref (cur_outport_fluid);
+ if (cur_outport_fluid)
+ return scm_fluid_ref (cur_outport_fluid);
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -392,7 +402,10 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
"@dfn{standard error} in Unix and C terminology).")
#define FUNC_NAME s_scm_current_error_port
{
- return scm_fluid_ref (cur_errport_fluid);
+ if (cur_errport_fluid)
+ return scm_fluid_ref (cur_errport_fluid);
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -509,10 +522,18 @@ scm_new_port_table_entry (scm_t_bits tag)
SCM z = scm_cons (SCM_EOL, SCM_EOL);
scm_t_port *entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
+ const char *enc;
entry->file_name = SCM_BOOL_F;
entry->rw_active = SCM_PORT_NEITHER;
entry->port = z;
+ /* Initialize this port with the thread's current default
+ encoding. */
+ if ((enc = scm_i_get_port_encoding (SCM_BOOL_F)) == NULL)
+ entry->encoding = NULL;
+ else
+ entry->encoding = strdup (enc);
+ entry->ilseq_handler = scm_i_get_conversion_strategy (SCM_BOOL_F);
SCM_SET_CELL_TYPE (z, tag);
SCM_SETPTAB_ENTRY (z, entry);
@@ -549,6 +570,11 @@ scm_i_remove_port (SCM 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_SETPTAB_ENTRY (port, 0);
@@ -632,21 +658,22 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
*/
static long
-scm_i_mode_bits_n (const char *modes, size_t n)
+scm_i_mode_bits_n (SCM modes)
{
return (SCM_OPN
- | (memchr (modes, 'r', n) || memchr (modes, '+', n) ? SCM_RDNG : 0)
- | ( memchr (modes, 'w', n)
- || memchr (modes, 'a', n)
- || memchr (modes, '+', n) ? SCM_WRTNG : 0)
- | (memchr (modes, '0', n) ? SCM_BUF0 : 0)
- | (memchr (modes, 'l', n) ? SCM_BUFLINE : 0));
+ | (scm_i_string_contains_char (modes, 'r')
+ || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0)
+ | (scm_i_string_contains_char (modes, 'w')
+ || scm_i_string_contains_char (modes, 'a')
+ || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0)
+ | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0)
+ | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0));
}
long
scm_mode_bits (char *modes)
{
- return scm_i_mode_bits_n (modes, strlen (modes));
+ return scm_i_mode_bits (scm_from_locale_string (modes));
}
long
@@ -657,8 +684,7 @@ scm_i_mode_bits (SCM modes)
if (!scm_is_string (modes))
scm_wrong_type_arg_msg (NULL, 0, modes, "string");
- bits = scm_i_mode_bits_n (scm_i_string_chars (modes),
- scm_i_string_length (modes));
+ bits = scm_i_mode_bits_n (modes);
scm_remember_upto_here_1 (modes);
return bits;
}
@@ -929,7 +955,7 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
"characters are available, the end-of-file object is returned.")
#define FUNC_NAME s_scm_read_char
{
- int c;
+ scm_t_wchar c;
if (SCM_UNBNDP (port))
port = scm_current_input_port ();
SCM_VALIDATE_OPINPORT (1, port);
@@ -940,6 +966,133 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
}
#undef FUNC_NAME
+#define SCM_MBCHAR_BUF_SIZE (4)
+
+/* Get one codepoint from a file, using the port's encoding. */
+scm_t_wchar
+scm_getc (SCM port)
+{
+ int c;
+ unsigned int bufcount = 0;
+ char buf[SCM_MBCHAR_BUF_SIZE];
+ scm_t_wchar codepoint = 0;
+ scm_t_uint32 *u32;
+ size_t u32len;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ c = scm_get_byte_or_eof (port);
+ if (c == EOF)
+ return (scm_t_wchar) EOF;
+
+ buf[0] = c;
+ bufcount++;
+
+ if (pt->encoding == NULL)
+ {
+ /* The encoding is Latin-1: bytes are characters. */
+ codepoint = buf[0];
+ goto success;
+ }
+
+ for (;;)
+ {
+ u32 = u32_conv_from_encoding (pt->encoding,
+ (enum iconv_ilseq_handler) pt->ilseq_handler,
+ buf, bufcount, NULL, NULL, &u32len);
+ if (u32 == NULL || u32len == 0)
+ {
+ if (errno == ENOMEM)
+ scm_memory_error ("Input decoding");
+
+ /* Otherwise errno is EILSEQ or EINVAL, so perhaps more
+ bytes are needed. Keep looping. */
+ }
+ else
+ {
+ /* Complete codepoint found. */
+ codepoint = u32[0];
+ free (u32);
+ goto success;
+ }
+
+ if (bufcount == SCM_MBCHAR_BUF_SIZE)
+ {
+ /* We've read several bytes and didn't find a good
+ codepoint. Give up. */
+ goto failure;
+ }
+
+ c = scm_get_byte_or_eof (port);
+
+ if (c == EOF)
+ {
+ /* EOF before a complete character was read. Push it all
+ back and return EOF. */
+ while (bufcount > 0)
+ {
+ /* FIXME: this will probably cause errors in the port column. */
+ scm_unget_byte (buf[bufcount-1], port);
+ bufcount --;
+ }
+ return EOF;
+ }
+
+ if (c == '\n')
+ {
+ /* It is always invalid to have EOL in the middle of a
+ multibyte character. */
+ scm_unget_byte ('\n', port);
+ goto failure;
+ }
+
+ buf[bufcount++] = c;
+ }
+
+ success:
+ switch (codepoint)
+ {
+ case '\a':
+ break;
+ case '\b':
+ SCM_DECCOL (port);
+ break;
+ case '\n':
+ SCM_INCLINE (port);
+ break;
+ case '\r':
+ SCM_ZEROCOL (port);
+ break;
+ case '\t':
+ SCM_TABCOL (port);
+ break;
+ default:
+ SCM_INCCOL (port);
+ break;
+ }
+
+ return codepoint;
+
+ failure:
+ {
+ char *err_buf;
+ SCM err_str = scm_i_make_string (bufcount, &err_buf);
+ memcpy (err_buf, buf, bufcount);
+
+ if (errno == EILSEQ)
+ scm_misc_error (NULL, "input encoding error for ~s: ~s",
+ scm_list_2 (scm_from_locale_string (scm_i_get_port_encoding (port)),
+ err_str));
+ else
+ scm_misc_error (NULL, "input encoding error (invalid) for ~s: ~s\n",
+ scm_list_2 (scm_from_locale_string (scm_i_get_port_encoding (port)),
+ err_str));
+ }
+
+ /* Never gets here. */
+ return 0;
+}
+
+
/* this should only be called when the read buffer is empty. it
tries to refill the read buffer. it returns the first char from
the port, which is either EOF or *(pt->read_pos). */
@@ -969,7 +1122,24 @@ scm_fill_input (SCM port)
* This function differs from scm_c_write; it updates port line and
* column. */
-void
+static void
+update_port_lf (scm_t_wchar c, SCM port)
+{
+ if (c == '\a')
+ ; /* Do nothing. */
+ else if (c == '\b')
+ SCM_DECCOL (port);
+ else if (c == '\n')
+ SCM_INCLINE (port);
+ else if (c == '\r')
+ SCM_ZEROCOL (port);
+ else if (c == '\t')
+ SCM_TABCOL (port);
+ else
+ SCM_INCCOL (port);
+}
+
+void
scm_lfwrite (const char *ptr, size_t size, SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -980,25 +1150,74 @@ scm_lfwrite (const char *ptr, size_t size, SCM port)
ptob->write (port, ptr, size);
- for (; size; ptr++, size--) {
- if (*ptr == '\a') {
- }
- else if (*ptr == '\b') {
- SCM_DECCOL(port);
- }
- else if (*ptr == '\n') {
- SCM_INCLINE(port);
- }
- else if (*ptr == '\r') {
- SCM_ZEROCOL(port);
- }
- else if (*ptr == '\t') {
- SCM_TABCOL(port);
+ for (; size; ptr++, size--)
+ update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
+
+/* Write a scheme string STR to PORT from START inclusive to END
+ exclusive. */
+void
+scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
+{
+ size_t i, size = scm_i_string_length (str);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+ scm_t_wchar p;
+ char *buf;
+ size_t len;
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (port);
+
+ if (end == (size_t) (-1))
+ end = size;
+ size = end - start;
+
+ /* Note that making a substring will likely take the
+ stringbuf_write_mutex. So, one shouldn't use scm_lfwrite_substr
+ if the stringbuf write mutex may still be held elsewhere. */
+ buf = scm_to_stringn (scm_c_substring (str, start, end), &len,
+ pt->encoding, pt->ilseq_handler);
+ ptob->write (port, buf, len);
+ free (buf);
+
+ for (i = 0; i < size; i++)
+ {
+ p = scm_i_string_ref (str, i + start);
+ update_port_lf (p, port);
}
- else {
- SCM_INCCOL(port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
+
+/* Write a scheme string STR to PORT. */
+void
+scm_lfwrite_str (SCM str, SCM port)
+{
+ size_t i, size = scm_i_string_length (str);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+ scm_t_wchar p;
+ char *buf;
+ size_t len;
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (port);
+
+ buf = scm_to_stringn (str, &len,
+ pt->encoding, pt->ilseq_handler);
+ ptob->write (port, buf, len);
+ free (buf);
+
+ for (i = 0; i < size; i++)
+ {
+ p = scm_i_string_ref (str, i);
+ update_port_lf (p, port);
}
- }
if (pt->rw_random)
pt->rw_active = SCM_PORT_WRITE;
@@ -1191,8 +1410,8 @@ scm_end_input (SCM port)
void
-scm_ungetc (int c, SCM port)
-#define FUNC_NAME "scm_ungetc"
+scm_unget_byte (int c, SCM port)
+#define FUNC_NAME "scm_unget_byte"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -1251,6 +1470,25 @@ scm_ungetc (int c, SCM port)
if (pt->rw_random)
pt->rw_active = SCM_PORT_READ;
+}
+#undef FUNC_NAME
+
+void
+scm_ungetc (scm_t_wchar c, SCM port)
+#define FUNC_NAME "scm_ungetc"
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_wchar *wbuf;
+ SCM str = scm_i_make_wide_string (1, &wbuf);
+ char *buf;
+ size_t len;
+ int i;
+
+ wbuf[0] = c;
+ buf = scm_to_stringn (str, &len, pt->encoding, pt->ilseq_handler);
+
+ for (i = len - 1; i >= 0; i--)
+ scm_unget_byte (buf[i], port);
if (c == '\n')
{
@@ -1297,7 +1535,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
"to @code{read-char} would have hung.")
#define FUNC_NAME s_scm_peek_char
{
- int c, column;
+ scm_t_wchar c, column;
if (SCM_UNBNDP (port))
port = scm_current_input_port ();
else
@@ -1343,13 +1581,17 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0,
"@var{port} is not supplied, the current-input-port is used.")
#define FUNC_NAME s_scm_unread_string
{
+ int n;
SCM_VALIDATE_STRING (1, str);
if (SCM_UNBNDP (port))
port = scm_current_input_port ();
else
SCM_VALIDATE_OPINPORT (2, port);
- scm_ungets (scm_i_string_chars (str), scm_i_string_length (str), port);
+ n = scm_i_string_length (str);
+
+ while (n--)
+ scm_ungetc (scm_i_string_ref (str, n), port);
return str;
}
@@ -1604,6 +1846,328 @@ SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
}
#undef FUNC_NAME
+/* The default port encoding for this locale. New ports will have this
+ encoding. If it is a string, that is the encoding. If it #f, it
+ is in the native (Latin-1) encoding. */
+SCM_GLOBAL_VARIABLE (scm_port_encoding_var, "%port-encoding");
+static int scm_port_encoding_init = 0;
+
+/* Return a C string representation of the current encoding. */
+const char *
+scm_i_get_port_encoding (SCM port)
+{
+ SCM encoding;
+
+ if (scm_is_false (port))
+ {
+ if (!scm_port_encoding_init)
+ return NULL;
+ else if (!scm_is_fluid (SCM_VARIABLE_REF (scm_port_encoding_var)))
+ return NULL;
+ else
+ {
+ encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_port_encoding_var));
+ if (!scm_is_string (encoding))
+ return NULL;
+ else
+ return scm_i_string_chars (encoding);
+ }
+ }
+ else
+ {
+ scm_t_port *pt;
+ pt = SCM_PTAB_ENTRY (port);
+ if (pt->encoding)
+ return pt->encoding;
+ else
+ return NULL;
+ }
+}
+
+/* Returns ENC is if 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 *
+find_valid_encoding (const char *enc)
+{
+ int isvalid = 0;
+ const char str[] = " ";
+ scm_t_uint32 *u32;
+ size_t u32len;
+
+ u32 = u32_conv_from_encoding (enc, iconveh_error, str, 1,
+ NULL, NULL, &u32len);
+ isvalid = (u32 != NULL);
+ free (u32);
+
+ if (isvalid)
+ return enc;
+
+ return NULL;
+}
+
+void
+scm_i_set_port_encoding_x (SCM port, const char *enc)
+{
+ const char *valid_enc;
+ scm_t_port *pt;
+
+ /* Null is shorthand for the native, Latin-1 encoding. */
+ if (enc == NULL)
+ valid_enc = NULL;
+ else
+ {
+ valid_enc = find_valid_encoding (enc);
+ if (valid_enc == NULL)
+ {
+ SCM err;
+ err = scm_from_locale_string (enc);
+ scm_misc_error (NULL, "invalid or unknown character encoding ~s",
+ scm_list_1 (err));
+ }
+ }
+
+ if (scm_is_false (port))
+ {
+ /* Set the default encoding for future ports. */
+ if (!scm_port_encoding_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (scm_port_encoding_var)))
+ scm_misc_error (NULL, "tried to set port encoding fluid before it is initialized",
+ SCM_EOL);
+
+ if (valid_enc == NULL
+ || !strcmp (valid_enc, "ASCII")
+ || !strcmp (valid_enc, "ANSI_X3.4-1968")
+ || !strcmp (valid_enc, "ISO-8859-1"))
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var), SCM_BOOL_F);
+ else
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var),
+ scm_from_locale_string (valid_enc));
+ }
+ else
+ {
+ /* 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);
+ }
+}
+
+SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0,
+ (SCM port),
+ "Returns, as a string, the character encoding that @var{port}\n"
+ "uses to interpret its input and output.\n")
+#define FUNC_NAME s_scm_port_encoding
+{
+ scm_t_port *pt;
+ const char *enc;
+
+ SCM_VALIDATE_PORT (1, port);
+
+ pt = SCM_PTAB_ENTRY (port);
+ enc = scm_i_get_port_encoding (port);
+ if (enc)
+ return scm_from_locale_string (pt->encoding);
+ else
+ return scm_from_locale_string ("NONE");
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0,
+ (SCM port, SCM enc),
+ "Sets the character encoding that will be used to interpret all\n"
+ "port I/O. New ports are created with the encoding\n"
+ "appropriate for the current locale if @code{setlocale} has \n"
+ "been called or ISO-8859-1 otherwise\n"
+ "and this procedure can be used to modify that encoding.\n")
+
+#define FUNC_NAME s_scm_set_port_encoding_x
+{
+ char *enc_str;
+ const char *valid_enc_str;
+
+ SCM_VALIDATE_PORT (1, port);
+ SCM_VALIDATE_STRING (2, enc);
+
+ enc_str = scm_to_locale_string (enc);
+ valid_enc_str = find_valid_encoding (enc_str);
+ if (valid_enc_str == NULL)
+ {
+ free (enc_str);
+ scm_misc_error (FUNC_NAME, "invalid or unknown character encoding ~s",
+ scm_list_1 (enc));
+ }
+ else
+ {
+ scm_i_set_port_encoding_x (port, valid_enc_str);
+ free (enc_str);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+/* This determines how conversions handle unconvertible characters. */
+SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy");
+static int scm_conversion_strategy_init = 0;
+
+scm_t_string_failed_conversion_handler
+scm_i_get_conversion_strategy (SCM port)
+{
+ SCM encoding;
+
+ if (scm_is_false (port))
+ {
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
+ return SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else
+ {
+ encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy));
+ if (scm_is_false (encoding))
+ return SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else
+ return (scm_t_string_failed_conversion_handler) scm_to_int (encoding);
+ }
+ }
+ else
+ {
+ scm_t_port *pt;
+ pt = SCM_PTAB_ENTRY (port);
+ return pt->ilseq_handler;
+ }
+
+}
+
+void
+scm_i_set_conversion_strategy_x (SCM port,
+ scm_t_string_failed_conversion_handler handler)
+{
+ SCM strategy;
+ scm_t_port *pt;
+
+ strategy = scm_from_int ((int) handler);
+
+ if (scm_is_false (port))
+ {
+ /* Set the default encoding for future ports. */
+ if (!scm_conversion_strategy
+ || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
+ scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
+ SCM_EOL);
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy);
+ }
+ else
+ {
+ /* Set the character encoding for this port. */
+ pt = SCM_PTAB_ENTRY (port);
+ pt->ilseq_handler = handler;
+ }
+}
+
+SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy",
+ 1, 0, 0, (SCM port),
+ "Returns the behavior of the port when handling a character that\n"
+ "is not representable in the port's current encoding.\n"
+ "It returns the symbol @code{error} if unrepresentable characters\n"
+ "should cause exceptions, @code{substitute} if the port should\n"
+ "try to replace unrepresentable characters with question marks or\n"
+ "approximate characters, or @code{escape} if unrepresentable\n"
+ "characters should be converted to string escapes.\n"
+ "\n"
+ "If @var{port} is @code{#f}, then the current default behavior\n"
+ "will be returned. New ports will have this default behavior\n"
+ "when they are created.\n")
+#define FUNC_NAME s_scm_port_conversion_strategy
+{
+ scm_t_string_failed_conversion_handler h;
+
+ SCM_VALIDATE_OPPORT (1, port);
+
+ if (!scm_is_false (port))
+ {
+ SCM_VALIDATE_OPPORT (1, port);
+ }
+
+ h = scm_i_get_conversion_strategy (port);
+ if (h == SCM_FAILED_CONVERSION_ERROR)
+ return scm_from_locale_symbol ("error");
+ else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK)
+ return scm_from_locale_symbol ("substitute");
+ else if (h == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ return scm_from_locale_symbol ("escape");
+ else
+ abort ();
+
+ /* Never gets here. */
+ return SCM_UNDEFINED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!",
+ 2, 0, 0,
+ (SCM port, SCM sym),
+ "Sets the behavior of the interpreter when outputting a character\n"
+ "that is not representable in the port's current encoding.\n"
+ "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
+ "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
+ "when an unconvertible character is encountered. If it is\n"
+ "@code{'substitute}, then unconvertible characters will \n"
+ "be replaced with approximate characters, or with question marks\n"
+ "if no approximately correct character is available.\n"
+ "If it is @code{'escape},\n"
+ "it will appear as a hex escape when output.\n"
+ "\n"
+ "If @var{port} is an open port, the conversion error behavior\n"
+ "is set for that port. If it is @code{#f}, it is set as the\n"
+ "default behavior for any future ports that get created in\n"
+ "this thread.\n")
+#define FUNC_NAME s_scm_set_port_conversion_strategy_x
+{
+ SCM err;
+ SCM qm;
+ SCM esc;
+
+ if (!scm_is_false (port))
+ {
+ SCM_VALIDATE_OPPORT (1, port);
+ }
+
+ err = scm_from_locale_symbol ("error");
+ if (scm_is_true (scm_eqv_p (sym, err)))
+ {
+ scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR);
+ return SCM_UNSPECIFIED;
+ }
+
+ qm = scm_from_locale_symbol ("substitute");
+ if (scm_is_true (scm_eqv_p (sym, qm)))
+ {
+ scm_i_set_conversion_strategy_x (port,
+ SCM_FAILED_CONVERSION_QUESTION_MARK);
+ return SCM_UNSPECIFIED;
+ }
+
+ esc = scm_from_locale_symbol ("escape");
+ if (scm_is_true (scm_eqv_p (sym, esc)))
+ {
+ scm_i_set_conversion_strategy_x (port,
+ SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
+ return SCM_UNSPECIFIED;
+ }
+
+ SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
void
scm_print_port_mode (SCM exp, SCM port)
{
@@ -1714,8 +2278,17 @@ scm_init_ports ()
cur_loadport_fluid = scm_permanent_object (scm_make_fluid ());
scm_i_port_weak_hash = scm_permanent_object (scm_make_weak_key_hash_table (SCM_I_MAKINUM(31)));
-
#include "libguile/ports.x"
+
+ SCM_VARIABLE_SET (scm_port_encoding_var, scm_make_fluid ());
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var), SCM_BOOL_F);
+ scm_port_encoding_init = 1;
+
+ SCM_VARIABLE_SET (scm_conversion_strategy, scm_make_fluid ());
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy),
+ scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK));
+ scm_conversion_strategy_init = 1;
+
}
/*
diff --git a/libguile/ports.h b/libguile/ports.h
index 8a21b09f9..c75f17d59 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -28,7 +28,7 @@
#include "libguile/print.h"
#include "libguile/struct.h"
#include "libguile/threads.h"
-
+#include "libguile/strings.h"
@@ -56,6 +56,10 @@ typedef struct
long line_number; /* debugging support. */
int column_number; /* debugging support. */
+ /* Character encoding support */
+ char *encoding;
+ scm_t_string_failed_conversion_handler ilseq_handler;
+
/* port buffers. the buffer(s) are set up for all ports.
in the case of string ports, the buffer is the string itself.
in the case of unbuffered file ports, the buffer is a
@@ -155,11 +159,11 @@ SCM_INTERNAL SCM scm_i_port_weak_hash;
#define SCM_REVEALED(x) (SCM_PTAB_ENTRY(x)->revealed)
#define SCM_SETREVEALED(x, s) (SCM_PTAB_ENTRY(x)->revealed = (s))
-#define SCM_INCLINE(port) {SCM_LINUM (port) += 1; SCM_COL (port) = 0;}
-#define SCM_ZEROCOL(port) {SCM_COL (port) = 0;}
-#define SCM_INCCOL(port) {SCM_COL (port) += 1;}
-#define SCM_DECCOL(port) {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;}
-#define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;}
+#define SCM_INCLINE(port) do {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} while (0)
+#define SCM_ZEROCOL(port) do {SCM_COL (port) = 0;} while (0)
+#define SCM_INCCOL(port) do {SCM_COL (port) += 1;} while (0)
+#define SCM_DECCOL(port) do {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;} while (0)
+#define SCM_TABCOL(port) do {SCM_COL (port) += 8 - SCM_COL (port) % 8;} while (0)
/* Maximum number of port types. */
#define SCM_I_MAX_PORT_TYPE_COUNT 256
@@ -266,13 +270,18 @@ SCM_API SCM scm_eof_object_p (SCM x);
SCM_API SCM scm_force_output (SCM port);
SCM_API SCM scm_flush_all_ports (void);
SCM_API SCM scm_read_char (SCM port);
+SCM_API scm_t_wchar scm_getc (SCM port);
SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size);
SCM_API void scm_c_write (SCM port, const void *buffer, size_t size);
SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port);
+SCM_INTERNAL void scm_lfwrite_str (SCM str, SCM port);
+SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end,
+ SCM port);
SCM_API void scm_flush (SCM port);
SCM_API void scm_end_input (SCM port);
SCM_API int scm_fill_input (SCM port);
-SCM_API void scm_ungetc (int c, SCM port);
+SCM_INTERNAL void scm_unget_byte (int c, SCM port);
+SCM_API void scm_ungetc (scm_t_wchar c, SCM port);
SCM_API void scm_ungets (const char *s, int n, SCM port);
SCM_API SCM scm_peek_char (SCM port);
SCM_API SCM scm_unread_char (SCM cobj, SCM port);
@@ -285,6 +294,15 @@ SCM_API SCM scm_port_column (SCM port);
SCM_API SCM scm_set_port_column_x (SCM port, SCM line);
SCM_API SCM scm_port_filename (SCM port);
SCM_API SCM scm_set_port_filename_x (SCM port, SCM filename);
+SCM_INTERNAL const char *scm_i_get_port_encoding (SCM port);
+SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str);
+SCM_API SCM scm_port_encoding (SCM port);
+SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding);
+SCM_INTERNAL scm_t_string_failed_conversion_handler scm_i_get_conversion_strategy (SCM port);
+SCM_INTERNAL void scm_i_set_conversion_strategy_x (SCM port,
+ scm_t_string_failed_conversion_handler h);
+SCM_API SCM scm_port_conversion_strategy (SCM port);
+SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior);
SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *);
SCM_API void scm_print_port_mode (SCM exp, SCM port);
SCM_API void scm_ports_prehistory (void);
@@ -292,7 +310,6 @@ SCM_API SCM scm_void_port (char * mode_str);
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);
#endif
diff --git a/libguile/posix.c b/libguile/posix.c
index dafc5e996..09d53f212 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -25,6 +25,7 @@
#include <stdlib.h>
#include <stdio.h>
#include <errno.h>
+#include <uniconv.h>
#include "libguile/_scm.h"
#include "libguile/dynwind.h"
@@ -1528,12 +1529,17 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
"Otherwise the specified locale category is set to the string\n"
"@var{locale} and the new value is returned as a\n"
"system-dependent string. If @var{locale} is an empty string,\n"
- "the locale will be set using environment variables.")
+ "the locale will be set using environment variables.\n"
+ "\n"
+ "When the locale is changed, the character encoding of the new\n"
+ "locale (UTF-8, ISO-8859-1, etc.) is used for the current\n"
+ "input, output, and error ports\n")
#define FUNC_NAME s_scm_setlocale
{
int c_category;
char *clocale;
char *rv;
+ const char *enc;
scm_dynwind_begin (0);
@@ -1562,15 +1568,47 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
SCM_SYSERROR;
}
- /* Recompute the standard SRFI-14 character sets in a locale-dependent
- (actually charset-dependent) way. */
- scm_srfi_14_compute_char_sets ();
+ enc = locale_charset ();
+ /* Set the default encoding for new ports. */
+ scm_i_set_port_encoding_x (SCM_BOOL_F, enc);
+ /* Set the encoding for the stdio ports. */
+ scm_i_set_port_encoding_x (scm_current_input_port (), enc);
+ scm_i_set_port_encoding_x (scm_current_output_port (), enc);
+ scm_i_set_port_encoding_x (scm_current_error_port (), enc);
scm_dynwind_end ();
return scm_from_locale_string (rv);
}
#undef FUNC_NAME
#endif /* HAVE_SETLOCALE */
+SCM_DEFINE (scm_setbinary, "setbinary", 0, 0, 0,
+ (void),
+ "Sets the encoding for the current input, output, and error\n"
+ "ports to ISO-8859-1. That character encoding allows\n"
+ "ports to operate on binary data.\n"
+ "\n"
+ "It also sets the default encoding for newly created ports\n"
+ "to ISO-8859-1.\n"
+ "\n"
+ "The previous default encoding for new ports is returned\n")
+#define FUNC_NAME s_scm_setbinary
+{
+ const char *enc = scm_i_get_port_encoding (SCM_BOOL_F);
+
+ /* Set the default encoding for new ports. */
+ scm_i_set_port_encoding_x (SCM_BOOL_F, NULL);
+ /* Set the encoding for the stdio ports. */
+ scm_i_set_port_encoding_x (scm_current_input_port (), NULL);
+ scm_i_set_port_encoding_x (scm_current_output_port (), NULL);
+ scm_i_set_port_encoding_x (scm_current_error_port (), NULL);
+
+ if (enc)
+ return scm_from_locale_string (enc);
+
+ return scm_from_locale_string ("ISO-8859-1");
+}
+#undef FUNC_NAME
+
#ifdef HAVE_MKNOD
SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0,
diff --git a/libguile/posix.h b/libguile/posix.h
index 4d057643c..2d93300b8 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -74,6 +74,7 @@ SCM_API SCM scm_access (SCM path, SCM how);
SCM_API SCM scm_getpid (void);
SCM_API SCM scm_putenv (SCM str);
SCM_API SCM scm_setlocale (SCM category, SCM locale);
+SCM_API SCM scm_setbinary (void);
SCM_API SCM scm_mknod (SCM path, SCM type, SCM perms, SCM dev);
SCM_API SCM scm_nice (SCM incr);
SCM_API SCM scm_sync (void);
diff --git a/libguile/print.c b/libguile/print.c
index f43856bbe..86d067b8b 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -23,6 +23,7 @@
#endif
#include <errno.h>
+#include <uniconv.h>
#include <unictype.h>
#include "libguile/_scm.h"
@@ -34,7 +35,7 @@
#include "libguile/procprop.h"
#include "libguile/read.h"
#include "libguile/weaks.h"
-#include "libguile/unif.h"
+#include "libguile/programs.h"
#include "libguile/alist.h"
#include "libguile/struct.h"
#include "libguile/objects.h"
@@ -293,13 +294,12 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref)
/* Print the name of a symbol. */
static int
-quote_keywordish_symbol (const char *str, size_t len)
+quote_keywordish_symbol (SCM symbol)
{
SCM option;
- /* LEN is guaranteed to be > 0.
- */
- if (str[0] != ':' && str[len-1] != ':')
+ if (scm_i_symbol_ref (symbol, 0) != ':'
+ && scm_i_symbol_ref (symbol, scm_i_symbol_length (symbol) - 1) != ':')
return 0;
option = SCM_PRINT_KEYWORD_STYLE;
@@ -311,7 +311,7 @@ quote_keywordish_symbol (const char *str, size_t len)
}
void
-scm_print_symbol_name (const char *str, size_t len, SCM port)
+scm_i_print_symbol_name (SCM str, SCM port)
{
/* This points to the first character that has not yet been written to the
* port. */
@@ -332,18 +332,20 @@ scm_print_symbol_name (const char *str, size_t len, SCM port)
* simpler and faster. */
int maybe_weird = 0;
size_t mw_pos = 0;
+ size_t len = scm_i_symbol_length (str);
+ scm_t_wchar str0 = scm_i_symbol_ref (str, 0);
- if (len == 0 || str[0] == '\'' || str[0] == '`' || str[0] == ','
- || quote_keywordish_symbol (str, len)
- || (str[0] == '.' && len == 1)
- || scm_is_true (scm_c_locale_stringn_to_number (str, len, 10)))
+ if (len == 0 || str0 == '\'' || str0 == '`' || str0 == ','
+ || quote_keywordish_symbol (str)
+ || (str0 == '.' && len == 1)
+ || scm_is_true (scm_i_string_to_number (scm_symbol_to_string (str), 10)))
{
scm_lfwrite ("#{", 2, port);
weird = 1;
}
for (end = pos; end < len; ++end)
- switch (str[end])
+ switch (scm_i_symbol_ref (str, end))
{
#ifdef BRACKETS_AS_PARENS
case '[':
@@ -368,11 +370,11 @@ scm_print_symbol_name (const char *str, size_t len, SCM port)
weird = 1;
}
if (pos < end)
- scm_lfwrite (str + pos, end - pos, port);
+ scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port);
{
char buf[2];
buf[0] = '\\';
- buf[1] = str[end];
+ buf[1] = (char) (unsigned char) scm_i_symbol_ref (str, end);
scm_lfwrite (buf, 2, port);
}
pos = end + 1;
@@ -390,11 +392,18 @@ scm_print_symbol_name (const char *str, size_t len, SCM port)
break;
}
if (pos < end)
- scm_lfwrite (str + pos, end - pos, port);
+ scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port);
if (weird)
scm_lfwrite ("}#", 2, port);
}
+void
+scm_print_symbol_name (const char *str, size_t len, SCM port)
+{
+ SCM symbol = scm_from_locale_symboln (str, len);
+ return scm_i_print_symbol_name (symbol, port);
+}
+
/* Print generally. Handles both write and display according to PSTATE.
*/
SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write);
@@ -453,20 +462,50 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
| UC_CATEGORY_MASK_S))
/* Print the character if is graphic character. */
{
- if (i<256)
- /* Character is graphic. Print it. */
- scm_putc (i, port);
+ scm_t_wchar *wbuf;
+ SCM wstr = scm_i_make_wide_string (1, &wbuf);
+ char *buf;
+ size_t len;
+ const char *enc;
+
+ enc = scm_i_get_port_encoding (port);
+ wbuf[0] = i;
+ if (enc == NULL)
+ {
+ if (i <= 0xFF)
+ /* Character is graphic and Latin-1. Print it */
+ scm_lfwrite_str (wstr, port);
+ else
+ /* Character is graphic but unrepresentable in
+ this port's encoding. */
+ scm_intprint (i, 8, port);
+ }
else
- /* Character is graphic but unrepresentable in
- this port's encoding. */
- scm_intprint (i, 8, port);
+ {
+ buf = u32_conv_to_encoding (enc,
+ iconveh_error,
+ (scm_t_uint32 *) wbuf,
+ 1,
+ NULL,
+ NULL, &len);
+ if (buf != NULL)
+ {
+ /* Character is graphic. Print it. */
+ scm_lfwrite_str (wstr, port);
+ free (buf);
+ }
+ else
+ /* Character is graphic but unrepresentable in
+ this port's encoding. */
+ scm_intprint (i, 8, port);
+ }
}
else
/* Character is a non-graphical character. */
scm_intprint (i, 8, port);
}
else
- scm_putc (i, port);
+ scm_i_charprint (i, port);
}
else if (SCM_IFLAGP (exp)
&& ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
@@ -559,63 +598,128 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
break;
}
break;
- case scm_tc7_string:
- if (SCM_WRITINGP (pstate))
- {
- size_t i, j, len;
- const char *data;
+ case scm_tc7_string:
+ if (SCM_WRITINGP (pstate))
+ {
+ size_t i, j, len;
+ static char const hex[] = "0123456789abcdef";
+ char buf[8];
- scm_putc ('"', port);
- len = scm_i_string_length (exp);
- data = scm_i_string_chars (exp);
- for (i = 0, j = 0; i < len; ++i)
- {
- unsigned char ch = data[i];
- if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148))
- {
- static char const hex[]="0123456789abcdef";
- char buf[4];
-
- scm_lfwrite (data+j, i-j, port);
- buf[0] = '\\';
- buf[1] = 'x';
- buf[2] = hex [ch / 16];
- buf[3] = hex [ch % 16];
- scm_lfwrite (buf, 4, port);
- data = scm_i_string_chars (exp);
- j = i+1;
- }
- else if (ch == '"' || ch == '\\')
- {
- scm_lfwrite (data+j, i-j, port);
- scm_putc ('\\', port);
- data = scm_i_string_chars (exp);
- j = i;
- }
- }
- scm_lfwrite (data+j, i-j, port);
- scm_putc ('"', port);
- scm_remember_upto_here_1 (exp);
- }
- else
- scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp),
- port);
- scm_remember_upto_here_1 (exp);
- break;
+
+ scm_putc ('"', port);
+ len = scm_i_string_length (exp);
+ for (i = 0; i < len; ++i)
+ {
+ scm_t_wchar ch = scm_i_string_ref (exp, i);
+ int printed = 0;
+
+ if (ch == ' ' || ch == '\n')
+ {
+ scm_putc (ch, port);
+ printed = 1;
+ }
+ else if (ch == '"' || ch == '\\')
+ {
+ scm_putc ('\\', port);
+ scm_i_charprint (ch, port);
+ printed = 1;
+ }
+ else
+ if (uc_is_general_category_withtable
+ (ch,
+ UC_CATEGORY_MASK_L | UC_CATEGORY_MASK_M |
+ UC_CATEGORY_MASK_N | UC_CATEGORY_MASK_P |
+ UC_CATEGORY_MASK_S))
+ {
+ /* Print the character since it is a graphic
+ character. */
+ scm_t_wchar *wbuf;
+ SCM wstr = scm_i_make_wide_string (1, &wbuf);
+ char *buf;
+ size_t len;
+
+ if (scm_i_get_port_encoding (port))
+ {
+ wstr = scm_i_make_wide_string (1, &wbuf);
+ wbuf[0] = ch;
+ buf = u32_conv_to_encoding (scm_i_get_port_encoding (port),
+ iconveh_error,
+ (scm_t_uint32 *) wbuf,
+ 1 ,
+ NULL,
+ NULL, &len);
+ if (buf != NULL)
+ {
+ /* Character is graphic and representable in
+ this encoding. Print it. */
+ scm_lfwrite_str (wstr, port);
+ free (buf);
+ printed = 1;
+ }
+ }
+ else
+ if (ch <= 0xFF)
+ {
+ scm_putc (ch, port);
+ printed = 1;
+ }
+ }
+
+ if (!printed)
+ {
+ /* Character is graphic but unrepresentable in
+ this port's encoding or is not graphic. */
+ if (ch <= 0xFF)
+ {
+ buf[0] = '\\';
+ buf[1] = 'x';
+ buf[2] = hex[ch / 16];
+ buf[3] = hex[ch % 16];
+ scm_lfwrite (buf, 4, port);
+ }
+ else if (ch <= 0xFFFF)
+ {
+ buf[0] = '\\';
+ buf[1] = 'u';
+ buf[2] = hex[(ch & 0xF000) >> 12];
+ buf[3] = hex[(ch & 0xF00) >> 8];
+ buf[4] = hex[(ch & 0xF0) >> 4];
+ buf[5] = hex[(ch & 0xF)];
+ scm_lfwrite (buf, 6, port);
+ j = i + 1;
+ }
+ else if (ch > 0xFFFF)
+ {
+ buf[0] = '\\';
+ buf[1] = 'U';
+ buf[2] = hex[(ch & 0xF00000) >> 20];
+ buf[3] = hex[(ch & 0xF0000) >> 16];
+ buf[4] = hex[(ch & 0xF000) >> 12];
+ buf[5] = hex[(ch & 0xF00) >> 8];
+ buf[6] = hex[(ch & 0xF0) >> 4];
+ buf[7] = hex[(ch & 0xF)];
+ scm_lfwrite (buf, 8, port);
+ j = i + 1;
+ }
+ }
+ }
+ scm_putc ('"', port);
+ scm_remember_upto_here_1 (exp);
+ }
+ else
+ scm_lfwrite_str (exp, port);
+ scm_remember_upto_here_1 (exp);
+ break;
case scm_tc7_symbol:
if (scm_i_symbol_is_interned (exp))
{
- scm_print_symbol_name (scm_i_symbol_chars (exp),
- scm_i_symbol_length (exp),
- port);
+ scm_i_print_symbol_name (exp, port);
scm_remember_upto_here_1 (exp);
}
else
{
scm_puts ("#<uninterned-symbol ", port);
- scm_print_symbol_name (scm_i_symbol_chars (exp),
- scm_i_symbol_length (exp),
- port);
+ scm_i_print_symbol_name (exp, port);
scm_putc (' ', port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
scm_putc ('>', port);
@@ -624,6 +728,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_variable:
scm_i_variable_print (exp, port, pstate);
break;
+ case scm_tc7_program:
+ scm_i_program_print (exp, port, pstate);
+ break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp))
@@ -664,14 +771,16 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
EXIT_NESTED_DATA (pstate);
break;
case scm_tcs_subrs:
- scm_puts (SCM_SUBR_GENERIC (exp)
- ? "#<primitive-generic "
- : "#<primitive-procedure ",
- port);
- scm_puts (scm_i_symbol_chars (SCM_SUBR_NAME (exp)), port);
- scm_putc ('>', port);
- break;
-
+ {
+ SCM name = scm_symbol_to_string (SCM_SUBR_NAME (exp));
+ scm_puts (SCM_SUBR_GENERIC (exp)
+ ? "#<primitive-generic "
+ : "#<primitive-procedure ",
+ port);
+ scm_lfwrite_str (name, port);
+ scm_putc ('>', port);
+ break;
+ }
case scm_tc7_pws:
scm_puts ("#<procedure-with-setter", port);
{
@@ -763,6 +872,17 @@ scm_prin1 (SCM exp, SCM port, int writingp)
}
}
+/* Print a character.
+ */
+void
+scm_i_charprint (scm_t_wchar ch, SCM port)
+{
+ scm_t_wchar *wbuf;
+ SCM wstr = scm_i_make_wide_string (1, &wbuf);
+
+ wbuf[0] = ch;
+ scm_lfwrite_str (wstr, port);
+}
/* Print an integer.
*/
@@ -977,9 +1097,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
SCM port, answer = SCM_UNSPECIFIED;
int fReturnString = 0;
int writingp;
- const char *start;
- const char *end;
- const char *p;
+ size_t start, p, end;
if (scm_is_eq (destination, SCM_BOOL_T))
{
@@ -1002,15 +1120,16 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
SCM_VALIDATE_STRING (2, message);
SCM_VALIDATE_REST_ARGUMENT (args);
- start = scm_i_string_chars (message);
- end = start + scm_i_string_length (message);
+ p = 0;
+ start = 0;
+ end = scm_i_string_length (message);
for (p = start; p != end; ++p)
- if (*p == '~')
+ if (scm_i_string_ref (message, p) == '~')
{
if (++p == end)
break;
- switch (*p)
+ switch (scm_i_string_ref (message, p))
{
case 'A': case 'a':
writingp = 0;
@@ -1019,33 +1138,33 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
writingp = 1;
break;
case '~':
- scm_lfwrite (start, p - start, port);
+ scm_lfwrite_substr (message, start, p, port);
start = p + 1;
continue;
case '%':
- scm_lfwrite (start, p - start - 1, port);
+ scm_lfwrite_substr (message, start, p - 1, port);
scm_newline (port);
start = p + 1;
continue;
default:
SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead",
- scm_list_1 (SCM_MAKE_CHAR (*p)));
+ scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p))));
}
if (!scm_is_pair (args))
SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A",
- scm_list_1 (SCM_MAKE_CHAR (*p)));
+ scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p))));
- scm_lfwrite (start, p - start - 1, port);
+ scm_lfwrite_substr (message, start, p - 1, port);
/* we pass destination here */
scm_prin1 (SCM_CAR (args), destination, writingp);
args = SCM_CDR (args);
start = p + 1;
}
- scm_lfwrite (start, p - start, port);
+ scm_lfwrite_substr (message, start, p, port);
if (!scm_is_eq (args, SCM_EOL))
SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments",
scm_list_1 (scm_length (args)));
diff --git a/libguile/print.h b/libguile/print.h
index d817a6fc3..ae2aaef54 100644
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -25,6 +25,7 @@
#include "libguile/__scm.h"
+#include "libguile/chars.h"
#include "libguile/options.h"
@@ -77,10 +78,12 @@ SCM_API SCM scm_print_options (SCM setting);
SCM_API SCM scm_make_print_state (void);
SCM_API void scm_free_print_state (SCM print_state);
SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state);
+SCM_INTERNAL void scm_i_charprint (scm_t_wchar c, SCM port);
SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port);
SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port);
SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port);
SCM_API void scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate);
+SCM_INTERNAL void scm_i_print_symbol_name (SCM sym, SCM port);
SCM_API void scm_print_symbol_name (const char *str, size_t len, SCM port);
SCM_API void scm_prin1 (SCM exp, SCM port, int writingp);
SCM_API void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate);
diff --git a/libguile/procprop.c b/libguile/procprop.c
index df96eaad4..5054291b1 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -33,6 +33,7 @@
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/hashtab.h"
+#include "libguile/programs.h"
#include "libguile/validate.h"
#include "libguile/procprop.h"
@@ -72,6 +73,11 @@ scm_i_procedure_arity (SCM proc)
case scm_tc7_lsubr:
r = 1;
break;
+ case scm_tc7_program:
+ a += SCM_PROGRAM_DATA (proc)->nargs;
+ r = SCM_PROGRAM_DATA (proc)->nrest;
+ a -= r;
+ break;
case scm_tc7_lsubr_2:
a += 2;
r = 1;
diff --git a/libguile/procs.c b/libguile/procs.c
index 93e35ab6c..815e29fe7 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -112,6 +112,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
case scm_tcs_closures:
case scm_tcs_subrs:
case scm_tc7_pws:
+ case scm_tc7_program:
return SCM_BOOL_T;
case scm_tc7_smob:
return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
@@ -151,6 +152,10 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
return SCM_BOOL_T;
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));
case scm_tc7_pws:
obj = SCM_PROCEDURE (obj);
goto again;
@@ -179,6 +184,8 @@ scm_subr_p (SCM obj)
return 0;
}
+SCM_SYMBOL (sym_documentation, "documentation");
+
SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
(SCM proc),
"Return the documentation string associated with @code{proc}. By\n"
@@ -190,6 +197,8 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
SCM code;
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
proc, SCM_ARG1, FUNC_NAME);
+ if (SCM_PROGRAM_P (proc))
+ return scm_assq_ref (scm_program_properties (proc), sym_documentation);
switch (SCM_TYP7 (proc))
{
case scm_tcs_closures:
diff --git a/libguile/programs.c b/libguile/programs.c
index 5c43ac525..b2bf80674 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -31,8 +31,6 @@
#include "vm.h"
-scm_t_bits scm_tc16_program;
-
static SCM write_program = SCM_BOOL_F;
SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
@@ -50,49 +48,13 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
else if (free_variables != SCM_BOOL_F)
SCM_VALIDATE_VECTOR (3, free_variables);
- SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_variables);
+ return scm_double_cell (scm_tc7_program, (scm_t_bits)objcode,
+ (scm_t_bits)objtable, (scm_t_bits)free_variables);
}
#undef FUNC_NAME
-static SCM
-program_mark (SCM obj)
-{
- if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
- scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
- if (scm_is_true (SCM_PROGRAM_FREE_VARIABLES (obj)))
- scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (obj));
- return SCM_PROGRAM_OBJCODE (obj);
-}
-
-static SCM
-program_apply (SCM program, SCM args)
-{
- return scm_vm_apply (scm_the_vm (), program, args);
-}
-
-static SCM
-program_apply_0 (SCM program)
-{
- return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
-}
-
-static SCM
-program_apply_1 (SCM program, SCM a)
-{
- return scm_c_vm_run (scm_the_vm (), program, &a, 1);
-}
-
-static SCM
-program_apply_2 (SCM program, SCM a, SCM b)
-{
- SCM args[2];
- args[0] = a;
- args[1] = b;
- return scm_c_vm_run (scm_the_vm (), program, args, 2);
-}
-
-static int
-program_print (SCM program, SCM port, scm_print_state *pstate)
+void
+scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
{
static int print_error = 0;
@@ -102,12 +64,17 @@ program_print (SCM program, SCM port, scm_print_state *pstate)
scm_from_locale_symbol ("write-program"));
if (SCM_FALSEP (write_program) || print_error)
- return scm_smob_print (program, port, pstate);
-
- print_error = 1;
- scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
- print_error = 0;
- return 1;
+ {
+ scm_puts ("#<program ", port);
+ scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);
+ scm_putc ('>', port);
+ }
+ else
+ {
+ print_error = 1;
+ scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
+ print_error = 0;
+ }
}
@@ -319,13 +286,6 @@ SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
void
scm_bootstrap_programs (void)
{
- scm_tc16_program = scm_make_smob_type ("program", 0);
- scm_set_smob_mark (scm_tc16_program, program_mark);
- scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
- scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_0 = program_apply_0;
- scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_1 = program_apply_1;
- scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_2 = program_apply_2;
- scm_set_smob_print (scm_tc16_program, program_print);
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 040e8ea2c..d52631fbb 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -26,19 +26,15 @@
* Programs
*/
-typedef unsigned char scm_byte_t;
+#define SCM_F_PROGRAM_IS_BOOT (1<<16)
-SCM_API scm_t_bits scm_tc16_program;
-
-#define SCM_F_PROGRAM_IS_BOOT (1<<0)
-
-#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x))
-#define SCM_PROGRAM_OBJCODE(x) (SCM_SMOB_OBJECT (x))
-#define SCM_PROGRAM_OBJTABLE(x) (SCM_SMOB_OBJECT_2 (x))
-#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_SMOB_OBJECT_3 (x))
+#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
+#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x))
+#define SCM_PROGRAM_OBJTABLE(x) (SCM_CELL_OBJECT_2 (x))
+#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_3 (x))
#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
-#define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
+#define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
@@ -58,6 +54,8 @@ SCM_API SCM scm_program_objcode (SCM program);
SCM_API SCM scm_c_program_source (SCM program, size_t ip);
+SCM_INTERNAL void scm_i_program_print (SCM program, SCM port,
+ scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_programs (void);
SCM_INTERNAL void scm_init_programs (void);
diff --git a/libguile/random.c b/libguile/random.c
index d7a1ffb11..32c770a99 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2009 Free Software Foundation, Inc.
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -33,9 +33,10 @@
#include "libguile/numbers.h"
#include "libguile/feature.h"
#include "libguile/strings.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/srfi-4.h"
#include "libguile/vectors.h"
+#include "libguile/generalized-vectors.h"
#include "libguile/validate.h"
#include "libguile/random.h"
diff --git a/libguile/rdelim.c b/libguile/rdelim.c
index 04a0944f4..1f46e5bf0 100644
--- a/libguile/rdelim.c
+++ b/libguile/rdelim.c
@@ -59,12 +59,10 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0,
size_t j;
size_t cstart;
size_t cend;
- int c;
- const char *cdelims;
+ scm_t_wchar c;
size_t num_delims;
SCM_VALIDATE_STRING (1, delims);
- cdelims = scm_i_string_chars (delims);
num_delims = scm_i_string_length (delims);
SCM_VALIDATE_STRING (2, str);
@@ -83,7 +81,7 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0,
c = scm_getc (port);
for (k = 0; k < num_delims; k++)
{
- if (cdelims[k] == c)
+ if (scm_i_string_ref (delims, k) == c)
{
if (scm_is_false (gobble))
scm_ungetc (c, port);
diff --git a/libguile/read.c b/libguile/read.c
index 2140fed25..d91c868e1 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -27,12 +27,15 @@
#include <stdio.h>
#include <ctype.h>
#include <string.h>
+#include <unistd.h>
+#include <unicase.h>
#include "libguile/_scm.h"
#include "libguile/bytevectors.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
+#include "libguile/bitvectors.h"
#include "libguile/keywords.h"
#include "libguile/alist.h"
#include "libguile/srcprop.h"
@@ -177,11 +180,6 @@ static SCM *scm_read_hash_procedures;
(((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f') \
|| ((_chr) == 'd') || ((_chr) == 'l'))
-/* An inlinable version of `scm_c_downcase ()'. */
-#define CHAR_DOWNCASE(_chr) \
- (((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr))
-
-
/* 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);
@@ -189,41 +187,69 @@ static SCM scm_read_commented_expression (int chr, SCM port);
/* Read from PORT until a delimiter (e.g., a whitespace) is read. Return
zero if the whole token fits in BUF, non-zero otherwise. */
static inline int
-read_token (SCM port, char *buf, size_t buf_size, size_t *read)
+read_token (SCM port, SCM buf, size_t *read)
{
+ scm_t_wchar chr;
*read = 0;
- while (*read < buf_size)
+ buf = scm_i_string_start_writing (buf);
+ while (*read < scm_i_string_length (buf))
{
- int chr;
-
chr = scm_getc (port);
- chr = (SCM_CASE_INSENSITIVE_P ? CHAR_DOWNCASE (chr) : chr);
if (chr == EOF)
- return 0;
- else if (CHAR_IS_DELIMITER (chr))
{
- scm_ungetc (chr, port);
+ scm_i_string_stop_writing ();
return 0;
}
- else
+
+ chr = (SCM_CASE_INSENSITIVE_P ? uc_tolower (chr) : chr);
+
+ if (CHAR_IS_DELIMITER (chr))
{
- *buf = (char) chr;
- buf++, (*read)++;
+ scm_i_string_stop_writing ();
+ scm_ungetc (chr, port);
+ return 0;
}
+
+ scm_i_string_set_x (buf, *read, chr);
+ (*read)++;
}
+ scm_i_string_stop_writing ();
return 1;
}
+static SCM
+read_complete_token (SCM port, size_t *read)
+{
+ SCM buffer, str = SCM_EOL;
+ size_t len;
+ int overflow;
+
+ buffer = scm_i_make_string (READER_BUFFER_SIZE, NULL);
+ overflow = read_token (port, buffer, read);
+ if (!overflow)
+ return scm_i_substring (buffer, 0, *read);
+
+ str = scm_string_copy (buffer);
+ do
+ {
+ overflow = read_token (port, buffer, &len);
+ str = scm_string_append (scm_list_2 (str, buffer));
+ *read += len;
+ }
+ while (overflow);
+
+ return scm_i_substring (str, 0, *read);
+}
/* Skip whitespace from PORT and return the first non-whitespace character
read. Raise an error on end-of-file. */
static int
flush_ws (SCM port, const char *eoferr)
{
- register int c;
+ register scm_t_wchar c;
while (1)
switch (c = scm_getc (port))
{
@@ -292,7 +318,7 @@ static SCM recsexpr (SCM obj, long line, int column, SCM filename);
static SCM
-scm_read_sexp (int chr, SCM port)
+scm_read_sexp (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_i_lreadparen"
{
register int c;
@@ -387,216 +413,218 @@ scm_read_string (int chr, SCM port)
object (the string returned). */
SCM str = SCM_BOOL_F;
- char c_str[READER_STRING_BUFFER_SIZE];
unsigned c_str_len = 0;
- int c;
+ scm_t_wchar c;
+ str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
while ('"' != (c = scm_getc (port)))
{
if (c == EOF)
- str_eof: scm_i_input_error (FUNC_NAME, port,
- "end of file in string constant",
- SCM_EOL);
-
- if (c_str_len + 1 >= sizeof (c_str))
- {
- /* Flush the C buffer onto a Scheme string. */
- SCM addy;
+ {
+ str_eof:
+ scm_i_input_error (FUNC_NAME, port,
+ "end of file in string constant", SCM_EOL);
+ }
- if (str == SCM_BOOL_F)
- str = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));
+ if (c_str_len + 1 >= scm_i_string_length (str))
+ {
+ SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
- addy = scm_from_locale_stringn (c_str, c_str_len);
- str = scm_string_append_shared (scm_list_2 (str, addy));
-
- c_str_len = 0;
- }
+ str = scm_string_append (scm_list_2 (str, addy));
+ }
if (c == '\\')
- switch (c = scm_getc (port))
- {
- case EOF:
- goto str_eof;
- case '"':
- case '\\':
- break;
+ {
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ goto str_eof;
+ case '"':
+ case '\\':
+ break;
#if SCM_ENABLE_ELISP
- case '(':
- case ')':
- if (SCM_ESCAPED_PARENS_P)
- break;
- goto bad_escaped;
+ case '(':
+ case ')':
+ if (SCM_ESCAPED_PARENS_P)
+ break;
+ goto bad_escaped;
#endif
- case '\n':
- continue;
- case '0':
- c = '\0';
- break;
- case 'f':
- c = '\f';
- break;
- case 'n':
- c = '\n';
- break;
- case 'r':
- c = '\r';
- break;
- case 't':
- c = '\t';
- break;
- case 'a':
- c = '\007';
- break;
- case 'v':
- c = '\v';
- break;
- case 'x':
- {
- int a, b;
- a = scm_getc (port);
- if (a == EOF) goto str_eof;
- b = scm_getc (port);
- if (b == EOF) goto str_eof;
- if ('0' <= a && a <= '9') a -= '0';
- else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
- else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
- else goto bad_escaped;
- if ('0' <= b && b <= '9') b -= '0';
- else if ('A' <= b && b <= 'F') b = b - 'A' + 10;
- else if ('a' <= b && b <= 'f') b = b - 'a' + 10;
- else goto bad_escaped;
- c = a * 16 + b;
- break;
- }
- default:
- bad_escaped:
- scm_i_input_error (FUNC_NAME, port,
- "illegal character in escape sequence: ~S",
- scm_list_1 (SCM_MAKE_CHAR (c)));
- }
- c_str[c_str_len++] = c;
+ case '\n':
+ continue;
+ case '0':
+ c = '\0';
+ break;
+ case 'f':
+ c = '\f';
+ break;
+ case 'n':
+ c = '\n';
+ break;
+ case 'r':
+ c = '\r';
+ break;
+ case 't':
+ c = '\t';
+ break;
+ case 'a':
+ c = '\007';
+ break;
+ case 'v':
+ c = '\v';
+ break;
+ case 'x':
+ {
+ scm_t_wchar a, b;
+ a = scm_getc (port);
+ if (a == EOF)
+ goto str_eof;
+ b = scm_getc (port);
+ if (b == EOF)
+ goto str_eof;
+ if ('0' <= a && a <= '9')
+ a -= '0';
+ else if ('A' <= a && a <= 'F')
+ a = a - 'A' + 10;
+ else if ('a' <= a && a <= 'f')
+ a = a - 'a' + 10;
+ else
+ {
+ c = a;
+ goto bad_escaped;
+ }
+ if ('0' <= b && b <= '9')
+ b -= '0';
+ else if ('A' <= b && b <= 'F')
+ b = b - 'A' + 10;
+ else if ('a' <= b && b <= 'f')
+ b = b - 'a' + 10;
+ else
+ {
+ c = b;
+ goto bad_escaped;
+ }
+ c = a * 16 + b;
+ break;
+ }
+ case 'u':
+ {
+ scm_t_wchar a;
+ int i;
+ c = 0;
+ for (i = 0; i < 4; i++)
+ {
+ a = scm_getc (port);
+ if (a == EOF)
+ goto str_eof;
+ if ('0' <= a && a <= '9')
+ a -= '0';
+ else if ('A' <= a && a <= 'F')
+ a = a - 'A' + 10;
+ else if ('a' <= a && a <= 'f')
+ a = a - 'a' + 10;
+ else
+ {
+ c = a;
+ goto bad_escaped;
+ }
+ c = c * 16 + a;
+ }
+ break;
+ }
+ case 'U':
+ {
+ scm_t_wchar a;
+ int i;
+ c = 0;
+ for (i = 0; i < 6; i++)
+ {
+ a = scm_getc (port);
+ if (a == EOF)
+ goto str_eof;
+ if ('0' <= a && a <= '9')
+ a -= '0';
+ else if ('A' <= a && a <= 'F')
+ a = a - 'A' + 10;
+ else if ('a' <= a && a <= 'f')
+ a = a - 'a' + 10;
+ else
+ {
+ c = a;
+ goto bad_escaped;
+ }
+ c = c * 16 + a;
+ }
+ break;
+ }
+ default:
+ bad_escaped:
+ scm_i_input_error (FUNC_NAME, port,
+ "illegal character in escape sequence: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (c)));
+ }
+ }
+ str = scm_i_string_start_writing (str);
+ scm_i_string_set_x (str, c_str_len++, c);
+ scm_i_string_stop_writing ();
}
if (c_str_len > 0)
{
- SCM addy;
-
- addy = scm_from_locale_stringn (c_str, c_str_len);
- if (str == SCM_BOOL_F)
- str = addy;
- else
- str = scm_string_append_shared (scm_list_2 (str, addy));
+ return scm_i_substring_copy (str, 0, c_str_len);
}
- else
- str = (str == SCM_BOOL_F) ? scm_nullstr : str;
-
- return str;
+
+ return scm_nullstr;
}
#undef FUNC_NAME
static SCM
-scm_read_number (int chr, SCM port)
+scm_read_number (scm_t_wchar chr, SCM port)
{
- SCM result, str = SCM_EOL;
- char buffer[READER_BUFFER_SIZE];
+ SCM result;
+ SCM buffer;
size_t read;
- int overflow = 0;
scm_ungetc (chr, port);
- do
- {
- overflow = read_token (port, buffer, sizeof (buffer), &read);
-
- if ((overflow) || (scm_is_pair (str)))
- str = scm_cons (scm_from_locale_stringn (buffer, read), str);
- }
- while (overflow);
-
- if (scm_is_pair (str))
- {
- /* The slow path. */
-
- str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
- result = scm_string_to_number (str, SCM_UNDEFINED);
- if (!scm_is_true (result))
- /* Return a symbol instead of a number. */
- result = scm_string_to_symbol (str);
- }
- else
- {
- result = scm_c_locale_stringn_to_number (buffer, read, 10);
- if (!scm_is_true (result))
- /* Return a symbol instead of a number. */
- result = scm_from_locale_symboln (buffer, read);
- }
+ buffer = read_complete_token (port, &read);
+ result = scm_string_to_number (buffer, SCM_UNDEFINED);
+ if (!scm_is_true (result))
+ /* Return a symbol instead of a number. */
+ result = scm_string_to_symbol (buffer);
return result;
}
static SCM
-scm_read_mixed_case_symbol (int chr, SCM port)
+scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
{
- SCM result, str = SCM_EOL;
- int overflow = 0, ends_with_colon = 0;
- char buffer[READER_BUFFER_SIZE];
+ SCM result;
+ int ends_with_colon = 0;
+ SCM buffer;
size_t read = 0;
int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix);
scm_ungetc (chr, port);
- do
- {
- overflow = read_token (port, buffer, sizeof (buffer), &read);
-
- if (read > 0)
- ends_with_colon = (buffer[read - 1] == ':');
-
- if ((overflow) || (scm_is_pair (str)))
- str = scm_cons (scm_from_locale_stringn (buffer, read), str);
- }
- while (overflow);
-
- if (scm_is_pair (str))
- {
- size_t len;
-
- str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
- len = scm_c_string_length (str);
+ buffer = read_complete_token (port, &read);
+ if (read > 0)
+ ends_with_colon = scm_i_string_ref (buffer, read - 1) == ':';
- /* Per SRFI-88, `:' alone is an identifier, not a keyword. */
- if (postfix && ends_with_colon && (len > 1))
- {
- /* Strip off colon. */
- str = scm_c_substring (str, 0, len-1);
- result = scm_string_to_symbol (str);
- result = scm_symbol_to_keyword (result);
- }
- else
- result = scm_string_to_symbol (str);
- }
+ if (postfix && ends_with_colon && (read > 1))
+ result = scm_symbol_to_keyword (scm_string_to_symbol (scm_i_substring (buffer, 0, read - 1)));
else
- {
- /* For symbols smaller than `sizeof (buffer)', we don't need to recur
- to Scheme strings. Therefore, we only create one Scheme object (a
- symbol) per symbol read. */
- if (postfix && ends_with_colon && (read > 1))
- result = scm_from_locale_keywordn (buffer, read - 1);
- else
- result = scm_from_locale_symboln (buffer, read);
- }
+ result = scm_string_to_symbol (buffer);
return result;
}
static SCM
-scm_read_number_and_radix (int chr, SCM port)
+scm_read_number_and_radix (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
- SCM result, str = SCM_EOL;
+ SCM result;
size_t read;
- char buffer[READER_BUFFER_SIZE];
+ SCM buffer = scm_i_make_string (READER_BUFFER_SIZE, NULL);
unsigned int radix;
- int overflow = 0;
switch (chr)
{
@@ -626,22 +654,8 @@ scm_read_number_and_radix (int chr, SCM port)
radix = 10;
}
- do
- {
- overflow = read_token (port, buffer, sizeof (buffer), &read);
-
- if ((overflow) || (scm_is_pair (str)))
- str = scm_cons (scm_from_locale_stringn (buffer, read), str);
- }
- while (overflow);
-
- if (scm_is_pair (str))
- {
- str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
- result = scm_string_to_number (str, scm_from_uint (radix));
- }
- else
- result = scm_c_locale_stringn_to_number (buffer, read, radix);
+ buffer = read_complete_token (port, &read);
+ result = scm_string_to_number (buffer, scm_from_uint (radix));
if (scm_is_true (result))
return result;
@@ -671,7 +685,7 @@ scm_read_quote (int chr, SCM port)
case ',':
{
- int c;
+ scm_t_wchar c;
c = scm_getc (port);
if ('@' == c)
@@ -770,7 +784,10 @@ scm_read_semicolon_comment (int chr, SCM port)
{
int c;
- for (c = scm_getc (port);
+ /* We use the get_byte here because there is no need to get the
+ locale correct with comment input. This presumes that newline
+ always represents itself no matter what the encoding is. */
+ for (c = scm_get_byte_or_eof (port);
(c != EOF) && (c != '\n');
c = scm_getc (port));
@@ -798,14 +815,18 @@ scm_read_boolean (int chr, SCM port)
}
static SCM
-scm_read_character (int chr, SCM port)
+scm_read_character (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
- SCM ch;
- char charname[READER_CHAR_NAME_MAX_SIZE];
+ SCM charname = scm_i_make_string (READER_CHAR_NAME_MAX_SIZE, NULL);
size_t charname_len;
+ scm_t_wchar cp;
+ int overflow;
- if (read_token (port, charname, sizeof (charname), &charname_len))
+ overflow = read_token (port, charname, &charname_len);
+ charname = scm_c_substring (charname, 0, charname_len);
+
+ if (overflow)
goto char_error;
if (charname_len == 0)
@@ -820,28 +841,34 @@ scm_read_character (int chr, SCM port)
}
if (charname_len == 1)
- return SCM_MAKE_CHAR (charname[0]);
+ return SCM_MAKE_CHAR (scm_i_string_ref (charname, 0));
- if (*charname >= '0' && *charname < '8')
+ cp = scm_i_string_ref (charname, 0);
+ 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. */
- SCM p = scm_c_locale_stringn_to_number (charname, charname_len, 8);
+ SCM p = scm_string_to_number (charname, scm_from_uint (8));
if (SCM_I_INUMP (p))
return SCM_MAKE_CHAR (SCM_I_INUM (p));
}
- ch = scm_i_charname_to_char (charname, charname_len);
- if (scm_is_true (ch))
- return ch;
+ /* The names of characters should never have non-Latin1
+ characters. */
+ if (scm_i_is_narrow_string (charname)
+ || scm_i_try_narrow_string (charname))
+ { SCM ch = scm_i_charname_to_char (scm_i_string_chars (charname),
+ charname_len);
+ if (scm_is_true (ch))
+ return ch;
+ }
char_error:
scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
- scm_list_1 (scm_from_locale_stringn (charname,
- charname_len)));
+ scm_list_1 (charname));
return SCM_UNSPECIFIED;
}
@@ -883,7 +910,7 @@ scm_read_srfi4_vector (int chr, SCM port)
}
static SCM
-scm_read_bytevector (int chr, SCM port)
+scm_read_bytevector (scm_t_wchar chr, SCM port)
{
chr = scm_getc (port);
if (chr != 'u')
@@ -907,7 +934,7 @@ scm_read_bytevector (int chr, SCM port)
}
static SCM
-scm_read_guile_bit_vector (int chr, SCM port)
+scm_read_guile_bit_vector (scm_t_wchar chr, SCM port)
{
/* Read the `#*10101'-style read syntax for bit vectors in Guile. This is
terribly inefficient but who cares? */
@@ -927,13 +954,17 @@ scm_read_guile_bit_vector (int chr, SCM port)
}
static inline SCM
-scm_read_scsh_block_comment (int chr, SCM port)
+scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
{
int bang_seen = 0;
+ /* We can use the get_byte here because there is no need to get the
+ locale correct when reading comments. This presumes that
+ hash and exclamation points always represent themselves no
+ matter what the source encoding is.*/
for (;;)
{
- int c = scm_getc (port);
+ int c = scm_get_byte_or_eof (port);
if (c == EOF)
scm_i_input_error ("skip_block_comment", port,
@@ -951,9 +982,9 @@ scm_read_scsh_block_comment (int chr, SCM port)
}
static SCM
-scm_read_commented_expression (int chr, SCM port)
+scm_read_commented_expression (scm_t_wchar chr, SCM port)
{
- int c;
+ scm_t_wchar c;
c = flush_ws (port, (char *) NULL);
if (EOF == c)
@@ -965,19 +996,18 @@ scm_read_commented_expression (int chr, SCM port)
}
static SCM
-scm_read_extended_symbol (int chr, SCM port)
+scm_read_extended_symbol (scm_t_wchar chr, SCM port)
{
/* Guile's extended symbol read syntax looks like this:
#{This is all a symbol name}#
So here, CHR is expected to be `{'. */
- SCM result;
int saw_brace = 0, finished = 0;
size_t len = 0;
- char buf[1024];
+ SCM buf = scm_i_make_string (1024, NULL);
- result = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));
+ buf = scm_i_string_start_writing (buf);
while ((chr = scm_getc (port)) != EOF)
{
@@ -991,32 +1021,30 @@ scm_read_extended_symbol (int chr, SCM port)
else
{
saw_brace = 0;
- buf[len++] = '}';
- buf[len++] = chr;
+ scm_i_string_set_x (buf, len++, '}');
+ scm_i_string_set_x (buf, len++, chr);
}
}
else if (chr == '}')
saw_brace = 1;
else
- buf[len++] = chr;
+ scm_i_string_set_x (buf, len++, chr);
- if (len >= sizeof (buf) - 2)
+ if (len >= scm_i_string_length (buf) - 2)
{
- scm_string_append (scm_list_2 (result,
- scm_from_locale_stringn (buf, len)));
+ scm_i_string_stop_writing ();
+ SCM addy = scm_i_make_string (1024, NULL);
+ buf = scm_string_append (scm_list_2 (buf, addy));
len = 0;
+ buf = scm_i_string_start_writing (buf);
}
if (finished)
break;
}
+ scm_i_string_stop_writing ();
- if (len)
- result = scm_string_append (scm_list_2
- (result,
- scm_from_locale_stringn (buf, len)));
-
- return (scm_string_to_symbol (result));
+ return (scm_string_to_symbol (scm_c_substring (buf, 0, len)));
}
@@ -1052,7 +1080,7 @@ scm_read_sharp_extension (int chr, SCM port)
/* The reader for the sharp `#' character. It basically dispatches reads
among the above token readers. */
static SCM
-scm_read_sharp (int chr, SCM port)
+scm_read_sharp (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
SCM result;
@@ -1104,7 +1132,7 @@ scm_read_sharp (int chr, SCM port)
{
/* When next char is '(', it really is an old-style
uniform array. */
- int next_c = scm_getc (port);
+ scm_t_wchar next_c = scm_getc (port);
if (next_c != EOF)
scm_ungetc (next_c, port);
if (next_c == '(')
@@ -1152,7 +1180,7 @@ scm_read_expression (SCM port)
{
while (1)
{
- register int chr;
+ register scm_t_wchar chr;
chr = scm_getc (port);
@@ -1363,6 +1391,127 @@ scm_get_hash_procedure (int c)
}
}
+#define SCM_ENCODING_SEARCH_SIZE (500)
+
+/* Search the first few hundred characters of a file for
+ an emacs-like coding declaration. */
+char *
+scm_scan_for_encoding (SCM port)
+{
+ char header[SCM_ENCODING_SEARCH_SIZE+1];
+ size_t bytes_read;
+ char *encoding = NULL;
+ int utf8_bom = 0;
+ char *pos;
+ int i;
+ int in_comment;
+
+ bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
+ scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
+
+ if (bytes_read > 3
+ && header[0] == '\xef' && header[1] == '\xbb' && header[2] == '\xbf')
+ utf8_bom = 1;
+
+ /* search past "coding[:=]" */
+ pos = header;
+ while (1)
+ {
+ if ((pos = strstr(pos, "coding")) == NULL)
+ return NULL;
+
+ pos += strlen("coding");
+ if (pos - header >= SCM_ENCODING_SEARCH_SIZE ||
+ (*pos == ':' || *pos == '='))
+ {
+ pos ++;
+ break;
+ }
+ }
+
+ /* skip spaces */
+ while (pos - header <= SCM_ENCODING_SEARCH_SIZE &&
+ (*pos == ' ' || *pos == '\t'))
+ pos ++;
+
+ /* grab the next token */
+ i = 0;
+ while (pos + i - header <= SCM_ENCODING_SEARCH_SIZE
+ && (isalnum(pos[i]) || pos[i] == '_' || pos[i] == '-' || pos[i] == '.'))
+ i++;
+
+ if (i == 0)
+ return NULL;
+
+ encoding = scm_malloc (i+1);
+ memcpy (encoding, pos, i);
+ encoding[i] ='\0';
+ for (i = 0; i < strlen (encoding); i++)
+ encoding[i] = toupper ((int) encoding[i]);
+
+ /* push backwards to make sure we were in a comment */
+ in_comment = 0;
+ while (pos - i - header > 0)
+ {
+ if (*(pos - i) == '\n')
+ {
+ /* This wasn't in a semicolon comment. Check for a
+ hash-bang comment. */
+ char *beg = strstr (header, "#!");
+ char *end = strstr (header, "!#");
+ if (beg < pos && pos < end)
+ in_comment = 1;
+ break;
+ }
+ if (*(pos - i) == ';')
+ {
+ in_comment = 1;
+ break;
+ }
+ i ++;
+ }
+ if (!in_comment)
+ {
+ /* This wasn't in a comment */
+ free (encoding);
+ return NULL;
+ }
+ if (utf8_bom && strcmp(encoding, "UTF-8"))
+ scm_misc_error (NULL,
+ "the port input declares the encoding ~s but is encoded as UTF-8",
+ scm_list_1 (scm_from_locale_string (encoding)));
+
+ return encoding;
+}
+
+SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
+ (SCM port),
+ "Scans the port for an EMACS-like character coding declaration\n"
+ "near the top of the contents of a port with random-acessible contents.\n"
+ "The coding declaration is of the form\n"
+ "@code{coding: XXXXX} and must appear in a scheme comment.\n"
+ "\n"
+ "Returns a string containing the character encoding of the file\n"
+ "if a declaration was found, or @code{#f} otherwise.\n")
+#define FUNC_NAME s_scm_file_encoding
+{
+ char *enc;
+ SCM s_enc;
+
+ enc = scm_scan_for_encoding (port);
+ if (enc == NULL)
+ return SCM_BOOL_F;
+ else
+ {
+ s_enc = scm_from_locale_string (enc);
+ free (enc);
+ return s_enc;
+ }
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
void
scm_init_read ()
{
diff --git a/libguile/read.h b/libguile/read.h
index 20d3f4bf7..7bc4a0ba4 100644
--- a/libguile/read.h
+++ b/libguile/read.h
@@ -56,6 +56,8 @@ SCM_API SCM scm_read_options (SCM setting);
SCM_API SCM scm_read (SCM port);
SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird);
SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc);
+SCM_INTERNAL char *scm_scan_for_encoding (SCM port);
+SCM_API SCM scm_file_encoding (SCM port);
SCM_INTERNAL void scm_i_input_error (const char *func, SCM port,
const char *message, SCM arg)
diff --git a/libguile/rw.c b/libguile/rw.c
index cb62b79b9..a9b4a329a 100644
--- a/libguile/rw.c
+++ b/libguile/rw.c
@@ -131,6 +131,7 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
don't touch the file descriptor. otherwise the
"return immediately if something is available" rule may
be violated. */
+ str = scm_i_string_start_writing (str);
dest = scm_i_string_writable_chars (str) + offset;
chars_read = scm_take_from_input_buffers (port, dest, read_len);
scm_i_string_stop_writing ();
@@ -140,6 +141,7 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with
EOF. */
{
+ str = scm_i_string_start_writing (str);
dest = scm_i_string_writable_chars (str) + offset;
SCM_SYSCALL (chars_read = read (fdes, dest, read_len));
scm_i_string_stop_writing ();
diff --git a/libguile/socket.c b/libguile/socket.c
index 553a1a185..3a81ed9d0 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 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
@@ -27,12 +27,13 @@
#include <gmp.h>
#include "libguile/_scm.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/feature.h"
#include "libguile/fports.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/dynwind.h"
+#include "libguile/srfi-13.h"
#include "libguile/validate.h"
#include "libguile/socket.h"
@@ -1414,6 +1415,8 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
"protocols, if a packet larger than this limit is encountered\n"
"then some data\n"
"will be irrevocably lost.\n\n"
+ "The data is assumed to be binary, and there is no decoding of\n"
+ "of locale-encoded strings.\n\n"
"The optional @var{flags} argument is a value or\n"
"bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
"The value returned is the number of bytes read from the\n"
@@ -1428,6 +1431,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
int flg;
char *dest;
size_t len;
+ SCM msg;
SCM_VALIDATE_OPFPORT (1, sock);
SCM_VALIDATE_STRING (2, buf);
@@ -1437,15 +1441,16 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
flg = scm_to_int (flags);
fd = SCM_FPORT_FDES (sock);
- len = scm_i_string_length (buf);
- dest = scm_i_string_writable_chars (buf);
+ len = scm_i_string_length (buf);
+ msg = scm_i_make_string (len, &dest);
SCM_SYSCALL (rv = recv (fd, dest, len, flg));
- scm_i_string_stop_writing ();
+ scm_string_copy_x (buf, scm_from_int (0),
+ msg, scm_from_int (0), scm_from_size_t (len));
if (rv == -1)
SCM_SYSERROR;
- scm_remember_upto_here_1 (buf);
+ scm_remember_upto_here_2 (buf, msg);
return scm_from_int (rv);
}
#undef FUNC_NAME
@@ -1463,18 +1468,28 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0,
"bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
"Note that the data is written directly to the socket\n"
"file descriptor:\n"
- "any unflushed buffered port data is ignored.")
+ "any unflushed buffered port data is ignored.\n\n"
+ "This operation is defined only for strings containing codepoints\n"
+ "zero to 255.")
#define FUNC_NAME s_scm_send
{
int rv;
int fd;
int flg;
- const char *src;
+ char *src;
size_t len;
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock);
SCM_VALIDATE_STRING (2, message);
+
+ /* If the string is wide, see if it can be coerced into
+ a narrow string. */
+ if (!scm_i_is_narrow_string (message)
+ || scm_i_try_narrow_string (message))
+ SCM_MISC_ERROR ("the message string is not 8-bit: ~s",
+ scm_list_1 (message));
+
if (SCM_UNBNDP (flags))
flg = 0;
else
@@ -1482,6 +1497,7 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0,
fd = SCM_FPORT_FDES (sock);
len = scm_i_string_length (message);
+ message = scm_i_string_start_writing (message);
src = scm_i_string_writable_chars (message);
SCM_SYSCALL (rv = send (fd, src, len, flg));
scm_i_string_stop_writing ();
@@ -1550,6 +1566,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
/* recvfrom will not necessarily return an address. usually nothing
is returned for stream sockets. */
+ str = scm_i_string_start_writing (str);
buf = scm_i_string_writable_chars (str);
((struct sockaddr *) &addr)->sa_family = AF_UNSPEC;
SCM_SYSCALL (rv = recvfrom (fd, buf + offset,
@@ -1589,7 +1606,9 @@ SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1,
"set to be non-blocking.\n"
"Note that the data is written directly to the socket\n"
"file descriptor:\n"
- "any unflushed buffered port data is ignored.")
+ "any unflushed buffered port data is ignored.\n"
+ "This operation is defined only for strings containing codepoints\n"
+ "zero to 255.")
#define FUNC_NAME s_scm_sendto
{
int rv;
diff --git a/libguile/sort.c b/libguile/sort.c
index 644526eac..a9e4dda8c 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999,2000,2001,2002, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001,2002, 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
* as published by the Free Software Foundation; either version 3 of
@@ -39,8 +39,8 @@
#include "libguile/_scm.h"
#include "libguile/eval.h"
-#include "libguile/unif.h"
-#include "libguile/ramap.h"
+#include "libguile/arrays.h"
+#include "libguile/array-map.h"
#include "libguile/feature.h"
#include "libguile/vectors.h"
#include "libguile/lang.h"
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index efa0b7f30..8fa039314 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -68,7 +68,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
* car = tag
* cbr = pos
* ccr = copy
- * cdr = plist
+ * cdr = alist
*/
#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
@@ -77,7 +77,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
#define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2))
-#define SRCPROPPLIST(p) (SCM_CELL_OBJECT_3(p))
+#define SRCPROPALIST(p) (SCM_CELL_OBJECT_3(p))
#define SETSRCPROPBRK(p) \
(SCM_SET_SMOB_FLAGS ((p), \
SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
@@ -89,9 +89,11 @@ SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
#define SETSRCPROPCOPY(p, c) (SCM_SET_CELL_WORD(p, 2, c))
-#define SETSRCPROPPLIST(p, l) (SCM_SET_CELL_WORD(p, 3, l))
+#define SETSRCPROPALIST(p, l) (SCM_SET_CELL_WORD(p, 3, l))
+static SCM scm_srcprops_to_alist (SCM obj);
+
scm_t_bits scm_tc16_srcprops;
@@ -99,7 +101,7 @@ static SCM
srcprops_mark (SCM obj)
{
scm_gc_mark (SRCPROPCOPY (obj));
- return SRCPROPPLIST (obj);
+ return SRCPROPALIST (obj);
}
static int
@@ -108,7 +110,7 @@ srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<srcprops ", port);
SCM_SET_WRITINGP (pstate, 1);
- scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate);
+ scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
scm_putc ('>', port);
return 1;
@@ -124,57 +126,57 @@ scm_c_source_property_breakpoint_p (SCM form)
/*
- * We remember the last file name settings, so we can share that plist
+ * We remember the last file name settings, so we can share that alist
* entry. This works because scm_set_source_property_x does not use
- * assoc-set! for modifying the plist.
+ * assoc-set! for modifying the alist.
*
* This variable contains a protected cons, whose cdr is the cached
- * plist
+ * alist
*/
-static SCM scm_last_plist_filename;
+static SCM scm_last_alist_filename;
SCM
-scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist)
+scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
{
if (!SCM_UNBNDP (filename))
{
- SCM old_plist = plist;
+ SCM old_alist = alist;
/*
have to extract the acons, and operate on that, for
thread safety.
*/
- SCM last_acons = SCM_CDR (scm_last_plist_filename);
- if (old_plist == SCM_EOL
+ SCM last_acons = SCM_CDR (scm_last_alist_filename);
+ if (old_alist == SCM_EOL
&& SCM_CDAR (last_acons) == filename)
{
- plist = last_acons;
+ alist = last_acons;
}
else
{
- plist = scm_acons (scm_sym_filename, filename, plist);
- if (old_plist == SCM_EOL)
- SCM_SETCDR (scm_last_plist_filename, plist);
+ alist = scm_acons (scm_sym_filename, filename, alist);
+ if (old_alist == SCM_EOL)
+ SCM_SETCDR (scm_last_alist_filename, alist);
}
}
SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
SRCPROPMAKPOS (line, col),
copy,
- plist);
+ alist);
}
-SCM
-scm_srcprops_to_plist (SCM obj)
+static SCM
+scm_srcprops_to_alist (SCM obj)
{
- SCM plist = SRCPROPPLIST (obj);
+ SCM alist = SRCPROPALIST (obj);
if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
- plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist);
- plist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), plist);
- plist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), plist);
- plist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), plist);
- return plist;
+ alist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), alist);
+ alist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), alist);
+ alist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), alist);
+ alist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), alist);
+ return alist;
}
SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
@@ -190,7 +192,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
SCM_WRONG_TYPE_ARG (1, obj);
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (SRCPROPSP (p))
- return scm_srcprops_to_plist (p);
+ return scm_srcprops_to_alist (p);
else
/* list from set-source-properties!, or SCM_EOL for not found */
return p;
@@ -200,20 +202,83 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
/* Perhaps this procedure should look through an alist
and try to make a srcprops-object...? */
SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
- (SCM obj, SCM plist),
- "Install the association list @var{plist} as the source property\n"
+ (SCM obj, SCM alist),
+ "Install the association list @var{alist} as the source property\n"
"list for @var{obj}.")
#define FUNC_NAME s_scm_set_source_properties_x
{
SCM handle;
+ long line = 0, col = 0;
+ SCM fname = SCM_UNDEFINED, copy = SCM_UNDEFINED, breakpoint = SCM_BOOL_F;
+ SCM others = SCM_EOL;
+ SCM *others_cdrloc = &others;
+ int need_srcprops = 0;
+ SCM tail, key;
+
SCM_VALIDATE_NIM (1, obj);
if (SCM_MEMOIZEDP (obj))
obj = SCM_MEMOIZED_EXP (obj);
else if (!scm_is_pair (obj))
SCM_WRONG_TYPE_ARG(1, obj);
- handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
- SCM_SETCDR (handle, plist);
- return plist;
+
+ tail = alist;
+ while (!scm_is_null (tail))
+ {
+ key = SCM_CAAR (tail);
+ if (scm_is_eq (key, scm_sym_line))
+ {
+ line = scm_to_long (SCM_CDAR (tail));
+ need_srcprops = 1;
+ }
+ else if (scm_is_eq (key, scm_sym_column))
+ {
+ col = scm_to_long (SCM_CDAR (tail));
+ need_srcprops = 1;
+ }
+ else if (scm_is_eq (key, scm_sym_filename))
+ {
+ fname = SCM_CDAR (tail);
+ need_srcprops = 1;
+ }
+ else if (scm_is_eq (key, scm_sym_copy))
+ {
+ copy = SCM_CDAR (tail);
+ need_srcprops = 1;
+ }
+ else if (scm_is_eq (key, scm_sym_breakpoint))
+ {
+ breakpoint = SCM_CDAR (tail);
+ need_srcprops = 1;
+ }
+ else
+ {
+ /* Do we allocate here, or clobber the caller's alist?
+
+ Source properties aren't supposed to be used for anything
+ except the special properties above, so the mainline case
+ is that we never execute this else branch, and hence it
+ doesn't matter much.
+
+ We choose allocation here, as that seems safer.
+ */
+ *others_cdrloc = scm_cons (scm_cons (key, SCM_CDAR (tail)),
+ SCM_EOL);
+ others_cdrloc = SCM_CDRLOC (*others_cdrloc);
+ }
+ tail = SCM_CDR (tail);
+ }
+ if (need_srcprops)
+ {
+ alist = scm_make_srcprops (line, col, fname, copy, others);
+ if (scm_is_true (breakpoint))
+ SETSRCPROPBRK (alist);
+ }
+ else
+ alist = others;
+
+ handle = scm_hashq_create_handle_x (scm_source_whash, obj, alist);
+ SCM_SETCDR (handle, alist);
+ return alist;
}
#undef FUNC_NAME
@@ -231,15 +296,15 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
SCM_WRONG_TYPE_ARG (1, obj);
p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
if (!SRCPROPSP (p))
- goto plist;
+ goto alist;
if (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p));
else if (scm_is_eq (scm_sym_line, key)) p = scm_from_int (SRCPROPLINE (p));
else if (scm_is_eq (scm_sym_column, key)) p = scm_from_int (SRCPROPCOL (p));
else if (scm_is_eq (scm_sym_copy, key)) p = SRCPROPCOPY (p);
else
{
- p = SRCPROPPLIST (p);
- plist:
+ p = SRCPROPALIST (p);
+ alist:
p = scm_assoc (key, p);
return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
}
@@ -315,7 +380,7 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
else
{
if (SRCPROPSP (p))
- SETSRCPROPPLIST (p, scm_acons (key, datum, SRCPROPPLIST (p)));
+ SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p)));
else
SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
}
@@ -334,7 +399,7 @@ scm_init_srcprop ()
scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
scm_c_define ("source-whash", scm_source_whash);
- scm_last_plist_filename
+ scm_last_alist_filename
= scm_permanent_object (scm_cons (SCM_EOL,
scm_acons (SCM_EOL, SCM_EOL, SCM_EOL)));
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
index 2a27e0409..89063bed4 100644
--- a/libguile/srcprop.h
+++ b/libguile/srcprop.h
@@ -64,13 +64,11 @@ SCM_API SCM scm_sym_breakpoint;
SCM_API int scm_c_source_property_breakpoint_p (SCM form);
-SCM_API SCM scm_srcprops_to_plist (SCM obj);
SCM_API SCM scm_make_srcprops (long line, int col, SCM fname, SCM copy, SCM plist);
SCM_API SCM scm_source_property (SCM obj, SCM key);
SCM_API SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum);
SCM_API SCM scm_source_properties (SCM obj);
SCM_API SCM scm_set_source_properties_x (SCM obj, SCM props);
-SCM_API void scm_finish_srcprop (void);
SCM_INTERNAL void scm_init_srcprop (void);
#if SCM_ENABLE_DEPRECATED == 1
diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index f3863d355..4faa377d0 100644
--- a/libguile/srfi-13.c
+++ b/libguile/srfi-13.c
@@ -1,6 +1,6 @@
/* srfi-13.c --- SRFI-13 procedures for Guile
*
- * Copyright (C) 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+ * Copyright (C) 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
@@ -24,41 +24,14 @@
#endif
#include <string.h>
-#include <ctype.h>
+#include <unicase.h>
+#include <unictype.h>
#include "libguile.h"
#include "libguile/srfi-13.h"
#include "libguile/srfi-14.h"
-/* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages
- messing with the internal representation of strings. We define our
- own version since we use it so much and are messing with Guile
- internals anyway.
-*/
-
-#define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
- pos_start, start, c_start, \
- pos_end, end, c_end) \
- do { \
- SCM_VALIDATE_STRING (pos_str, str); \
- c_str = scm_i_string_chars (str); \
- scm_i_get_substring_spec (scm_i_string_length (str), \
- start, &c_start, end, &c_end); \
- } while (0)
-
-/* Expecting "unsigned char *c_str" */
-#define MY_VALIDATE_SUBSTRING_SPEC_UCOPY(pos_str, str, c_str, \
- pos_start, start, c_start, \
- pos_end, end, c_end) \
- do { \
- const char *signed_c_str; \
- MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, signed_c_str, \
- pos_start, start, c_start, \
- pos_end, end, c_end); \
- c_str = (unsigned char *) signed_c_str; \
- } while (0)
-
#define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
pos_start, start, c_start, \
pos_end, end, c_end) \
@@ -68,6 +41,18 @@
start, &c_start, end, &c_end); \
} while (0)
+#define MY_SUBF_VALIDATE_SUBSTRING_SPEC(fname, pos_str, str, \
+ pos_start, start, c_start, \
+ pos_end, end, c_end) \
+ do { \
+ SCM_ASSERT_TYPE (scm_is_string (str), str, pos_str, fname, "string"); \
+ scm_i_get_substring_spec (scm_i_string_length (str), \
+ start, &c_start, end, &c_end); \
+ } while (0)
+
+#define REF_IN_CHARSET(s, i, cs) \
+ (scm_is_true (scm_char_set_contains_p ((cs), SCM_MAKE_CHAR (scm_i_string_ref (s, i)))))
+
SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0,
(SCM str),
"Return @code{#t} if @var{str}'s length is zero, and\n"
@@ -111,25 +96,28 @@ SCM_DEFINE (scm_string_any, "string-any-c-code", 2, 2, 0,
"@var{end}) then the return is @code{#f}.\n")
#define FUNC_NAME s_scm_string_any
{
- const char *cstr;
size_t cstart, cend;
SCM res = SCM_BOOL_F;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- res = (memchr (cstr+cstart, (int) SCM_CHAR (char_pred),
- cend-cstart) == NULL
- ? SCM_BOOL_F : SCM_BOOL_T);
+ size_t i;
+ for (i = cstart; i < cend; i ++)
+ if (scm_i_string_ref (s, i) == SCM_CHAR (char_pred))
+ {
+ res = SCM_BOOL_T;
+ break;
+ }
}
else if (SCM_CHARSETP (char_pred))
{
size_t i;
for (i = cstart; i < cend; i++)
- if (SCM_CHARSET_GET (char_pred, cstr[i]))
+ if (REF_IN_CHARSET (s, i, char_pred))
{
res = SCM_BOOL_T;
break;
@@ -142,10 +130,10 @@ SCM_DEFINE (scm_string_any, "string-any-c-code", 2, 2, 0,
while (cstart < cend)
{
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = pred_tramp (char_pred,
+ SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
break;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
@@ -176,19 +164,17 @@ SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0,
"@var{end}) then the return is @code{#t}.\n")
#define FUNC_NAME s_scm_string_every
{
- const char *cstr;
size_t cstart, cend;
SCM res = SCM_BOOL_T;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
size_t i;
for (i = cstart; i < cend; i++)
- if (cstr[i] != cchr)
+ if (scm_i_string_ref (s, i) != SCM_CHAR (char_pred))
{
res = SCM_BOOL_F;
break;
@@ -198,7 +184,7 @@ SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0,
{
size_t i;
for (i = cstart; i < cend; i++)
- if (!SCM_CHARSET_GET (char_pred, cstr[i]))
+ if (!REF_IN_CHARSET (s, i, char_pred))
{
res = SCM_BOOL_F;
break;
@@ -211,10 +197,10 @@ SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0,
while (cstart < cend)
{
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = pred_tramp (char_pred,
+ SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
@@ -236,28 +222,49 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
size_t clen, i;
SCM res;
SCM ch;
- char *p;
scm_t_trampoline_1 proc_tramp;
proc_tramp = scm_trampoline_1 (proc);
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT_RANGE (2, len, scm_to_int (len) >= 0);
clen = scm_to_size_t (len);
- SCM_ASSERT_RANGE (2, len, clen >= 0);
- res = scm_i_make_string (clen, &p);
- i = 0;
- while (i < clen)
- {
- /* The RES string remains untouched since nobody knows about it
- yet. No need to refetch P.
- */
- ch = proc_tramp (proc, scm_from_size_t (i));
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
- *p++ = SCM_CHAR (ch);
- i++;
- }
+ {
+ /* This function is more complicated than necessary for the sake
+ of speed. */
+ scm_t_wchar *buf = scm_malloc (clen * sizeof (scm_t_wchar));
+ int wide = 0;
+ i = 0;
+ while (i < clen)
+ {
+ ch = proc_tramp (proc, scm_from_size_t (i));
+ if (!SCM_CHARP (ch))
+ {
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
+ }
+ if (SCM_CHAR (ch) > 255)
+ wide = 1;
+ buf[i] = SCM_CHAR (ch);
+ i++;
+ }
+ if (wide)
+ {
+ scm_t_wchar *wbuf = NULL;
+ res = scm_i_make_wide_string (clen, &wbuf);
+ memcpy (wbuf, buf, clen * sizeof (scm_t_wchar));
+ free (buf);
+ }
+ else
+ {
+ char *nbuf = NULL;
+ res = scm_i_make_string (clen, &nbuf);
+ for (i = 0; i < clen; i ++)
+ nbuf[i] = (unsigned char) buf[i];
+ free (buf);
+ }
+ }
+
return res;
}
#undef FUNC_NAME
@@ -268,18 +275,34 @@ SCM_DEFINE (scm_substring_to_list, "string->list", 1, 2, 0,
"Convert the string @var{str} into a list of characters.")
#define FUNC_NAME s_scm_substring_to_list
{
- const char *cstr;
size_t cstart, cend;
+ int narrow;
SCM result = SCM_EOL;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
- while (cstart < cend)
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
+
+ /* This explicit narrow/wide logic (instead of just using
+ scm_i_string_ref) is for speed optimizaion. */
+ narrow = scm_i_is_narrow_string (str);
+ if (narrow)
{
- cend--;
- result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result);
- cstr = scm_i_string_chars (str);
+ const char *buf = scm_i_string_chars (str);
+ while (cstart < cend)
+ {
+ cend--;
+ result = scm_cons (SCM_MAKE_CHAR (buf[cend]), result);
+ }
+ }
+ else
+ {
+ const scm_t_wchar *buf = scm_i_string_wide_chars (str);
+ while (cstart < cend)
+ {
+ cend--;
+ result = scm_cons (SCM_MAKE_CHAR (buf[cend]), result);
+ }
}
scm_remember_upto_here_1 (str);
return result;
@@ -308,7 +331,7 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0,
#define FUNC_NAME s_scm_reverse_list_to_string
{
SCM result;
- long i = scm_ilength (chrs);
+ long i = scm_ilength (chrs), j;
char *data;
if (i < 0)
@@ -316,18 +339,27 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0,
result = scm_i_make_string (i, &data);
{
-
- data += i;
- while (i > 0 && scm_is_pair (chrs))
+ SCM rest;
+ rest = chrs;
+ j = 0;
+ while (j < i && scm_is_pair (rest))
{
- SCM elt = SCM_CAR (chrs);
-
- SCM_VALIDATE_CHAR (SCM_ARGn, elt);
- data--;
- *data = SCM_CHAR (elt);
- chrs = SCM_CDR (chrs);
- i--;
+ SCM elt = SCM_CAR (rest);
+ SCM_VALIDATE_CHAR (SCM_ARGn, elt);
+ j++;
+ rest = SCM_CDR (rest);
+ }
+ rest = chrs;
+ j = i;
+ result = scm_i_string_start_writing (result);
+ while (j > 0 && scm_is_pair (rest))
+ {
+ SCM elt = SCM_CAR (rest);
+ scm_i_string_set_x (result, j-1, SCM_CHAR (elt));
+ rest = SCM_CDR (rest);
+ j--;
}
+ scm_i_string_stop_writing ();
}
return result;
@@ -340,18 +372,6 @@ SCM_SYMBOL (scm_sym_strict_infix, "strict-infix");
SCM_SYMBOL (scm_sym_suffix, "suffix");
SCM_SYMBOL (scm_sym_prefix, "prefix");
-static void
-append_string (char **sp, size_t *lp, SCM str)
-{
- size_t len;
- len = scm_c_string_length (str);
- if (len > *lp)
- len = *lp;
- memcpy (*sp, scm_i_string_chars (str), len);
- *lp -= len;
- *sp += len;
-}
-
SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
(SCM ls, SCM delimiter, SCM grammar),
"Append the string in the string list @var{ls}, using the string\n"
@@ -382,8 +402,6 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
SCM result;
int gram = GRAM_INFIX;
size_t del_len = 0;
- size_t len = 0;
- char *p;
long strings = scm_ilength (ls);
/* Validate the string list. */
@@ -397,7 +415,10 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
del_len = 1;
}
else
- del_len = scm_c_string_length (delimiter);
+ {
+ SCM_VALIDATE_STRING (2, delimiter);
+ del_len = scm_i_string_length (delimiter);
+ }
/* Validate the grammar symbol and remember the grammar. */
if (SCM_UNBNDP (grammar))
@@ -413,33 +434,12 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
else
SCM_WRONG_TYPE_ARG (3, grammar);
- /* Check grammar constraints and calculate the space required for
- the delimiter(s). */
- switch (gram)
- {
- case GRAM_INFIX:
- if (!scm_is_null (ls))
- len = (strings > 0) ? ((strings - 1) * del_len) : 0;
- break;
- case GRAM_STRICT_INFIX:
- if (strings == 0)
- SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
- SCM_EOL);
- len = (strings - 1) * del_len;
- break;
- default:
- len = strings * del_len;
- break;
- }
-
- tmp = ls;
- while (scm_is_pair (tmp))
- {
- len += scm_c_string_length (SCM_CAR (tmp));
- tmp = SCM_CDR (tmp);
- }
+ /* Check grammar constraints. */
+ if (strings == 0 && gram == GRAM_STRICT_INFIX)
+ SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
+ SCM_EOL);
- result = scm_i_make_string (len, &p);
+ result = scm_i_make_string (0, NULL);
tmp = ls;
switch (gram)
@@ -448,18 +448,18 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
case GRAM_STRICT_INFIX:
while (scm_is_pair (tmp))
{
- append_string (&p, &len, SCM_CAR (tmp));
+ result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
if (!scm_is_null (SCM_CDR (tmp)) && del_len > 0)
- append_string (&p, &len, delimiter);
+ result = scm_string_append (scm_list_2 (result, delimiter));
tmp = SCM_CDR (tmp);
}
break;
case GRAM_SUFFIX:
while (scm_is_pair (tmp))
{
- append_string (&p, &len, SCM_CAR (tmp));
+ result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
if (del_len > 0)
- append_string (&p, &len, delimiter);
+ result = scm_string_append (scm_list_2 (result, delimiter));
tmp = SCM_CDR (tmp);
}
break;
@@ -467,8 +467,8 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
while (scm_is_pair (tmp))
{
if (del_len > 0)
- append_string (&p, &len, delimiter);
- append_string (&p, &len, SCM_CAR (tmp));
+ result = scm_string_append (scm_list_2 (result, delimiter));
+ result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp)));
tmp = SCM_CDR (tmp);
}
break;
@@ -508,20 +508,22 @@ SCM_DEFINE (scm_srfi13_substring_copy, "string-copy", 1, 2, 0,
"@var{str} which is copied.")
#define FUNC_NAME s_scm_srfi13_substring_copy
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
- return scm_c_substring_copy (str, cstart, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
+ return scm_i_substring_copy (str, cstart, cend);
}
#undef FUNC_NAME
SCM
scm_string_copy (SCM str)
{
- return scm_c_substring (str, 0, scm_c_string_length (str));
+ if (!scm_is_string (str))
+ scm_wrong_type_arg ("scm_string_copy", 0, str);
+
+ return scm_i_substring (str, 0, scm_i_string_length (str));
}
SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
@@ -535,22 +537,24 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
"string.")
#define FUNC_NAME s_scm_string_copy_x
{
- const char *cstr;
- char *ctarget;
- size_t cstart, cend, ctstart, dummy, len;
+ size_t cstart, cend, ctstart, dummy, len, i;
SCM sdummy = SCM_UNDEFINED;
MY_VALIDATE_SUBSTRING_SPEC (1, target,
2, tstart, ctstart,
2, sdummy, dummy);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
- 4, start, cstart,
- 5, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (3, s,
+ 4, start, cstart,
+ 5, end, cend);
len = cend - cstart;
SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
- ctarget = scm_i_string_writable_chars (target);
- memmove (ctarget + ctstart, cstr + cstart, len);
+ target = scm_i_string_start_writing (target);
+ for (i = 0; i < cend - cstart; i++)
+ {
+ scm_i_string_set_x (target, ctstart + i,
+ scm_i_string_ref (s, cstart + i));
+ }
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (target);
@@ -621,7 +625,6 @@ SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0,
"string is longer than @var{len}, it is truncated on the right.")
#define FUNC_NAME s_scm_string_pad
{
- char cchr;
size_t cstart, cend, clen;
MY_VALIDATE_SUBSTRING_SPEC (1, s,
@@ -630,23 +633,19 @@ SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0,
clen = scm_to_size_t (len);
if (SCM_UNBNDP (chr))
- cchr = ' ';
+ chr = SCM_MAKE_CHAR (' ');
else
{
SCM_VALIDATE_CHAR (3, chr);
- cchr = SCM_CHAR (chr);
}
if (clen < (cend - cstart))
- return scm_c_substring (s, cend - clen, cend);
+ return scm_i_substring (s, cend - clen, cend);
else
{
SCM result;
- char *dst;
-
- result = scm_i_make_string (clen, &dst);
- memset (dst, cchr, (clen - (cend - cstart)));
- memmove (dst + clen - (cend - cstart),
- scm_i_string_chars (s) + cstart, cend - cstart);
+ result = (scm_string_append
+ (scm_list_2 (scm_c_make_string (clen - (cend - cstart), chr),
+ scm_i_substring (s, cstart, cend))));
return result;
}
}
@@ -661,7 +660,6 @@ SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0,
"string is longer than @var{len}, it is truncated on the left.")
#define FUNC_NAME s_scm_string_pad_right
{
- char cchr;
size_t cstart, cend, clen;
MY_VALIDATE_SUBSTRING_SPEC (1, s,
@@ -670,22 +668,21 @@ SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0,
clen = scm_to_size_t (len);
if (SCM_UNBNDP (chr))
- cchr = ' ';
+ chr = SCM_MAKE_CHAR (' ');
else
{
SCM_VALIDATE_CHAR (3, chr);
- cchr = SCM_CHAR (chr);
}
if (clen < (cend - cstart))
- return scm_c_substring (s, cstart, cstart + clen);
+ return scm_i_substring (s, cstart, cstart + clen);
else
{
SCM result;
- char *dst;
- result = scm_i_make_string (clen, &dst);
- memset (dst + (cend - cstart), cchr, clen - (cend - cstart));
- memmove (dst, scm_i_string_chars (s) + cstart, cend - cstart);
+ result = (scm_string_append
+ (scm_list_2 (scm_i_substring (s, cstart, cend),
+ scm_c_make_string (clen - (cend - cstart), chr))));
+
return result;
}
}
@@ -714,27 +711,25 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
"trimmed.")
#define FUNC_NAME s_scm_string_trim
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_UNBNDP (char_pred))
{
while (cstart < cend)
{
- if (!isspace((int) (unsigned char) cstr[cstart]))
+ if (!uc_is_c_whitespace (scm_i_string_ref (s, cstart)))
break;
cstart++;
}
}
else if (SCM_CHARP (char_pred))
{
- char chr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (chr != cstr[cstart])
+ if (scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
break;
cstart++;
}
@@ -743,7 +738,7 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
{
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ if (!REF_IN_CHARSET (s, cstart, char_pred))
break;
cstart++;
}
@@ -757,21 +752,20 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
- return scm_c_substring (s, cstart, cend);
+ return scm_i_substring (s, cstart, cend);
}
#undef FUNC_NAME
SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
(SCM s, SCM char_pred, SCM start, SCM end),
- "Trim @var{s} by skipping over all characters on the rightt\n"
+ "Trim @var{s} by skipping over all characters on the right\n"
"that satisfy the parameter @var{char_pred}:\n"
"\n"
"@itemize @bullet\n"
@@ -792,27 +786,25 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
"trimmed.")
#define FUNC_NAME s_scm_string_trim_right
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_UNBNDP (char_pred))
{
while (cstart < cend)
{
- if (!isspace((int) (unsigned char) cstr[cend - 1]))
+ if (!uc_is_c_whitespace (scm_i_string_ref (s, cend - 1)))
break;
cend--;
}
}
else if (SCM_CHARP (char_pred))
{
- char chr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (chr != cstr[cend - 1])
+ if (scm_i_string_ref (s, cend - 1) != SCM_CHAR (char_pred))
break;
cend--;
}
@@ -821,7 +813,7 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
{
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
+ if (!REF_IN_CHARSET (s, cend-1, char_pred))
break;
cend--;
}
@@ -835,14 +827,13 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
if (scm_is_false (res))
break;
- cstr = scm_i_string_chars (s);
cend--;
}
}
- return scm_c_substring (s, cstart, cend);
+ return scm_i_substring (s, cstart, cend);
}
#undef FUNC_NAME
@@ -870,39 +861,37 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
"trimmed.")
#define FUNC_NAME s_scm_string_trim_both
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_UNBNDP (char_pred))
{
while (cstart < cend)
{
- if (!isspace((int) (unsigned char) cstr[cstart]))
+ if (!uc_is_c_whitespace (scm_i_string_ref (s, cstart)))
break;
cstart++;
}
while (cstart < cend)
{
- if (!isspace((int) (unsigned char) cstr[cend - 1]))
+ if (!uc_is_c_whitespace (scm_i_string_ref (s, cend - 1)))
break;
cend--;
}
}
else if (SCM_CHARP (char_pred))
{
- char chr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (chr != cstr[cstart])
+ if (scm_i_string_ref (s, cstart) != SCM_CHAR(char_pred))
break;
cstart++;
}
while (cstart < cend)
{
- if (chr != cstr[cend - 1])
+ if (scm_i_string_ref (s, cend - 1) != SCM_CHAR (char_pred))
break;
cend--;
}
@@ -911,13 +900,13 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
{
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ if (!REF_IN_CHARSET (s, cstart, char_pred))
break;
cstart++;
}
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
+ if (!REF_IN_CHARSET (s, cend-1, char_pred))
break;
cend--;
}
@@ -931,24 +920,22 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
break;
- cstr = scm_i_string_chars (s);
cstart++;
}
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1)));
if (scm_is_false (res))
break;
- cstr = scm_i_string_chars (s);
cend--;
}
}
- return scm_c_substring (s, cstart, cend);
+ return scm_i_substring (s, cstart, cend);
}
#undef FUNC_NAME
@@ -959,9 +946,7 @@ SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0,
"returns an unspecified value.")
#define FUNC_NAME s_scm_substring_fill_x
{
- char *cstr;
size_t cstart, cend;
- int c;
size_t k;
/* Older versions of Guile provided the function
@@ -983,13 +968,13 @@ SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0,
MY_VALIDATE_SUBSTRING_SPEC (1, str,
3, start, cstart,
4, end, cend);
- SCM_VALIDATE_CHAR_COPY (2, chr, c);
+ SCM_VALIDATE_CHAR (2, chr);
+
- cstr = scm_i_string_writable_chars (str);
+ str = scm_i_string_start_writing (str);
for (k = cstart; k < cend; k++)
- cstr[k] = c;
+ scm_i_string_set_x (str, k, SCM_CHAR (chr));
scm_i_string_stop_writing ();
- scm_remember_upto_here_1 (str);
return SCM_UNSPECIFIED;
}
@@ -1011,28 +996,29 @@ SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0,
"@var{i} is the first position that does not match.")
#define FUNC_NAME s_scm_string_compare
{
- const unsigned char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
SCM proc;
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 6, start1, cstart1,
- 7, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 8, start2, cstart2,
- 9, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 6, start1, cstart1,
+ 7, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 8, start2, cstart2,
+ 9, end2, cend2);
SCM_VALIDATE_PROC (3, proc_lt);
SCM_VALIDATE_PROC (4, proc_eq);
SCM_VALIDATE_PROC (5, proc_gt);
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (cstr1[cstart1] < cstr2[cstart2])
+ if (scm_i_string_ref (s1, cstart1)
+ < scm_i_string_ref (s2, cstart2))
{
proc = proc_lt;
goto ret;
}
- else if (cstr1[cstart1] > cstr2[cstart2])
+ else if (scm_i_string_ref (s1, cstart1)
+ > scm_i_string_ref (s2, cstart2))
{
proc = proc_gt;
goto ret;
@@ -1061,33 +1047,33 @@ SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0,
"equal to, or greater than @var{s2}. The mismatch index is the\n"
"largest index @var{i} such that for every 0 <= @var{j} <\n"
"@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
- "@var{i} is the first position that does not match. The\n"
- "character comparison is done case-insensitively.")
+ "@var{i} is the first position where the lowercased letters \n"
+ "do not match.\n")
#define FUNC_NAME s_scm_string_compare_ci
{
- const unsigned char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
SCM proc;
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 6, start1, cstart1,
- 7, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 8, start2, cstart2,
- 9, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 6, start1, cstart1,
+ 7, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 8, start2, cstart2,
+ 9, end2, cend2);
SCM_VALIDATE_PROC (3, proc_lt);
SCM_VALIDATE_PROC (4, proc_eq);
SCM_VALIDATE_PROC (5, proc_gt);
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
+ if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
+ < uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
{
proc = proc_lt;
goto ret;
}
- else if (scm_c_downcase (cstr1[cstart1])
- > scm_c_downcase (cstr2[cstart2]))
+ else if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
+ > uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
{
proc = proc_gt;
goto ret;
@@ -1109,42 +1095,83 @@ SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0,
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0,
- (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
- "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
- "value otherwise.")
-#define FUNC_NAME s_scm_string_eq
+/* This function compares two substrings, S1 from START1 to END1 and
+ S2 from START2 to END2, possibly case insensitively, and returns
+ one of the parameters LESSTHAN, GREATERTHAN, LONGER, SHORTER, or
+ EQUAL depending if S1 is less than S2, greater than S2, longer,
+ shorter, or equal. */
+static SCM
+compare_strings (const char *fname, int case_insensitive,
+ SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2,
+ SCM lessthan, SCM greaterthan, SCM longer, SCM shorter, SCM equal)
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
+ SCM ret;
+ scm_t_wchar a, b;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname, 1, s1,
3, start1, cstart1,
4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname, 2, s2,
5, start2, cstart2,
6, end2, cend2);
- if ((cend1 - cstart1) != (cend2 - cstart2))
- goto false;
-
- while (cstart1 < cend1)
+ while (cstart1 < cend1 && cstart2 < cend2)
{
- if (cstr1[cstart1] < cstr2[cstart2])
- goto false;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto false;
+ if (case_insensitive)
+ {
+ a = uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)));
+ b = uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)));
+ }
+ else
+ {
+ a = scm_i_string_ref (s1, cstart1);
+ b = scm_i_string_ref (s2, cstart2);
+ }
+ if (a < b)
+ {
+ ret = lessthan;
+ goto done;
+ }
+ else if (a > b)
+ {
+ ret = greaterthan;
+ goto done;
+ }
cstart1++;
cstart2++;
}
-
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
+ if (cstart1 < cend1)
+ {
+ ret = longer;
+ goto done;
+ }
+ else if (cstart2 < cend2)
+ {
+ ret = shorter;
+ goto done;
+ }
+ else
+ {
+ ret = equal;
+ goto done;
+ }
- false:
+ done:
scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return ret;
+}
+
+
+SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
+ "value otherwise.")
+#define FUNC_NAME s_scm_string_eq
+{
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_T);
}
#undef FUNC_NAME
@@ -1155,39 +1182,9 @@ SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0,
"value otherwise.")
#define FUNC_NAME s_scm_string_neq
{
- const char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] < cstr2[cstart2])
- goto true;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto true;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_F);
}
#undef FUNC_NAME
@@ -1198,39 +1195,9 @@ SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0,
"true value otherwise.")
#define FUNC_NAME s_scm_string_lt
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] < cstr2[cstart2])
- goto true;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto false;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto false;
- else if (cstart2 < cend2)
- goto true;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_F);
}
#undef FUNC_NAME
@@ -1241,39 +1208,9 @@ SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0,
"true value otherwise.")
#define FUNC_NAME s_scm_string_gt
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] < cstr2[cstart2])
- goto false;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto false;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F);
}
#undef FUNC_NAME
@@ -1284,39 +1221,9 @@ SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0,
"value otherwise.")
#define FUNC_NAME s_scm_string_le
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] < cstr2[cstart2])
- goto true;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto false;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto false;
- else if (cstart2 < cend2)
- goto true;
- else
- goto true;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T);
}
#undef FUNC_NAME
@@ -1327,39 +1234,9 @@ SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0,
"otherwise.")
#define FUNC_NAME s_scm_string_ge
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (cstr1[cstart1] < cstr2[cstart2])
- goto false;
- else if (cstr1[cstart1] > cstr2[cstart2])
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto false;
- else
- goto true;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 0,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_T);
}
#undef FUNC_NAME
@@ -1371,39 +1248,9 @@ SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0,
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_eq
{
- const char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto false;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto false;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto false;
- else if (cstart2 < cend2)
- goto false;
- else
- goto true;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_T);
}
#undef FUNC_NAME
@@ -1415,39 +1262,9 @@ SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0,
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_neq
{
- const char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto true;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto true;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_F);
}
#undef FUNC_NAME
@@ -1459,39 +1276,9 @@ SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0,
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_lt
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto true;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto false;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto false;
- else if (cstart2 < cend2)
- goto true;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_F);
}
#undef FUNC_NAME
@@ -1503,39 +1290,9 @@ SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0,
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_gt
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto false;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto false;
- else
- goto false;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F);
}
#undef FUNC_NAME
@@ -1547,39 +1304,9 @@ SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0,
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_le
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto true;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto false;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto false;
- else if (cstart2 < cend2)
- goto true;
- else
- goto true;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T);
}
#undef FUNC_NAME
@@ -1591,39 +1318,9 @@ SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0,
"case-insensitively.")
#define FUNC_NAME s_scm_string_ci_ge
{
- const unsigned char *cstr1, *cstr2;
- size_t cstart1, cend1, cstart2, cend2;
-
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
-
- while (cstart1 < cend1 && cstart2 < cend2)
- {
- if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
- goto false;
- else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
- goto true;
- cstart1++;
- cstart2++;
- }
- if (cstart1 < cend1)
- goto true;
- else if (cstart2 < cend2)
- goto false;
- else
- goto true;
-
- true:
- scm_remember_upto_here_2 (s1, s2);
- return scm_from_size_t (cstart1);
-
- false:
- scm_remember_upto_here_2 (s1, s2);
- return SCM_BOOL_F;
+ return compare_strings (FUNC_NAME, 1,
+ s1, s2, start1, end1, start2, end2,
+ SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_T);
}
#undef FUNC_NAME
@@ -1665,19 +1362,20 @@ SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0,
"strings.")
#define FUNC_NAME s_scm_string_prefix_length
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (cstr1[cstart1] != cstr2[cstart2])
+ if (scm_i_string_ref (s1, cstart1)
+ != scm_i_string_ref (s2, cstart2))
goto ret;
len++;
cstart1++;
@@ -1697,19 +1395,19 @@ SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0,
"strings, ignoring character case.")
#define FUNC_NAME s_scm_string_prefix_length_ci
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
+ if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)))
+ != uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))))
goto ret;
len++;
cstart1++;
@@ -1729,21 +1427,21 @@ SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0,
"strings.")
#define FUNC_NAME s_scm_string_suffix_length
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
while (cstart1 < cend1 && cstart2 < cend2)
{
cend1--;
cend2--;
- if (cstr1[cend1] != cstr2[cend2])
+ if (scm_i_string_ref (s1, cend1)
+ != scm_i_string_ref (s2, cend2))
goto ret;
len++;
}
@@ -1761,21 +1459,21 @@ SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0,
"strings, ignoring character case.")
#define FUNC_NAME s_scm_string_suffix_length_ci
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
while (cstart1 < cend1 && cstart2 < cend2)
{
cend1--;
cend2--;
- if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
+ if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cend1)))
+ != uc_tolower (uc_toupper (scm_i_string_ref (s2, cend2))))
goto ret;
len++;
}
@@ -1792,20 +1490,20 @@ SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0,
"Is @var{s1} a prefix of @var{s2}?")
#define FUNC_NAME s_scm_string_prefix_p
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0, len1;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len1 = cend1 - cstart1;
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (cstr1[cstart1] != cstr2[cstart2])
+ if (scm_i_string_ref (s1, cstart1)
+ != scm_i_string_ref (s2, cstart2))
goto ret;
len++;
cstart1++;
@@ -1824,20 +1522,21 @@ SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0,
"Is @var{s1} a prefix of @var{s2}, ignoring character case?")
#define FUNC_NAME s_scm_string_prefix_ci_p
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0, len1;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len1 = cend1 - cstart1;
while (cstart1 < cend1 && cstart2 < cend2)
{
- if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
+ scm_t_wchar a = uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1)));
+ scm_t_wchar b = uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)));
+ if (a != b)
goto ret;
len++;
cstart1++;
@@ -1856,22 +1555,22 @@ SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0,
"Is @var{s1} a suffix of @var{s2}?")
#define FUNC_NAME s_scm_string_suffix_p
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0, len1;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len1 = cend1 - cstart1;
while (cstart1 < cend1 && cstart2 < cend2)
{
cend1--;
cend2--;
- if (cstr1[cend1] != cstr2[cend2])
+ if (scm_i_string_ref (s1, cend1)
+ != scm_i_string_ref (s2, cend2))
goto ret;
len++;
}
@@ -1888,22 +1587,22 @@ SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0,
"Is @var{s1} a suffix of @var{s2}, ignoring character case?")
#define FUNC_NAME s_scm_string_suffix_ci_p
{
- const char *cstr1, *cstr2;
size_t cstart1, cend1, cstart2, cend2;
size_t len = 0, len1;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len1 = cend1 - cstart1;
while (cstart1 < cend1 && cstart2 < cend2)
{
cend1--;
cend2--;
- if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
+ if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cend1)))
+ != uc_tolower (uc_toupper (scm_i_string_ref (s2, cend2))))
goto ret;
len++;
}
@@ -1932,18 +1631,16 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
"@end itemize")
#define FUNC_NAME s_scm_string_index
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (cchr == cstr[cstart])
+ if (scm_i_string_ref (s, cstart) == SCM_CHAR (char_pred))
goto found;
cstart++;
}
@@ -1952,7 +1649,7 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
{
while (cstart < cend)
{
- if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ if (REF_IN_CHARSET (s, cstart, char_pred))
goto found;
cstart++;
}
@@ -1965,10 +1662,9 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
goto found;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
@@ -1999,19 +1695,17 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0,
"@end itemize")
#define FUNC_NAME s_scm_string_index_right
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
while (cstart < cend)
{
cend--;
- if (cchr == cstr[cend])
+ if (scm_i_string_ref (s, cend) == SCM_CHAR (char_pred))
goto found;
}
}
@@ -2020,7 +1714,7 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0,
while (cstart < cend)
{
cend--;
- if (SCM_CHARSET_GET (char_pred, cstr[cend]))
+ if (REF_IN_CHARSET (s, cend, char_pred))
goto found;
}
}
@@ -2033,10 +1727,9 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0,
{
SCM res;
cend--;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend]));
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
if (scm_is_true (res))
goto found;
- cstr = scm_i_string_chars (s);
}
}
@@ -2088,18 +1781,16 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0,
"@end itemize")
#define FUNC_NAME s_scm_string_skip
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (cchr != cstr[cstart])
+ if (scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
goto found;
cstart++;
}
@@ -2108,7 +1799,7 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0,
{
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ if (!REF_IN_CHARSET (s, cstart, char_pred))
goto found;
cstart++;
}
@@ -2121,10 +1812,9 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0,
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_false (res))
goto found;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
@@ -2157,19 +1847,17 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0,
"@end itemize")
#define FUNC_NAME s_scm_string_skip_right
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
while (cstart < cend)
{
cend--;
- if (cchr != cstr[cend])
+ if (scm_i_string_ref (s, cend) != SCM_CHAR (char_pred))
goto found;
}
}
@@ -2178,7 +1866,7 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0,
while (cstart < cend)
{
cend--;
- if (!SCM_CHARSET_GET (char_pred, cstr[cend]))
+ if (!REF_IN_CHARSET (s, cend, char_pred))
goto found;
}
}
@@ -2191,10 +1879,9 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0,
{
SCM res;
cend--;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend]));
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend)));
if (scm_is_false (res))
goto found;
- cstr = scm_i_string_chars (s);
}
}
@@ -2226,19 +1913,17 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0,
"@end itemize")
#define FUNC_NAME s_scm_string_count
{
- const char *cstr;
size_t cstart, cend;
size_t count = 0;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_CHARP (char_pred))
{
- char cchr = SCM_CHAR (char_pred);
while (cstart < cend)
{
- if (cchr == cstr[cstart])
+ if (scm_i_string_ref (s, cstart) == SCM_CHAR(char_pred))
count++;
cstart++;
}
@@ -2247,7 +1932,7 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0,
{
while (cstart < cend)
{
- if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ if (REF_IN_CHARSET (s, cstart, char_pred))
count++;
cstart++;
}
@@ -2260,10 +1945,9 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0,
while (cstart < cend)
{
SCM res;
- res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
if (scm_is_true (res))
count++;
- cstr = scm_i_string_chars (s);
cstart++;
}
}
@@ -2285,23 +1969,25 @@ SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0,
"indicated substrings.")
#define FUNC_NAME s_scm_string_contains
{
- const char *cs1, * cs2;
size_t cstart1, cend1, cstart2, cend2;
size_t len2, i, j;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len2 = cend2 - cstart2;
if (cend1 - cstart1 >= len2)
while (cstart1 <= cend1 - len2)
{
i = cstart1;
j = cstart2;
- while (i < cend1 && j < cend2 && cs1[i] == cs2[j])
+ while (i < cend1
+ && j < cend2
+ && (scm_i_string_ref (s1, i)
+ == scm_i_string_ref (s2, j)))
{
i++;
j++;
@@ -2332,24 +2018,25 @@ SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0,
"case-insensitively.")
#define FUNC_NAME s_scm_string_contains_ci
{
- const char *cs1, * cs2;
size_t cstart1, cend1, cstart2, cend2;
size_t len2, i, j;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
- 3, start1, cstart1,
- 4, end1, cend1);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2,
- 5, start2, cstart2,
- 6, end2, cend2);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
len2 = cend2 - cstart2;
if (cend1 - cstart1 >= len2)
while (cstart1 <= cend1 - len2)
{
i = cstart1;
j = cstart2;
- while (i < cend1 && j < cend2 &&
- scm_c_downcase (cs1[i]) == scm_c_downcase (cs2[j]))
+ while (i < cend1
+ && j < cend2
+ && (uc_tolower (uc_toupper (scm_i_string_ref (s1, i)))
+ == uc_tolower (uc_toupper (scm_i_string_ref (s2, j)))))
{
i++;
j++;
@@ -2368,17 +2055,15 @@ SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0,
#undef FUNC_NAME
-/* Helper function for the string uppercase conversion functions.
- * No argument checking is performed. */
+/* Helper function for the string uppercase conversion functions. */
static SCM
string_upcase_x (SCM v, size_t start, size_t end)
{
size_t k;
- char *dst;
- dst = scm_i_string_writable_chars (v);
+ v = scm_i_string_start_writing (v);
for (k = start; k < end; ++k)
- dst[k] = scm_c_upcase (dst[k]);
+ scm_i_string_set_x (v, k, uc_toupper (scm_i_string_ref (v, k)));
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (v);
@@ -2397,12 +2082,11 @@ SCM_DEFINE (scm_substring_upcase_x, "string-upcase!", 1, 2, 0,
"@end lisp")
#define FUNC_NAME s_scm_substring_upcase_x
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_upcase_x (str, cstart, cend);
}
#undef FUNC_NAME
@@ -2418,12 +2102,11 @@ SCM_DEFINE (scm_substring_upcase, "string-upcase", 1, 2, 0,
"Upcase every character in @code{str}.")
#define FUNC_NAME s_scm_substring_upcase
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_upcase_x (scm_string_copy (str), cstart, cend);
}
#undef FUNC_NAME
@@ -2440,11 +2123,10 @@ static SCM
string_downcase_x (SCM v, size_t start, size_t end)
{
size_t k;
- char *dst;
- dst = scm_i_string_writable_chars (v);
+ v = scm_i_string_start_writing (v);
for (k = start; k < end; ++k)
- dst[k] = scm_c_downcase (dst[k]);
+ scm_i_string_set_x (v, k, uc_tolower (scm_i_string_ref (v, k)));
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (v);
@@ -2465,12 +2147,11 @@ SCM_DEFINE (scm_substring_downcase_x, "string-downcase!", 1, 2, 0,
"@end lisp")
#define FUNC_NAME s_scm_substring_downcase_x
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_downcase_x (str, cstart, cend);
}
#undef FUNC_NAME
@@ -2486,12 +2167,11 @@ SCM_DEFINE (scm_substring_downcase, "string-downcase", 1, 2, 0,
"Downcase every character in @var{str}.")
#define FUNC_NAME s_scm_substring_downcase
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_downcase_x (scm_string_copy (str), cstart, cend);
}
#undef FUNC_NAME
@@ -2507,23 +2187,24 @@ scm_string_downcase (SCM str)
static SCM
string_titlecase_x (SCM str, size_t start, size_t end)
{
- unsigned char *sz;
+ SCM ch;
size_t i;
int in_word = 0;
- sz = (unsigned char *) scm_i_string_writable_chars (str);
+ str = scm_i_string_start_writing (str);
for(i = start; i < end; i++)
{
- if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i]))))
+ ch = SCM_MAKE_CHAR (scm_i_string_ref (str, i));
+ if (scm_is_true (scm_char_alphabetic_p (ch)))
{
if (!in_word)
{
- sz[i] = scm_c_upcase(sz[i]);
+ scm_i_string_set_x (str, i, uc_toupper (SCM_CHAR (ch)));
in_word = 1;
}
else
{
- sz[i] = scm_c_downcase(sz[i]);
+ scm_i_string_set_x (str, i, uc_tolower (SCM_CHAR (ch)));
}
}
else
@@ -2542,12 +2223,11 @@ SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0,
"@var{str}.")
#define FUNC_NAME s_scm_string_titlecase_x
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_titlecase_x (str, cstart, cend);
}
#undef FUNC_NAME
@@ -2558,12 +2238,11 @@ SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0,
"Titlecase every first character in a word in @var{str}.")
#define FUNC_NAME s_scm_string_titlecase
{
- const char *cstr;
size_t cstart, cend;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
return string_titlecase_x (scm_string_copy (str), cstart, cend);
}
#undef FUNC_NAME
@@ -2600,22 +2279,24 @@ SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0,
/* Reverse the portion of @var{str} between str[cstart] (including)
and str[cend] excluding. */
static void
-string_reverse_x (char * str, size_t cstart, size_t cend)
+string_reverse_x (SCM str, size_t cstart, size_t cend)
{
- char tmp;
+ SCM tmp;
+ str = scm_i_string_start_writing (str);
if (cend > 0)
{
cend--;
while (cstart < cend)
{
- tmp = str[cstart];
- str[cstart] = str[cend];
- str[cend] = tmp;
+ tmp = SCM_MAKE_CHAR (scm_i_string_ref (str, cstart));
+ scm_i_string_set_x (str, cstart, scm_i_string_ref (str, cend));
+ scm_i_string_set_x (str, cend, SCM_CHAR (tmp));
cstart++;
cend--;
}
}
+ scm_i_string_stop_writing ();
}
@@ -2626,18 +2307,14 @@ SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0,
"operate on.")
#define FUNC_NAME s_scm_string_reverse
{
- const char *cstr;
- char *ctarget;
size_t cstart, cend;
SCM result;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
- 2, start, cstart,
- 3, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
result = scm_string_copy (str);
- ctarget = scm_i_string_writable_chars (result);
- string_reverse_x (ctarget, cstart, cend);
- scm_i_string_stop_writing ();
+ string_reverse_x (result, cstart, cend);
scm_remember_upto_here_1 (str);
return result;
}
@@ -2651,16 +2328,13 @@ SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0,
"operate on. The return value is unspecified.")
#define FUNC_NAME s_scm_string_reverse_x
{
- char *cstr;
size_t cstart, cend;
MY_VALIDATE_SUBSTRING_SPEC (1, str,
2, start, cstart,
3, end, cend);
- cstr = scm_i_string_writable_chars (str);
- string_reverse_x (cstr, cstart, cend);
- scm_i_string_stop_writing ();
+ string_reverse_x (str, cstart, cend);
scm_remember_upto_here_1 (str);
return SCM_UNSPECIFIED;
}
@@ -2686,7 +2360,9 @@ SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1,
for (l = rest; scm_is_pair (l); l = SCM_CDR (l))
{
s = SCM_CAR (l);
- if (scm_c_string_length (s) != 0)
+ if (!scm_is_string (s))
+ scm_wrong_type_arg (FUNC_NAME, 0, s);
+ if (scm_i_string_length (s) != 0)
{
if (seen_nonempty)
/* two or more non-empty strings, need full concat */
@@ -2773,7 +2449,7 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
"string elements is not specified.")
#define FUNC_NAME s_scm_string_map
{
- char *p;
+ size_t p;
size_t cstart, cend;
SCM result;
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
@@ -2782,15 +2458,20 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
MY_VALIDATE_SUBSTRING_SPEC (2, s,
3, start, cstart,
4, end, cend);
- result = scm_i_make_string (cend - cstart, &p);
+ result = scm_i_make_string (cend - cstart, NULL);
+ p = 0;
while (cstart < cend)
{
SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
cstart++;
- *p++ = SCM_CHAR (ch);
+ result = scm_i_string_start_writing (result);
+ scm_i_string_set_x (result, p, SCM_CHAR (ch));
+ scm_i_string_stop_writing ();
+ p++;
}
+
return result;
}
#undef FUNC_NAME
@@ -2816,7 +2497,9 @@ SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0,
SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
- scm_c_string_set_x (s, cstart, ch);
+ s = scm_i_string_start_writing (s);
+ scm_i_string_set_x (s, cstart, SCM_CHAR (ch));
+ scm_i_string_stop_writing ();
cstart++;
}
return SCM_UNSPECIFIED;
@@ -2832,20 +2515,17 @@ SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0,
"result of @var{kons}' application.")
#define FUNC_NAME s_scm_string_fold
{
- const char *cstr;
size_t cstart, cend;
SCM result;
SCM_VALIDATE_PROC (1, kons);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
- 4, start, cstart,
- 5, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (3, s,
+ 4, start, cstart,
+ 5, end, cend);
result = knil;
while (cstart < cend)
{
- unsigned int c = (unsigned char) cstr[cstart];
- result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result);
- cstr = scm_i_string_chars (s);
+ result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)), result);
cstart++;
}
@@ -2863,20 +2543,17 @@ SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0,
"result of @var{kons}' application.")
#define FUNC_NAME s_scm_string_fold_right
{
- const char *cstr;
size_t cstart, cend;
SCM result;
SCM_VALIDATE_PROC (1, kons);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
- 4, start, cstart,
- 5, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (3, s,
+ 4, start, cstart,
+ 5, end, cend);
result = knil;
while (cstart < cend)
{
- unsigned int c = (unsigned char) cstr[cend - 1];
- result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result);
- cstr = scm_i_string_chars (s);
+ result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cend-1)), result);
cend--;
}
@@ -2927,12 +2604,15 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
while (scm_is_false (res))
{
SCM str;
- char *ptr;
+ size_t i = 0;
SCM ch = scm_call_1 (f, seed);
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
- str = scm_i_make_string (1, &ptr);
- *ptr = SCM_CHAR (ch);
+ str = scm_i_make_string (1, NULL);
+ str = scm_i_string_start_writing (str);
+ scm_i_string_set_x (str, i, SCM_CHAR (ch));
+ scm_i_string_stop_writing ();
+ i++;
ans = scm_string_append (scm_list_2 (ans, str));
seed = scm_call_1 (g, seed);
@@ -2990,12 +2670,15 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
while (scm_is_false (res))
{
SCM str;
- char *ptr;
+ size_t i = 0;
SCM ch = scm_call_1 (f, seed);
if (!SCM_CHARP (ch))
SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
- str = scm_i_make_string (1, &ptr);
- *ptr = SCM_CHAR (ch);
+ str = scm_i_make_string (1, NULL);
+ str = scm_i_string_start_writing (str);
+ scm_i_string_set_x (str, i, SCM_CHAR (ch));
+ scm_i_string_stop_writing ();
+ i++;
ans = scm_string_append (scm_list_2 (str, ans));
seed = scm_call_1 (g, seed);
@@ -3018,19 +2701,16 @@ SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0,
"return value is not specified.")
#define FUNC_NAME s_scm_string_for_each
{
- const char *cstr;
size_t cstart, cend;
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
while (cstart < cend)
{
- unsigned int c = (unsigned char) cstr[cstart];
- proc_tramp (proc, SCM_MAKE_CHAR (c));
- cstr = scm_i_string_chars (s);
+ proc_tramp (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
cstart++;
}
@@ -3092,8 +2772,7 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0,
"defaults to @var{from} + (@var{end} - @var{start}).")
#define FUNC_NAME s_scm_xsubstring
{
- const char *cs;
- char *p;
+ size_t p;
size_t cstart, cend;
int cfrom, cto;
SCM result;
@@ -3110,19 +2789,22 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0,
if (cstart == cend && cfrom != cto)
SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
- result = scm_i_make_string (cto - cfrom, &p);
+ result = scm_i_make_string (cto - cfrom, NULL);
+ result = scm_i_string_start_writing (result);
- cs = scm_i_string_chars (s);
+ p = 0;
while (cfrom < cto)
{
size_t t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart);
if (cfrom < 0)
- *p = cs[(cend - cstart) - t];
+ scm_i_string_set_x (result, p,
+ scm_i_string_ref (s, (cend - cstart) - t));
else
- *p = cs[t];
+ scm_i_string_set_x (result, p, scm_i_string_ref (s, t));
cfrom++;
p++;
}
+ scm_i_string_stop_writing ();
scm_remember_upto_here_1 (s);
return result;
@@ -3139,8 +2821,7 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0,
"cannot copy a string on top of itself.")
#define FUNC_NAME s_scm_string_xcopy_x
{
- char *p;
- const char *cs;
+ size_t p;
size_t ctstart, cstart, cend;
int csfrom, csto;
SCM dummy = SCM_UNDEFINED;
@@ -3162,15 +2843,15 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0,
SCM_ASSERT_RANGE (1, tstart,
ctstart + (csto - csfrom) <= scm_i_string_length (target));
- p = scm_i_string_writable_chars (target) + ctstart;
- cs = scm_i_string_chars (s);
+ p = 0;
+ target = scm_i_string_start_writing (target);
while (csfrom < csto)
{
size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
if (csfrom < 0)
- *p = cs[(cend - cstart) - t];
+ scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, (cend - cstart) - t));
else
- *p = cs[t];
+ scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, t));
csfrom++;
p++;
}
@@ -3189,8 +2870,6 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0,
"@var{start2} @dots{} @var{end2} from @var{s2}.")
#define FUNC_NAME s_scm_string_replace
{
- const char *cstr1, *cstr2;
- char *p;
size_t cstart1, cend1, cstart2, cend2;
SCM result;
@@ -3200,16 +2879,10 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0,
MY_VALIDATE_SUBSTRING_SPEC (2, s2,
5, start2, cstart2,
6, end2, cend2);
- result = scm_i_make_string (cstart1 + (cend2 - cstart2) +
- scm_i_string_length (s1) - cend1, &p);
- cstr1 = scm_i_string_chars (s1);
- cstr2 = scm_i_string_chars (s2);
- memmove (p, cstr1, cstart1 * sizeof (char));
- memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char));
- memmove (p + cstart1 + (cend2 - cstart2),
- cstr1 + cend1,
- (scm_i_string_length (s1) - cend1) * sizeof (char));
- scm_remember_upto_here_2 (s1, s2);
+ return (scm_string_append
+ (scm_list_3 (scm_i_substring (s1, 0, cstart1),
+ scm_i_substring (s2, cstart2, cend2),
+ scm_i_substring (s1, cend1, scm_i_string_length (s1)))));
return result;
}
#undef FUNC_NAME
@@ -3226,13 +2899,12 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
"of @var{s}.")
#define FUNC_NAME s_scm_string_tokenize
{
- const char *cstr;
size_t cstart, cend;
SCM result = SCM_EOL;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
if (SCM_UNBNDP (token_set))
token_set = scm_char_set_graphic;
@@ -3245,7 +2917,7 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
{
while (cstart < cend)
{
- if (SCM_CHARSET_GET (token_set, cstr[cend - 1]))
+ if (REF_IN_CHARSET (s, cend-1, token_set))
break;
cend--;
}
@@ -3254,12 +2926,11 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
idx = cend;
while (cstart < cend)
{
- if (!SCM_CHARSET_GET (token_set, cstr[cend - 1]))
+ if (!REF_IN_CHARSET (s, cend-1, token_set))
break;
cend--;
}
- result = scm_cons (scm_c_substring (s, cend, idx), result);
- cstr = scm_i_string_chars (s);
+ result = scm_cons (scm_i_substring (s, cend, idx), result);
}
}
else
@@ -3293,27 +2964,45 @@ SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
#define FUNC_NAME s_scm_string_split
{
long idx, last_idx;
- const char * p;
- char ch;
+ int narrow;
SCM res = SCM_EOL;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_CHAR (2, chr);
-
+
+ /* This is explicit wide/narrow logic (instead of using
+ scm_i_string_ref) is a speed optimization. */
idx = scm_i_string_length (str);
- p = scm_i_string_chars (str);
- ch = SCM_CHAR (chr);
- while (idx >= 0)
- {
- last_idx = idx;
- while (idx > 0 && p[idx - 1] != ch)
- idx--;
- if (idx >= 0)
- {
- res = scm_cons (scm_c_substring (str, idx, last_idx), res);
- p = scm_i_string_chars (str);
- idx--;
- }
+ narrow = scm_i_is_narrow_string (str);
+ if (narrow)
+ {
+ const char *buf = scm_i_string_chars (str);
+ while (idx >= 0)
+ {
+ last_idx = idx;
+ while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr))
+ idx--;
+ if (idx >= 0)
+ {
+ res = scm_cons (scm_i_substring (str, idx, last_idx), res);
+ idx--;
+ }
+ }
+ }
+ else
+ {
+ const scm_t_wchar *buf = scm_i_string_wide_chars (str);
+ while (idx >= 0)
+ {
+ last_idx = idx;
+ while (idx > 0 && buf[idx-1] != SCM_CHAR(chr))
+ idx--;
+ if (idx >= 0)
+ {
+ res = scm_cons (scm_i_substring (str, idx, last_idx), res);
+ idx--;
+ }
+ }
}
scm_remember_upto_here_1 (str);
return res;
@@ -3332,14 +3021,13 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
"membership.")
#define FUNC_NAME s_scm_string_filter
{
- const char *cstr;
size_t cstart, cend;
SCM result;
size_t idx;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
/* The explicit loops below stripping leading and trailing non-matches
mean we can return a substring if those are the only deletions, making
@@ -3348,22 +3036,19 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
if (SCM_CHARP (char_pred))
{
size_t count;
- char chr;
-
- chr = SCM_CHAR (char_pred);
/* strip leading non-matches by incrementing cstart */
- while (cstart < cend && cstr[cstart] != chr)
+ while (cstart < cend && scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred))
cstart++;
/* strip trailing non-matches by decrementing cend */
- while (cend > cstart && cstr[cend-1] != chr)
+ while (cend > cstart && scm_i_string_ref (s, cend-1) != SCM_CHAR (char_pred))
cend--;
/* count chars to keep */
count = 0;
for (idx = cstart; idx < cend; idx++)
- if (cstr[idx] == chr)
+ if (scm_i_string_ref (s, idx) == SCM_CHAR (char_pred))
count++;
if (count == cend - cstart)
@@ -3381,17 +3066,17 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
size_t count;
/* strip leading non-matches by incrementing cstart */
- while (cstart < cend && ! SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ while (cstart < cend && ! REF_IN_CHARSET (s, cstart, char_pred))
cstart++;
/* strip trailing non-matches by decrementing cend */
- while (cend > cstart && ! SCM_CHARSET_GET (char_pred, cstr[cend-1]))
+ while (cend > cstart && ! REF_IN_CHARSET (s, cend-1, char_pred))
cend--;
/* count chars to be kept */
count = 0;
for (idx = cstart; idx < cend; idx++)
- if (SCM_CHARSET_GET (char_pred, cstr[idx]))
+ if (REF_IN_CHARSET (s, idx, char_pred))
count++;
/* if whole of start to end kept then return substring */
@@ -3399,21 +3084,23 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
goto result_substring;
else
{
- char *dst;
- result = scm_i_make_string (count, &dst);
- cstr = scm_i_string_chars (s);
+ size_t dst = 0;
+ result = scm_i_make_string (count, NULL);
+ result = scm_i_string_start_writing (result);
/* decrement "count" in this loop as well as using idx, so that if
another thread is simultaneously changing "s" there's no chance
it'll make us copy more than count characters */
for (idx = cstart; idx < cend && count != 0; idx++)
{
- if (SCM_CHARSET_GET (char_pred, cstr[idx]))
+ if (REF_IN_CHARSET (s, idx, char_pred))
{
- *dst++ = cstr[idx];
+ scm_i_string_set_x (result, dst, scm_i_string_ref (s, idx));
+ dst ++;
count--;
}
}
+ scm_i_string_stop_writing ();
}
}
else
@@ -3426,11 +3113,10 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
while (idx < cend)
{
SCM res, ch;
- ch = SCM_MAKE_CHAR (cstr[idx]);
+ ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
res = pred_tramp (char_pred, ch);
if (scm_is_true (res))
ls = scm_cons (ch, ls);
- cstr = scm_i_string_chars (s);
idx++;
}
result = scm_reverse_list_to_string (ls);
@@ -3452,14 +3138,13 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
"membership.")
#define FUNC_NAME s_scm_string_delete
{
- const char *cstr;
size_t cstart, cend;
SCM result;
size_t idx;
- MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 3, start, cstart,
+ 4, end, cend);
/* The explicit loops below stripping leading and trailing matches mean we
can return a substring if those are the only deletions, making
@@ -3468,22 +3153,19 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
if (SCM_CHARP (char_pred))
{
size_t count;
- char chr;
-
- chr = SCM_CHAR (char_pred);
/* strip leading matches by incrementing cstart */
- while (cstart < cend && cstr[cstart] == chr)
+ while (cstart < cend && scm_i_string_ref (s, cstart) == SCM_CHAR(char_pred))
cstart++;
/* strip trailing matches by decrementing cend */
- while (cend > cstart && cstr[cend-1] == chr)
+ while (cend > cstart && scm_i_string_ref (s, cend-1) == SCM_CHAR (char_pred))
cend--;
/* count chars to be kept */
count = 0;
for (idx = cstart; idx < cend; idx++)
- if (cstr[idx] != chr)
+ if (scm_i_string_ref (s, idx) != SCM_CHAR (char_pred))
count++;
if (count == cend - cstart)
@@ -3495,22 +3177,24 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
}
else
{
+ int i = 0;
/* new string for retained portion */
- char *dst;
- result = scm_i_make_string (count, &dst);
- cstr = scm_i_string_chars (s);
-
+ result = scm_i_make_string (count, NULL);
+ result = scm_i_string_start_writing (result);
/* decrement "count" in this loop as well as using idx, so that if
another thread is simultaneously changing "s" there's no chance
it'll make us copy more than count characters */
for (idx = cstart; idx < cend && count != 0; idx++)
{
- if (cstr[idx] != chr)
+ scm_t_wchar c = scm_i_string_ref (s, idx);
+ if (c != SCM_CHAR (char_pred))
{
- *dst++ = cstr[idx];
+ scm_i_string_set_x (result, i, c);
+ i++;
count--;
}
}
+ scm_i_string_stop_writing ();
}
}
else if (SCM_CHARSETP (char_pred))
@@ -3518,39 +3202,41 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
size_t count;
/* strip leading matches by incrementing cstart */
- while (cstart < cend && SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ while (cstart < cend && REF_IN_CHARSET (s, cstart, char_pred))
cstart++;
/* strip trailing matches by decrementing cend */
- while (cend > cstart && SCM_CHARSET_GET (char_pred, cstr[cend-1]))
+ while (cend > cstart && REF_IN_CHARSET (s, cend-1, char_pred))
cend--;
/* count chars to be kept */
count = 0;
for (idx = cstart; idx < cend; idx++)
- if (! SCM_CHARSET_GET (char_pred, cstr[idx]))
+ if (!REF_IN_CHARSET (s, idx, char_pred))
count++;
if (count == cend - cstart)
goto result_substring;
else
{
+ size_t i = 0;
/* new string for retained portion */
- char *dst;
- result = scm_i_make_string (count, &dst);
- cstr = scm_i_string_chars (s);
+ result = scm_i_make_string (count, NULL);
+ result = scm_i_string_start_writing (result);
/* decrement "count" in this loop as well as using idx, so that if
another thread is simultaneously changing "s" there's no chance
it'll make us copy more than count characters */
for (idx = cstart; idx < cend && count != 0; idx++)
{
- if (! SCM_CHARSET_GET (char_pred, cstr[idx]))
+ if (!REF_IN_CHARSET (s, idx, char_pred))
{
- *dst++ = cstr[idx];
+ scm_i_string_set_x (result, i, scm_i_string_ref (s, idx));
+ i++;
count--;
}
}
+ scm_i_string_stop_writing ();
}
}
else
@@ -3562,11 +3248,10 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
idx = cstart;
while (idx < cend)
{
- SCM res, ch = SCM_MAKE_CHAR (cstr[idx]);
+ SCM res, ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx));
res = pred_tramp (char_pred, ch);
if (scm_is_false (res))
ls = scm_cons (ch, ls);
- cstr = scm_i_string_chars (s);
idx++;
}
result = scm_reverse_list_to_string (ls);
diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c
index 3b4a5ff7f..fe5627008 100644
--- a/libguile/srfi-14.c
+++ b/libguile/srfi-14.c
@@ -24,45 +24,476 @@
#include <string.h>
-#include <ctype.h>
+#include <unictype.h>
#include "libguile.h"
#include "libguile/srfi-14.h"
+#include "libguile/strings.h"
+/* Include the pre-computed standard charset data. */
+#include "libguile/srfi-14.i.c"
-#define SCM_CHARSET_SET(cs, idx) \
- (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \
- (1L << ((idx) % SCM_BITS_PER_LONG)))
+#define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset))
-#define SCM_CHARSET_UNSET(cs, idx) \
- (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] &= \
- (~(1L << ((idx) % SCM_BITS_PER_LONG))))
-
-#define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8)
-#define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG)
+#define SCM_CHARSET_SET(cs, idx) \
+ scm_i_charset_set (SCM_CHARSET_DATA (cs), idx)
+#define SCM_CHARSET_UNSET(cs, idx) \
+ scm_i_charset_unset (SCM_CHARSET_DATA (cs), idx)
/* Smob type code for character sets. */
int scm_tc16_charset = 0;
+int scm_tc16_charset_cursor = 0;
+
+/* True if N exists in charset CS. */
+int
+scm_i_charset_get (scm_t_char_set *cs, scm_t_wchar n)
+{
+ size_t i;
+
+ i = 0;
+ while (i < cs->len)
+ {
+ if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi)
+ return 1;
+ i++;
+ }
+
+ return 0;
+}
+
+/* Put N into charset CS. */
+void
+scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n)
+{
+ size_t i;
+ size_t len;
+
+ len = cs->len;
+
+ i = 0;
+ while (i < len)
+ {
+ /* Already in this range */
+ if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi)
+ {
+ return;
+ }
+
+ if (n == cs->ranges[i].lo - 1)
+ {
+ /* 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;
+ }
+ else
+ {
+ /* Expand the range down by one. */
+ cs->ranges[i].lo = n;
+ return;
+ }
+ }
+ else if (n == cs->ranges[i].hi + 1)
+ {
+ /* This char is one above the current range. */
+ if (i < len - 1 && cs->ranges[i + 1].lo - 1 == n)
+ {
+ /* It is also one below the next range, so combine them. */
+ cs->ranges[i].hi = cs->ranges[i + 1].hi;
+ if (i < len - 2)
+ memmove (cs->ranges + (i + 1), cs->ranges + (i + 2),
+ sizeof (scm_t_char_range) * (len - i - 2));
+ 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;
+ }
+ else
+ {
+ /* Expand the range up by one. */
+ cs->ranges[i].hi = n;
+ return;
+ }
+ }
+ else if (n < cs->ranges[i].lo - 1)
+ {
+ /* This is a new range below the current one. */
+ cs->ranges = scm_gc_realloc (cs->ranges,
+ sizeof (scm_t_char_range) * len,
+ sizeof (scm_t_char_range) * (len + 1),
+ "character-set");
+ memmove (cs->ranges + (i + 1), cs->ranges + i,
+ sizeof (scm_t_char_range) * (len - i));
+ cs->ranges[i].lo = n;
+ cs->ranges[i].hi = n;
+ cs->len = len + 1;
+ return;
+ }
+
+ i++;
+ }
+
+ /* This is a new range above all previous ranges. */
+ if (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) * len,
+ sizeof (scm_t_char_range) * (len + 1),
+ "character-set");
+ }
+ cs->ranges[len].lo = n;
+ cs->ranges[len].hi = n;
+ cs->len = len + 1;
+
+ return;
+}
+
+/* If N is in charset CS, remove it. */
+void
+scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n)
+{
+ size_t i;
+ size_t len;
+
+ len = cs->len;
+
+ i = 0;
+ while (i < len)
+ {
+ if (n < cs->ranges[i].lo)
+ /* Not in this set. */
+ return;
+
+ if (n == cs->ranges[i].lo && n == cs->ranges[i].hi)
+ {
+ /* Remove this one-character range. */
+ if (len == 1)
+ {
+ scm_gc_free (cs->ranges,
+ sizeof (scm_t_char_range) * cs->len,
+ "character-set");
+ cs->ranges = NULL;
+ cs->len = 0;
+ return;
+ }
+ else 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;
+ }
+ else if (i == len - 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;
+ }
+ }
+ else if (n == cs->ranges[i].lo)
+ {
+ /* Shrink this range from the left. */
+ cs->ranges[i].lo = n + 1;
+ return;
+ }
+ else if (n == cs->ranges[i].hi)
+ {
+ /* Shrink this range from the right. */
+ cs->ranges[i].hi = n - 1;
+ return;
+ }
+ else if (n > cs->ranges[i].lo && n < cs->ranges[i].hi)
+ {
+ /* Split this range into two pieces. */
+ cs->ranges = scm_gc_realloc (cs->ranges,
+ sizeof (scm_t_char_range) * len,
+ sizeof (scm_t_char_range) * (len + 1),
+ "character-set");
+ if (i < len - 1)
+ memmove (cs->ranges + (i + 2), cs->ranges + (i + 1),
+ sizeof (scm_t_char_range) * (len - i - 1));
+ cs->ranges[i + 1].hi = cs->ranges[i].hi;
+ cs->ranges[i + 1].lo = n + 1;
+ cs->ranges[i].hi = n - 1;
+ cs->len = len + 1;
+ return;
+ }
+
+ i++;
+ }
+
+ /* This value is above all ranges, so do nothing here. */
+ return;
+}
+
+static int
+charsets_equal (scm_t_char_set *a, scm_t_char_set *b)
+{
+ if (a->len != b->len)
+ return 0;
+
+ if (memcmp (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len) != 0)
+ return 0;
+
+ return 1;
+}
+
+/* Return true if every character in A is also in B. */
+static int
+charsets_leq (scm_t_char_set *a, scm_t_char_set *b)
+{
+ size_t i = 0, j = 0;
+ scm_t_wchar alo, ahi;
+
+ if (a->len == 0)
+ return 1;
+ if (b->len == 0)
+ return 0;
+ while (i < a->len)
+ {
+ alo = a->ranges[i].lo;
+ ahi = a->ranges[i].hi;
+ while (b->ranges[j].hi < alo)
+ {
+ if (j < b->len - 1)
+ j++;
+ else
+ return 0;
+ }
+ if (alo < b->ranges[j].lo || ahi > b->ranges[j].hi)
+ return 0;
+ i++;
+ }
+
+ return 1;
+}
+
+/* Merge B into A. */
+static void
+charsets_union (scm_t_char_set *a, scm_t_char_set *b)
+{
+ size_t i = 0;
+ scm_t_wchar blo, bhi, n;
+
+ if (b->len == 0)
+ return;
+
+ if (a->len == 0)
+ {
+ a->len = b->len;
+ a->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * b->len,
+ "character-set");
+ memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * b->len);
+ 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);
+
+ i++;
+ }
+
+ return;
+}
+
+/* Remove elements not both in A and B from A. */
+static void
+charsets_intersection (scm_t_char_set *a, scm_t_char_set *b)
+{
+ size_t i = 0;
+ scm_t_wchar blo, bhi, n;
+ scm_t_char_set *c;
+
+ if (a->len == 0)
+ return;
+
+ if (b->len == 0)
+ {
+ scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len,
+ "character-set");
+ a->len = 0;
+ return;
+ }
+
+ c = (scm_t_char_set *) scm_malloc (sizeof (scm_t_char_set));
+ c->len = 0;
+ c->ranges = NULL;
+
+ while (i < b->len)
+ {
+ blo = b->ranges[i].lo;
+ bhi = b->ranges[i].hi;
+ for (n = blo; n <= bhi; n++)
+ if (scm_i_charset_get (a, n))
+ scm_i_charset_set (c, n);
+ i++;
+ }
+ scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len,
+ "character-set");
+
+ a->len = c->len;
+ if (c->len != 0)
+ a->ranges = c->ranges;
+ else
+ a->ranges = NULL;
+ free (c);
+ return;
+}
+
+/* Make P the compelement of Q. */
+static void
+charsets_complement (scm_t_char_set *p, scm_t_char_set *q)
+{
+ int k, idx;
+
+ 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;
+ return;
+ }
+
+ if (p->len > 0)
+ scm_gc_free (p->ranges, sizeof (scm_t_char_set) * p->len,
+ "character-set");
+
+ 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->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;
+ }
+ 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[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;
+ }
+ return;
+}
+
+/* Replace A with elements only found in one of A or B. */
+static void
+charsets_xor (scm_t_char_set *a, scm_t_char_set *b)
+{
+ size_t i = 0;
+ scm_t_wchar blo, bhi, n;
+
+ if (b->len == 0)
+ {
+ return;
+ }
+ if (a->len == 0)
+ {
+ a->ranges =
+ (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) *
+ b->len, "character-set");
+ a->len = b->len;
+ memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len);
+ return;
+ }
+
+ while (i < b->len)
+ {
+ blo = b->ranges[i].lo;
+ bhi = b->ranges[i].hi;
+ for (n = blo; n <= bhi; n++)
+ {
+ if (scm_i_charset_get (a, n))
+ scm_i_charset_unset (a, n);
+ else
+ scm_i_charset_set (a, n);
+ }
+
+ i++;
+ }
+ return;
+}
/* Smob print hook for character sets. */
static int
charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- int i;
+ size_t i;
int first = 1;
+ scm_t_char_set *p;
+ const size_t max_ranges_to_print = 50;
+
+ p = SCM_CHARSET_DATA (charset);
scm_puts ("#<charset {", port);
- for (i = 0; i < SCM_CHARSET_SIZE; i++)
- if (SCM_CHARSET_GET (charset, i))
- {
- if (first)
- first = 0;
- else
- scm_puts (" ", port);
- scm_write (SCM_MAKE_CHAR (i), port);
- }
+ for (i = 0; i < p->len; i++)
+ {
+ if (first)
+ first = 0;
+ else
+ scm_puts (" ", port);
+ scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port);
+ if (p->ranges[i].lo != p->ranges[i].hi)
+ {
+ scm_puts ("..", port);
+ scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port);
+ }
+ if (i >= max_ranges_to_print)
+ {
+ /* Too many to print here. Quit early. */
+ scm_puts (" ...", port);
+ break;
+ }
+ }
scm_puts ("}>", port);
return 1;
}
@@ -72,18 +503,71 @@ charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED)
static size_t
charset_free (SCM charset)
{
- return scm_smob_free (charset);
+ scm_t_char_set *cs;
+ size_t len = 0;
+
+ cs = SCM_CHARSET_DATA (charset);
+ if (cs != NULL)
+ len = cs->len;
+ if (len > 0)
+ scm_gc_free (cs->ranges, sizeof (scm_t_char_range) * len,
+ "character-set");
+
+ cs->ranges = NULL;
+ cs->len = 0;
+
+ scm_gc_free (cs, sizeof (scm_t_char_set), "character-set");
+
+ scm_remember_upto_here_1 (charset);
+
+ return 0;
+}
+
+
+/* Smob print hook for character sets cursors. */
+static int
+charset_cursor_print (SCM cursor, SCM port,
+ scm_print_state *pstate SCM_UNUSED)
+{
+ scm_t_char_set_cursor *cur;
+
+ cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
+
+ scm_puts ("#<charset-cursor ", port);
+ if (cur->range == (size_t) (-1))
+ scm_puts ("(empty)", port);
+ else
+ {
+ scm_write (scm_from_size_t (cur->range), port);
+ scm_puts (":", port);
+ scm_write (scm_from_int32 (cur->n), port);
+ }
+ scm_puts (">", port);
+ return 1;
+}
+
+/* Smob free hook for character sets. */
+static size_t
+charset_cursor_free (SCM charset)
+{
+ scm_t_char_set_cursor *cur;
+
+ cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (charset);
+ scm_gc_free (cur, sizeof (scm_t_char_set_cursor), "charset-cursor");
+ scm_remember_upto_here_1 (charset);
+
+ return 0;
}
/* Create a new, empty character set. */
static SCM
-make_char_set (const char * func_name)
+make_char_set (const char *func_name)
{
- long * p;
+ scm_t_char_set *p;
- p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set");
- memset (p, 0, BYTES_PER_CHARSET);
+ p = scm_gc_malloc (sizeof (scm_t_char_set), "character-set");
+ memset (p, 0, sizeof (scm_t_char_set));
SCM_RETURN_NEWSMOB (scm_tc16_charset, p);
}
@@ -105,22 +589,22 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1,
#define FUNC_NAME s_scm_char_set_eq
{
int argnum = 1;
- long *cs1_data = NULL;
+ scm_t_char_set *cs1_data = NULL;
SCM_VALIDATE_REST_ARGUMENT (char_sets);
while (!scm_is_null (char_sets))
{
SCM csi = SCM_CAR (char_sets);
- long *csi_data;
+ scm_t_char_set *csi_data;
SCM_VALIDATE_SMOB (argnum, csi, charset);
argnum++;
- csi_data = (long *) SCM_SMOB_DATA (csi);
+ csi_data = SCM_CHARSET_DATA (csi);
if (cs1_data == NULL)
- cs1_data = csi_data;
- else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0)
- return SCM_BOOL_F;
+ cs1_data = csi_data;
+ else if (!charsets_equal (cs1_data, csi_data))
+ return SCM_BOOL_F;
char_sets = SCM_CDR (char_sets);
}
return SCM_BOOL_T;
@@ -135,28 +619,23 @@ SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1,
#define FUNC_NAME s_scm_char_set_leq
{
int argnum = 1;
- long *prev_data = NULL;
+ scm_t_char_set *prev_data = NULL;
SCM_VALIDATE_REST_ARGUMENT (char_sets);
while (!scm_is_null (char_sets))
{
SCM csi = SCM_CAR (char_sets);
- long *csi_data;
+ scm_t_char_set *csi_data;
SCM_VALIDATE_SMOB (argnum, csi, charset);
argnum++;
- csi_data = (long *) SCM_SMOB_DATA (csi);
+ csi_data = SCM_CHARSET_DATA (csi);
if (prev_data)
- {
- int k;
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- {
- if ((prev_data[k] & csi_data[k]) != prev_data[k])
- return SCM_BOOL_F;
- }
- }
+ {
+ if (!charsets_leq (prev_data, csi_data))
+ return SCM_BOOL_F;
+ }
prev_data = csi_data;
char_sets = SCM_CDR (char_sets);
}
@@ -174,9 +653,10 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
{
const unsigned long default_bnd = 871;
unsigned long bnd;
- long * p;
+ scm_t_char_set *p;
unsigned long val = 0;
int k;
+ scm_t_wchar c;
SCM_VALIDATE_SMOB (1, cs, charset);
@@ -186,14 +666,14 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
{
bnd = scm_to_ulong (bound);
if (bnd == 0)
- bnd = default_bnd;
+ bnd = default_bnd;
}
- p = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p = SCM_CHARSET_DATA (cs);
+ for (k = 0; k < p->len; k++)
{
- if (p[k] != 0)
- val = p[k] + (val << 1);
+ for (c = p->ranges[k].lo; c <= p->ranges[k].hi; c++)
+ val = c + (val << 1);
}
return scm_from_ulong (val % bnd);
}
@@ -201,89 +681,154 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0,
- (SCM cs),
- "Return a cursor into the character set @var{cs}.")
+ (SCM cs), "Return a cursor into the character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_cursor
{
- int idx;
+ scm_t_char_set *cs_data;
+ scm_t_char_set_cursor *cur_data;
SCM_VALIDATE_SMOB (1, cs, charset);
- for (idx = 0; idx < SCM_CHARSET_SIZE; idx++)
+ cs_data = SCM_CHARSET_DATA (cs);
+ cur_data =
+ (scm_t_char_set_cursor *) scm_gc_malloc (sizeof (scm_t_char_set_cursor),
+ "charset-cursor");
+ if (cs_data->len == 0)
{
- if (SCM_CHARSET_GET (cs, idx))
- break;
+ cur_data->range = (size_t) (-1);
+ cur_data->n = 0;
}
- return SCM_I_MAKINUM (idx);
+ else
+ {
+ cur_data->range = 0;
+ cur_data->n = cs_data->ranges[0].lo;
+ }
+ SCM_RETURN_NEWSMOB (scm_tc16_charset_cursor, cur_data);
}
+
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0,
- (SCM cs, SCM cursor),
- "Return the character at the current cursor position\n"
- "@var{cursor} in the character set @var{cs}. It is an error to\n"
- "pass a cursor for which @code{end-of-char-set?} returns true.")
+ (SCM cs, SCM cursor),
+ "Return the character at the current cursor position\n"
+ "@var{cursor} in the character set @var{cs}. It is an error to\n"
+ "pass a cursor for which @code{end-of-char-set?} returns true.")
#define FUNC_NAME s_scm_char_set_ref
{
- size_t ccursor = scm_to_size_t (cursor);
+ scm_t_char_set *cs_data;
+ scm_t_char_set_cursor *cur_data;
+ size_t i;
+
SCM_VALIDATE_SMOB (1, cs, charset);
+ SCM_VALIDATE_SMOB (2, cursor, charset_cursor);
+
+ cs_data = SCM_CHARSET_DATA (cs);
+ cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
- if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
+ /* Validate that this cursor is still true. */
+ i = cur_data->range;
+ if (i == (size_t) (-1)
+ || i >= cs_data->len
+ || cur_data->n < cs_data->ranges[i].lo
+ || cur_data->n > cs_data->ranges[i].hi)
SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
- return SCM_MAKE_CHAR (ccursor);
+ return SCM_MAKE_CHAR (cur_data->n);
}
+
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0,
- (SCM cs, SCM cursor),
- "Advance the character set cursor @var{cursor} to the next\n"
- "character in the character set @var{cs}. It is an error if the\n"
- "cursor given satisfies @code{end-of-char-set?}.")
+ (SCM cs, SCM cursor),
+ "Advance the character set cursor @var{cursor} to the next\n"
+ "character in the character set @var{cs}. It is an error if the\n"
+ "cursor given satisfies @code{end-of-char-set?}.")
#define FUNC_NAME s_scm_char_set_cursor_next
{
- size_t ccursor = scm_to_size_t (cursor);
+ scm_t_char_set *cs_data;
+ scm_t_char_set_cursor *cur_data;
+ size_t i;
+
SCM_VALIDATE_SMOB (1, cs, charset);
+ SCM_VALIDATE_SMOB (2, cursor, charset_cursor);
+
+ cs_data = SCM_CHARSET_DATA (cs);
+ cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
- if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
+ /* Validate that this cursor is still true. */
+ i = cur_data->range;
+ if (i == (size_t) (-1)
+ || i >= cs_data->len
+ || cur_data->n < cs_data->ranges[i].lo
+ || cur_data->n > cs_data->ranges[i].hi)
SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
- for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++)
+ /* Increment the cursor. */
+ if (cur_data->n == cs_data->ranges[i].hi)
{
- if (SCM_CHARSET_GET (cs, ccursor))
- break;
+ if (i + 1 < cs_data->len)
+ {
+ cur_data->range = i + 1;
+ cur_data->n = cs_data->ranges[i + 1].lo;
+ }
+ else
+ {
+ /* This is the end of the road. */
+ cur_data->range = (size_t) (-1);
+ cur_data->n = 0;
+ }
}
- return SCM_I_MAKINUM (ccursor);
+ else
+ {
+ cur_data->n = cur_data->n + 1;
+ }
+
+ return cursor;
}
+
#undef FUNC_NAME
SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0,
- (SCM cursor),
- "Return @code{#t} if @var{cursor} has reached the end of a\n"
- "character set, @code{#f} otherwise.")
+ (SCM cursor),
+ "Return @code{#t} if @var{cursor} has reached the end of a\n"
+ "character set, @code{#f} otherwise.")
#define FUNC_NAME s_scm_end_of_char_set_p
{
- size_t ccursor = scm_to_size_t (cursor);
- return scm_from_bool (ccursor >= SCM_CHARSET_SIZE);
+ scm_t_char_set_cursor *cur_data;
+ SCM_VALIDATE_SMOB (1, cursor, charset_cursor);
+
+ cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
+ if (cur_data->range == (size_t) (-1))
+ return SCM_BOOL_T;
+
+ return SCM_BOOL_F;
}
+
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0,
- (SCM kons, SCM knil, SCM cs),
- "Fold the procedure @var{kons} over the character set @var{cs},\n"
- "initializing it with @var{knil}.")
+ (SCM kons, SCM knil, SCM cs),
+ "Fold the procedure @var{kons} over the character set @var{cs},\n"
+ "initializing it with @var{knil}.")
#define FUNC_NAME s_scm_char_set_fold
{
+ scm_t_char_set *cs_data;
int k;
+ scm_t_wchar n;
SCM_VALIDATE_PROC (1, kons);
SCM_VALIDATE_SMOB (3, cs, charset);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
+ cs_data = SCM_CHARSET_DATA (cs);
+
+ if (cs_data->len == 0)
+ return knil;
+
+ for (k = 0; k < cs_data->len; k++)
+ for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
{
- knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), knil);
+ knil = scm_call_2 (kons, SCM_MAKE_CHAR (n), knil);
}
return knil;
}
@@ -373,21 +918,32 @@ SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0,
SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0,
- (SCM proc, SCM cs),
- "Apply @var{proc} to every character in the character set\n"
- "@var{cs}. The return value is not specified.")
+ (SCM proc, SCM cs),
+ "Apply @var{proc} to every character in the character set\n"
+ "@var{cs}. The return value is not specified.")
#define FUNC_NAME s_scm_char_set_for_each
{
+ scm_t_char_set *cs_data;
int k;
+ scm_t_wchar n;
SCM_VALIDATE_PROC (1, proc);
SCM_VALIDATE_SMOB (2, cs, charset);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- scm_call_1 (proc, SCM_MAKE_CHAR (k));
+ cs_data = SCM_CHARSET_DATA (cs);
+
+ if (cs_data->len == 0)
+ return SCM_UNSPECIFIED;
+
+ for (k = 0; k < cs_data->len; k++)
+ for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
+ {
+ scm_call_1 (proc, SCM_MAKE_CHAR (n));
+ }
+
return SCM_UNSPECIFIED;
}
+
#undef FUNC_NAME
@@ -399,18 +955,26 @@ SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0,
{
SCM result;
int k;
+ scm_t_char_set *cs_data;
+ scm_t_wchar n;
SCM_VALIDATE_PROC (1, proc);
SCM_VALIDATE_SMOB (2, cs, charset);
result = make_char_set (FUNC_NAME);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
+ cs_data = SCM_CHARSET_DATA (cs);
+
+ if (cs_data->len == 0)
+ return result;
+
+ for (k = 0; k < cs_data->len; k++)
+ for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
{
- SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k));
- if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
- SCM_CHARSET_SET (result, SCM_CHAR (ch));
+ SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (n));
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char",
+ scm_list_1 (proc));
+ SCM_CHARSET_SET (result, SCM_CHAR (ch));
}
return result;
}
@@ -424,17 +988,26 @@ SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0,
#define FUNC_NAME s_scm_char_set_copy
{
SCM ret;
- long * p1, * p2;
- int k;
+ scm_t_char_set *p1, *p2;
SCM_VALIDATE_SMOB (1, cs, charset);
ret = make_char_set (FUNC_NAME);
- p1 = (long *) SCM_SMOB_DATA (cs);
- p2 = (long *) SCM_SMOB_DATA (ret);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p2[k] = p1[k];
+ p1 = SCM_CHARSET_DATA (cs);
+ p2 = SCM_CHARSET_DATA (ret);
+ p2->len = p1->len;
+
+ if (p1->len == 0)
+ p2->ranges = NULL;
+ else
+ {
+ p2->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * p1->len,
+ "character-set");
+ memcpy (p2->ranges, p1->ranges, sizeof (scm_t_char_range) * p1->len);
+ }
+
return ret;
}
+
#undef FUNC_NAME
@@ -444,20 +1017,18 @@ SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1,
#define FUNC_NAME s_scm_char_set
{
SCM cs;
- long * p;
int argnum = 1;
SCM_VALIDATE_REST_ARGUMENT (rest);
cs = make_char_set (FUNC_NAME);
- p = (long *) SCM_SMOB_DATA (cs);
while (!scm_is_null (rest))
{
- int c;
+ scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c);
argnum++;
rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ SCM_CHARSET_SET (cs, c);
}
return cs;
}
@@ -472,7 +1043,6 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0,
#define FUNC_NAME s_scm_list_to_char_set
{
SCM cs;
- long * p;
SCM_VALIDATE_LIST (1, list);
if (SCM_UNBNDP (base_cs))
@@ -482,16 +1052,16 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0,
SCM_VALIDATE_SMOB (2, base_cs, charset);
cs = scm_char_set_copy (base_cs);
}
- p = (long *) SCM_SMOB_DATA (cs);
while (!scm_is_null (list))
{
SCM chr = SCM_CAR (list);
- int c;
+ scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (0, chr, c);
list = SCM_CDR (list);
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+
+ SCM_CHARSET_SET (cs, c);
}
return cs;
}
@@ -499,26 +1069,23 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0,
SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0,
- (SCM list, SCM base_cs),
- "Convert the character list @var{list} to a character set. The\n"
- "characters are added to @var{base_cs} and @var{base_cs} is\n"
- "returned.")
+ (SCM list, SCM base_cs),
+ "Convert the character list @var{list} to a character set. The\n"
+ "characters are added to @var{base_cs} and @var{base_cs} is\n"
+ "returned.")
#define FUNC_NAME s_scm_list_to_char_set_x
{
- long * p;
-
SCM_VALIDATE_LIST (1, list);
SCM_VALIDATE_SMOB (2, base_cs, charset);
- p = (long *) SCM_SMOB_DATA (base_cs);
while (!scm_is_null (list))
{
SCM chr = SCM_CAR (list);
- int c;
+ scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (0, chr, c);
list = SCM_CDR (list);
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ SCM_CHARSET_SET (base_cs, c);
}
return base_cs;
}
@@ -533,8 +1100,6 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0,
#define FUNC_NAME s_scm_string_to_char_set
{
SCM cs;
- long * p;
- const char * s;
size_t k = 0, len;
SCM_VALIDATE_STRING (1, str);
@@ -545,13 +1110,11 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0,
SCM_VALIDATE_SMOB (2, base_cs, charset);
cs = scm_char_set_copy (base_cs);
}
- p = (long *) SCM_SMOB_DATA (cs);
- s = scm_i_string_chars (str);
len = scm_i_string_length (str);
while (k < len)
{
- int c = s[k++];
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ scm_t_wchar c = scm_i_string_ref (str, k++);
+ SCM_CHARSET_SET (cs, c);
}
scm_remember_upto_here_1 (str);
return cs;
@@ -560,25 +1123,21 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0,
SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0,
- (SCM str, SCM base_cs),
- "Convert the string @var{str} to a character set. The\n"
- "characters from the string are added to @var{base_cs}, and\n"
- "@var{base_cs} is returned.")
+ (SCM str, SCM base_cs),
+ "Convert the string @var{str} to a character set. The\n"
+ "characters from the string are added to @var{base_cs}, and\n"
+ "@var{base_cs} is returned.")
#define FUNC_NAME s_scm_string_to_char_set_x
{
- long * p;
- const char * s;
size_t k = 0, len;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_SMOB (2, base_cs, charset);
- p = (long *) SCM_SMOB_DATA (base_cs);
- s = scm_i_string_chars (str);
len = scm_i_string_length (str);
while (k < len)
{
- int c = s[k++];
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ scm_t_wchar c = scm_i_string_ref (str, k++);
+ SCM_CHARSET_SET (base_cs, c);
}
scm_remember_upto_here_1 (str);
return base_cs;
@@ -595,7 +1154,8 @@ SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0,
{
SCM ret;
int k;
- long * p;
+ scm_t_wchar n;
+ scm_t_char_set *p;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_SMOB (2, cs, charset);
@@ -606,19 +1166,23 @@ SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0,
}
else
ret = make_char_set (FUNC_NAME);
- p = (long *) SCM_SMOB_DATA (ret);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- {
- if (SCM_CHARSET_GET (cs, k))
- {
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
- if (scm_is_true (res))
- p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
- }
- }
+ p = SCM_CHARSET_DATA (cs);
+
+ if (p->len == 0)
+ return ret;
+
+ 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 (n));
+
+ if (scm_is_true (res))
+ SCM_CHARSET_SET (ret, n);
+ }
return ret;
}
+
#undef FUNC_NAME
@@ -630,24 +1194,27 @@ SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0,
#define FUNC_NAME s_scm_char_set_filter_x
{
int k;
- long * p;
+ scm_t_wchar n;
+ scm_t_char_set *p;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_SMOB (2, cs, charset);
SCM_VALIDATE_SMOB (3, base_cs, charset);
- p = (long *) SCM_SMOB_DATA (base_cs);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- {
- if (SCM_CHARSET_GET (cs, k))
- {
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
+ p = SCM_CHARSET_DATA (cs);
+ if (p->len == 0)
+ return base_cs;
- if (scm_is_true (res))
- p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
- }
- }
+ 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));
+
+ if (scm_is_true (res))
+ SCM_CHARSET_SET (base_cs, n);
+ }
return base_cs;
}
+
#undef FUNC_NAME
@@ -669,7 +1236,6 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
{
SCM cs;
size_t clower, cupper;
- long * p;
clower = scm_to_size_t (lower);
cupper = scm_to_size_t (upper);
@@ -677,15 +1243,15 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
if (!SCM_UNBNDP (error))
{
if (scm_is_true (error))
- {
- SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE);
- SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE);
- }
+ {
+ SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
+ SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
+ }
}
- if (clower > SCM_CHARSET_SIZE)
- clower = SCM_CHARSET_SIZE;
- if (cupper > SCM_CHARSET_SIZE)
- cupper = SCM_CHARSET_SIZE;
+ if (clower > 0x10FFFF)
+ clower = 0x10FFFF;
+ if (cupper > 0x10FFFF)
+ cupper = 0x10FFFF;
if (SCM_UNBNDP (base_cs))
cs = make_char_set (FUNC_NAME);
else
@@ -693,10 +1259,11 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
SCM_VALIDATE_SMOB (4, base_cs, charset);
cs = scm_char_set_copy (base_cs);
}
- p = (long *) SCM_SMOB_DATA (cs);
+ /* It not be difficult to write a more optimized version of the
+ following. */
while (clower < cupper)
{
- p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
+ SCM_CHARSET_SET (cs, clower);
clower++;
}
return cs;
@@ -721,24 +1288,24 @@ SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0,
#define FUNC_NAME s_scm_ucs_range_to_char_set_x
{
size_t clower, cupper;
- long * p;
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, clower <= SCM_CHARSET_SIZE);
- SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE);
+ SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
+ SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
}
- if (clower > SCM_CHARSET_SIZE)
- clower = SCM_CHARSET_SIZE;
- if (cupper > SCM_CHARSET_SIZE)
- cupper = SCM_CHARSET_SIZE;
- p = (long *) SCM_SMOB_DATA (base_cs);
+ if (clower > SCM_CODEPOINT_MAX)
+ clower = SCM_CODEPOINT_MAX;
+ if (cupper > SCM_CODEPOINT_MAX)
+ cupper = SCM_CODEPOINT_MAX;
+
while (clower < cupper)
{
- p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
+ if (SCM_IS_UNICODE_CHAR (clower))
+ SCM_CHARSET_SET (base_cs, clower);
clower++;
}
return base_cs;
@@ -767,13 +1334,20 @@ SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0,
#define FUNC_NAME s_scm_char_set_size
{
int k, count = 0;
+ scm_t_char_set *cs_data;
SCM_VALIDATE_SMOB (1, cs, charset);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- count++;
- return SCM_I_MAKINUM (count);
+ cs_data = SCM_CHARSET_DATA (cs);
+
+ if (cs_data->len == 0)
+ return scm_from_int (0);
+
+ for (k = 0; k < cs_data->len; k++)
+ count += cs_data->ranges[k].hi - cs_data->ranges[k].lo + 1;
+
+ return scm_from_int (count);
}
+
#undef FUNC_NAME
@@ -784,16 +1358,21 @@ SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0,
#define FUNC_NAME s_scm_char_set_count
{
int k, count = 0;
+ scm_t_wchar n;
+ scm_t_char_set *cs_data;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_SMOB (2, cs, charset);
+ cs_data = SCM_CHARSET_DATA (cs);
+ if (cs_data->len == 0)
+ return scm_from_int (0);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
+ for (k = 0; k < cs_data->len; k++)
+ for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
{
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
- if (scm_is_true (res))
- count++;
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
+ if (scm_is_true (res))
+ count++;
}
return SCM_I_MAKINUM (count);
}
@@ -807,14 +1386,21 @@ SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0,
#define FUNC_NAME s_scm_char_set_to_list
{
int k;
+ scm_t_wchar n;
SCM result = SCM_EOL;
+ scm_t_char_set *p;
SCM_VALIDATE_SMOB (1, cs, charset);
- for (k = SCM_CHARSET_SIZE; k > 0; k--)
- if (SCM_CHARSET_GET (cs, k - 1))
- result = scm_cons (SCM_MAKE_CHAR (k - 1), result);
+ p = SCM_CHARSET_DATA (cs);
+ if (p->len == 0)
+ return SCM_EOL;
+
+ for (k = p->len - 1; k >= 0; k--)
+ for (n = p->ranges[k].hi; n >= p->ranges[k].lo; n--)
+ result = scm_cons (SCM_MAKE_CHAR (n), result);
return result;
}
+
#undef FUNC_NAME
@@ -828,19 +1414,38 @@ SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0,
int k;
int count = 0;
int idx = 0;
+ int wide = 0;
SCM result;
- char * p;
+ scm_t_wchar n;
+ scm_t_char_set *cs_data;
+ char *buf;
+ scm_t_wchar *wbuf;
SCM_VALIDATE_SMOB (1, cs, charset);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- count++;
- result = scm_i_make_string (count, &p);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
- p[idx++] = k;
+ cs_data = SCM_CHARSET_DATA (cs);
+ if (cs_data->len == 0)
+ return scm_nullstr;
+
+ if (cs_data->ranges[cs_data->len - 1].hi > 255)
+ wide = 1;
+
+ count = scm_to_int (scm_char_set_size (cs));
+ if (wide)
+ result = scm_i_make_wide_string (count, &wbuf);
+ else
+ result = scm_i_make_string (count, &buf);
+
+ for (k = 0; k < cs_data->len; k++)
+ for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
+ {
+ if (wide)
+ wbuf[idx++] = n;
+ else
+ buf[idx++] = n;
+ }
return result;
}
+
#undef FUNC_NAME
@@ -864,20 +1469,27 @@ SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0,
#define FUNC_NAME s_scm_char_set_every
{
int k;
+ scm_t_wchar n;
SCM res = SCM_BOOL_T;
+ scm_t_char_set *cs_data;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_SMOB (2, cs, charset);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
+ 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++)
{
- res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
- if (scm_is_false (res))
- return res;
+ res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
+ if (scm_is_false (res))
+ return res;
}
- return res;
+ return SCM_BOOL_T;
}
+
#undef FUNC_NAME
@@ -888,16 +1500,20 @@ SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0,
#define FUNC_NAME s_scm_char_set_any
{
int k;
+ scm_t_wchar n;
+ scm_t_char_set *cs_data;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_SMOB (2, cs, charset);
- for (k = 0; k < SCM_CHARSET_SIZE; k++)
- if (SCM_CHARSET_GET (cs, k))
+ cs_data = (scm_t_char_set *) cs;
+
+ for (k = 0; k < cs_data->len; k++)
+ for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
{
- SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
- if (scm_is_true (res))
- return res;
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
+ if (scm_is_true (res))
+ return res;
}
return SCM_BOOL_F;
}
@@ -905,27 +1521,24 @@ SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0,
SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1,
- (SCM cs, SCM rest),
- "Add all character arguments to the first argument, which must\n"
- "be a character set.")
+ (SCM cs, SCM rest),
+ "Add all character arguments to the first argument, which must\n"
+ "be a character set.")
#define FUNC_NAME s_scm_char_set_adjoin
{
- long * p;
-
SCM_VALIDATE_SMOB (1, cs, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
cs = scm_char_set_copy (cs);
- p = (long *) SCM_SMOB_DATA (cs);
while (!scm_is_null (rest))
{
SCM chr = SCM_CAR (rest);
- int c;
+ scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ SCM_CHARSET_SET (cs, c);
}
return cs;
}
@@ -933,27 +1546,24 @@ SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1,
SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
- (SCM cs, SCM rest),
- "Delete all character arguments from the first argument, which\n"
- "must be a character set.")
+ (SCM cs, SCM rest),
+ "Delete all character arguments from the first argument, which\n"
+ "must be a character set.")
#define FUNC_NAME s_scm_char_set_delete
{
- long * p;
-
SCM_VALIDATE_SMOB (1, cs, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
cs = scm_char_set_copy (cs);
- p = (long *) SCM_SMOB_DATA (cs);
while (!scm_is_null (rest))
{
SCM chr = SCM_CAR (rest);
- int c;
+ scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
+ SCM_CHARSET_UNSET (cs, c);
}
return cs;
}
@@ -961,26 +1571,23 @@ SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
- (SCM cs, SCM rest),
- "Add all character arguments to the first argument, which must\n"
- "be a character set.")
+ (SCM cs, SCM rest),
+ "Add all character arguments to the first argument, which must\n"
+ "be a character set.")
#define FUNC_NAME s_scm_char_set_adjoin_x
{
- long * p;
-
SCM_VALIDATE_SMOB (1, cs, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
- p = (long *) SCM_SMOB_DATA (cs);
while (!scm_is_null (rest))
{
SCM chr = SCM_CAR (rest);
- int c;
+ scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ SCM_CHARSET_SET (cs, c);
}
return cs;
}
@@ -988,26 +1595,23 @@ SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
- (SCM cs, SCM rest),
- "Delete all character arguments from the first argument, which\n"
- "must be a character set.")
+ (SCM cs, SCM rest),
+ "Delete all character arguments from the first argument, which\n"
+ "must be a character set.")
#define FUNC_NAME s_scm_char_set_delete_x
{
- long * p;
-
SCM_VALIDATE_SMOB (1, cs, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
- p = (long *) SCM_SMOB_DATA (cs);
while (!scm_is_null (rest))
{
SCM chr = SCM_CAR (rest);
- int c;
+ scm_t_wchar c;
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
+ SCM_CHARSET_UNSET (cs, c);
}
return cs;
}
@@ -1015,23 +1619,22 @@ SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0,
- (SCM cs),
- "Return the complement of the character set @var{cs}.")
+ (SCM cs), "Return the complement of the character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_complement
{
- int k;
SCM res;
- long * p, * q;
+ scm_t_char_set *p, *q;
SCM_VALIDATE_SMOB (1, cs, charset);
res = make_char_set (FUNC_NAME);
- p = (long *) SCM_SMOB_DATA (res);
- q = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] = ~q[k];
+ p = SCM_CHARSET_DATA (res);
+ q = SCM_CHARSET_DATA (cs);
+
+ charsets_complement (p, q);
return res;
}
+
#undef FUNC_NAME
@@ -1042,22 +1645,21 @@ SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1,
{
int c = 1;
SCM res;
- long * p;
+ scm_t_char_set *p;
SCM_VALIDATE_REST_ARGUMENT (rest);
res = make_char_set (FUNC_NAME);
- p = (long *) SCM_SMOB_DATA (res);
+ p = SCM_CHARSET_DATA (res);
while (!scm_is_null (rest))
{
- int k;
SCM cs = SCM_CAR (rest);
SCM_VALIDATE_SMOB (c, cs, charset);
c++;
rest = SCM_CDR (rest);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
+
+ charsets_union (p, (scm_t_char_set *) SCM_SMOB_DATA (cs));
}
return res;
}
@@ -1077,26 +1679,24 @@ SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1,
res = make_char_set (FUNC_NAME);
else
{
- long *p;
+ scm_t_char_set *p;
int argnum = 2;
res = scm_char_set_copy (SCM_CAR (rest));
- p = (long *) SCM_SMOB_DATA (res);
+ p = SCM_CHARSET_DATA (res);
rest = SCM_CDR (rest);
while (scm_is_pair (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- long *cs_data;
-
- SCM_VALIDATE_SMOB (argnum, cs, charset);
- argnum++;
- cs_data = (long *) SCM_SMOB_DATA (cs);
- rest = SCM_CDR (rest);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] &= cs_data[k];
- }
+ {
+ SCM cs = SCM_CAR (rest);
+ scm_t_char_set *cs_data;
+
+ SCM_VALIDATE_SMOB (argnum, cs, charset);
+ argnum++;
+ cs_data = SCM_CHARSET_DATA (cs);
+ rest = SCM_CDR (rest);
+ charsets_intersection (p, cs_data);
+ }
}
return res;
@@ -1110,24 +1710,25 @@ SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1,
#define FUNC_NAME s_scm_char_set_difference
{
int c = 2;
- SCM res;
- long * p;
+ SCM res, compl;
+ scm_t_char_set *p, *q;
SCM_VALIDATE_SMOB (1, cs1, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
res = scm_char_set_copy (cs1);
- p = (long *) SCM_SMOB_DATA (res);
+ p = SCM_CHARSET_DATA (res);
+ compl = make_char_set (FUNC_NAME);
+ q = SCM_CHARSET_DATA (compl);
while (!scm_is_null (rest))
{
- int k;
SCM cs = SCM_CAR (rest);
SCM_VALIDATE_SMOB (c, cs, charset);
c++;
rest = SCM_CDR (rest);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
+ charsets_complement (q, SCM_CHARSET_DATA (cs));
+ charsets_intersection (p, q);
}
return res;
}
@@ -1148,26 +1749,24 @@ SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1,
else
{
int argnum = 2;
- long * p;
+ scm_t_char_set *p;
res = scm_char_set_copy (SCM_CAR (rest));
- p = (long *) SCM_SMOB_DATA (res);
+ p = SCM_CHARSET_DATA (res);
rest = SCM_CDR (rest);
while (scm_is_pair (rest))
- {
- SCM cs = SCM_CAR (rest);
- long *cs_data;
- int k;
-
- SCM_VALIDATE_SMOB (argnum, cs, charset);
- argnum++;
- cs_data = (long *) SCM_SMOB_DATA (cs);
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] ^= cs_data[k];
- }
+ {
+ SCM cs = SCM_CAR (rest);
+ scm_t_char_set *cs_data;
+
+ SCM_VALIDATE_SMOB (argnum, cs, charset);
+ argnum++;
+ cs_data = SCM_CHARSET_DATA (cs);
+ rest = SCM_CDR (rest);
+
+ charsets_xor (p, cs_data);
+ }
}
return res;
}
@@ -1182,30 +1781,26 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1
{
int c = 2;
SCM res1, res2;
- long * p, * q;
+ scm_t_char_set *p, *q;
SCM_VALIDATE_SMOB (1, cs1, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
res1 = scm_char_set_copy (cs1);
res2 = make_char_set (FUNC_NAME);
- p = (long *) SCM_SMOB_DATA (res1);
- q = (long *) SCM_SMOB_DATA (res2);
+ p = SCM_CHARSET_DATA (res1);
+ q = SCM_CHARSET_DATA (res2);
while (!scm_is_null (rest))
{
- int k;
SCM cs = SCM_CAR (rest);
- long *r;
+ scm_t_char_set *r;
SCM_VALIDATE_SMOB (c, cs, charset);
c++;
- r = (long *) SCM_SMOB_DATA (cs);
+ r = SCM_CHARSET_DATA (cs);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- {
- q[k] |= p[k] & r[k];
- p[k] &= ~r[k];
- }
+ charsets_union (q, r);
+ charsets_intersection (p, r);
rest = SCM_CDR (rest);
}
return scm_values (scm_list_2 (res1, res2));
@@ -1214,103 +1809,59 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1
SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0,
- (SCM cs),
- "Return the complement of the character set @var{cs}.")
+ (SCM cs), "Return the complement of the character set @var{cs}.")
#define FUNC_NAME s_scm_char_set_complement_x
{
- int k;
- long * p;
-
SCM_VALIDATE_SMOB (1, cs, charset);
- p = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] = ~p[k];
+ cs = scm_char_set_complement (cs);
return cs;
}
+
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the union of all argument character sets.")
+ (SCM cs1, SCM rest),
+ "Return the union of all argument character sets.")
#define FUNC_NAME s_scm_char_set_union_x
{
- int c = 2;
- long * p;
-
SCM_VALIDATE_SMOB (1, cs1, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
- p = (long *) SCM_SMOB_DATA (cs1);
- while (!scm_is_null (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
- }
+ cs1 = scm_char_set_union (scm_cons (cs1, rest));
return cs1;
}
+
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the intersection of all argument character sets.")
+ (SCM cs1, SCM rest),
+ "Return the intersection of all argument character sets.")
#define FUNC_NAME s_scm_char_set_intersection_x
{
- int c = 2;
- long * p;
-
SCM_VALIDATE_SMOB (1, cs1, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
- p = (long *) SCM_SMOB_DATA (cs1);
- while (!scm_is_null (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
- }
+ cs1 = scm_char_set_intersection (scm_cons (cs1, rest));
return cs1;
}
+
#undef FUNC_NAME
SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the difference of all argument character sets.")
+ (SCM cs1, SCM rest),
+ "Return the difference of all argument character sets.")
#define FUNC_NAME s_scm_char_set_difference_x
{
- int c = 2;
- long * p;
-
SCM_VALIDATE_SMOB (1, cs1, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
- p = (long *) SCM_SMOB_DATA (cs1);
- while (!scm_is_null (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
- }
+ cs1 = scm_char_set_difference (cs1, rest);
return cs1;
}
+
#undef FUNC_NAME
@@ -1323,86 +1874,33 @@ SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
(define a (char-set #\a))
(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));
-
-#if 0
- /* this would give (char-set-xor! a a a) -> empty char set. */
- int c = 2;
- long * p;
-
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- p = (long *) SCM_SMOB_DATA (cs1);
- while (!scm_is_null (rest))
- {
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- rest = SCM_CDR (rest);
-
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k];
- }
- return cs1;
-#endif
}
+
#undef FUNC_NAME
-SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 2, 0, 1,
- (SCM cs1, SCM cs2, SCM rest),
- "Return the difference and the intersection of all argument\n"
- "character sets.")
+SCM_DEFINE (scm_char_set_diff_plus_intersection_x,
+ "char-set-diff+intersection!", 2, 0, 1, (SCM cs1, SCM cs2,
+ SCM rest),
+ "Return the difference and the intersection of all argument\n"
+ "character sets.")
#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
{
- int c = 3;
- long * p, * q;
- int k;
-
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_SMOB (2, cs2, charset);
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- p = (long *) SCM_SMOB_DATA (cs1);
- q = (long *) SCM_SMOB_DATA (cs2);
- if (p == q)
- {
- /* (char-set-diff+intersection! a a ...): can't share storage,
- but we know the answer without checking for further
- arguments. */
- return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1));
- }
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- {
- long t = p[k];
-
- p[k] &= ~q[k];
- q[k] = t & q[k];
- }
- while (!scm_is_null (rest))
- {
- SCM cs = SCM_CAR (rest);
- long *r;
-
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
- r = (long *) SCM_SMOB_DATA (cs);
+ SCM diff, intersect;
- for (k = 0; k < LONGS_PER_CHARSET; k++)
- {
- q[k] |= p[k] & r[k];
- p[k] &= ~r[k];
- }
- rest = SCM_CDR (rest);
- }
+ diff = scm_char_set_difference (cs1, scm_cons (cs2, rest));
+ intersect =
+ scm_char_set_intersection (scm_cons (cs1, scm_cons (cs2, rest)));
+ cs1 = diff;
+ cs2 = intersect;
return scm_values (scm_list_2 (cs1, cs2));
}
-#undef FUNC_NAME
+#undef FUNC_NAME
+
/* Standard character sets. */
SCM scm_char_set_lower_case;
@@ -1426,147 +1924,80 @@ SCM scm_char_set_full;
/* Create an empty character set and return it after binding it to NAME. */
static inline SCM
-define_charset (const char *name)
+define_charset (const char *name, const scm_t_char_set *p)
{
- SCM cs = make_char_set (NULL);
+ SCM cs;
+
+ SCM_NEWSMOB (cs, scm_tc16_charset, p);
scm_c_define (name, cs);
return scm_permanent_object (cs);
}
-/* Membership predicates for the various char sets.
-
- XXX: The `punctuation' and `symbol' char sets have no direct equivalent in
- <ctype.h>. Thus, the predicates below yield correct results for ASCII,
- but they do not provide the result described by the SRFI for Latin-1. The
- correct Latin-1 result could only be obtained by hard-coding the
- characters listed by the SRFI, but the problem would remain for other
- 8-bit charsets.
-
- Similarly, character 0xA0 in Latin-1 (unbreakable space, `#\0240') should
- be part of `char-set:blank'. However, glibc's current (2006/09) Latin-1
- locales (which use the ISO 14652 "i18n" FDCC-set) do not consider it
- `blank' so it ends up in `char-set:punctuation'. */
-#ifdef HAVE_ISBLANK
-# define CSET_BLANK_PRED(c) (isblank (c))
-#else
-# define CSET_BLANK_PRED(c) \
- (((c) == ' ') || ((c) == '\t'))
-#endif
-
-#define CSET_SYMBOL_PRED(c) \
- (((c) != '\0') && (strchr ("$+<=>^`|~", (c)) != NULL))
-#define CSET_PUNCT_PRED(c) \
- ((ispunct (c)) && (!CSET_SYMBOL_PRED (c)))
-
-#define CSET_LOWER_PRED(c) (islower (c))
-#define CSET_UPPER_PRED(c) (isupper (c))
-#define CSET_LETTER_PRED(c) (isalpha (c))
-#define CSET_DIGIT_PRED(c) (isdigit (c))
-#define CSET_WHITESPACE_PRED(c) (isspace (c))
-#define CSET_CONTROL_PRED(c) (iscntrl (c))
-#define CSET_HEX_DIGIT_PRED(c) (isxdigit (c))
-#define CSET_ASCII_PRED(c) (isascii (c))
-
-/* Some char sets are explicitly defined by the SRFI as a union of other char
- sets so we try to follow this closely. */
-
-#define CSET_LETTER_AND_DIGIT_PRED(c) \
- (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c))
-
-#define CSET_GRAPHIC_PRED(c) \
- (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c) \
- || CSET_PUNCT_PRED (c) || CSET_SYMBOL_PRED (c))
-
-#define CSET_PRINTING_PRED(c) \
- (CSET_GRAPHIC_PRED (c) || CSET_WHITESPACE_PRED (c))
-
-/* False and true predicates. */
-#define CSET_TRUE_PRED(c) (1)
-#define CSET_FALSE_PRED(c) (0)
-
-
-/* Compute the contents of all the standard character sets. Computation may
- need to be re-done at `setlocale'-time because some char sets (e.g.,
- `char-set:letter') need to reflect the character set supported by Guile.
-
- For instance, at startup time, the "C" locale is used, thus Guile supports
- only ASCII; therefore, `char-set:letter' only contains English letters.
- The user can change this by invoking `setlocale' and specifying a locale
- with an 8-bit charset, thereby augmenting some of the SRFI-14 standard
- character sets.
-
- This works because some of the predicates used below to construct
- character sets (e.g., `isalpha(3)') are locale-dependent (so
- charset-dependent, though generally not language-dependent). For details,
- please see the `guile-devel' mailing list archive of September 2006. */
-void
-scm_srfi_14_compute_char_sets (void)
+#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_debug_char_set
{
-#define UPDATE_CSET(c, cset, pred) \
- do \
- { \
- if (pred (c)) \
- SCM_CHARSET_SET ((cset), (c)); \
- else \
- SCM_CHARSET_UNSET ((cset), (c)); \
- } \
- while (0)
-
- register int ch;
-
- for (ch = 0; ch < 256; ch++)
+ 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);
+ for (i = 0; i < cs->len; i++)
{
- UPDATE_CSET (ch, scm_char_set_upper_case, CSET_UPPER_PRED);
- UPDATE_CSET (ch, scm_char_set_lower_case, CSET_LOWER_PRED);
- UPDATE_CSET (ch, scm_char_set_title_case, CSET_FALSE_PRED);
- UPDATE_CSET (ch, scm_char_set_letter, CSET_LETTER_PRED);
- UPDATE_CSET (ch, scm_char_set_digit, CSET_DIGIT_PRED);
- UPDATE_CSET (ch, scm_char_set_letter_and_digit,
- CSET_LETTER_AND_DIGIT_PRED);
- UPDATE_CSET (ch, scm_char_set_graphic, CSET_GRAPHIC_PRED);
- UPDATE_CSET (ch, scm_char_set_printing, CSET_PRINTING_PRED);
- UPDATE_CSET (ch, scm_char_set_whitespace, CSET_WHITESPACE_PRED);
- UPDATE_CSET (ch, scm_char_set_iso_control, CSET_CONTROL_PRED);
- UPDATE_CSET (ch, scm_char_set_punctuation, CSET_PUNCT_PRED);
- UPDATE_CSET (ch, scm_char_set_symbol, CSET_SYMBOL_PRED);
- UPDATE_CSET (ch, scm_char_set_hex_digit, CSET_HEX_DIGIT_PRED);
- UPDATE_CSET (ch, scm_char_set_blank, CSET_BLANK_PRED);
- UPDATE_CSET (ch, scm_char_set_ascii, CSET_ASCII_PRED);
- UPDATE_CSET (ch, scm_char_set_empty, CSET_FALSE_PRED);
- UPDATE_CSET (ch, scm_char_set_full, CSET_TRUE_PRED);
+ if (cs->ranges[i].lo == cs->ranges[i].hi)
+ fprintf (stderr, "%04x\n", 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);
}
-
-#undef UPDATE_CSET
+ printf ("\n");
+ return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
+#endif
+
+
void
scm_init_srfi_14 (void)
{
- scm_tc16_charset = scm_make_smob_type ("character-set",
- BYTES_PER_CHARSET);
+ scm_tc16_charset = scm_make_smob_type ("character-set", 0);
scm_set_smob_free (scm_tc16_charset, charset_free);
scm_set_smob_print (scm_tc16_charset, charset_print);
- scm_char_set_upper_case = define_charset ("char-set:upper-case");
- scm_char_set_lower_case = define_charset ("char-set:lower-case");
- scm_char_set_title_case = define_charset ("char-set:title-case");
- scm_char_set_letter = define_charset ("char-set:letter");
- scm_char_set_digit = define_charset ("char-set:digit");
- scm_char_set_letter_and_digit = define_charset ("char-set:letter+digit");
- scm_char_set_graphic = define_charset ("char-set:graphic");
- scm_char_set_printing = define_charset ("char-set:printing");
- scm_char_set_whitespace = define_charset ("char-set:whitespace");
- scm_char_set_iso_control = define_charset ("char-set:iso-control");
- scm_char_set_punctuation = define_charset ("char-set:punctuation");
- scm_char_set_symbol = define_charset ("char-set:symbol");
- scm_char_set_hex_digit = define_charset ("char-set:hex-digit");
- scm_char_set_blank = define_charset ("char-set:blank");
- scm_char_set_ascii = define_charset ("char-set:ascii");
- scm_char_set_empty = define_charset ("char-set:empty");
- scm_char_set_full = define_charset ("char-set:full");
-
- scm_srfi_14_compute_char_sets ();
+ scm_tc16_charset_cursor = scm_make_smob_type ("char-set-cursor", 0);
+ scm_set_smob_free (scm_tc16_charset_cursor, charset_cursor_free);
+ scm_set_smob_print (scm_tc16_charset_cursor, charset_cursor_print);
+
+ scm_char_set_upper_case =
+ define_charset ("char-set:upper-case", &cs_upper_case);
+ scm_char_set_lower_case =
+ define_charset ("char-set:lower-case", &cs_lower_case);
+ scm_char_set_title_case =
+ define_charset ("char-set:title-case", &cs_title_case);
+ scm_char_set_letter = define_charset ("char-set:letter", &cs_letter);
+ scm_char_set_digit = define_charset ("char-set:digit", &cs_digit);
+ scm_char_set_letter_and_digit =
+ define_charset ("char-set:letter+digit", &cs_letter_plus_digit);
+ scm_char_set_graphic = define_charset ("char-set:graphic", &cs_graphic);
+ scm_char_set_printing = define_charset ("char-set:printing", &cs_printing);
+ scm_char_set_whitespace =
+ define_charset ("char-set:whitespace", &cs_whitespace);
+ scm_char_set_iso_control =
+ define_charset ("char-set:iso-control", &cs_iso_control);
+ scm_char_set_punctuation =
+ define_charset ("char-set:punctuation", &cs_punctuation);
+ scm_char_set_symbol = define_charset ("char-set:symbol", &cs_symbol);
+ scm_char_set_hex_digit =
+ define_charset ("char-set:hex-digit", &cs_hex_digit);
+ 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_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 54e0d329c..bdcdd0889 100644
--- a/libguile/srfi-14.h
+++ b/libguile/srfi-14.h
@@ -24,22 +24,34 @@
#include "libguile/__scm.h"
-#define SCM_CHARSET_SIZE 256
+typedef struct
+{
+ scm_t_wchar lo;
+ scm_t_wchar hi;
+} scm_t_char_range;
-/* We expect 8-bit bytes here. Should be no problem in the year
- 2001. */
-#ifndef SCM_BITS_PER_LONG
-# define SCM_BITS_PER_LONG (sizeof (long) * 8)
-#endif
+typedef struct
+{
+ size_t len;
+ scm_t_char_range *ranges;
+} scm_t_char_set;
+
+typedef struct
+{
+ size_t range;
+ scm_t_wchar n;
+} scm_t_char_set_cursor;
-#define SCM_CHARSET_GET(cs, idx) (((long *) SCM_SMOB_DATA (cs))\
- [((unsigned char) (idx)) / SCM_BITS_PER_LONG] &\
- (1L << (((unsigned char) (idx)) % SCM_BITS_PER_LONG)))
+#define SCM_CHARSET_GET(cs,idx) \
+ scm_i_charset_get((scm_t_char_set *)SCM_SMOB_DATA(cs),idx)
#define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset))
/* Smob type code for character sets. */
SCM_API int scm_tc16_charset;
+SCM_INTERNAL int scm_i_charset_get (scm_t_char_set *cs, scm_t_wchar n);
+SCM_INTERNAL void scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n);
+SCM_INTERNAL void scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n);
SCM_API SCM scm_char_set_p (SCM obj);
SCM_API SCM scm_char_set_eq (SCM char_sets);
@@ -88,6 +100,9 @@ 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_API SCM scm_char_set_lower_case;
SCM_API SCM scm_char_set_upper_case;
@@ -107,7 +122,6 @@ SCM_API SCM scm_char_set_ascii;
SCM_API SCM scm_char_set_empty;
SCM_API SCM scm_char_set_full;
-SCM_INTERNAL void scm_srfi_14_compute_char_sets (void);
SCM_INTERNAL void scm_init_srfi_14 (void);
#endif /* SCM_SRFI_14_H */
diff --git a/libguile/srfi-14.i.c b/libguile/srfi-14.i.c
new file mode 100644
index 000000000..5ef21f333
--- /dev/null
+++ b/libguile/srfi-14.i.c
@@ -0,0 +1,7150 @@
+/* srfi-14.i.c -- standard SRFI-14 character set data */
+
+/* This file is #include'd by srfi-14.c. */
+
+/* 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[] = {
+ {0x0061, 0x007a}
+ ,
+ {0x00b5, 0x00b5}
+ ,
+ {0x00df, 0x00f6}
+ ,
+ {0x00f8, 0x00ff}
+ ,
+ {0x0101, 0x0101}
+ ,
+ {0x0103, 0x0103}
+ ,
+ {0x0105, 0x0105}
+ ,
+ {0x0107, 0x0107}
+ ,
+ {0x0109, 0x0109}
+ ,
+ {0x010b, 0x010b}
+ ,
+ {0x010d, 0x010d}
+ ,
+ {0x010f, 0x010f}
+ ,
+ {0x0111, 0x0111}
+ ,
+ {0x0113, 0x0113}
+ ,
+ {0x0115, 0x0115}
+ ,
+ {0x0117, 0x0117}
+ ,
+ {0x0119, 0x0119}
+ ,
+ {0x011b, 0x011b}
+ ,
+ {0x011d, 0x011d}
+ ,
+ {0x011f, 0x011f}
+ ,
+ {0x0121, 0x0121}
+ ,
+ {0x0123, 0x0123}
+ ,
+ {0x0125, 0x0125}
+ ,
+ {0x0127, 0x0127}
+ ,
+ {0x0129, 0x0129}
+ ,
+ {0x012b, 0x012b}
+ ,
+ {0x012d, 0x012d}
+ ,
+ {0x012f, 0x012f}
+ ,
+ {0x0131, 0x0131}
+ ,
+ {0x0133, 0x0133}
+ ,
+ {0x0135, 0x0135}
+ ,
+ {0x0137, 0x0138}
+ ,
+ {0x013a, 0x013a}
+ ,
+ {0x013c, 0x013c}
+ ,
+ {0x013e, 0x013e}
+ ,
+ {0x0140, 0x0140}
+ ,
+ {0x0142, 0x0142}
+ ,
+ {0x0144, 0x0144}
+ ,
+ {0x0146, 0x0146}
+ ,
+ {0x0148, 0x0149}
+ ,
+ {0x014b, 0x014b}
+ ,
+ {0x014d, 0x014d}
+ ,
+ {0x014f, 0x014f}
+ ,
+ {0x0151, 0x0151}
+ ,
+ {0x0153, 0x0153}
+ ,
+ {0x0155, 0x0155}
+ ,
+ {0x0157, 0x0157}
+ ,
+ {0x0159, 0x0159}
+ ,
+ {0x015b, 0x015b}
+ ,
+ {0x015d, 0x015d}
+ ,
+ {0x015f, 0x015f}
+ ,
+ {0x0161, 0x0161}
+ ,
+ {0x0163, 0x0163}
+ ,
+ {0x0165, 0x0165}
+ ,
+ {0x0167, 0x0167}
+ ,
+ {0x0169, 0x0169}
+ ,
+ {0x016b, 0x016b}
+ ,
+ {0x016d, 0x016d}
+ ,
+ {0x016f, 0x016f}
+ ,
+ {0x0171, 0x0171}
+ ,
+ {0x0173, 0x0173}
+ ,
+ {0x0175, 0x0175}
+ ,
+ {0x0177, 0x0177}
+ ,
+ {0x017a, 0x017a}
+ ,
+ {0x017c, 0x017c}
+ ,
+ {0x017e, 0x0180}
+ ,
+ {0x0183, 0x0183}
+ ,
+ {0x0185, 0x0185}
+ ,
+ {0x0188, 0x0188}
+ ,
+ {0x018c, 0x018d}
+ ,
+ {0x0192, 0x0192}
+ ,
+ {0x0195, 0x0195}
+ ,
+ {0x0199, 0x019b}
+ ,
+ {0x019e, 0x019e}
+ ,
+ {0x01a1, 0x01a1}
+ ,
+ {0x01a3, 0x01a3}
+ ,
+ {0x01a5, 0x01a5}
+ ,
+ {0x01a8, 0x01a8}
+ ,
+ {0x01ab, 0x01ab}
+ ,
+ {0x01ad, 0x01ad}
+ ,
+ {0x01b0, 0x01b0}
+ ,
+ {0x01b4, 0x01b4}
+ ,
+ {0x01b6, 0x01b6}
+ ,
+ {0x01b9, 0x01ba}
+ ,
+ {0x01bd, 0x01bd}
+ ,
+ {0x01bf, 0x01bf}
+ ,
+ {0x01c6, 0x01c6}
+ ,
+ {0x01c9, 0x01c9}
+ ,
+ {0x01cc, 0x01cc}
+ ,
+ {0x01ce, 0x01ce}
+ ,
+ {0x01d0, 0x01d0}
+ ,
+ {0x01d2, 0x01d2}
+ ,
+ {0x01d4, 0x01d4}
+ ,
+ {0x01d6, 0x01d6}
+ ,
+ {0x01d8, 0x01d8}
+ ,
+ {0x01da, 0x01da}
+ ,
+ {0x01dc, 0x01dd}
+ ,
+ {0x01df, 0x01df}
+ ,
+ {0x01e1, 0x01e1}
+ ,
+ {0x01e3, 0x01e3}
+ ,
+ {0x01e5, 0x01e5}
+ ,
+ {0x01e7, 0x01e7}
+ ,
+ {0x01e9, 0x01e9}
+ ,
+ {0x01eb, 0x01eb}
+ ,
+ {0x01ed, 0x01ed}
+ ,
+ {0x01ef, 0x01f0}
+ ,
+ {0x01f3, 0x01f3}
+ ,
+ {0x01f5, 0x01f5}
+ ,
+ {0x01f9, 0x01f9}
+ ,
+ {0x01fb, 0x01fb}
+ ,
+ {0x01fd, 0x01fd}
+ ,
+ {0x01ff, 0x01ff}
+ ,
+ {0x0201, 0x0201}
+ ,
+ {0x0203, 0x0203}
+ ,
+ {0x0205, 0x0205}
+ ,
+ {0x0207, 0x0207}
+ ,
+ {0x0209, 0x0209}
+ ,
+ {0x020b, 0x020b}
+ ,
+ {0x020d, 0x020d}
+ ,
+ {0x020f, 0x020f}
+ ,
+ {0x0211, 0x0211}
+ ,
+ {0x0213, 0x0213}
+ ,
+ {0x0215, 0x0215}
+ ,
+ {0x0217, 0x0217}
+ ,
+ {0x0219, 0x0219}
+ ,
+ {0x021b, 0x021b}
+ ,
+ {0x021d, 0x021d}
+ ,
+ {0x021f, 0x021f}
+ ,
+ {0x0221, 0x0221}
+ ,
+ {0x0223, 0x0223}
+ ,
+ {0x0225, 0x0225}
+ ,
+ {0x0227, 0x0227}
+ ,
+ {0x0229, 0x0229}
+ ,
+ {0x022b, 0x022b}
+ ,
+ {0x022d, 0x022d}
+ ,
+ {0x022f, 0x022f}
+ ,
+ {0x0231, 0x0231}
+ ,
+ {0x0233, 0x0239}
+ ,
+ {0x023c, 0x023c}
+ ,
+ {0x023f, 0x0240}
+ ,
+ {0x0242, 0x0242}
+ ,
+ {0x0247, 0x0247}
+ ,
+ {0x0249, 0x0249}
+ ,
+ {0x024b, 0x024b}
+ ,
+ {0x024d, 0x024d}
+ ,
+ {0x024f, 0x0261}
+ ,
+ {0x0263, 0x0269}
+ ,
+ {0x026b, 0x0273}
+ ,
+ {0x0275, 0x0275}
+ ,
+ {0x0277, 0x0280}
+ ,
+ {0x0282, 0x028e}
+ ,
+ {0x0290, 0x0293}
+ ,
+ {0x029a, 0x029a}
+ ,
+ {0x029d, 0x029e}
+ ,
+ {0x02a0, 0x02a0}
+ ,
+ {0x02a3, 0x02ab}
+ ,
+ {0x02ae, 0x02af}
+ ,
+ {0x0345, 0x0345}
+ ,
+ {0x0363, 0x036f}
+ ,
+ {0x0371, 0x0371}
+ ,
+ {0x0373, 0x0373}
+ ,
+ {0x0377, 0x0377}
+ ,
+ {0x037b, 0x037d}
+ ,
+ {0x0390, 0x0390}
+ ,
+ {0x03ac, 0x03ce}
+ ,
+ {0x03d0, 0x03d1}
+ ,
+ {0x03d5, 0x03d7}
+ ,
+ {0x03d9, 0x03d9}
+ ,
+ {0x03db, 0x03db}
+ ,
+ {0x03dd, 0x03dd}
+ ,
+ {0x03df, 0x03df}
+ ,
+ {0x03e1, 0x03e1}
+ ,
+ {0x03e3, 0x03e3}
+ ,
+ {0x03e5, 0x03e5}
+ ,
+ {0x03e7, 0x03e7}
+ ,
+ {0x03e9, 0x03e9}
+ ,
+ {0x03eb, 0x03eb}
+ ,
+ {0x03ed, 0x03ed}
+ ,
+ {0x03ef, 0x03f2}
+ ,
+ {0x03f5, 0x03f5}
+ ,
+ {0x03f8, 0x03f8}
+ ,
+ {0x03fb, 0x03fb}
+ ,
+ {0x0430, 0x045f}
+ ,
+ {0x0461, 0x0461}
+ ,
+ {0x0463, 0x0463}
+ ,
+ {0x0465, 0x0465}
+ ,
+ {0x0467, 0x0467}
+ ,
+ {0x0469, 0x0469}
+ ,
+ {0x046b, 0x046b}
+ ,
+ {0x046d, 0x046d}
+ ,
+ {0x046f, 0x046f}
+ ,
+ {0x0471, 0x0471}
+ ,
+ {0x0473, 0x0473}
+ ,
+ {0x0475, 0x0475}
+ ,
+ {0x0477, 0x0477}
+ ,
+ {0x0479, 0x0479}
+ ,
+ {0x047b, 0x047b}
+ ,
+ {0x047d, 0x047d}
+ ,
+ {0x047f, 0x047f}
+ ,
+ {0x0481, 0x0481}
+ ,
+ {0x048b, 0x048b}
+ ,
+ {0x048d, 0x048d}
+ ,
+ {0x048f, 0x048f}
+ ,
+ {0x0491, 0x0491}
+ ,
+ {0x0493, 0x0493}
+ ,
+ {0x0495, 0x0495}
+ ,
+ {0x0497, 0x0497}
+ ,
+ {0x0499, 0x0499}
+ ,
+ {0x049b, 0x049b}
+ ,
+ {0x049d, 0x049d}
+ ,
+ {0x049f, 0x049f}
+ ,
+ {0x04a1, 0x04a1}
+ ,
+ {0x04a3, 0x04a3}
+ ,
+ {0x04a5, 0x04a5}
+ ,
+ {0x04a7, 0x04a7}
+ ,
+ {0x04a9, 0x04a9}
+ ,
+ {0x04ab, 0x04ab}
+ ,
+ {0x04ad, 0x04ad}
+ ,
+ {0x04af, 0x04af}
+ ,
+ {0x04b1, 0x04b1}
+ ,
+ {0x04b3, 0x04b3}
+ ,
+ {0x04b5, 0x04b5}
+ ,
+ {0x04b7, 0x04b7}
+ ,
+ {0x04b9, 0x04b9}
+ ,
+ {0x04bb, 0x04bb}
+ ,
+ {0x04bd, 0x04bd}
+ ,
+ {0x04bf, 0x04bf}
+ ,
+ {0x04c2, 0x04c2}
+ ,
+ {0x04c4, 0x04c4}
+ ,
+ {0x04c6, 0x04c6}
+ ,
+ {0x04c8, 0x04c8}
+ ,
+ {0x04ca, 0x04ca}
+ ,
+ {0x04cc, 0x04cc}
+ ,
+ {0x04ce, 0x04cf}
+ ,
+ {0x04d1, 0x04d1}
+ ,
+ {0x04d3, 0x04d3}
+ ,
+ {0x04d5, 0x04d5}
+ ,
+ {0x04d7, 0x04d7}
+ ,
+ {0x04d9, 0x04d9}
+ ,
+ {0x04db, 0x04db}
+ ,
+ {0x04dd, 0x04dd}
+ ,
+ {0x04df, 0x04df}
+ ,
+ {0x04e1, 0x04e1}
+ ,
+ {0x04e3, 0x04e3}
+ ,
+ {0x04e5, 0x04e5}
+ ,
+ {0x04e7, 0x04e7}
+ ,
+ {0x04e9, 0x04e9}
+ ,
+ {0x04eb, 0x04eb}
+ ,
+ {0x04ed, 0x04ed}
+ ,
+ {0x04ef, 0x04ef}
+ ,
+ {0x04f1, 0x04f1}
+ ,
+ {0x04f3, 0x04f3}
+ ,
+ {0x04f5, 0x04f5}
+ ,
+ {0x04f7, 0x04f7}
+ ,
+ {0x04f9, 0x04f9}
+ ,
+ {0x04fb, 0x04fb}
+ ,
+ {0x04fd, 0x04fd}
+ ,
+ {0x04ff, 0x04ff}
+ ,
+ {0x0501, 0x0501}
+ ,
+ {0x0503, 0x0503}
+ ,
+ {0x0505, 0x0505}
+ ,
+ {0x0507, 0x0507}
+ ,
+ {0x0509, 0x0509}
+ ,
+ {0x050b, 0x050b}
+ ,
+ {0x050d, 0x050d}
+ ,
+ {0x050f, 0x050f}
+ ,
+ {0x0511, 0x0511}
+ ,
+ {0x0513, 0x0513}
+ ,
+ {0x0515, 0x0515}
+ ,
+ {0x0517, 0x0517}
+ ,
+ {0x0519, 0x0519}
+ ,
+ {0x051b, 0x051b}
+ ,
+ {0x051d, 0x051d}
+ ,
+ {0x051f, 0x051f}
+ ,
+ {0x0521, 0x0521}
+ ,
+ {0x0523, 0x0523}
+ ,
+ {0x0561, 0x0587}
+ ,
+ {0x1930, 0x1938}
+ ,
+ {0x1d02, 0x1d02}
+ ,
+ {0x1d08, 0x1d09}
+ ,
+ {0x1d11, 0x1d14}
+ ,
+ {0x1d16, 0x1d17}
+ ,
+ {0x1d1d, 0x1d1f}
+ ,
+ {0x1d62, 0x1d77}
+ ,
+ {0x1d79, 0x1d7a}
+ ,
+ {0x1d7c, 0x1d7d}
+ ,
+ {0x1d7f, 0x1d9a}
+ ,
+ {0x1dca, 0x1dca}
+ ,
+ {0x1dd3, 0x1dda}
+ ,
+ {0x1ddc, 0x1ddd}
+ ,
+ {0x1de0, 0x1de0}
+ ,
+ {0x1de3, 0x1de6}
+ ,
+ {0x1e01, 0x1e01}
+ ,
+ {0x1e03, 0x1e03}
+ ,
+ {0x1e05, 0x1e05}
+ ,
+ {0x1e07, 0x1e07}
+ ,
+ {0x1e09, 0x1e09}
+ ,
+ {0x1e0b, 0x1e0b}
+ ,
+ {0x1e0d, 0x1e0d}
+ ,
+ {0x1e0f, 0x1e0f}
+ ,
+ {0x1e11, 0x1e11}
+ ,
+ {0x1e13, 0x1e13}
+ ,
+ {0x1e15, 0x1e15}
+ ,
+ {0x1e17, 0x1e17}
+ ,
+ {0x1e19, 0x1e19}
+ ,
+ {0x1e1b, 0x1e1b}
+ ,
+ {0x1e1d, 0x1e1d}
+ ,
+ {0x1e1f, 0x1e1f}
+ ,
+ {0x1e21, 0x1e21}
+ ,
+ {0x1e23, 0x1e23}
+ ,
+ {0x1e25, 0x1e25}
+ ,
+ {0x1e27, 0x1e27}
+ ,
+ {0x1e29, 0x1e29}
+ ,
+ {0x1e2b, 0x1e2b}
+ ,
+ {0x1e2d, 0x1e2d}
+ ,
+ {0x1e2f, 0x1e2f}
+ ,
+ {0x1e31, 0x1e31}
+ ,
+ {0x1e33, 0x1e33}
+ ,
+ {0x1e35, 0x1e35}
+ ,
+ {0x1e37, 0x1e37}
+ ,
+ {0x1e39, 0x1e39}
+ ,
+ {0x1e3b, 0x1e3b}
+ ,
+ {0x1e3d, 0x1e3d}
+ ,
+ {0x1e3f, 0x1e3f}
+ ,
+ {0x1e41, 0x1e41}
+ ,
+ {0x1e43, 0x1e43}
+ ,
+ {0x1e45, 0x1e45}
+ ,
+ {0x1e47, 0x1e47}
+ ,
+ {0x1e49, 0x1e49}
+ ,
+ {0x1e4b, 0x1e4b}
+ ,
+ {0x1e4d, 0x1e4d}
+ ,
+ {0x1e4f, 0x1e4f}
+ ,
+ {0x1e51, 0x1e51}
+ ,
+ {0x1e53, 0x1e53}
+ ,
+ {0x1e55, 0x1e55}
+ ,
+ {0x1e57, 0x1e57}
+ ,
+ {0x1e59, 0x1e59}
+ ,
+ {0x1e5b, 0x1e5b}
+ ,
+ {0x1e5d, 0x1e5d}
+ ,
+ {0x1e5f, 0x1e5f}
+ ,
+ {0x1e61, 0x1e61}
+ ,
+ {0x1e63, 0x1e63}
+ ,
+ {0x1e65, 0x1e65}
+ ,
+ {0x1e67, 0x1e67}
+ ,
+ {0x1e69, 0x1e69}
+ ,
+ {0x1e6b, 0x1e6b}
+ ,
+ {0x1e6d, 0x1e6d}
+ ,
+ {0x1e6f, 0x1e6f}
+ ,
+ {0x1e71, 0x1e71}
+ ,
+ {0x1e73, 0x1e73}
+ ,
+ {0x1e75, 0x1e75}
+ ,
+ {0x1e77, 0x1e77}
+ ,
+ {0x1e79, 0x1e79}
+ ,
+ {0x1e7b, 0x1e7b}
+ ,
+ {0x1e7d, 0x1e7d}
+ ,
+ {0x1e7f, 0x1e7f}
+ ,
+ {0x1e81, 0x1e81}
+ ,
+ {0x1e83, 0x1e83}
+ ,
+ {0x1e85, 0x1e85}
+ ,
+ {0x1e87, 0x1e87}
+ ,
+ {0x1e89, 0x1e89}
+ ,
+ {0x1e8b, 0x1e8b}
+ ,
+ {0x1e8d, 0x1e8d}
+ ,
+ {0x1e8f, 0x1e8f}
+ ,
+ {0x1e91, 0x1e91}
+ ,
+ {0x1e93, 0x1e93}
+ ,
+ {0x1e95, 0x1e9d}
+ ,
+ {0x1e9f, 0x1e9f}
+ ,
+ {0x1ea1, 0x1ea1}
+ ,
+ {0x1ea3, 0x1ea3}
+ ,
+ {0x1ea5, 0x1ea5}
+ ,
+ {0x1ea7, 0x1ea7}
+ ,
+ {0x1ea9, 0x1ea9}
+ ,
+ {0x1eab, 0x1eab}
+ ,
+ {0x1ead, 0x1ead}
+ ,
+ {0x1eaf, 0x1eaf}
+ ,
+ {0x1eb1, 0x1eb1}
+ ,
+ {0x1eb3, 0x1eb3}
+ ,
+ {0x1eb5, 0x1eb5}
+ ,
+ {0x1eb7, 0x1eb7}
+ ,
+ {0x1eb9, 0x1eb9}
+ ,
+ {0x1ebb, 0x1ebb}
+ ,
+ {0x1ebd, 0x1ebd}
+ ,
+ {0x1ebf, 0x1ebf}
+ ,
+ {0x1ec1, 0x1ec1}
+ ,
+ {0x1ec3, 0x1ec3}
+ ,
+ {0x1ec5, 0x1ec5}
+ ,
+ {0x1ec7, 0x1ec7}
+ ,
+ {0x1ec9, 0x1ec9}
+ ,
+ {0x1ecb, 0x1ecb}
+ ,
+ {0x1ecd, 0x1ecd}
+ ,
+ {0x1ecf, 0x1ecf}
+ ,
+ {0x1ed1, 0x1ed1}
+ ,
+ {0x1ed3, 0x1ed3}
+ ,
+ {0x1ed5, 0x1ed5}
+ ,
+ {0x1ed7, 0x1ed7}
+ ,
+ {0x1ed9, 0x1ed9}
+ ,
+ {0x1edb, 0x1edb}
+ ,
+ {0x1edd, 0x1edd}
+ ,
+ {0x1edf, 0x1edf}
+ ,
+ {0x1ee1, 0x1ee1}
+ ,
+ {0x1ee3, 0x1ee3}
+ ,
+ {0x1ee5, 0x1ee5}
+ ,
+ {0x1ee7, 0x1ee7}
+ ,
+ {0x1ee9, 0x1ee9}
+ ,
+ {0x1eeb, 0x1eeb}
+ ,
+ {0x1eed, 0x1eed}
+ ,
+ {0x1eef, 0x1eef}
+ ,
+ {0x1ef1, 0x1ef1}
+ ,
+ {0x1ef3, 0x1ef3}
+ ,
+ {0x1ef5, 0x1ef5}
+ ,
+ {0x1ef7, 0x1ef7}
+ ,
+ {0x1ef9, 0x1ef9}
+ ,
+ {0x1efb, 0x1efb}
+ ,
+ {0x1efd, 0x1efd}
+ ,
+ {0x1eff, 0x1f07}
+ ,
+ {0x1f10, 0x1f15}
+ ,
+ {0x1f20, 0x1f27}
+ ,
+ {0x1f30, 0x1f37}
+ ,
+ {0x1f40, 0x1f45}
+ ,
+ {0x1f50, 0x1f57}
+ ,
+ {0x1f60, 0x1f67}
+ ,
+ {0x1f70, 0x1f7d}
+ ,
+ {0x1f80, 0x1f87}
+ ,
+ {0x1f90, 0x1f97}
+ ,
+ {0x1fa0, 0x1fa7}
+ ,
+ {0x1fb0, 0x1fb4}
+ ,
+ {0x1fb6, 0x1fb7}
+ ,
+ {0x1fbe, 0x1fbe}
+ ,
+ {0x1fc2, 0x1fc4}
+ ,
+ {0x1fc6, 0x1fc7}
+ ,
+ {0x1fd0, 0x1fd3}
+ ,
+ {0x1fd6, 0x1fd7}
+ ,
+ {0x1fe0, 0x1fe7}
+ ,
+ {0x1ff2, 0x1ff4}
+ ,
+ {0x1ff6, 0x1ff7}
+ ,
+ {0xa641, 0xa641}
+ ,
+ {0xa643, 0xa643}
+ ,
+ {0xa645, 0xa645}
+ ,
+ {0xa647, 0xa647}
+ ,
+ {0xa649, 0xa649}
+ ,
+ {0xa64b, 0xa64b}
+ ,
+ {0xa64d, 0xa64d}
+ ,
+ {0xa64f, 0xa64f}
+ ,
+ {0xa651, 0xa651}
+ ,
+ {0xa653, 0xa653}
+ ,
+ {0xa655, 0xa655}
+ ,
+ {0xa657, 0xa657}
+ ,
+ {0xa659, 0xa659}
+ ,
+ {0xa65b, 0xa65b}
+ ,
+ {0xa65d, 0xa65d}
+ ,
+ {0xa65f, 0xa65f}
+ ,
+ {0xa663, 0xa663}
+ ,
+ {0xa665, 0xa665}
+ ,
+ {0xa667, 0xa667}
+ ,
+ {0xa669, 0xa669}
+ ,
+ {0xa66b, 0xa66b}
+ ,
+ {0xa66d, 0xa66d}
+ ,
+ {0xa681, 0xa681}
+ ,
+ {0xa683, 0xa683}
+ ,
+ {0xa685, 0xa685}
+ ,
+ {0xa687, 0xa687}
+ ,
+ {0xa689, 0xa689}
+ ,
+ {0xa68b, 0xa68b}
+ ,
+ {0xa68d, 0xa68d}
+ ,
+ {0xa68f, 0xa68f}
+ ,
+ {0xa691, 0xa691}
+ ,
+ {0xa693, 0xa693}
+ ,
+ {0xa695, 0xa695}
+ ,
+ {0xa697, 0xa697}
+ ,
+ {0xa723, 0xa723}
+ ,
+ {0xa725, 0xa725}
+ ,
+ {0xa727, 0xa727}
+ ,
+ {0xa729, 0xa729}
+ ,
+ {0xa72b, 0xa72b}
+ ,
+ {0xa72d, 0xa72d}
+ ,
+ {0xa72f, 0xa72f}
+ ,
+ {0xa733, 0xa733}
+ ,
+ {0xa735, 0xa735}
+ ,
+ {0xa737, 0xa737}
+ ,
+ {0xa739, 0xa739}
+ ,
+ {0xa73b, 0xa73b}
+ ,
+ {0xa73d, 0xa73d}
+ ,
+ {0xa73f, 0xa73f}
+ ,
+ {0xa741, 0xa741}
+ ,
+ {0xa743, 0xa743}
+ ,
+ {0xa745, 0xa745}
+ ,
+ {0xa747, 0xa747}
+ ,
+ {0xa749, 0xa749}
+ ,
+ {0xa74b, 0xa74b}
+ ,
+ {0xa74d, 0xa74d}
+ ,
+ {0xa74f, 0xa74f}
+ ,
+ {0xa751, 0xa751}
+ ,
+ {0xa753, 0xa753}
+ ,
+ {0xa755, 0xa755}
+ ,
+ {0xa757, 0xa757}
+ ,
+ {0xa759, 0xa759}
+ ,
+ {0xa75b, 0xa75b}
+ ,
+ {0xa75d, 0xa75d}
+ ,
+ {0xa75f, 0xa75f}
+ ,
+ {0xa761, 0xa761}
+ ,
+ {0xa763, 0xa763}
+ ,
+ {0xa765, 0xa765}
+ ,
+ {0xa767, 0xa767}
+ ,
+ {0xa769, 0xa769}
+ ,
+ {0xa76b, 0xa76b}
+ ,
+ {0xa76d, 0xa76d}
+ ,
+ {0xa76f, 0xa76f}
+ ,
+ {0xa771, 0xa775}
+ ,
+ {0xa777, 0xa778}
+ ,
+ {0xa77a, 0xa77a}
+ ,
+ {0xa77c, 0xa77c}
+ ,
+ {0xa77f, 0xa77f}
+ ,
+ {0xa781, 0xa781}
+ ,
+ {0xa783, 0xa783}
+ ,
+ {0xa785, 0xa785}
+ ,
+ {0xa787, 0xa787}
+ ,
+ {0xa78c, 0xa78c}
+ ,
+ {0xfb00, 0xfb06}
+ ,
+ {0xfb13, 0xfb17}
+ ,
+ {0xff41, 0xff5a}
+ ,
+ {0x10428, 0x1044f}
+ ,
+ {0xe0061, 0xe007a}
+};
+
+scm_t_char_set cs_lower_case = {
+ 523,
+ cs_lower_case_ranges
+};
+
+scm_t_char_range cs_upper_case_ranges[] = {
+ {0x0041, 0x005a}
+ ,
+ {0x00c0, 0x00d6}
+ ,
+ {0x00d8, 0x00de}
+ ,
+ {0x0100, 0x0100}
+ ,
+ {0x0102, 0x0102}
+ ,
+ {0x0104, 0x0104}
+ ,
+ {0x0106, 0x0106}
+ ,
+ {0x0108, 0x0108}
+ ,
+ {0x010a, 0x010a}
+ ,
+ {0x010c, 0x010c}
+ ,
+ {0x010e, 0x010e}
+ ,
+ {0x0110, 0x0110}
+ ,
+ {0x0112, 0x0112}
+ ,
+ {0x0114, 0x0114}
+ ,
+ {0x0116, 0x0116}
+ ,
+ {0x0118, 0x0118}
+ ,
+ {0x011a, 0x011a}
+ ,
+ {0x011c, 0x011c}
+ ,
+ {0x011e, 0x011e}
+ ,
+ {0x0120, 0x0120}
+ ,
+ {0x0122, 0x0122}
+ ,
+ {0x0124, 0x0124}
+ ,
+ {0x0126, 0x0126}
+ ,
+ {0x0128, 0x0128}
+ ,
+ {0x012a, 0x012a}
+ ,
+ {0x012c, 0x012c}
+ ,
+ {0x012e, 0x012e}
+ ,
+ {0x0130, 0x0130}
+ ,
+ {0x0132, 0x0132}
+ ,
+ {0x0134, 0x0134}
+ ,
+ {0x0136, 0x0136}
+ ,
+ {0x0139, 0x0139}
+ ,
+ {0x013b, 0x013b}
+ ,
+ {0x013d, 0x013d}
+ ,
+ {0x013f, 0x013f}
+ ,
+ {0x0141, 0x0141}
+ ,
+ {0x0143, 0x0143}
+ ,
+ {0x0145, 0x0145}
+ ,
+ {0x0147, 0x0147}
+ ,
+ {0x014a, 0x014a}
+ ,
+ {0x014c, 0x014c}
+ ,
+ {0x014e, 0x014e}
+ ,
+ {0x0150, 0x0150}
+ ,
+ {0x0152, 0x0152}
+ ,
+ {0x0154, 0x0154}
+ ,
+ {0x0156, 0x0156}
+ ,
+ {0x0158, 0x0158}
+ ,
+ {0x015a, 0x015a}
+ ,
+ {0x015c, 0x015c}
+ ,
+ {0x015e, 0x015e}
+ ,
+ {0x0160, 0x0160}
+ ,
+ {0x0162, 0x0162}
+ ,
+ {0x0164, 0x0164}
+ ,
+ {0x0166, 0x0166}
+ ,
+ {0x0168, 0x0168}
+ ,
+ {0x016a, 0x016a}
+ ,
+ {0x016c, 0x016c}
+ ,
+ {0x016e, 0x016e}
+ ,
+ {0x0170, 0x0170}
+ ,
+ {0x0172, 0x0172}
+ ,
+ {0x0174, 0x0174}
+ ,
+ {0x0176, 0x0176}
+ ,
+ {0x0178, 0x0179}
+ ,
+ {0x017b, 0x017b}
+ ,
+ {0x017d, 0x017d}
+ ,
+ {0x0181, 0x0182}
+ ,
+ {0x0184, 0x0184}
+ ,
+ {0x0186, 0x0187}
+ ,
+ {0x0189, 0x018b}
+ ,
+ {0x018e, 0x0191}
+ ,
+ {0x0193, 0x0194}
+ ,
+ {0x0196, 0x0198}
+ ,
+ {0x019c, 0x019d}
+ ,
+ {0x019f, 0x01a0}
+ ,
+ {0x01a2, 0x01a2}
+ ,
+ {0x01a4, 0x01a4}
+ ,
+ {0x01a6, 0x01a7}
+ ,
+ {0x01a9, 0x01a9}
+ ,
+ {0x01ac, 0x01ac}
+ ,
+ {0x01ae, 0x01af}
+ ,
+ {0x01b1, 0x01b3}
+ ,
+ {0x01b5, 0x01b5}
+ ,
+ {0x01b7, 0x01b8}
+ ,
+ {0x01bc, 0x01bc}
+ ,
+ {0x01c4, 0x01c4}
+ ,
+ {0x01c7, 0x01c7}
+ ,
+ {0x01ca, 0x01ca}
+ ,
+ {0x01cd, 0x01cd}
+ ,
+ {0x01cf, 0x01cf}
+ ,
+ {0x01d1, 0x01d1}
+ ,
+ {0x01d3, 0x01d3}
+ ,
+ {0x01d5, 0x01d5}
+ ,
+ {0x01d7, 0x01d7}
+ ,
+ {0x01d9, 0x01d9}
+ ,
+ {0x01db, 0x01db}
+ ,
+ {0x01de, 0x01de}
+ ,
+ {0x01e0, 0x01e0}
+ ,
+ {0x01e2, 0x01e2}
+ ,
+ {0x01e4, 0x01e4}
+ ,
+ {0x01e6, 0x01e6}
+ ,
+ {0x01e8, 0x01e8}
+ ,
+ {0x01ea, 0x01ea}
+ ,
+ {0x01ec, 0x01ec}
+ ,
+ {0x01ee, 0x01ee}
+ ,
+ {0x01f1, 0x01f1}
+ ,
+ {0x01f4, 0x01f4}
+ ,
+ {0x01f6, 0x01f8}
+ ,
+ {0x01fa, 0x01fa}
+ ,
+ {0x01fc, 0x01fc}
+ ,
+ {0x01fe, 0x01fe}
+ ,
+ {0x0200, 0x0200}
+ ,
+ {0x0202, 0x0202}
+ ,
+ {0x0204, 0x0204}
+ ,
+ {0x0206, 0x0206}
+ ,
+ {0x0208, 0x0208}
+ ,
+ {0x020a, 0x020a}
+ ,
+ {0x020c, 0x020c}
+ ,
+ {0x020e, 0x020e}
+ ,
+ {0x0210, 0x0210}
+ ,
+ {0x0212, 0x0212}
+ ,
+ {0x0214, 0x0214}
+ ,
+ {0x0216, 0x0216}
+ ,
+ {0x0218, 0x0218}
+ ,
+ {0x021a, 0x021a}
+ ,
+ {0x021c, 0x021c}
+ ,
+ {0x021e, 0x021e}
+ ,
+ {0x0220, 0x0220}
+ ,
+ {0x0222, 0x0222}
+ ,
+ {0x0224, 0x0224}
+ ,
+ {0x0226, 0x0226}
+ ,
+ {0x0228, 0x0228}
+ ,
+ {0x022a, 0x022a}
+ ,
+ {0x022c, 0x022c}
+ ,
+ {0x022e, 0x022e}
+ ,
+ {0x0230, 0x0230}
+ ,
+ {0x0232, 0x0232}
+ ,
+ {0x023a, 0x023b}
+ ,
+ {0x023d, 0x023e}
+ ,
+ {0x0241, 0x0241}
+ ,
+ {0x0243, 0x0246}
+ ,
+ {0x0248, 0x0248}
+ ,
+ {0x024a, 0x024a}
+ ,
+ {0x024c, 0x024c}
+ ,
+ {0x024e, 0x024e}
+ ,
+ {0x0370, 0x0370}
+ ,
+ {0x0372, 0x0372}
+ ,
+ {0x0376, 0x0376}
+ ,
+ {0x0386, 0x0386}
+ ,
+ {0x0388, 0x038a}
+ ,
+ {0x038c, 0x038c}
+ ,
+ {0x038e, 0x038f}
+ ,
+ {0x0391, 0x03a1}
+ ,
+ {0x03a3, 0x03ab}
+ ,
+ {0x03cf, 0x03cf}
+ ,
+ {0x03d8, 0x03d8}
+ ,
+ {0x03da, 0x03da}
+ ,
+ {0x03dc, 0x03dc}
+ ,
+ {0x03de, 0x03de}
+ ,
+ {0x03e0, 0x03e0}
+ ,
+ {0x03e2, 0x03e2}
+ ,
+ {0x03e4, 0x03e4}
+ ,
+ {0x03e6, 0x03e6}
+ ,
+ {0x03e8, 0x03e8}
+ ,
+ {0x03ea, 0x03ea}
+ ,
+ {0x03ec, 0x03ec}
+ ,
+ {0x03ee, 0x03ee}
+ ,
+ {0x03f4, 0x03f4}
+ ,
+ {0x03f7, 0x03f7}
+ ,
+ {0x03f9, 0x03fa}
+ ,
+ {0x03fd, 0x042f}
+ ,
+ {0x0460, 0x0460}
+ ,
+ {0x0462, 0x0462}
+ ,
+ {0x0464, 0x0464}
+ ,
+ {0x0466, 0x0466}
+ ,
+ {0x0468, 0x0468}
+ ,
+ {0x046a, 0x046a}
+ ,
+ {0x046c, 0x046c}
+ ,
+ {0x046e, 0x046e}
+ ,
+ {0x0470, 0x0470}
+ ,
+ {0x0472, 0x0472}
+ ,
+ {0x0474, 0x0474}
+ ,
+ {0x0476, 0x0476}
+ ,
+ {0x0478, 0x0478}
+ ,
+ {0x047a, 0x047a}
+ ,
+ {0x047c, 0x047c}
+ ,
+ {0x047e, 0x047e}
+ ,
+ {0x0480, 0x0480}
+ ,
+ {0x048a, 0x048a}
+ ,
+ {0x048c, 0x048c}
+ ,
+ {0x048e, 0x048e}
+ ,
+ {0x0490, 0x0490}
+ ,
+ {0x0492, 0x0492}
+ ,
+ {0x0494, 0x0494}
+ ,
+ {0x0496, 0x0496}
+ ,
+ {0x0498, 0x0498}
+ ,
+ {0x049a, 0x049a}
+ ,
+ {0x049c, 0x049c}
+ ,
+ {0x049e, 0x049e}
+ ,
+ {0x04a0, 0x04a0}
+ ,
+ {0x04a2, 0x04a2}
+ ,
+ {0x04a4, 0x04a4}
+ ,
+ {0x04a6, 0x04a6}
+ ,
+ {0x04a8, 0x04a8}
+ ,
+ {0x04aa, 0x04aa}
+ ,
+ {0x04ac, 0x04ac}
+ ,
+ {0x04ae, 0x04ae}
+ ,
+ {0x04b0, 0x04b0}
+ ,
+ {0x04b2, 0x04b2}
+ ,
+ {0x04b4, 0x04b4}
+ ,
+ {0x04b6, 0x04b6}
+ ,
+ {0x04b8, 0x04b8}
+ ,
+ {0x04ba, 0x04ba}
+ ,
+ {0x04bc, 0x04bc}
+ ,
+ {0x04be, 0x04be}
+ ,
+ {0x04c0, 0x04c1}
+ ,
+ {0x04c3, 0x04c3}
+ ,
+ {0x04c5, 0x04c5}
+ ,
+ {0x04c7, 0x04c7}
+ ,
+ {0x04c9, 0x04c9}
+ ,
+ {0x04cb, 0x04cb}
+ ,
+ {0x04cd, 0x04cd}
+ ,
+ {0x04d0, 0x04d0}
+ ,
+ {0x04d2, 0x04d2}
+ ,
+ {0x04d4, 0x04d4}
+ ,
+ {0x04d6, 0x04d6}
+ ,
+ {0x04d8, 0x04d8}
+ ,
+ {0x04da, 0x04da}
+ ,
+ {0x04dc, 0x04dc}
+ ,
+ {0x04de, 0x04de}
+ ,
+ {0x04e0, 0x04e0}
+ ,
+ {0x04e2, 0x04e2}
+ ,
+ {0x04e4, 0x04e4}
+ ,
+ {0x04e6, 0x04e6}
+ ,
+ {0x04e8, 0x04e8}
+ ,
+ {0x04ea, 0x04ea}
+ ,
+ {0x04ec, 0x04ec}
+ ,
+ {0x04ee, 0x04ee}
+ ,
+ {0x04f0, 0x04f0}
+ ,
+ {0x04f2, 0x04f2}
+ ,
+ {0x04f4, 0x04f4}
+ ,
+ {0x04f6, 0x04f6}
+ ,
+ {0x04f8, 0x04f8}
+ ,
+ {0x04fa, 0x04fa}
+ ,
+ {0x04fc, 0x04fc}
+ ,
+ {0x04fe, 0x04fe}
+ ,
+ {0x0500, 0x0500}
+ ,
+ {0x0502, 0x0502}
+ ,
+ {0x0504, 0x0504}
+ ,
+ {0x0506, 0x0506}
+ ,
+ {0x0508, 0x0508}
+ ,
+ {0x050a, 0x050a}
+ ,
+ {0x050c, 0x050c}
+ ,
+ {0x050e, 0x050e}
+ ,
+ {0x0510, 0x0510}
+ ,
+ {0x0512, 0x0512}
+ ,
+ {0x0514, 0x0514}
+ ,
+ {0x0516, 0x0516}
+ ,
+ {0x0518, 0x0518}
+ ,
+ {0x051a, 0x051a}
+ ,
+ {0x051c, 0x051c}
+ ,
+ {0x051e, 0x051e}
+ ,
+ {0x0520, 0x0520}
+ ,
+ {0x0522, 0x0522}
+ ,
+ {0x0531, 0x0556}
+ ,
+ {0x10a0, 0x10c5}
+ ,
+ {0x1d7b, 0x1d7b}
+ ,
+ {0x1d7e, 0x1d7e}
+ ,
+ {0x1e00, 0x1e00}
+ ,
+ {0x1e02, 0x1e02}
+ ,
+ {0x1e04, 0x1e04}
+ ,
+ {0x1e06, 0x1e06}
+ ,
+ {0x1e08, 0x1e08}
+ ,
+ {0x1e0a, 0x1e0a}
+ ,
+ {0x1e0c, 0x1e0c}
+ ,
+ {0x1e0e, 0x1e0e}
+ ,
+ {0x1e10, 0x1e10}
+ ,
+ {0x1e12, 0x1e12}
+ ,
+ {0x1e14, 0x1e14}
+ ,
+ {0x1e16, 0x1e16}
+ ,
+ {0x1e18, 0x1e18}
+ ,
+ {0x1e1a, 0x1e1a}
+ ,
+ {0x1e1c, 0x1e1c}
+ ,
+ {0x1e1e, 0x1e1e}
+ ,
+ {0x1e20, 0x1e20}
+ ,
+ {0x1e22, 0x1e22}
+ ,
+ {0x1e24, 0x1e24}
+ ,
+ {0x1e26, 0x1e26}
+ ,
+ {0x1e28, 0x1e28}
+ ,
+ {0x1e2a, 0x1e2a}
+ ,
+ {0x1e2c, 0x1e2c}
+ ,
+ {0x1e2e, 0x1e2e}
+ ,
+ {0x1e30, 0x1e30}
+ ,
+ {0x1e32, 0x1e32}
+ ,
+ {0x1e34, 0x1e34}
+ ,
+ {0x1e36, 0x1e36}
+ ,
+ {0x1e38, 0x1e38}
+ ,
+ {0x1e3a, 0x1e3a}
+ ,
+ {0x1e3c, 0x1e3c}
+ ,
+ {0x1e3e, 0x1e3e}
+ ,
+ {0x1e40, 0x1e40}
+ ,
+ {0x1e42, 0x1e42}
+ ,
+ {0x1e44, 0x1e44}
+ ,
+ {0x1e46, 0x1e46}
+ ,
+ {0x1e48, 0x1e48}
+ ,
+ {0x1e4a, 0x1e4a}
+ ,
+ {0x1e4c, 0x1e4c}
+ ,
+ {0x1e4e, 0x1e4e}
+ ,
+ {0x1e50, 0x1e50}
+ ,
+ {0x1e52, 0x1e52}
+ ,
+ {0x1e54, 0x1e54}
+ ,
+ {0x1e56, 0x1e56}
+ ,
+ {0x1e58, 0x1e58}
+ ,
+ {0x1e5a, 0x1e5a}
+ ,
+ {0x1e5c, 0x1e5c}
+ ,
+ {0x1e5e, 0x1e5e}
+ ,
+ {0x1e60, 0x1e60}
+ ,
+ {0x1e62, 0x1e62}
+ ,
+ {0x1e64, 0x1e64}
+ ,
+ {0x1e66, 0x1e66}
+ ,
+ {0x1e68, 0x1e68}
+ ,
+ {0x1e6a, 0x1e6a}
+ ,
+ {0x1e6c, 0x1e6c}
+ ,
+ {0x1e6e, 0x1e6e}
+ ,
+ {0x1e70, 0x1e70}
+ ,
+ {0x1e72, 0x1e72}
+ ,
+ {0x1e74, 0x1e74}
+ ,
+ {0x1e76, 0x1e76}
+ ,
+ {0x1e78, 0x1e78}
+ ,
+ {0x1e7a, 0x1e7a}
+ ,
+ {0x1e7c, 0x1e7c}
+ ,
+ {0x1e7e, 0x1e7e}
+ ,
+ {0x1e80, 0x1e80}
+ ,
+ {0x1e82, 0x1e82}
+ ,
+ {0x1e84, 0x1e84}
+ ,
+ {0x1e86, 0x1e86}
+ ,
+ {0x1e88, 0x1e88}
+ ,
+ {0x1e8a, 0x1e8a}
+ ,
+ {0x1e8c, 0x1e8c}
+ ,
+ {0x1e8e, 0x1e8e}
+ ,
+ {0x1e90, 0x1e90}
+ ,
+ {0x1e92, 0x1e92}
+ ,
+ {0x1e94, 0x1e94}
+ ,
+ {0x1e9e, 0x1e9e}
+ ,
+ {0x1ea0, 0x1ea0}
+ ,
+ {0x1ea2, 0x1ea2}
+ ,
+ {0x1ea4, 0x1ea4}
+ ,
+ {0x1ea6, 0x1ea6}
+ ,
+ {0x1ea8, 0x1ea8}
+ ,
+ {0x1eaa, 0x1eaa}
+ ,
+ {0x1eac, 0x1eac}
+ ,
+ {0x1eae, 0x1eae}
+ ,
+ {0x1eb0, 0x1eb0}
+ ,
+ {0x1eb2, 0x1eb2}
+ ,
+ {0x1eb4, 0x1eb4}
+ ,
+ {0x1eb6, 0x1eb6}
+ ,
+ {0x1eb8, 0x1eb8}
+ ,
+ {0x1eba, 0x1eba}
+ ,
+ {0x1ebc, 0x1ebc}
+ ,
+ {0x1ebe, 0x1ebe}
+ ,
+ {0x1ec0, 0x1ec0}
+ ,
+ {0x1ec2, 0x1ec2}
+ ,
+ {0x1ec4, 0x1ec4}
+ ,
+ {0x1ec6, 0x1ec6}
+ ,
+ {0x1ec8, 0x1ec8}
+ ,
+ {0x1eca, 0x1eca}
+ ,
+ {0x1ecc, 0x1ecc}
+ ,
+ {0x1ece, 0x1ece}
+ ,
+ {0x1ed0, 0x1ed0}
+ ,
+ {0x1ed2, 0x1ed2}
+ ,
+ {0x1ed4, 0x1ed4}
+ ,
+ {0x1ed6, 0x1ed6}
+ ,
+ {0x1ed8, 0x1ed8}
+ ,
+ {0x1eda, 0x1eda}
+ ,
+ {0x1edc, 0x1edc}
+ ,
+ {0x1ede, 0x1ede}
+ ,
+ {0x1ee0, 0x1ee0}
+ ,
+ {0x1ee2, 0x1ee2}
+ ,
+ {0x1ee4, 0x1ee4}
+ ,
+ {0x1ee6, 0x1ee6}
+ ,
+ {0x1ee8, 0x1ee8}
+ ,
+ {0x1eea, 0x1eea}
+ ,
+ {0x1eec, 0x1eec}
+ ,
+ {0x1eee, 0x1eee}
+ ,
+ {0x1ef0, 0x1ef0}
+ ,
+ {0x1ef2, 0x1ef2}
+ ,
+ {0x1ef4, 0x1ef4}
+ ,
+ {0x1ef6, 0x1ef6}
+ ,
+ {0x1ef8, 0x1ef8}
+ ,
+ {0x1efa, 0x1efa}
+ ,
+ {0x1efc, 0x1efc}
+ ,
+ {0x1efe, 0x1efe}
+ ,
+ {0x1f08, 0x1f0f}
+ ,
+ {0x1f18, 0x1f1d}
+ ,
+ {0x1f28, 0x1f2f}
+ ,
+ {0x1f38, 0x1f3f}
+ ,
+ {0x1f48, 0x1f4d}
+ ,
+ {0x1f59, 0x1f59}
+ ,
+ {0x1f5b, 0x1f5b}
+ ,
+ {0x1f5d, 0x1f5d}
+ ,
+ {0x1f5f, 0x1f5f}
+ ,
+ {0x1f68, 0x1f6f}
+ ,
+ {0x1f88, 0x1f8f}
+ ,
+ {0x1f98, 0x1f9f}
+ ,
+ {0x1fa8, 0x1faf}
+ ,
+ {0x1fb8, 0x1fbc}
+ ,
+ {0x1fc8, 0x1fcc}
+ ,
+ {0x1fd8, 0x1fdb}
+ ,
+ {0x1fe8, 0x1fec}
+ ,
+ {0x1ff8, 0x1ffc}
+ ,
+ {0xa640, 0xa640}
+ ,
+ {0xa642, 0xa642}
+ ,
+ {0xa644, 0xa644}
+ ,
+ {0xa646, 0xa646}
+ ,
+ {0xa648, 0xa648}
+ ,
+ {0xa64a, 0xa64a}
+ ,
+ {0xa64c, 0xa64c}
+ ,
+ {0xa64e, 0xa64e}
+ ,
+ {0xa650, 0xa650}
+ ,
+ {0xa652, 0xa652}
+ ,
+ {0xa654, 0xa654}
+ ,
+ {0xa656, 0xa656}
+ ,
+ {0xa658, 0xa658}
+ ,
+ {0xa65a, 0xa65a}
+ ,
+ {0xa65c, 0xa65c}
+ ,
+ {0xa65e, 0xa65e}
+ ,
+ {0xa662, 0xa662}
+ ,
+ {0xa664, 0xa664}
+ ,
+ {0xa666, 0xa666}
+ ,
+ {0xa668, 0xa668}
+ ,
+ {0xa66a, 0xa66a}
+ ,
+ {0xa66c, 0xa66c}
+ ,
+ {0xa680, 0xa680}
+ ,
+ {0xa682, 0xa682}
+ ,
+ {0xa684, 0xa684}
+ ,
+ {0xa686, 0xa686}
+ ,
+ {0xa688, 0xa688}
+ ,
+ {0xa68a, 0xa68a}
+ ,
+ {0xa68c, 0xa68c}
+ ,
+ {0xa68e, 0xa68e}
+ ,
+ {0xa690, 0xa690}
+ ,
+ {0xa692, 0xa692}
+ ,
+ {0xa694, 0xa694}
+ ,
+ {0xa696, 0xa696}
+ ,
+ {0xa722, 0xa722}
+ ,
+ {0xa724, 0xa724}
+ ,
+ {0xa726, 0xa726}
+ ,
+ {0xa728, 0xa728}
+ ,
+ {0xa72a, 0xa72a}
+ ,
+ {0xa72c, 0xa72c}
+ ,
+ {0xa72e, 0xa72e}
+ ,
+ {0xa732, 0xa732}
+ ,
+ {0xa734, 0xa734}
+ ,
+ {0xa736, 0xa736}
+ ,
+ {0xa738, 0xa738}
+ ,
+ {0xa73a, 0xa73a}
+ ,
+ {0xa73c, 0xa73c}
+ ,
+ {0xa73e, 0xa73e}
+ ,
+ {0xa740, 0xa740}
+ ,
+ {0xa742, 0xa742}
+ ,
+ {0xa744, 0xa744}
+ ,
+ {0xa746, 0xa746}
+ ,
+ {0xa748, 0xa748}
+ ,
+ {0xa74a, 0xa74a}
+ ,
+ {0xa74c, 0xa74c}
+ ,
+ {0xa74e, 0xa74e}
+ ,
+ {0xa750, 0xa750}
+ ,
+ {0xa752, 0xa752}
+ ,
+ {0xa754, 0xa754}
+ ,
+ {0xa756, 0xa756}
+ ,
+ {0xa758, 0xa758}
+ ,
+ {0xa75a, 0xa75a}
+ ,
+ {0xa75c, 0xa75c}
+ ,
+ {0xa75e, 0xa75e}
+ ,
+ {0xa760, 0xa760}
+ ,
+ {0xa762, 0xa762}
+ ,
+ {0xa764, 0xa764}
+ ,
+ {0xa766, 0xa766}
+ ,
+ {0xa768, 0xa768}
+ ,
+ {0xa76a, 0xa76a}
+ ,
+ {0xa76c, 0xa76c}
+ ,
+ {0xa76e, 0xa76e}
+ ,
+ {0xa779, 0xa779}
+ ,
+ {0xa77b, 0xa77b}
+ ,
+ {0xa77d, 0xa77e}
+ ,
+ {0xa780, 0xa780}
+ ,
+ {0xa782, 0xa782}
+ ,
+ {0xa784, 0xa784}
+ ,
+ {0xa786, 0xa786}
+ ,
+ {0xa78b, 0xa78b}
+ ,
+ {0xff21, 0xff3a}
+ ,
+ {0x10400, 0x10427}
+ ,
+ {0xe0041, 0xe005a}
+};
+
+scm_t_char_set cs_upper_case = {
+ 492,
+ cs_upper_case_ranges
+};
+
+scm_t_char_range cs_title_case_ranges[] = {
+ {0x01c5, 0x01c5}
+ ,
+ {0x01c8, 0x01c8}
+ ,
+ {0x01cb, 0x01cb}
+ ,
+ {0x01f2, 0x01f2}
+ ,
+ {0x1f88, 0x1f8f}
+ ,
+ {0x1f98, 0x1f9f}
+ ,
+ {0x1fa8, 0x1faf}
+ ,
+ {0x1fbc, 0x1fbc}
+ ,
+ {0x1fcc, 0x1fcc}
+ ,
+ {0x1ffc, 0x1ffc}
+};
+
+scm_t_char_set cs_title_case = {
+ 10,
+ cs_title_case_ranges
+};
+
+scm_t_char_range cs_letter_ranges[] = {
+ {0x0041, 0x005a}
+ ,
+ {0x0061, 0x007a}
+ ,
+ {0x00aa, 0x00aa}
+ ,
+ {0x00b5, 0x00b5}
+ ,
+ {0x00ba, 0x00ba}
+ ,
+ {0x00c0, 0x00d6}
+ ,
+ {0x00d8, 0x00f6}
+ ,
+ {0x00f8, 0x02c1}
+ ,
+ {0x02c6, 0x02d1}
+ ,
+ {0x02e0, 0x02e4}
+ ,
+ {0x02ec, 0x02ec}
+ ,
+ {0x02ee, 0x02ee}
+ ,
+ {0x0370, 0x0374}
+ ,
+ {0x0376, 0x0377}
+ ,
+ {0x037a, 0x037d}
+ ,
+ {0x0386, 0x0386}
+ ,
+ {0x0388, 0x038a}
+ ,
+ {0x038c, 0x038c}
+ ,
+ {0x038e, 0x03a1}
+ ,
+ {0x03a3, 0x03f5}
+ ,
+ {0x03f7, 0x0481}
+ ,
+ {0x048a, 0x0523}
+ ,
+ {0x0531, 0x0556}
+ ,
+ {0x0559, 0x0559}
+ ,
+ {0x0561, 0x0587}
+ ,
+ {0x05d0, 0x05ea}
+ ,
+ {0x05f0, 0x05f2}
+ ,
+ {0x0621, 0x064a}
+ ,
+ {0x066e, 0x066f}
+ ,
+ {0x0671, 0x06d3}
+ ,
+ {0x06d5, 0x06d5}
+ ,
+ {0x06e5, 0x06e6}
+ ,
+ {0x06ee, 0x06ef}
+ ,
+ {0x06fa, 0x06fc}
+ ,
+ {0x06ff, 0x06ff}
+ ,
+ {0x0710, 0x0710}
+ ,
+ {0x0712, 0x072f}
+ ,
+ {0x074d, 0x07a5}
+ ,
+ {0x07b1, 0x07b1}
+ ,
+ {0x07ca, 0x07ea}
+ ,
+ {0x07f4, 0x07f5}
+ ,
+ {0x07fa, 0x07fa}
+ ,
+ {0x0904, 0x0939}
+ ,
+ {0x093d, 0x093d}
+ ,
+ {0x0950, 0x0950}
+ ,
+ {0x0958, 0x0961}
+ ,
+ {0x0971, 0x0972}
+ ,
+ {0x097b, 0x097f}
+ ,
+ {0x0985, 0x098c}
+ ,
+ {0x098f, 0x0990}
+ ,
+ {0x0993, 0x09a8}
+ ,
+ {0x09aa, 0x09b0}
+ ,
+ {0x09b2, 0x09b2}
+ ,
+ {0x09b6, 0x09b9}
+ ,
+ {0x09bd, 0x09bd}
+ ,
+ {0x09ce, 0x09ce}
+ ,
+ {0x09dc, 0x09dd}
+ ,
+ {0x09df, 0x09e1}
+ ,
+ {0x09f0, 0x09f1}
+ ,
+ {0x0a05, 0x0a0a}
+ ,
+ {0x0a0f, 0x0a10}
+ ,
+ {0x0a13, 0x0a28}
+ ,
+ {0x0a2a, 0x0a30}
+ ,
+ {0x0a32, 0x0a33}
+ ,
+ {0x0a35, 0x0a36}
+ ,
+ {0x0a38, 0x0a39}
+ ,
+ {0x0a59, 0x0a5c}
+ ,
+ {0x0a5e, 0x0a5e}
+ ,
+ {0x0a72, 0x0a74}
+ ,
+ {0x0a85, 0x0a8d}
+ ,
+ {0x0a8f, 0x0a91}
+ ,
+ {0x0a93, 0x0aa8}
+ ,
+ {0x0aaa, 0x0ab0}
+ ,
+ {0x0ab2, 0x0ab3}
+ ,
+ {0x0ab5, 0x0ab9}
+ ,
+ {0x0abd, 0x0abd}
+ ,
+ {0x0ad0, 0x0ad0}
+ ,
+ {0x0ae0, 0x0ae1}
+ ,
+ {0x0b05, 0x0b0c}
+ ,
+ {0x0b0f, 0x0b10}
+ ,
+ {0x0b13, 0x0b28}
+ ,
+ {0x0b2a, 0x0b30}
+ ,
+ {0x0b32, 0x0b33}
+ ,
+ {0x0b35, 0x0b39}
+ ,
+ {0x0b3d, 0x0b3d}
+ ,
+ {0x0b5c, 0x0b5d}
+ ,
+ {0x0b5f, 0x0b61}
+ ,
+ {0x0b71, 0x0b71}
+ ,
+ {0x0b83, 0x0b83}
+ ,
+ {0x0b85, 0x0b8a}
+ ,
+ {0x0b8e, 0x0b90}
+ ,
+ {0x0b92, 0x0b95}
+ ,
+ {0x0b99, 0x0b9a}
+ ,
+ {0x0b9c, 0x0b9c}
+ ,
+ {0x0b9e, 0x0b9f}
+ ,
+ {0x0ba3, 0x0ba4}
+ ,
+ {0x0ba8, 0x0baa}
+ ,
+ {0x0bae, 0x0bb9}
+ ,
+ {0x0bd0, 0x0bd0}
+ ,
+ {0x0c05, 0x0c0c}
+ ,
+ {0x0c0e, 0x0c10}
+ ,
+ {0x0c12, 0x0c28}
+ ,
+ {0x0c2a, 0x0c33}
+ ,
+ {0x0c35, 0x0c39}
+ ,
+ {0x0c3d, 0x0c3d}
+ ,
+ {0x0c58, 0x0c59}
+ ,
+ {0x0c60, 0x0c61}
+ ,
+ {0x0c85, 0x0c8c}
+ ,
+ {0x0c8e, 0x0c90}
+ ,
+ {0x0c92, 0x0ca8}
+ ,
+ {0x0caa, 0x0cb3}
+ ,
+ {0x0cb5, 0x0cb9}
+ ,
+ {0x0cbd, 0x0cbd}
+ ,
+ {0x0cde, 0x0cde}
+ ,
+ {0x0ce0, 0x0ce1}
+ ,
+ {0x0d05, 0x0d0c}
+ ,
+ {0x0d0e, 0x0d10}
+ ,
+ {0x0d12, 0x0d28}
+ ,
+ {0x0d2a, 0x0d39}
+ ,
+ {0x0d3d, 0x0d3d}
+ ,
+ {0x0d60, 0x0d61}
+ ,
+ {0x0d7a, 0x0d7f}
+ ,
+ {0x0d85, 0x0d96}
+ ,
+ {0x0d9a, 0x0db1}
+ ,
+ {0x0db3, 0x0dbb}
+ ,
+ {0x0dbd, 0x0dbd}
+ ,
+ {0x0dc0, 0x0dc6}
+ ,
+ {0x0e01, 0x0e30}
+ ,
+ {0x0e32, 0x0e33}
+ ,
+ {0x0e40, 0x0e46}
+ ,
+ {0x0e81, 0x0e82}
+ ,
+ {0x0e84, 0x0e84}
+ ,
+ {0x0e87, 0x0e88}
+ ,
+ {0x0e8a, 0x0e8a}
+ ,
+ {0x0e8d, 0x0e8d}
+ ,
+ {0x0e94, 0x0e97}
+ ,
+ {0x0e99, 0x0e9f}
+ ,
+ {0x0ea1, 0x0ea3}
+ ,
+ {0x0ea5, 0x0ea5}
+ ,
+ {0x0ea7, 0x0ea7}
+ ,
+ {0x0eaa, 0x0eab}
+ ,
+ {0x0ead, 0x0eb0}
+ ,
+ {0x0eb2, 0x0eb3}
+ ,
+ {0x0ebd, 0x0ebd}
+ ,
+ {0x0ec0, 0x0ec4}
+ ,
+ {0x0ec6, 0x0ec6}
+ ,
+ {0x0edc, 0x0edd}
+ ,
+ {0x0f00, 0x0f00}
+ ,
+ {0x0f40, 0x0f47}
+ ,
+ {0x0f49, 0x0f6c}
+ ,
+ {0x0f88, 0x0f8b}
+ ,
+ {0x1000, 0x102a}
+ ,
+ {0x103f, 0x103f}
+ ,
+ {0x1050, 0x1055}
+ ,
+ {0x105a, 0x105d}
+ ,
+ {0x1061, 0x1061}
+ ,
+ {0x1065, 0x1066}
+ ,
+ {0x106e, 0x1070}
+ ,
+ {0x1075, 0x1081}
+ ,
+ {0x108e, 0x108e}
+ ,
+ {0x10a0, 0x10c5}
+ ,
+ {0x10d0, 0x10fa}
+ ,
+ {0x10fc, 0x10fc}
+ ,
+ {0x1100, 0x1159}
+ ,
+ {0x115f, 0x11a2}
+ ,
+ {0x11a8, 0x11f9}
+ ,
+ {0x1200, 0x1248}
+ ,
+ {0x124a, 0x124d}
+ ,
+ {0x1250, 0x1256}
+ ,
+ {0x1258, 0x1258}
+ ,
+ {0x125a, 0x125d}
+ ,
+ {0x1260, 0x1288}
+ ,
+ {0x128a, 0x128d}
+ ,
+ {0x1290, 0x12b0}
+ ,
+ {0x12b2, 0x12b5}
+ ,
+ {0x12b8, 0x12be}
+ ,
+ {0x12c0, 0x12c0}
+ ,
+ {0x12c2, 0x12c5}
+ ,
+ {0x12c8, 0x12d6}
+ ,
+ {0x12d8, 0x1310}
+ ,
+ {0x1312, 0x1315}
+ ,
+ {0x1318, 0x135a}
+ ,
+ {0x1380, 0x138f}
+ ,
+ {0x13a0, 0x13f4}
+ ,
+ {0x1401, 0x166c}
+ ,
+ {0x166f, 0x1676}
+ ,
+ {0x1681, 0x169a}
+ ,
+ {0x16a0, 0x16ea}
+ ,
+ {0x1700, 0x170c}
+ ,
+ {0x170e, 0x1711}
+ ,
+ {0x1720, 0x1731}
+ ,
+ {0x1740, 0x1751}
+ ,
+ {0x1760, 0x176c}
+ ,
+ {0x176e, 0x1770}
+ ,
+ {0x1780, 0x17b3}
+ ,
+ {0x17d7, 0x17d7}
+ ,
+ {0x17dc, 0x17dc}
+ ,
+ {0x1820, 0x1877}
+ ,
+ {0x1880, 0x18a8}
+ ,
+ {0x18aa, 0x18aa}
+ ,
+ {0x1900, 0x191c}
+ ,
+ {0x1950, 0x196d}
+ ,
+ {0x1970, 0x1974}
+ ,
+ {0x1980, 0x19a9}
+ ,
+ {0x19c1, 0x19c7}
+ ,
+ {0x1a00, 0x1a16}
+ ,
+ {0x1b05, 0x1b33}
+ ,
+ {0x1b45, 0x1b4b}
+ ,
+ {0x1b83, 0x1ba0}
+ ,
+ {0x1bae, 0x1baf}
+ ,
+ {0x1c00, 0x1c23}
+ ,
+ {0x1c4d, 0x1c4f}
+ ,
+ {0x1c5a, 0x1c7d}
+ ,
+ {0x1d00, 0x1dbf}
+ ,
+ {0x1e00, 0x1f15}
+ ,
+ {0x1f18, 0x1f1d}
+ ,
+ {0x1f20, 0x1f45}
+ ,
+ {0x1f48, 0x1f4d}
+ ,
+ {0x1f50, 0x1f57}
+ ,
+ {0x1f59, 0x1f59}
+ ,
+ {0x1f5b, 0x1f5b}
+ ,
+ {0x1f5d, 0x1f5d}
+ ,
+ {0x1f5f, 0x1f7d}
+ ,
+ {0x1f80, 0x1fb4}
+ ,
+ {0x1fb6, 0x1fbc}
+ ,
+ {0x1fbe, 0x1fbe}
+ ,
+ {0x1fc2, 0x1fc4}
+ ,
+ {0x1fc6, 0x1fcc}
+ ,
+ {0x1fd0, 0x1fd3}
+ ,
+ {0x1fd6, 0x1fdb}
+ ,
+ {0x1fe0, 0x1fec}
+ ,
+ {0x1ff2, 0x1ff4}
+ ,
+ {0x1ff6, 0x1ffc}
+ ,
+ {0x2071, 0x2071}
+ ,
+ {0x207f, 0x207f}
+ ,
+ {0x2090, 0x2094}
+ ,
+ {0x2102, 0x2102}
+ ,
+ {0x2107, 0x2107}
+ ,
+ {0x210a, 0x2113}
+ ,
+ {0x2115, 0x2115}
+ ,
+ {0x2119, 0x211d}
+ ,
+ {0x2124, 0x2124}
+ ,
+ {0x2126, 0x2126}
+ ,
+ {0x2128, 0x2128}
+ ,
+ {0x212a, 0x212d}
+ ,
+ {0x212f, 0x2139}
+ ,
+ {0x213c, 0x213f}
+ ,
+ {0x2145, 0x2149}
+ ,
+ {0x214e, 0x214e}
+ ,
+ {0x2183, 0x2184}
+ ,
+ {0x2c00, 0x2c2e}
+ ,
+ {0x2c30, 0x2c5e}
+ ,
+ {0x2c60, 0x2c6f}
+ ,
+ {0x2c71, 0x2c7d}
+ ,
+ {0x2c80, 0x2ce4}
+ ,
+ {0x2d00, 0x2d25}
+ ,
+ {0x2d30, 0x2d65}
+ ,
+ {0x2d6f, 0x2d6f}
+ ,
+ {0x2d80, 0x2d96}
+ ,
+ {0x2da0, 0x2da6}
+ ,
+ {0x2da8, 0x2dae}
+ ,
+ {0x2db0, 0x2db6}
+ ,
+ {0x2db8, 0x2dbe}
+ ,
+ {0x2dc0, 0x2dc6}
+ ,
+ {0x2dc8, 0x2dce}
+ ,
+ {0x2dd0, 0x2dd6}
+ ,
+ {0x2dd8, 0x2dde}
+ ,
+ {0x2e2f, 0x2e2f}
+ ,
+ {0x3005, 0x3006}
+ ,
+ {0x3031, 0x3035}
+ ,
+ {0x303b, 0x303c}
+ ,
+ {0x3041, 0x3096}
+ ,
+ {0x309d, 0x309f}
+ ,
+ {0x30a1, 0x30fa}
+ ,
+ {0x30fc, 0x30ff}
+ ,
+ {0x3105, 0x312d}
+ ,
+ {0x3131, 0x318e}
+ ,
+ {0x31a0, 0x31b7}
+ ,
+ {0x31f0, 0x31ff}
+ ,
+ {0x3400, 0x4db5}
+ ,
+ {0x4e00, 0x9fc3}
+ ,
+ {0xa000, 0xa48c}
+ ,
+ {0xa500, 0xa60c}
+ ,
+ {0xa610, 0xa61f}
+ ,
+ {0xa62a, 0xa62b}
+ ,
+ {0xa640, 0xa65f}
+ ,
+ {0xa662, 0xa66e}
+ ,
+ {0xa67f, 0xa697}
+ ,
+ {0xa717, 0xa71f}
+ ,
+ {0xa722, 0xa788}
+ ,
+ {0xa78b, 0xa78c}
+ ,
+ {0xa7fb, 0xa801}
+ ,
+ {0xa803, 0xa805}
+ ,
+ {0xa807, 0xa80a}
+ ,
+ {0xa80c, 0xa822}
+ ,
+ {0xa840, 0xa873}
+ ,
+ {0xa882, 0xa8b3}
+ ,
+ {0xa90a, 0xa925}
+ ,
+ {0xa930, 0xa946}
+ ,
+ {0xaa00, 0xaa28}
+ ,
+ {0xaa40, 0xaa42}
+ ,
+ {0xaa44, 0xaa4b}
+ ,
+ {0xac00, 0xd7a3}
+ ,
+ {0xf900, 0xfa2d}
+ ,
+ {0xfa30, 0xfa6a}
+ ,
+ {0xfa70, 0xfad9}
+ ,
+ {0xfb00, 0xfb06}
+ ,
+ {0xfb13, 0xfb17}
+ ,
+ {0xfb1d, 0xfb1d}
+ ,
+ {0xfb1f, 0xfb28}
+ ,
+ {0xfb2a, 0xfb36}
+ ,
+ {0xfb38, 0xfb3c}
+ ,
+ {0xfb3e, 0xfb3e}
+ ,
+ {0xfb40, 0xfb41}
+ ,
+ {0xfb43, 0xfb44}
+ ,
+ {0xfb46, 0xfbb1}
+ ,
+ {0xfbd3, 0xfd3d}
+ ,
+ {0xfd50, 0xfd8f}
+ ,
+ {0xfd92, 0xfdc7}
+ ,
+ {0xfdf0, 0xfdfb}
+ ,
+ {0xfe70, 0xfe74}
+ ,
+ {0xfe76, 0xfefc}
+ ,
+ {0xff21, 0xff3a}
+ ,
+ {0xff41, 0xff5a}
+ ,
+ {0xff66, 0xffbe}
+ ,
+ {0xffc2, 0xffc7}
+ ,
+ {0xffca, 0xffcf}
+ ,
+ {0xffd2, 0xffd7}
+ ,
+ {0xffda, 0xffdc}
+ ,
+ {0x10000, 0x1000b}
+ ,
+ {0x1000d, 0x10026}
+ ,
+ {0x10028, 0x1003a}
+ ,
+ {0x1003c, 0x1003d}
+ ,
+ {0x1003f, 0x1004d}
+ ,
+ {0x10050, 0x1005d}
+ ,
+ {0x10080, 0x100fa}
+ ,
+ {0x10280, 0x1029c}
+ ,
+ {0x102a0, 0x102d0}
+ ,
+ {0x10300, 0x1031e}
+ ,
+ {0x10330, 0x10340}
+ ,
+ {0x10342, 0x10349}
+ ,
+ {0x10380, 0x1039d}
+ ,
+ {0x103a0, 0x103c3}
+ ,
+ {0x103c8, 0x103cf}
+ ,
+ {0x10400, 0x1049d}
+ ,
+ {0x10800, 0x10805}
+ ,
+ {0x10808, 0x10808}
+ ,
+ {0x1080a, 0x10835}
+ ,
+ {0x10837, 0x10838}
+ ,
+ {0x1083c, 0x1083c}
+ ,
+ {0x1083f, 0x1083f}
+ ,
+ {0x10900, 0x10915}
+ ,
+ {0x10920, 0x10939}
+ ,
+ {0x10a00, 0x10a00}
+ ,
+ {0x10a10, 0x10a13}
+ ,
+ {0x10a15, 0x10a17}
+ ,
+ {0x10a19, 0x10a33}
+ ,
+ {0x12000, 0x1236e}
+ ,
+ {0x1d400, 0x1d454}
+ ,
+ {0x1d456, 0x1d49c}
+ ,
+ {0x1d49e, 0x1d49f}
+ ,
+ {0x1d4a2, 0x1d4a2}
+ ,
+ {0x1d4a5, 0x1d4a6}
+ ,
+ {0x1d4a9, 0x1d4ac}
+ ,
+ {0x1d4ae, 0x1d4b9}
+ ,
+ {0x1d4bb, 0x1d4bb}
+ ,
+ {0x1d4bd, 0x1d4c3}
+ ,
+ {0x1d4c5, 0x1d505}
+ ,
+ {0x1d507, 0x1d50a}
+ ,
+ {0x1d50d, 0x1d514}
+ ,
+ {0x1d516, 0x1d51c}
+ ,
+ {0x1d51e, 0x1d539}
+ ,
+ {0x1d53b, 0x1d53e}
+ ,
+ {0x1d540, 0x1d544}
+ ,
+ {0x1d546, 0x1d546}
+ ,
+ {0x1d54a, 0x1d550}
+ ,
+ {0x1d552, 0x1d6a5}
+ ,
+ {0x1d6a8, 0x1d6c0}
+ ,
+ {0x1d6c2, 0x1d6da}
+ ,
+ {0x1d6dc, 0x1d6fa}
+ ,
+ {0x1d6fc, 0x1d714}
+ ,
+ {0x1d716, 0x1d734}
+ ,
+ {0x1d736, 0x1d74e}
+ ,
+ {0x1d750, 0x1d76e}
+ ,
+ {0x1d770, 0x1d788}
+ ,
+ {0x1d78a, 0x1d7a8}
+ ,
+ {0x1d7aa, 0x1d7c2}
+ ,
+ {0x1d7c4, 0x1d7cb}
+ ,
+ {0x20000, 0x2a6d6}
+ ,
+ {0x2f800, 0x2fa1d}
+};
+
+scm_t_char_set cs_letter = {
+ 390,
+ cs_letter_ranges
+};
+
+scm_t_char_range cs_digit_ranges[] = {
+ {0x0030, 0x0039}
+ ,
+ {0x0660, 0x0669}
+ ,
+ {0x06f0, 0x06f9}
+ ,
+ {0x07c0, 0x07c9}
+ ,
+ {0x0966, 0x096f}
+ ,
+ {0x09e6, 0x09ef}
+ ,
+ {0x0a66, 0x0a6f}
+ ,
+ {0x0ae6, 0x0aef}
+ ,
+ {0x0b66, 0x0b6f}
+ ,
+ {0x0be6, 0x0bef}
+ ,
+ {0x0c66, 0x0c6f}
+ ,
+ {0x0ce6, 0x0cef}
+ ,
+ {0x0d66, 0x0d6f}
+ ,
+ {0x0e50, 0x0e59}
+ ,
+ {0x0ed0, 0x0ed9}
+ ,
+ {0x0f20, 0x0f29}
+ ,
+ {0x1040, 0x1049}
+ ,
+ {0x1090, 0x1099}
+ ,
+ {0x17e0, 0x17e9}
+ ,
+ {0x1810, 0x1819}
+ ,
+ {0x1946, 0x194f}
+ ,
+ {0x19d0, 0x19d9}
+ ,
+ {0x1b50, 0x1b59}
+ ,
+ {0x1bb0, 0x1bb9}
+ ,
+ {0x1c40, 0x1c49}
+ ,
+ {0x1c50, 0x1c59}
+ ,
+ {0xa620, 0xa629}
+ ,
+ {0xa8d0, 0xa8d9}
+ ,
+ {0xa900, 0xa909}
+ ,
+ {0xaa50, 0xaa59}
+ ,
+ {0xff10, 0xff19}
+ ,
+ {0x104a0, 0x104a9}
+ ,
+ {0x1d7ce, 0x1d7ff}
+};
+
+scm_t_char_set cs_digit = {
+ 33,
+ cs_digit_ranges
+};
+
+scm_t_char_range cs_hex_digit_ranges[] = {
+ {0x0030, 0x0039}
+ ,
+ {0x0041, 0x0046}
+ ,
+ {0x0061, 0x0066}
+};
+
+scm_t_char_set cs_hex_digit = {
+ 3,
+ cs_hex_digit_ranges
+};
+
+scm_t_char_range cs_letter_plus_digit_ranges[] = {
+ {0x0030, 0x0039}
+ ,
+ {0x0041, 0x005a}
+ ,
+ {0x0061, 0x007a}
+ ,
+ {0x00aa, 0x00aa}
+ ,
+ {0x00b5, 0x00b5}
+ ,
+ {0x00ba, 0x00ba}
+ ,
+ {0x00c0, 0x00d6}
+ ,
+ {0x00d8, 0x00f6}
+ ,
+ {0x00f8, 0x02c1}
+ ,
+ {0x02c6, 0x02d1}
+ ,
+ {0x02e0, 0x02e4}
+ ,
+ {0x02ec, 0x02ec}
+ ,
+ {0x02ee, 0x02ee}
+ ,
+ {0x0370, 0x0374}
+ ,
+ {0x0376, 0x0377}
+ ,
+ {0x037a, 0x037d}
+ ,
+ {0x0386, 0x0386}
+ ,
+ {0x0388, 0x038a}
+ ,
+ {0x038c, 0x038c}
+ ,
+ {0x038e, 0x03a1}
+ ,
+ {0x03a3, 0x03f5}
+ ,
+ {0x03f7, 0x0481}
+ ,
+ {0x048a, 0x0523}
+ ,
+ {0x0531, 0x0556}
+ ,
+ {0x0559, 0x0559}
+ ,
+ {0x0561, 0x0587}
+ ,
+ {0x05d0, 0x05ea}
+ ,
+ {0x05f0, 0x05f2}
+ ,
+ {0x0621, 0x064a}
+ ,
+ {0x0660, 0x0669}
+ ,
+ {0x066e, 0x066f}
+ ,
+ {0x0671, 0x06d3}
+ ,
+ {0x06d5, 0x06d5}
+ ,
+ {0x06e5, 0x06e6}
+ ,
+ {0x06ee, 0x06fc}
+ ,
+ {0x06ff, 0x06ff}
+ ,
+ {0x0710, 0x0710}
+ ,
+ {0x0712, 0x072f}
+ ,
+ {0x074d, 0x07a5}
+ ,
+ {0x07b1, 0x07b1}
+ ,
+ {0x07c0, 0x07ea}
+ ,
+ {0x07f4, 0x07f5}
+ ,
+ {0x07fa, 0x07fa}
+ ,
+ {0x0904, 0x0939}
+ ,
+ {0x093d, 0x093d}
+ ,
+ {0x0950, 0x0950}
+ ,
+ {0x0958, 0x0961}
+ ,
+ {0x0966, 0x096f}
+ ,
+ {0x0971, 0x0972}
+ ,
+ {0x097b, 0x097f}
+ ,
+ {0x0985, 0x098c}
+ ,
+ {0x098f, 0x0990}
+ ,
+ {0x0993, 0x09a8}
+ ,
+ {0x09aa, 0x09b0}
+ ,
+ {0x09b2, 0x09b2}
+ ,
+ {0x09b6, 0x09b9}
+ ,
+ {0x09bd, 0x09bd}
+ ,
+ {0x09ce, 0x09ce}
+ ,
+ {0x09dc, 0x09dd}
+ ,
+ {0x09df, 0x09e1}
+ ,
+ {0x09e6, 0x09f1}
+ ,
+ {0x0a05, 0x0a0a}
+ ,
+ {0x0a0f, 0x0a10}
+ ,
+ {0x0a13, 0x0a28}
+ ,
+ {0x0a2a, 0x0a30}
+ ,
+ {0x0a32, 0x0a33}
+ ,
+ {0x0a35, 0x0a36}
+ ,
+ {0x0a38, 0x0a39}
+ ,
+ {0x0a59, 0x0a5c}
+ ,
+ {0x0a5e, 0x0a5e}
+ ,
+ {0x0a66, 0x0a6f}
+ ,
+ {0x0a72, 0x0a74}
+ ,
+ {0x0a85, 0x0a8d}
+ ,
+ {0x0a8f, 0x0a91}
+ ,
+ {0x0a93, 0x0aa8}
+ ,
+ {0x0aaa, 0x0ab0}
+ ,
+ {0x0ab2, 0x0ab3}
+ ,
+ {0x0ab5, 0x0ab9}
+ ,
+ {0x0abd, 0x0abd}
+ ,
+ {0x0ad0, 0x0ad0}
+ ,
+ {0x0ae0, 0x0ae1}
+ ,
+ {0x0ae6, 0x0aef}
+ ,
+ {0x0b05, 0x0b0c}
+ ,
+ {0x0b0f, 0x0b10}
+ ,
+ {0x0b13, 0x0b28}
+ ,
+ {0x0b2a, 0x0b30}
+ ,
+ {0x0b32, 0x0b33}
+ ,
+ {0x0b35, 0x0b39}
+ ,
+ {0x0b3d, 0x0b3d}
+ ,
+ {0x0b5c, 0x0b5d}
+ ,
+ {0x0b5f, 0x0b61}
+ ,
+ {0x0b66, 0x0b6f}
+ ,
+ {0x0b71, 0x0b71}
+ ,
+ {0x0b83, 0x0b83}
+ ,
+ {0x0b85, 0x0b8a}
+ ,
+ {0x0b8e, 0x0b90}
+ ,
+ {0x0b92, 0x0b95}
+ ,
+ {0x0b99, 0x0b9a}
+ ,
+ {0x0b9c, 0x0b9c}
+ ,
+ {0x0b9e, 0x0b9f}
+ ,
+ {0x0ba3, 0x0ba4}
+ ,
+ {0x0ba8, 0x0baa}
+ ,
+ {0x0bae, 0x0bb9}
+ ,
+ {0x0bd0, 0x0bd0}
+ ,
+ {0x0be6, 0x0bef}
+ ,
+ {0x0c05, 0x0c0c}
+ ,
+ {0x0c0e, 0x0c10}
+ ,
+ {0x0c12, 0x0c28}
+ ,
+ {0x0c2a, 0x0c33}
+ ,
+ {0x0c35, 0x0c39}
+ ,
+ {0x0c3d, 0x0c3d}
+ ,
+ {0x0c58, 0x0c59}
+ ,
+ {0x0c60, 0x0c61}
+ ,
+ {0x0c66, 0x0c6f}
+ ,
+ {0x0c85, 0x0c8c}
+ ,
+ {0x0c8e, 0x0c90}
+ ,
+ {0x0c92, 0x0ca8}
+ ,
+ {0x0caa, 0x0cb3}
+ ,
+ {0x0cb5, 0x0cb9}
+ ,
+ {0x0cbd, 0x0cbd}
+ ,
+ {0x0cde, 0x0cde}
+ ,
+ {0x0ce0, 0x0ce1}
+ ,
+ {0x0ce6, 0x0cef}
+ ,
+ {0x0d05, 0x0d0c}
+ ,
+ {0x0d0e, 0x0d10}
+ ,
+ {0x0d12, 0x0d28}
+ ,
+ {0x0d2a, 0x0d39}
+ ,
+ {0x0d3d, 0x0d3d}
+ ,
+ {0x0d60, 0x0d61}
+ ,
+ {0x0d66, 0x0d6f}
+ ,
+ {0x0d7a, 0x0d7f}
+ ,
+ {0x0d85, 0x0d96}
+ ,
+ {0x0d9a, 0x0db1}
+ ,
+ {0x0db3, 0x0dbb}
+ ,
+ {0x0dbd, 0x0dbd}
+ ,
+ {0x0dc0, 0x0dc6}
+ ,
+ {0x0e01, 0x0e30}
+ ,
+ {0x0e32, 0x0e33}
+ ,
+ {0x0e40, 0x0e46}
+ ,
+ {0x0e50, 0x0e59}
+ ,
+ {0x0e81, 0x0e82}
+ ,
+ {0x0e84, 0x0e84}
+ ,
+ {0x0e87, 0x0e88}
+ ,
+ {0x0e8a, 0x0e8a}
+ ,
+ {0x0e8d, 0x0e8d}
+ ,
+ {0x0e94, 0x0e97}
+ ,
+ {0x0e99, 0x0e9f}
+ ,
+ {0x0ea1, 0x0ea3}
+ ,
+ {0x0ea5, 0x0ea5}
+ ,
+ {0x0ea7, 0x0ea7}
+ ,
+ {0x0eaa, 0x0eab}
+ ,
+ {0x0ead, 0x0eb0}
+ ,
+ {0x0eb2, 0x0eb3}
+ ,
+ {0x0ebd, 0x0ebd}
+ ,
+ {0x0ec0, 0x0ec4}
+ ,
+ {0x0ec6, 0x0ec6}
+ ,
+ {0x0ed0, 0x0ed9}
+ ,
+ {0x0edc, 0x0edd}
+ ,
+ {0x0f00, 0x0f00}
+ ,
+ {0x0f20, 0x0f29}
+ ,
+ {0x0f40, 0x0f47}
+ ,
+ {0x0f49, 0x0f6c}
+ ,
+ {0x0f88, 0x0f8b}
+ ,
+ {0x1000, 0x102a}
+ ,
+ {0x103f, 0x1049}
+ ,
+ {0x1050, 0x1055}
+ ,
+ {0x105a, 0x105d}
+ ,
+ {0x1061, 0x1061}
+ ,
+ {0x1065, 0x1066}
+ ,
+ {0x106e, 0x1070}
+ ,
+ {0x1075, 0x1081}
+ ,
+ {0x108e, 0x108e}
+ ,
+ {0x1090, 0x1099}
+ ,
+ {0x10a0, 0x10c5}
+ ,
+ {0x10d0, 0x10fa}
+ ,
+ {0x10fc, 0x10fc}
+ ,
+ {0x1100, 0x1159}
+ ,
+ {0x115f, 0x11a2}
+ ,
+ {0x11a8, 0x11f9}
+ ,
+ {0x1200, 0x1248}
+ ,
+ {0x124a, 0x124d}
+ ,
+ {0x1250, 0x1256}
+ ,
+ {0x1258, 0x1258}
+ ,
+ {0x125a, 0x125d}
+ ,
+ {0x1260, 0x1288}
+ ,
+ {0x128a, 0x128d}
+ ,
+ {0x1290, 0x12b0}
+ ,
+ {0x12b2, 0x12b5}
+ ,
+ {0x12b8, 0x12be}
+ ,
+ {0x12c0, 0x12c0}
+ ,
+ {0x12c2, 0x12c5}
+ ,
+ {0x12c8, 0x12d6}
+ ,
+ {0x12d8, 0x1310}
+ ,
+ {0x1312, 0x1315}
+ ,
+ {0x1318, 0x135a}
+ ,
+ {0x1380, 0x138f}
+ ,
+ {0x13a0, 0x13f4}
+ ,
+ {0x1401, 0x166c}
+ ,
+ {0x166f, 0x1676}
+ ,
+ {0x1681, 0x169a}
+ ,
+ {0x16a0, 0x16ea}
+ ,
+ {0x1700, 0x170c}
+ ,
+ {0x170e, 0x1711}
+ ,
+ {0x1720, 0x1731}
+ ,
+ {0x1740, 0x1751}
+ ,
+ {0x1760, 0x176c}
+ ,
+ {0x176e, 0x1770}
+ ,
+ {0x1780, 0x17b3}
+ ,
+ {0x17d7, 0x17d7}
+ ,
+ {0x17dc, 0x17dc}
+ ,
+ {0x17e0, 0x17e9}
+ ,
+ {0x1810, 0x1819}
+ ,
+ {0x1820, 0x1877}
+ ,
+ {0x1880, 0x18a8}
+ ,
+ {0x18aa, 0x18aa}
+ ,
+ {0x1900, 0x191c}
+ ,
+ {0x1946, 0x196d}
+ ,
+ {0x1970, 0x1974}
+ ,
+ {0x1980, 0x19a9}
+ ,
+ {0x19c1, 0x19c7}
+ ,
+ {0x19d0, 0x19d9}
+ ,
+ {0x1a00, 0x1a16}
+ ,
+ {0x1b05, 0x1b33}
+ ,
+ {0x1b45, 0x1b4b}
+ ,
+ {0x1b50, 0x1b59}
+ ,
+ {0x1b83, 0x1ba0}
+ ,
+ {0x1bae, 0x1bb9}
+ ,
+ {0x1c00, 0x1c23}
+ ,
+ {0x1c40, 0x1c49}
+ ,
+ {0x1c4d, 0x1c7d}
+ ,
+ {0x1d00, 0x1dbf}
+ ,
+ {0x1e00, 0x1f15}
+ ,
+ {0x1f18, 0x1f1d}
+ ,
+ {0x1f20, 0x1f45}
+ ,
+ {0x1f48, 0x1f4d}
+ ,
+ {0x1f50, 0x1f57}
+ ,
+ {0x1f59, 0x1f59}
+ ,
+ {0x1f5b, 0x1f5b}
+ ,
+ {0x1f5d, 0x1f5d}
+ ,
+ {0x1f5f, 0x1f7d}
+ ,
+ {0x1f80, 0x1fb4}
+ ,
+ {0x1fb6, 0x1fbc}
+ ,
+ {0x1fbe, 0x1fbe}
+ ,
+ {0x1fc2, 0x1fc4}
+ ,
+ {0x1fc6, 0x1fcc}
+ ,
+ {0x1fd0, 0x1fd3}
+ ,
+ {0x1fd6, 0x1fdb}
+ ,
+ {0x1fe0, 0x1fec}
+ ,
+ {0x1ff2, 0x1ff4}
+ ,
+ {0x1ff6, 0x1ffc}
+ ,
+ {0x2071, 0x2071}
+ ,
+ {0x207f, 0x207f}
+ ,
+ {0x2090, 0x2094}
+ ,
+ {0x2102, 0x2102}
+ ,
+ {0x2107, 0x2107}
+ ,
+ {0x210a, 0x2113}
+ ,
+ {0x2115, 0x2115}
+ ,
+ {0x2119, 0x211d}
+ ,
+ {0x2124, 0x2124}
+ ,
+ {0x2126, 0x2126}
+ ,
+ {0x2128, 0x2128}
+ ,
+ {0x212a, 0x212d}
+ ,
+ {0x212f, 0x2139}
+ ,
+ {0x213c, 0x213f}
+ ,
+ {0x2145, 0x2149}
+ ,
+ {0x214e, 0x214e}
+ ,
+ {0x2183, 0x2184}
+ ,
+ {0x2c00, 0x2c2e}
+ ,
+ {0x2c30, 0x2c5e}
+ ,
+ {0x2c60, 0x2c6f}
+ ,
+ {0x2c71, 0x2c7d}
+ ,
+ {0x2c80, 0x2ce4}
+ ,
+ {0x2d00, 0x2d25}
+ ,
+ {0x2d30, 0x2d65}
+ ,
+ {0x2d6f, 0x2d6f}
+ ,
+ {0x2d80, 0x2d96}
+ ,
+ {0x2da0, 0x2da6}
+ ,
+ {0x2da8, 0x2dae}
+ ,
+ {0x2db0, 0x2db6}
+ ,
+ {0x2db8, 0x2dbe}
+ ,
+ {0x2dc0, 0x2dc6}
+ ,
+ {0x2dc8, 0x2dce}
+ ,
+ {0x2dd0, 0x2dd6}
+ ,
+ {0x2dd8, 0x2dde}
+ ,
+ {0x2e2f, 0x2e2f}
+ ,
+ {0x3005, 0x3006}
+ ,
+ {0x3031, 0x3035}
+ ,
+ {0x303b, 0x303c}
+ ,
+ {0x3041, 0x3096}
+ ,
+ {0x309d, 0x309f}
+ ,
+ {0x30a1, 0x30fa}
+ ,
+ {0x30fc, 0x30ff}
+ ,
+ {0x3105, 0x312d}
+ ,
+ {0x3131, 0x318e}
+ ,
+ {0x31a0, 0x31b7}
+ ,
+ {0x31f0, 0x31ff}
+ ,
+ {0x3400, 0x4db5}
+ ,
+ {0x4e00, 0x9fc3}
+ ,
+ {0xa000, 0xa48c}
+ ,
+ {0xa500, 0xa60c}
+ ,
+ {0xa610, 0xa62b}
+ ,
+ {0xa640, 0xa65f}
+ ,
+ {0xa662, 0xa66e}
+ ,
+ {0xa67f, 0xa697}
+ ,
+ {0xa717, 0xa71f}
+ ,
+ {0xa722, 0xa788}
+ ,
+ {0xa78b, 0xa78c}
+ ,
+ {0xa7fb, 0xa801}
+ ,
+ {0xa803, 0xa805}
+ ,
+ {0xa807, 0xa80a}
+ ,
+ {0xa80c, 0xa822}
+ ,
+ {0xa840, 0xa873}
+ ,
+ {0xa882, 0xa8b3}
+ ,
+ {0xa8d0, 0xa8d9}
+ ,
+ {0xa900, 0xa925}
+ ,
+ {0xa930, 0xa946}
+ ,
+ {0xaa00, 0xaa28}
+ ,
+ {0xaa40, 0xaa42}
+ ,
+ {0xaa44, 0xaa4b}
+ ,
+ {0xaa50, 0xaa59}
+ ,
+ {0xac00, 0xd7a3}
+ ,
+ {0xf900, 0xfa2d}
+ ,
+ {0xfa30, 0xfa6a}
+ ,
+ {0xfa70, 0xfad9}
+ ,
+ {0xfb00, 0xfb06}
+ ,
+ {0xfb13, 0xfb17}
+ ,
+ {0xfb1d, 0xfb1d}
+ ,
+ {0xfb1f, 0xfb28}
+ ,
+ {0xfb2a, 0xfb36}
+ ,
+ {0xfb38, 0xfb3c}
+ ,
+ {0xfb3e, 0xfb3e}
+ ,
+ {0xfb40, 0xfb41}
+ ,
+ {0xfb43, 0xfb44}
+ ,
+ {0xfb46, 0xfbb1}
+ ,
+ {0xfbd3, 0xfd3d}
+ ,
+ {0xfd50, 0xfd8f}
+ ,
+ {0xfd92, 0xfdc7}
+ ,
+ {0xfdf0, 0xfdfb}
+ ,
+ {0xfe70, 0xfe74}
+ ,
+ {0xfe76, 0xfefc}
+ ,
+ {0xff10, 0xff19}
+ ,
+ {0xff21, 0xff3a}
+ ,
+ {0xff41, 0xff5a}
+ ,
+ {0xff66, 0xffbe}
+ ,
+ {0xffc2, 0xffc7}
+ ,
+ {0xffca, 0xffcf}
+ ,
+ {0xffd2, 0xffd7}
+ ,
+ {0xffda, 0xffdc}
+ ,
+ {0x10000, 0x1000b}
+ ,
+ {0x1000d, 0x10026}
+ ,
+ {0x10028, 0x1003a}
+ ,
+ {0x1003c, 0x1003d}
+ ,
+ {0x1003f, 0x1004d}
+ ,
+ {0x10050, 0x1005d}
+ ,
+ {0x10080, 0x100fa}
+ ,
+ {0x10280, 0x1029c}
+ ,
+ {0x102a0, 0x102d0}
+ ,
+ {0x10300, 0x1031e}
+ ,
+ {0x10330, 0x10340}
+ ,
+ {0x10342, 0x10349}
+ ,
+ {0x10380, 0x1039d}
+ ,
+ {0x103a0, 0x103c3}
+ ,
+ {0x103c8, 0x103cf}
+ ,
+ {0x10400, 0x1049d}
+ ,
+ {0x104a0, 0x104a9}
+ ,
+ {0x10800, 0x10805}
+ ,
+ {0x10808, 0x10808}
+ ,
+ {0x1080a, 0x10835}
+ ,
+ {0x10837, 0x10838}
+ ,
+ {0x1083c, 0x1083c}
+ ,
+ {0x1083f, 0x1083f}
+ ,
+ {0x10900, 0x10915}
+ ,
+ {0x10920, 0x10939}
+ ,
+ {0x10a00, 0x10a00}
+ ,
+ {0x10a10, 0x10a13}
+ ,
+ {0x10a15, 0x10a17}
+ ,
+ {0x10a19, 0x10a33}
+ ,
+ {0x12000, 0x1236e}
+ ,
+ {0x1d400, 0x1d454}
+ ,
+ {0x1d456, 0x1d49c}
+ ,
+ {0x1d49e, 0x1d49f}
+ ,
+ {0x1d4a2, 0x1d4a2}
+ ,
+ {0x1d4a5, 0x1d4a6}
+ ,
+ {0x1d4a9, 0x1d4ac}
+ ,
+ {0x1d4ae, 0x1d4b9}
+ ,
+ {0x1d4bb, 0x1d4bb}
+ ,
+ {0x1d4bd, 0x1d4c3}
+ ,
+ {0x1d4c5, 0x1d505}
+ ,
+ {0x1d507, 0x1d50a}
+ ,
+ {0x1d50d, 0x1d514}
+ ,
+ {0x1d516, 0x1d51c}
+ ,
+ {0x1d51e, 0x1d539}
+ ,
+ {0x1d53b, 0x1d53e}
+ ,
+ {0x1d540, 0x1d544}
+ ,
+ {0x1d546, 0x1d546}
+ ,
+ {0x1d54a, 0x1d550}
+ ,
+ {0x1d552, 0x1d6a5}
+ ,
+ {0x1d6a8, 0x1d6c0}
+ ,
+ {0x1d6c2, 0x1d6da}
+ ,
+ {0x1d6dc, 0x1d6fa}
+ ,
+ {0x1d6fc, 0x1d714}
+ ,
+ {0x1d716, 0x1d734}
+ ,
+ {0x1d736, 0x1d74e}
+ ,
+ {0x1d750, 0x1d76e}
+ ,
+ {0x1d770, 0x1d788}
+ ,
+ {0x1d78a, 0x1d7a8}
+ ,
+ {0x1d7aa, 0x1d7c2}
+ ,
+ {0x1d7c4, 0x1d7cb}
+ ,
+ {0x1d7ce, 0x1d7ff}
+ ,
+ {0x20000, 0x2a6d6}
+ ,
+ {0x2f800, 0x2fa1d}
+};
+
+scm_t_char_set cs_letter_plus_digit = {
+ 411,
+ cs_letter_plus_digit_ranges
+};
+
+scm_t_char_range cs_graphic_ranges[] = {
+ {0x0021, 0x007e}
+ ,
+ {0x00a1, 0x00ac}
+ ,
+ {0x00ae, 0x0377}
+ ,
+ {0x037a, 0x037e}
+ ,
+ {0x0384, 0x038a}
+ ,
+ {0x038c, 0x038c}
+ ,
+ {0x038e, 0x03a1}
+ ,
+ {0x03a3, 0x0523}
+ ,
+ {0x0531, 0x0556}
+ ,
+ {0x0559, 0x055f}
+ ,
+ {0x0561, 0x0587}
+ ,
+ {0x0589, 0x058a}
+ ,
+ {0x0591, 0x05c7}
+ ,
+ {0x05d0, 0x05ea}
+ ,
+ {0x05f0, 0x05f4}
+ ,
+ {0x0606, 0x061b}
+ ,
+ {0x061e, 0x061f}
+ ,
+ {0x0621, 0x065e}
+ ,
+ {0x0660, 0x06dc}
+ ,
+ {0x06de, 0x070d}
+ ,
+ {0x0710, 0x074a}
+ ,
+ {0x074d, 0x07b1}
+ ,
+ {0x07c0, 0x07fa}
+ ,
+ {0x0901, 0x0939}
+ ,
+ {0x093c, 0x094d}
+ ,
+ {0x0950, 0x0954}
+ ,
+ {0x0958, 0x0972}
+ ,
+ {0x097b, 0x097f}
+ ,
+ {0x0981, 0x0983}
+ ,
+ {0x0985, 0x098c}
+ ,
+ {0x098f, 0x0990}
+ ,
+ {0x0993, 0x09a8}
+ ,
+ {0x09aa, 0x09b0}
+ ,
+ {0x09b2, 0x09b2}
+ ,
+ {0x09b6, 0x09b9}
+ ,
+ {0x09bc, 0x09c4}
+ ,
+ {0x09c7, 0x09c8}
+ ,
+ {0x09cb, 0x09ce}
+ ,
+ {0x09d7, 0x09d7}
+ ,
+ {0x09dc, 0x09dd}
+ ,
+ {0x09df, 0x09e3}
+ ,
+ {0x09e6, 0x09fa}
+ ,
+ {0x0a01, 0x0a03}
+ ,
+ {0x0a05, 0x0a0a}
+ ,
+ {0x0a0f, 0x0a10}
+ ,
+ {0x0a13, 0x0a28}
+ ,
+ {0x0a2a, 0x0a30}
+ ,
+ {0x0a32, 0x0a33}
+ ,
+ {0x0a35, 0x0a36}
+ ,
+ {0x0a38, 0x0a39}
+ ,
+ {0x0a3c, 0x0a3c}
+ ,
+ {0x0a3e, 0x0a42}
+ ,
+ {0x0a47, 0x0a48}
+ ,
+ {0x0a4b, 0x0a4d}
+ ,
+ {0x0a51, 0x0a51}
+ ,
+ {0x0a59, 0x0a5c}
+ ,
+ {0x0a5e, 0x0a5e}
+ ,
+ {0x0a66, 0x0a75}
+ ,
+ {0x0a81, 0x0a83}
+ ,
+ {0x0a85, 0x0a8d}
+ ,
+ {0x0a8f, 0x0a91}
+ ,
+ {0x0a93, 0x0aa8}
+ ,
+ {0x0aaa, 0x0ab0}
+ ,
+ {0x0ab2, 0x0ab3}
+ ,
+ {0x0ab5, 0x0ab9}
+ ,
+ {0x0abc, 0x0ac5}
+ ,
+ {0x0ac7, 0x0ac9}
+ ,
+ {0x0acb, 0x0acd}
+ ,
+ {0x0ad0, 0x0ad0}
+ ,
+ {0x0ae0, 0x0ae3}
+ ,
+ {0x0ae6, 0x0aef}
+ ,
+ {0x0af1, 0x0af1}
+ ,
+ {0x0b01, 0x0b03}
+ ,
+ {0x0b05, 0x0b0c}
+ ,
+ {0x0b0f, 0x0b10}
+ ,
+ {0x0b13, 0x0b28}
+ ,
+ {0x0b2a, 0x0b30}
+ ,
+ {0x0b32, 0x0b33}
+ ,
+ {0x0b35, 0x0b39}
+ ,
+ {0x0b3c, 0x0b44}
+ ,
+ {0x0b47, 0x0b48}
+ ,
+ {0x0b4b, 0x0b4d}
+ ,
+ {0x0b56, 0x0b57}
+ ,
+ {0x0b5c, 0x0b5d}
+ ,
+ {0x0b5f, 0x0b63}
+ ,
+ {0x0b66, 0x0b71}
+ ,
+ {0x0b82, 0x0b83}
+ ,
+ {0x0b85, 0x0b8a}
+ ,
+ {0x0b8e, 0x0b90}
+ ,
+ {0x0b92, 0x0b95}
+ ,
+ {0x0b99, 0x0b9a}
+ ,
+ {0x0b9c, 0x0b9c}
+ ,
+ {0x0b9e, 0x0b9f}
+ ,
+ {0x0ba3, 0x0ba4}
+ ,
+ {0x0ba8, 0x0baa}
+ ,
+ {0x0bae, 0x0bb9}
+ ,
+ {0x0bbe, 0x0bc2}
+ ,
+ {0x0bc6, 0x0bc8}
+ ,
+ {0x0bca, 0x0bcd}
+ ,
+ {0x0bd0, 0x0bd0}
+ ,
+ {0x0bd7, 0x0bd7}
+ ,
+ {0x0be6, 0x0bfa}
+ ,
+ {0x0c01, 0x0c03}
+ ,
+ {0x0c05, 0x0c0c}
+ ,
+ {0x0c0e, 0x0c10}
+ ,
+ {0x0c12, 0x0c28}
+ ,
+ {0x0c2a, 0x0c33}
+ ,
+ {0x0c35, 0x0c39}
+ ,
+ {0x0c3d, 0x0c44}
+ ,
+ {0x0c46, 0x0c48}
+ ,
+ {0x0c4a, 0x0c4d}
+ ,
+ {0x0c55, 0x0c56}
+ ,
+ {0x0c58, 0x0c59}
+ ,
+ {0x0c60, 0x0c63}
+ ,
+ {0x0c66, 0x0c6f}
+ ,
+ {0x0c78, 0x0c7f}
+ ,
+ {0x0c82, 0x0c83}
+ ,
+ {0x0c85, 0x0c8c}
+ ,
+ {0x0c8e, 0x0c90}
+ ,
+ {0x0c92, 0x0ca8}
+ ,
+ {0x0caa, 0x0cb3}
+ ,
+ {0x0cb5, 0x0cb9}
+ ,
+ {0x0cbc, 0x0cc4}
+ ,
+ {0x0cc6, 0x0cc8}
+ ,
+ {0x0cca, 0x0ccd}
+ ,
+ {0x0cd5, 0x0cd6}
+ ,
+ {0x0cde, 0x0cde}
+ ,
+ {0x0ce0, 0x0ce3}
+ ,
+ {0x0ce6, 0x0cef}
+ ,
+ {0x0cf1, 0x0cf2}
+ ,
+ {0x0d02, 0x0d03}
+ ,
+ {0x0d05, 0x0d0c}
+ ,
+ {0x0d0e, 0x0d10}
+ ,
+ {0x0d12, 0x0d28}
+ ,
+ {0x0d2a, 0x0d39}
+ ,
+ {0x0d3d, 0x0d44}
+ ,
+ {0x0d46, 0x0d48}
+ ,
+ {0x0d4a, 0x0d4d}
+ ,
+ {0x0d57, 0x0d57}
+ ,
+ {0x0d60, 0x0d63}
+ ,
+ {0x0d66, 0x0d75}
+ ,
+ {0x0d79, 0x0d7f}
+ ,
+ {0x0d82, 0x0d83}
+ ,
+ {0x0d85, 0x0d96}
+ ,
+ {0x0d9a, 0x0db1}
+ ,
+ {0x0db3, 0x0dbb}
+ ,
+ {0x0dbd, 0x0dbd}
+ ,
+ {0x0dc0, 0x0dc6}
+ ,
+ {0x0dca, 0x0dca}
+ ,
+ {0x0dcf, 0x0dd4}
+ ,
+ {0x0dd6, 0x0dd6}
+ ,
+ {0x0dd8, 0x0ddf}
+ ,
+ {0x0df2, 0x0df4}
+ ,
+ {0x0e01, 0x0e3a}
+ ,
+ {0x0e3f, 0x0e5b}
+ ,
+ {0x0e81, 0x0e82}
+ ,
+ {0x0e84, 0x0e84}
+ ,
+ {0x0e87, 0x0e88}
+ ,
+ {0x0e8a, 0x0e8a}
+ ,
+ {0x0e8d, 0x0e8d}
+ ,
+ {0x0e94, 0x0e97}
+ ,
+ {0x0e99, 0x0e9f}
+ ,
+ {0x0ea1, 0x0ea3}
+ ,
+ {0x0ea5, 0x0ea5}
+ ,
+ {0x0ea7, 0x0ea7}
+ ,
+ {0x0eaa, 0x0eab}
+ ,
+ {0x0ead, 0x0eb9}
+ ,
+ {0x0ebb, 0x0ebd}
+ ,
+ {0x0ec0, 0x0ec4}
+ ,
+ {0x0ec6, 0x0ec6}
+ ,
+ {0x0ec8, 0x0ecd}
+ ,
+ {0x0ed0, 0x0ed9}
+ ,
+ {0x0edc, 0x0edd}
+ ,
+ {0x0f00, 0x0f47}
+ ,
+ {0x0f49, 0x0f6c}
+ ,
+ {0x0f71, 0x0f8b}
+ ,
+ {0x0f90, 0x0f97}
+ ,
+ {0x0f99, 0x0fbc}
+ ,
+ {0x0fbe, 0x0fcc}
+ ,
+ {0x0fce, 0x0fd4}
+ ,
+ {0x1000, 0x1099}
+ ,
+ {0x109e, 0x10c5}
+ ,
+ {0x10d0, 0x10fc}
+ ,
+ {0x1100, 0x1159}
+ ,
+ {0x115f, 0x11a2}
+ ,
+ {0x11a8, 0x11f9}
+ ,
+ {0x1200, 0x1248}
+ ,
+ {0x124a, 0x124d}
+ ,
+ {0x1250, 0x1256}
+ ,
+ {0x1258, 0x1258}
+ ,
+ {0x125a, 0x125d}
+ ,
+ {0x1260, 0x1288}
+ ,
+ {0x128a, 0x128d}
+ ,
+ {0x1290, 0x12b0}
+ ,
+ {0x12b2, 0x12b5}
+ ,
+ {0x12b8, 0x12be}
+ ,
+ {0x12c0, 0x12c0}
+ ,
+ {0x12c2, 0x12c5}
+ ,
+ {0x12c8, 0x12d6}
+ ,
+ {0x12d8, 0x1310}
+ ,
+ {0x1312, 0x1315}
+ ,
+ {0x1318, 0x135a}
+ ,
+ {0x135f, 0x137c}
+ ,
+ {0x1380, 0x1399}
+ ,
+ {0x13a0, 0x13f4}
+ ,
+ {0x1401, 0x1676}
+ ,
+ {0x1681, 0x169c}
+ ,
+ {0x16a0, 0x16f0}
+ ,
+ {0x1700, 0x170c}
+ ,
+ {0x170e, 0x1714}
+ ,
+ {0x1720, 0x1736}
+ ,
+ {0x1740, 0x1753}
+ ,
+ {0x1760, 0x176c}
+ ,
+ {0x176e, 0x1770}
+ ,
+ {0x1772, 0x1773}
+ ,
+ {0x1780, 0x17b3}
+ ,
+ {0x17b6, 0x17dd}
+ ,
+ {0x17e0, 0x17e9}
+ ,
+ {0x17f0, 0x17f9}
+ ,
+ {0x1800, 0x180d}
+ ,
+ {0x1810, 0x1819}
+ ,
+ {0x1820, 0x1877}
+ ,
+ {0x1880, 0x18aa}
+ ,
+ {0x1900, 0x191c}
+ ,
+ {0x1920, 0x192b}
+ ,
+ {0x1930, 0x193b}
+ ,
+ {0x1940, 0x1940}
+ ,
+ {0x1944, 0x196d}
+ ,
+ {0x1970, 0x1974}
+ ,
+ {0x1980, 0x19a9}
+ ,
+ {0x19b0, 0x19c9}
+ ,
+ {0x19d0, 0x19d9}
+ ,
+ {0x19de, 0x1a1b}
+ ,
+ {0x1a1e, 0x1a1f}
+ ,
+ {0x1b00, 0x1b4b}
+ ,
+ {0x1b50, 0x1b7c}
+ ,
+ {0x1b80, 0x1baa}
+ ,
+ {0x1bae, 0x1bb9}
+ ,
+ {0x1c00, 0x1c37}
+ ,
+ {0x1c3b, 0x1c49}
+ ,
+ {0x1c4d, 0x1c7f}
+ ,
+ {0x1d00, 0x1de6}
+ ,
+ {0x1dfe, 0x1f15}
+ ,
+ {0x1f18, 0x1f1d}
+ ,
+ {0x1f20, 0x1f45}
+ ,
+ {0x1f48, 0x1f4d}
+ ,
+ {0x1f50, 0x1f57}
+ ,
+ {0x1f59, 0x1f59}
+ ,
+ {0x1f5b, 0x1f5b}
+ ,
+ {0x1f5d, 0x1f5d}
+ ,
+ {0x1f5f, 0x1f7d}
+ ,
+ {0x1f80, 0x1fb4}
+ ,
+ {0x1fb6, 0x1fc4}
+ ,
+ {0x1fc6, 0x1fd3}
+ ,
+ {0x1fd6, 0x1fdb}
+ ,
+ {0x1fdd, 0x1fef}
+ ,
+ {0x1ff2, 0x1ff4}
+ ,
+ {0x1ff6, 0x1ffe}
+ ,
+ {0x2010, 0x2027}
+ ,
+ {0x2030, 0x205e}
+ ,
+ {0x2070, 0x2071}
+ ,
+ {0x2074, 0x208e}
+ ,
+ {0x2090, 0x2094}
+ ,
+ {0x20a0, 0x20b5}
+ ,
+ {0x20d0, 0x20f0}
+ ,
+ {0x2100, 0x214f}
+ ,
+ {0x2153, 0x2188}
+ ,
+ {0x2190, 0x23e7}
+ ,
+ {0x2400, 0x2426}
+ ,
+ {0x2440, 0x244a}
+ ,
+ {0x2460, 0x269d}
+ ,
+ {0x26a0, 0x26bc}
+ ,
+ {0x26c0, 0x26c3}
+ ,
+ {0x2701, 0x2704}
+ ,
+ {0x2706, 0x2709}
+ ,
+ {0x270c, 0x2727}
+ ,
+ {0x2729, 0x274b}
+ ,
+ {0x274d, 0x274d}
+ ,
+ {0x274f, 0x2752}
+ ,
+ {0x2756, 0x2756}
+ ,
+ {0x2758, 0x275e}
+ ,
+ {0x2761, 0x2794}
+ ,
+ {0x2798, 0x27af}
+ ,
+ {0x27b1, 0x27be}
+ ,
+ {0x27c0, 0x27ca}
+ ,
+ {0x27cc, 0x27cc}
+ ,
+ {0x27d0, 0x2b4c}
+ ,
+ {0x2b50, 0x2b54}
+ ,
+ {0x2c00, 0x2c2e}
+ ,
+ {0x2c30, 0x2c5e}
+ ,
+ {0x2c60, 0x2c6f}
+ ,
+ {0x2c71, 0x2c7d}
+ ,
+ {0x2c80, 0x2cea}
+ ,
+ {0x2cf9, 0x2d25}
+ ,
+ {0x2d30, 0x2d65}
+ ,
+ {0x2d6f, 0x2d6f}
+ ,
+ {0x2d80, 0x2d96}
+ ,
+ {0x2da0, 0x2da6}
+ ,
+ {0x2da8, 0x2dae}
+ ,
+ {0x2db0, 0x2db6}
+ ,
+ {0x2db8, 0x2dbe}
+ ,
+ {0x2dc0, 0x2dc6}
+ ,
+ {0x2dc8, 0x2dce}
+ ,
+ {0x2dd0, 0x2dd6}
+ ,
+ {0x2dd8, 0x2dde}
+ ,
+ {0x2de0, 0x2e30}
+ ,
+ {0x2e80, 0x2e99}
+ ,
+ {0x2e9b, 0x2ef3}
+ ,
+ {0x2f00, 0x2fd5}
+ ,
+ {0x2ff0, 0x2ffb}
+ ,
+ {0x3001, 0x303f}
+ ,
+ {0x3041, 0x3096}
+ ,
+ {0x3099, 0x30ff}
+ ,
+ {0x3105, 0x312d}
+ ,
+ {0x3131, 0x318e}
+ ,
+ {0x3190, 0x31b7}
+ ,
+ {0x31c0, 0x31e3}
+ ,
+ {0x31f0, 0x321e}
+ ,
+ {0x3220, 0x3243}
+ ,
+ {0x3250, 0x32fe}
+ ,
+ {0x3300, 0x4db5}
+ ,
+ {0x4dc0, 0x9fc3}
+ ,
+ {0xa000, 0xa48c}
+ ,
+ {0xa490, 0xa4c6}
+ ,
+ {0xa500, 0xa62b}
+ ,
+ {0xa640, 0xa65f}
+ ,
+ {0xa662, 0xa673}
+ ,
+ {0xa67c, 0xa697}
+ ,
+ {0xa700, 0xa78c}
+ ,
+ {0xa7fb, 0xa82b}
+ ,
+ {0xa840, 0xa877}
+ ,
+ {0xa880, 0xa8c4}
+ ,
+ {0xa8ce, 0xa8d9}
+ ,
+ {0xa900, 0xa953}
+ ,
+ {0xa95f, 0xa95f}
+ ,
+ {0xaa00, 0xaa36}
+ ,
+ {0xaa40, 0xaa4d}
+ ,
+ {0xaa50, 0xaa59}
+ ,
+ {0xaa5c, 0xaa5f}
+ ,
+ {0xac00, 0xd7a3}
+ ,
+ {0xf900, 0xfa2d}
+ ,
+ {0xfa30, 0xfa6a}
+ ,
+ {0xfa70, 0xfad9}
+ ,
+ {0xfb00, 0xfb06}
+ ,
+ {0xfb13, 0xfb17}
+ ,
+ {0xfb1d, 0xfb36}
+ ,
+ {0xfb38, 0xfb3c}
+ ,
+ {0xfb3e, 0xfb3e}
+ ,
+ {0xfb40, 0xfb41}
+ ,
+ {0xfb43, 0xfb44}
+ ,
+ {0xfb46, 0xfbb1}
+ ,
+ {0xfbd3, 0xfd3f}
+ ,
+ {0xfd50, 0xfd8f}
+ ,
+ {0xfd92, 0xfdc7}
+ ,
+ {0xfdf0, 0xfdfd}
+ ,
+ {0xfe00, 0xfe19}
+ ,
+ {0xfe20, 0xfe26}
+ ,
+ {0xfe30, 0xfe52}
+ ,
+ {0xfe54, 0xfe66}
+ ,
+ {0xfe68, 0xfe6b}
+ ,
+ {0xfe70, 0xfe74}
+ ,
+ {0xfe76, 0xfefc}
+ ,
+ {0xff01, 0xffbe}
+ ,
+ {0xffc2, 0xffc7}
+ ,
+ {0xffca, 0xffcf}
+ ,
+ {0xffd2, 0xffd7}
+ ,
+ {0xffda, 0xffdc}
+ ,
+ {0xffe0, 0xffe6}
+ ,
+ {0xffe8, 0xffee}
+ ,
+ {0xfffc, 0xfffd}
+ ,
+ {0x10000, 0x1000b}
+ ,
+ {0x1000d, 0x10026}
+ ,
+ {0x10028, 0x1003a}
+ ,
+ {0x1003c, 0x1003d}
+ ,
+ {0x1003f, 0x1004d}
+ ,
+ {0x10050, 0x1005d}
+ ,
+ {0x10080, 0x100fa}
+ ,
+ {0x10100, 0x10102}
+ ,
+ {0x10107, 0x10133}
+ ,
+ {0x10137, 0x1018a}
+ ,
+ {0x10190, 0x1019b}
+ ,
+ {0x101d0, 0x101fd}
+ ,
+ {0x10280, 0x1029c}
+ ,
+ {0x102a0, 0x102d0}
+ ,
+ {0x10300, 0x1031e}
+ ,
+ {0x10320, 0x10323}
+ ,
+ {0x10330, 0x1034a}
+ ,
+ {0x10380, 0x1039d}
+ ,
+ {0x1039f, 0x103c3}
+ ,
+ {0x103c8, 0x103d5}
+ ,
+ {0x10400, 0x1049d}
+ ,
+ {0x104a0, 0x104a9}
+ ,
+ {0x10800, 0x10805}
+ ,
+ {0x10808, 0x10808}
+ ,
+ {0x1080a, 0x10835}
+ ,
+ {0x10837, 0x10838}
+ ,
+ {0x1083c, 0x1083c}
+ ,
+ {0x1083f, 0x1083f}
+ ,
+ {0x10900, 0x10919}
+ ,
+ {0x1091f, 0x10939}
+ ,
+ {0x1093f, 0x1093f}
+ ,
+ {0x10a00, 0x10a03}
+ ,
+ {0x10a05, 0x10a06}
+ ,
+ {0x10a0c, 0x10a13}
+ ,
+ {0x10a15, 0x10a17}
+ ,
+ {0x10a19, 0x10a33}
+ ,
+ {0x10a38, 0x10a3a}
+ ,
+ {0x10a3f, 0x10a47}
+ ,
+ {0x10a50, 0x10a58}
+ ,
+ {0x12000, 0x1236e}
+ ,
+ {0x12400, 0x12462}
+ ,
+ {0x12470, 0x12473}
+ ,
+ {0x1d000, 0x1d0f5}
+ ,
+ {0x1d100, 0x1d126}
+ ,
+ {0x1d129, 0x1d172}
+ ,
+ {0x1d17b, 0x1d1dd}
+ ,
+ {0x1d200, 0x1d245}
+ ,
+ {0x1d300, 0x1d356}
+ ,
+ {0x1d360, 0x1d371}
+ ,
+ {0x1d400, 0x1d454}
+ ,
+ {0x1d456, 0x1d49c}
+ ,
+ {0x1d49e, 0x1d49f}
+ ,
+ {0x1d4a2, 0x1d4a2}
+ ,
+ {0x1d4a5, 0x1d4a6}
+ ,
+ {0x1d4a9, 0x1d4ac}
+ ,
+ {0x1d4ae, 0x1d4b9}
+ ,
+ {0x1d4bb, 0x1d4bb}
+ ,
+ {0x1d4bd, 0x1d4c3}
+ ,
+ {0x1d4c5, 0x1d505}
+ ,
+ {0x1d507, 0x1d50a}
+ ,
+ {0x1d50d, 0x1d514}
+ ,
+ {0x1d516, 0x1d51c}
+ ,
+ {0x1d51e, 0x1d539}
+ ,
+ {0x1d53b, 0x1d53e}
+ ,
+ {0x1d540, 0x1d544}
+ ,
+ {0x1d546, 0x1d546}
+ ,
+ {0x1d54a, 0x1d550}
+ ,
+ {0x1d552, 0x1d6a5}
+ ,
+ {0x1d6a8, 0x1d7cb}
+ ,
+ {0x1d7ce, 0x1d7ff}
+ ,
+ {0x1f000, 0x1f02b}
+ ,
+ {0x1f030, 0x1f093}
+ ,
+ {0x20000, 0x2a6d6}
+ ,
+ {0x2f800, 0x2fa1d}
+ ,
+ {0xe0100, 0xe01ef}
+};
+
+scm_t_char_set cs_graphic = {
+ 445,
+ cs_graphic_ranges
+};
+
+scm_t_char_range cs_whitespace_ranges[] = {
+ {0x0009, 0x000d}
+ ,
+ {0x0020, 0x0020}
+ ,
+ {0x00a0, 0x00a0}
+ ,
+ {0x1680, 0x1680}
+ ,
+ {0x180e, 0x180e}
+ ,
+ {0x2000, 0x200a}
+ ,
+ {0x2028, 0x2029}
+ ,
+ {0x202f, 0x202f}
+ ,
+ {0x205f, 0x205f}
+ ,
+ {0x3000, 0x3000}
+};
+
+scm_t_char_set cs_whitespace = {
+ 10,
+ cs_whitespace_ranges
+};
+
+scm_t_char_range cs_printing_ranges[] = {
+ {0x0009, 0x000d}
+ ,
+ {0x0020, 0x007e}
+ ,
+ {0x00a0, 0x00ac}
+ ,
+ {0x00ae, 0x0377}
+ ,
+ {0x037a, 0x037e}
+ ,
+ {0x0384, 0x038a}
+ ,
+ {0x038c, 0x038c}
+ ,
+ {0x038e, 0x03a1}
+ ,
+ {0x03a3, 0x0523}
+ ,
+ {0x0531, 0x0556}
+ ,
+ {0x0559, 0x055f}
+ ,
+ {0x0561, 0x0587}
+ ,
+ {0x0589, 0x058a}
+ ,
+ {0x0591, 0x05c7}
+ ,
+ {0x05d0, 0x05ea}
+ ,
+ {0x05f0, 0x05f4}
+ ,
+ {0x0606, 0x061b}
+ ,
+ {0x061e, 0x061f}
+ ,
+ {0x0621, 0x065e}
+ ,
+ {0x0660, 0x06dc}
+ ,
+ {0x06de, 0x070d}
+ ,
+ {0x0710, 0x074a}
+ ,
+ {0x074d, 0x07b1}
+ ,
+ {0x07c0, 0x07fa}
+ ,
+ {0x0901, 0x0939}
+ ,
+ {0x093c, 0x094d}
+ ,
+ {0x0950, 0x0954}
+ ,
+ {0x0958, 0x0972}
+ ,
+ {0x097b, 0x097f}
+ ,
+ {0x0981, 0x0983}
+ ,
+ {0x0985, 0x098c}
+ ,
+ {0x098f, 0x0990}
+ ,
+ {0x0993, 0x09a8}
+ ,
+ {0x09aa, 0x09b0}
+ ,
+ {0x09b2, 0x09b2}
+ ,
+ {0x09b6, 0x09b9}
+ ,
+ {0x09bc, 0x09c4}
+ ,
+ {0x09c7, 0x09c8}
+ ,
+ {0x09cb, 0x09ce}
+ ,
+ {0x09d7, 0x09d7}
+ ,
+ {0x09dc, 0x09dd}
+ ,
+ {0x09df, 0x09e3}
+ ,
+ {0x09e6, 0x09fa}
+ ,
+ {0x0a01, 0x0a03}
+ ,
+ {0x0a05, 0x0a0a}
+ ,
+ {0x0a0f, 0x0a10}
+ ,
+ {0x0a13, 0x0a28}
+ ,
+ {0x0a2a, 0x0a30}
+ ,
+ {0x0a32, 0x0a33}
+ ,
+ {0x0a35, 0x0a36}
+ ,
+ {0x0a38, 0x0a39}
+ ,
+ {0x0a3c, 0x0a3c}
+ ,
+ {0x0a3e, 0x0a42}
+ ,
+ {0x0a47, 0x0a48}
+ ,
+ {0x0a4b, 0x0a4d}
+ ,
+ {0x0a51, 0x0a51}
+ ,
+ {0x0a59, 0x0a5c}
+ ,
+ {0x0a5e, 0x0a5e}
+ ,
+ {0x0a66, 0x0a75}
+ ,
+ {0x0a81, 0x0a83}
+ ,
+ {0x0a85, 0x0a8d}
+ ,
+ {0x0a8f, 0x0a91}
+ ,
+ {0x0a93, 0x0aa8}
+ ,
+ {0x0aaa, 0x0ab0}
+ ,
+ {0x0ab2, 0x0ab3}
+ ,
+ {0x0ab5, 0x0ab9}
+ ,
+ {0x0abc, 0x0ac5}
+ ,
+ {0x0ac7, 0x0ac9}
+ ,
+ {0x0acb, 0x0acd}
+ ,
+ {0x0ad0, 0x0ad0}
+ ,
+ {0x0ae0, 0x0ae3}
+ ,
+ {0x0ae6, 0x0aef}
+ ,
+ {0x0af1, 0x0af1}
+ ,
+ {0x0b01, 0x0b03}
+ ,
+ {0x0b05, 0x0b0c}
+ ,
+ {0x0b0f, 0x0b10}
+ ,
+ {0x0b13, 0x0b28}
+ ,
+ {0x0b2a, 0x0b30}
+ ,
+ {0x0b32, 0x0b33}
+ ,
+ {0x0b35, 0x0b39}
+ ,
+ {0x0b3c, 0x0b44}
+ ,
+ {0x0b47, 0x0b48}
+ ,
+ {0x0b4b, 0x0b4d}
+ ,
+ {0x0b56, 0x0b57}
+ ,
+ {0x0b5c, 0x0b5d}
+ ,
+ {0x0b5f, 0x0b63}
+ ,
+ {0x0b66, 0x0b71}
+ ,
+ {0x0b82, 0x0b83}
+ ,
+ {0x0b85, 0x0b8a}
+ ,
+ {0x0b8e, 0x0b90}
+ ,
+ {0x0b92, 0x0b95}
+ ,
+ {0x0b99, 0x0b9a}
+ ,
+ {0x0b9c, 0x0b9c}
+ ,
+ {0x0b9e, 0x0b9f}
+ ,
+ {0x0ba3, 0x0ba4}
+ ,
+ {0x0ba8, 0x0baa}
+ ,
+ {0x0bae, 0x0bb9}
+ ,
+ {0x0bbe, 0x0bc2}
+ ,
+ {0x0bc6, 0x0bc8}
+ ,
+ {0x0bca, 0x0bcd}
+ ,
+ {0x0bd0, 0x0bd0}
+ ,
+ {0x0bd7, 0x0bd7}
+ ,
+ {0x0be6, 0x0bfa}
+ ,
+ {0x0c01, 0x0c03}
+ ,
+ {0x0c05, 0x0c0c}
+ ,
+ {0x0c0e, 0x0c10}
+ ,
+ {0x0c12, 0x0c28}
+ ,
+ {0x0c2a, 0x0c33}
+ ,
+ {0x0c35, 0x0c39}
+ ,
+ {0x0c3d, 0x0c44}
+ ,
+ {0x0c46, 0x0c48}
+ ,
+ {0x0c4a, 0x0c4d}
+ ,
+ {0x0c55, 0x0c56}
+ ,
+ {0x0c58, 0x0c59}
+ ,
+ {0x0c60, 0x0c63}
+ ,
+ {0x0c66, 0x0c6f}
+ ,
+ {0x0c78, 0x0c7f}
+ ,
+ {0x0c82, 0x0c83}
+ ,
+ {0x0c85, 0x0c8c}
+ ,
+ {0x0c8e, 0x0c90}
+ ,
+ {0x0c92, 0x0ca8}
+ ,
+ {0x0caa, 0x0cb3}
+ ,
+ {0x0cb5, 0x0cb9}
+ ,
+ {0x0cbc, 0x0cc4}
+ ,
+ {0x0cc6, 0x0cc8}
+ ,
+ {0x0cca, 0x0ccd}
+ ,
+ {0x0cd5, 0x0cd6}
+ ,
+ {0x0cde, 0x0cde}
+ ,
+ {0x0ce0, 0x0ce3}
+ ,
+ {0x0ce6, 0x0cef}
+ ,
+ {0x0cf1, 0x0cf2}
+ ,
+ {0x0d02, 0x0d03}
+ ,
+ {0x0d05, 0x0d0c}
+ ,
+ {0x0d0e, 0x0d10}
+ ,
+ {0x0d12, 0x0d28}
+ ,
+ {0x0d2a, 0x0d39}
+ ,
+ {0x0d3d, 0x0d44}
+ ,
+ {0x0d46, 0x0d48}
+ ,
+ {0x0d4a, 0x0d4d}
+ ,
+ {0x0d57, 0x0d57}
+ ,
+ {0x0d60, 0x0d63}
+ ,
+ {0x0d66, 0x0d75}
+ ,
+ {0x0d79, 0x0d7f}
+ ,
+ {0x0d82, 0x0d83}
+ ,
+ {0x0d85, 0x0d96}
+ ,
+ {0x0d9a, 0x0db1}
+ ,
+ {0x0db3, 0x0dbb}
+ ,
+ {0x0dbd, 0x0dbd}
+ ,
+ {0x0dc0, 0x0dc6}
+ ,
+ {0x0dca, 0x0dca}
+ ,
+ {0x0dcf, 0x0dd4}
+ ,
+ {0x0dd6, 0x0dd6}
+ ,
+ {0x0dd8, 0x0ddf}
+ ,
+ {0x0df2, 0x0df4}
+ ,
+ {0x0e01, 0x0e3a}
+ ,
+ {0x0e3f, 0x0e5b}
+ ,
+ {0x0e81, 0x0e82}
+ ,
+ {0x0e84, 0x0e84}
+ ,
+ {0x0e87, 0x0e88}
+ ,
+ {0x0e8a, 0x0e8a}
+ ,
+ {0x0e8d, 0x0e8d}
+ ,
+ {0x0e94, 0x0e97}
+ ,
+ {0x0e99, 0x0e9f}
+ ,
+ {0x0ea1, 0x0ea3}
+ ,
+ {0x0ea5, 0x0ea5}
+ ,
+ {0x0ea7, 0x0ea7}
+ ,
+ {0x0eaa, 0x0eab}
+ ,
+ {0x0ead, 0x0eb9}
+ ,
+ {0x0ebb, 0x0ebd}
+ ,
+ {0x0ec0, 0x0ec4}
+ ,
+ {0x0ec6, 0x0ec6}
+ ,
+ {0x0ec8, 0x0ecd}
+ ,
+ {0x0ed0, 0x0ed9}
+ ,
+ {0x0edc, 0x0edd}
+ ,
+ {0x0f00, 0x0f47}
+ ,
+ {0x0f49, 0x0f6c}
+ ,
+ {0x0f71, 0x0f8b}
+ ,
+ {0x0f90, 0x0f97}
+ ,
+ {0x0f99, 0x0fbc}
+ ,
+ {0x0fbe, 0x0fcc}
+ ,
+ {0x0fce, 0x0fd4}
+ ,
+ {0x1000, 0x1099}
+ ,
+ {0x109e, 0x10c5}
+ ,
+ {0x10d0, 0x10fc}
+ ,
+ {0x1100, 0x1159}
+ ,
+ {0x115f, 0x11a2}
+ ,
+ {0x11a8, 0x11f9}
+ ,
+ {0x1200, 0x1248}
+ ,
+ {0x124a, 0x124d}
+ ,
+ {0x1250, 0x1256}
+ ,
+ {0x1258, 0x1258}
+ ,
+ {0x125a, 0x125d}
+ ,
+ {0x1260, 0x1288}
+ ,
+ {0x128a, 0x128d}
+ ,
+ {0x1290, 0x12b0}
+ ,
+ {0x12b2, 0x12b5}
+ ,
+ {0x12b8, 0x12be}
+ ,
+ {0x12c0, 0x12c0}
+ ,
+ {0x12c2, 0x12c5}
+ ,
+ {0x12c8, 0x12d6}
+ ,
+ {0x12d8, 0x1310}
+ ,
+ {0x1312, 0x1315}
+ ,
+ {0x1318, 0x135a}
+ ,
+ {0x135f, 0x137c}
+ ,
+ {0x1380, 0x1399}
+ ,
+ {0x13a0, 0x13f4}
+ ,
+ {0x1401, 0x1676}
+ ,
+ {0x1680, 0x169c}
+ ,
+ {0x16a0, 0x16f0}
+ ,
+ {0x1700, 0x170c}
+ ,
+ {0x170e, 0x1714}
+ ,
+ {0x1720, 0x1736}
+ ,
+ {0x1740, 0x1753}
+ ,
+ {0x1760, 0x176c}
+ ,
+ {0x176e, 0x1770}
+ ,
+ {0x1772, 0x1773}
+ ,
+ {0x1780, 0x17b3}
+ ,
+ {0x17b6, 0x17dd}
+ ,
+ {0x17e0, 0x17e9}
+ ,
+ {0x17f0, 0x17f9}
+ ,
+ {0x1800, 0x180e}
+ ,
+ {0x1810, 0x1819}
+ ,
+ {0x1820, 0x1877}
+ ,
+ {0x1880, 0x18aa}
+ ,
+ {0x1900, 0x191c}
+ ,
+ {0x1920, 0x192b}
+ ,
+ {0x1930, 0x193b}
+ ,
+ {0x1940, 0x1940}
+ ,
+ {0x1944, 0x196d}
+ ,
+ {0x1970, 0x1974}
+ ,
+ {0x1980, 0x19a9}
+ ,
+ {0x19b0, 0x19c9}
+ ,
+ {0x19d0, 0x19d9}
+ ,
+ {0x19de, 0x1a1b}
+ ,
+ {0x1a1e, 0x1a1f}
+ ,
+ {0x1b00, 0x1b4b}
+ ,
+ {0x1b50, 0x1b7c}
+ ,
+ {0x1b80, 0x1baa}
+ ,
+ {0x1bae, 0x1bb9}
+ ,
+ {0x1c00, 0x1c37}
+ ,
+ {0x1c3b, 0x1c49}
+ ,
+ {0x1c4d, 0x1c7f}
+ ,
+ {0x1d00, 0x1de6}
+ ,
+ {0x1dfe, 0x1f15}
+ ,
+ {0x1f18, 0x1f1d}
+ ,
+ {0x1f20, 0x1f45}
+ ,
+ {0x1f48, 0x1f4d}
+ ,
+ {0x1f50, 0x1f57}
+ ,
+ {0x1f59, 0x1f59}
+ ,
+ {0x1f5b, 0x1f5b}
+ ,
+ {0x1f5d, 0x1f5d}
+ ,
+ {0x1f5f, 0x1f7d}
+ ,
+ {0x1f80, 0x1fb4}
+ ,
+ {0x1fb6, 0x1fc4}
+ ,
+ {0x1fc6, 0x1fd3}
+ ,
+ {0x1fd6, 0x1fdb}
+ ,
+ {0x1fdd, 0x1fef}
+ ,
+ {0x1ff2, 0x1ff4}
+ ,
+ {0x1ff6, 0x1ffe}
+ ,
+ {0x2000, 0x200a}
+ ,
+ {0x2010, 0x2029}
+ ,
+ {0x202f, 0x205f}
+ ,
+ {0x2070, 0x2071}
+ ,
+ {0x2074, 0x208e}
+ ,
+ {0x2090, 0x2094}
+ ,
+ {0x20a0, 0x20b5}
+ ,
+ {0x20d0, 0x20f0}
+ ,
+ {0x2100, 0x214f}
+ ,
+ {0x2153, 0x2188}
+ ,
+ {0x2190, 0x23e7}
+ ,
+ {0x2400, 0x2426}
+ ,
+ {0x2440, 0x244a}
+ ,
+ {0x2460, 0x269d}
+ ,
+ {0x26a0, 0x26bc}
+ ,
+ {0x26c0, 0x26c3}
+ ,
+ {0x2701, 0x2704}
+ ,
+ {0x2706, 0x2709}
+ ,
+ {0x270c, 0x2727}
+ ,
+ {0x2729, 0x274b}
+ ,
+ {0x274d, 0x274d}
+ ,
+ {0x274f, 0x2752}
+ ,
+ {0x2756, 0x2756}
+ ,
+ {0x2758, 0x275e}
+ ,
+ {0x2761, 0x2794}
+ ,
+ {0x2798, 0x27af}
+ ,
+ {0x27b1, 0x27be}
+ ,
+ {0x27c0, 0x27ca}
+ ,
+ {0x27cc, 0x27cc}
+ ,
+ {0x27d0, 0x2b4c}
+ ,
+ {0x2b50, 0x2b54}
+ ,
+ {0x2c00, 0x2c2e}
+ ,
+ {0x2c30, 0x2c5e}
+ ,
+ {0x2c60, 0x2c6f}
+ ,
+ {0x2c71, 0x2c7d}
+ ,
+ {0x2c80, 0x2cea}
+ ,
+ {0x2cf9, 0x2d25}
+ ,
+ {0x2d30, 0x2d65}
+ ,
+ {0x2d6f, 0x2d6f}
+ ,
+ {0x2d80, 0x2d96}
+ ,
+ {0x2da0, 0x2da6}
+ ,
+ {0x2da8, 0x2dae}
+ ,
+ {0x2db0, 0x2db6}
+ ,
+ {0x2db8, 0x2dbe}
+ ,
+ {0x2dc0, 0x2dc6}
+ ,
+ {0x2dc8, 0x2dce}
+ ,
+ {0x2dd0, 0x2dd6}
+ ,
+ {0x2dd8, 0x2dde}
+ ,
+ {0x2de0, 0x2e30}
+ ,
+ {0x2e80, 0x2e99}
+ ,
+ {0x2e9b, 0x2ef3}
+ ,
+ {0x2f00, 0x2fd5}
+ ,
+ {0x2ff0, 0x2ffb}
+ ,
+ {0x3000, 0x303f}
+ ,
+ {0x3041, 0x3096}
+ ,
+ {0x3099, 0x30ff}
+ ,
+ {0x3105, 0x312d}
+ ,
+ {0x3131, 0x318e}
+ ,
+ {0x3190, 0x31b7}
+ ,
+ {0x31c0, 0x31e3}
+ ,
+ {0x31f0, 0x321e}
+ ,
+ {0x3220, 0x3243}
+ ,
+ {0x3250, 0x32fe}
+ ,
+ {0x3300, 0x4db5}
+ ,
+ {0x4dc0, 0x9fc3}
+ ,
+ {0xa000, 0xa48c}
+ ,
+ {0xa490, 0xa4c6}
+ ,
+ {0xa500, 0xa62b}
+ ,
+ {0xa640, 0xa65f}
+ ,
+ {0xa662, 0xa673}
+ ,
+ {0xa67c, 0xa697}
+ ,
+ {0xa700, 0xa78c}
+ ,
+ {0xa7fb, 0xa82b}
+ ,
+ {0xa840, 0xa877}
+ ,
+ {0xa880, 0xa8c4}
+ ,
+ {0xa8ce, 0xa8d9}
+ ,
+ {0xa900, 0xa953}
+ ,
+ {0xa95f, 0xa95f}
+ ,
+ {0xaa00, 0xaa36}
+ ,
+ {0xaa40, 0xaa4d}
+ ,
+ {0xaa50, 0xaa59}
+ ,
+ {0xaa5c, 0xaa5f}
+ ,
+ {0xac00, 0xd7a3}
+ ,
+ {0xf900, 0xfa2d}
+ ,
+ {0xfa30, 0xfa6a}
+ ,
+ {0xfa70, 0xfad9}
+ ,
+ {0xfb00, 0xfb06}
+ ,
+ {0xfb13, 0xfb17}
+ ,
+ {0xfb1d, 0xfb36}
+ ,
+ {0xfb38, 0xfb3c}
+ ,
+ {0xfb3e, 0xfb3e}
+ ,
+ {0xfb40, 0xfb41}
+ ,
+ {0xfb43, 0xfb44}
+ ,
+ {0xfb46, 0xfbb1}
+ ,
+ {0xfbd3, 0xfd3f}
+ ,
+ {0xfd50, 0xfd8f}
+ ,
+ {0xfd92, 0xfdc7}
+ ,
+ {0xfdf0, 0xfdfd}
+ ,
+ {0xfe00, 0xfe19}
+ ,
+ {0xfe20, 0xfe26}
+ ,
+ {0xfe30, 0xfe52}
+ ,
+ {0xfe54, 0xfe66}
+ ,
+ {0xfe68, 0xfe6b}
+ ,
+ {0xfe70, 0xfe74}
+ ,
+ {0xfe76, 0xfefc}
+ ,
+ {0xff01, 0xffbe}
+ ,
+ {0xffc2, 0xffc7}
+ ,
+ {0xffca, 0xffcf}
+ ,
+ {0xffd2, 0xffd7}
+ ,
+ {0xffda, 0xffdc}
+ ,
+ {0xffe0, 0xffe6}
+ ,
+ {0xffe8, 0xffee}
+ ,
+ {0xfffc, 0xfffd}
+ ,
+ {0x10000, 0x1000b}
+ ,
+ {0x1000d, 0x10026}
+ ,
+ {0x10028, 0x1003a}
+ ,
+ {0x1003c, 0x1003d}
+ ,
+ {0x1003f, 0x1004d}
+ ,
+ {0x10050, 0x1005d}
+ ,
+ {0x10080, 0x100fa}
+ ,
+ {0x10100, 0x10102}
+ ,
+ {0x10107, 0x10133}
+ ,
+ {0x10137, 0x1018a}
+ ,
+ {0x10190, 0x1019b}
+ ,
+ {0x101d0, 0x101fd}
+ ,
+ {0x10280, 0x1029c}
+ ,
+ {0x102a0, 0x102d0}
+ ,
+ {0x10300, 0x1031e}
+ ,
+ {0x10320, 0x10323}
+ ,
+ {0x10330, 0x1034a}
+ ,
+ {0x10380, 0x1039d}
+ ,
+ {0x1039f, 0x103c3}
+ ,
+ {0x103c8, 0x103d5}
+ ,
+ {0x10400, 0x1049d}
+ ,
+ {0x104a0, 0x104a9}
+ ,
+ {0x10800, 0x10805}
+ ,
+ {0x10808, 0x10808}
+ ,
+ {0x1080a, 0x10835}
+ ,
+ {0x10837, 0x10838}
+ ,
+ {0x1083c, 0x1083c}
+ ,
+ {0x1083f, 0x1083f}
+ ,
+ {0x10900, 0x10919}
+ ,
+ {0x1091f, 0x10939}
+ ,
+ {0x1093f, 0x1093f}
+ ,
+ {0x10a00, 0x10a03}
+ ,
+ {0x10a05, 0x10a06}
+ ,
+ {0x10a0c, 0x10a13}
+ ,
+ {0x10a15, 0x10a17}
+ ,
+ {0x10a19, 0x10a33}
+ ,
+ {0x10a38, 0x10a3a}
+ ,
+ {0x10a3f, 0x10a47}
+ ,
+ {0x10a50, 0x10a58}
+ ,
+ {0x12000, 0x1236e}
+ ,
+ {0x12400, 0x12462}
+ ,
+ {0x12470, 0x12473}
+ ,
+ {0x1d000, 0x1d0f5}
+ ,
+ {0x1d100, 0x1d126}
+ ,
+ {0x1d129, 0x1d172}
+ ,
+ {0x1d17b, 0x1d1dd}
+ ,
+ {0x1d200, 0x1d245}
+ ,
+ {0x1d300, 0x1d356}
+ ,
+ {0x1d360, 0x1d371}
+ ,
+ {0x1d400, 0x1d454}
+ ,
+ {0x1d456, 0x1d49c}
+ ,
+ {0x1d49e, 0x1d49f}
+ ,
+ {0x1d4a2, 0x1d4a2}
+ ,
+ {0x1d4a5, 0x1d4a6}
+ ,
+ {0x1d4a9, 0x1d4ac}
+ ,
+ {0x1d4ae, 0x1d4b9}
+ ,
+ {0x1d4bb, 0x1d4bb}
+ ,
+ {0x1d4bd, 0x1d4c3}
+ ,
+ {0x1d4c5, 0x1d505}
+ ,
+ {0x1d507, 0x1d50a}
+ ,
+ {0x1d50d, 0x1d514}
+ ,
+ {0x1d516, 0x1d51c}
+ ,
+ {0x1d51e, 0x1d539}
+ ,
+ {0x1d53b, 0x1d53e}
+ ,
+ {0x1d540, 0x1d544}
+ ,
+ {0x1d546, 0x1d546}
+ ,
+ {0x1d54a, 0x1d550}
+ ,
+ {0x1d552, 0x1d6a5}
+ ,
+ {0x1d6a8, 0x1d7cb}
+ ,
+ {0x1d7ce, 0x1d7ff}
+ ,
+ {0x1f000, 0x1f02b}
+ ,
+ {0x1f030, 0x1f093}
+ ,
+ {0x20000, 0x2a6d6}
+ ,
+ {0x2f800, 0x2fa1d}
+ ,
+ {0xe0100, 0xe01ef}
+};
+
+scm_t_char_set cs_printing = {
+ 447,
+ cs_printing_ranges
+};
+
+scm_t_char_range cs_iso_control_ranges[] = {
+ {0x0000, 0x001f}
+ ,
+ {0x007f, 0x009f}
+};
+
+scm_t_char_set cs_iso_control = {
+ 2,
+ cs_iso_control_ranges
+};
+
+scm_t_char_range cs_punctuation_ranges[] = {
+ {0x0021, 0x0023}
+ ,
+ {0x0025, 0x002a}
+ ,
+ {0x002c, 0x002f}
+ ,
+ {0x003a, 0x003b}
+ ,
+ {0x003f, 0x0040}
+ ,
+ {0x005b, 0x005d}
+ ,
+ {0x005f, 0x005f}
+ ,
+ {0x007b, 0x007b}
+ ,
+ {0x007d, 0x007d}
+ ,
+ {0x00a1, 0x00a1}
+ ,
+ {0x00ab, 0x00ab}
+ ,
+ {0x00b7, 0x00b7}
+ ,
+ {0x00bb, 0x00bb}
+ ,
+ {0x00bf, 0x00bf}
+ ,
+ {0x037e, 0x037e}
+ ,
+ {0x0387, 0x0387}
+ ,
+ {0x055a, 0x055f}
+ ,
+ {0x0589, 0x058a}
+ ,
+ {0x05be, 0x05be}
+ ,
+ {0x05c0, 0x05c0}
+ ,
+ {0x05c3, 0x05c3}
+ ,
+ {0x05c6, 0x05c6}
+ ,
+ {0x05f3, 0x05f4}
+ ,
+ {0x0609, 0x060a}
+ ,
+ {0x060c, 0x060d}
+ ,
+ {0x061b, 0x061b}
+ ,
+ {0x061e, 0x061f}
+ ,
+ {0x066a, 0x066d}
+ ,
+ {0x06d4, 0x06d4}
+ ,
+ {0x0700, 0x070d}
+ ,
+ {0x07f7, 0x07f9}
+ ,
+ {0x0964, 0x0965}
+ ,
+ {0x0970, 0x0970}
+ ,
+ {0x0df4, 0x0df4}
+ ,
+ {0x0e4f, 0x0e4f}
+ ,
+ {0x0e5a, 0x0e5b}
+ ,
+ {0x0f04, 0x0f12}
+ ,
+ {0x0f3a, 0x0f3d}
+ ,
+ {0x0f85, 0x0f85}
+ ,
+ {0x0fd0, 0x0fd4}
+ ,
+ {0x104a, 0x104f}
+ ,
+ {0x10fb, 0x10fb}
+ ,
+ {0x1361, 0x1368}
+ ,
+ {0x166d, 0x166e}
+ ,
+ {0x169b, 0x169c}
+ ,
+ {0x16eb, 0x16ed}
+ ,
+ {0x1735, 0x1736}
+ ,
+ {0x17d4, 0x17d6}
+ ,
+ {0x17d8, 0x17da}
+ ,
+ {0x1800, 0x180a}
+ ,
+ {0x1944, 0x1945}
+ ,
+ {0x19de, 0x19df}
+ ,
+ {0x1a1e, 0x1a1f}
+ ,
+ {0x1b5a, 0x1b60}
+ ,
+ {0x1c3b, 0x1c3f}
+ ,
+ {0x1c7e, 0x1c7f}
+ ,
+ {0x2010, 0x2027}
+ ,
+ {0x2030, 0x2043}
+ ,
+ {0x2045, 0x2051}
+ ,
+ {0x2053, 0x205e}
+ ,
+ {0x207d, 0x207e}
+ ,
+ {0x208d, 0x208e}
+ ,
+ {0x2329, 0x232a}
+ ,
+ {0x2768, 0x2775}
+ ,
+ {0x27c5, 0x27c6}
+ ,
+ {0x27e6, 0x27ef}
+ ,
+ {0x2983, 0x2998}
+ ,
+ {0x29d8, 0x29db}
+ ,
+ {0x29fc, 0x29fd}
+ ,
+ {0x2cf9, 0x2cfc}
+ ,
+ {0x2cfe, 0x2cff}
+ ,
+ {0x2e00, 0x2e2e}
+ ,
+ {0x2e30, 0x2e30}
+ ,
+ {0x3001, 0x3003}
+ ,
+ {0x3008, 0x3011}
+ ,
+ {0x3014, 0x301f}
+ ,
+ {0x3030, 0x3030}
+ ,
+ {0x303d, 0x303d}
+ ,
+ {0x30a0, 0x30a0}
+ ,
+ {0x30fb, 0x30fb}
+ ,
+ {0xa60d, 0xa60f}
+ ,
+ {0xa673, 0xa673}
+ ,
+ {0xa67e, 0xa67e}
+ ,
+ {0xa874, 0xa877}
+ ,
+ {0xa8ce, 0xa8cf}
+ ,
+ {0xa92e, 0xa92f}
+ ,
+ {0xa95f, 0xa95f}
+ ,
+ {0xaa5c, 0xaa5f}
+ ,
+ {0xfd3e, 0xfd3f}
+ ,
+ {0xfe10, 0xfe19}
+ ,
+ {0xfe30, 0xfe52}
+ ,
+ {0xfe54, 0xfe61}
+ ,
+ {0xfe63, 0xfe63}
+ ,
+ {0xfe68, 0xfe68}
+ ,
+ {0xfe6a, 0xfe6b}
+ ,
+ {0xff01, 0xff03}
+ ,
+ {0xff05, 0xff0a}
+ ,
+ {0xff0c, 0xff0f}
+ ,
+ {0xff1a, 0xff1b}
+ ,
+ {0xff1f, 0xff20}
+ ,
+ {0xff3b, 0xff3d}
+ ,
+ {0xff3f, 0xff3f}
+ ,
+ {0xff5b, 0xff5b}
+ ,
+ {0xff5d, 0xff5d}
+ ,
+ {0xff5f, 0xff65}
+ ,
+ {0x10100, 0x10101}
+ ,
+ {0x1039f, 0x1039f}
+ ,
+ {0x103d0, 0x103d0}
+ ,
+ {0x1091f, 0x1091f}
+ ,
+ {0x1093f, 0x1093f}
+ ,
+ {0x10a50, 0x10a58}
+ ,
+ {0x12470, 0x12473}
+};
+
+scm_t_char_set cs_punctuation = {
+ 112,
+ cs_punctuation_ranges
+};
+
+scm_t_char_range cs_symbol_ranges[] = {
+ {0x0024, 0x0024}
+ ,
+ {0x002b, 0x002b}
+ ,
+ {0x003c, 0x003e}
+ ,
+ {0x005e, 0x005e}
+ ,
+ {0x0060, 0x0060}
+ ,
+ {0x007c, 0x007c}
+ ,
+ {0x007e, 0x007e}
+ ,
+ {0x00a2, 0x00a9}
+ ,
+ {0x00ac, 0x00ac}
+ ,
+ {0x00ae, 0x00b1}
+ ,
+ {0x00b4, 0x00b4}
+ ,
+ {0x00b6, 0x00b6}
+ ,
+ {0x00b8, 0x00b8}
+ ,
+ {0x00d7, 0x00d7}
+ ,
+ {0x00f7, 0x00f7}
+ ,
+ {0x02c2, 0x02c5}
+ ,
+ {0x02d2, 0x02df}
+ ,
+ {0x02e5, 0x02eb}
+ ,
+ {0x02ed, 0x02ed}
+ ,
+ {0x02ef, 0x02ff}
+ ,
+ {0x0375, 0x0375}
+ ,
+ {0x0384, 0x0385}
+ ,
+ {0x03f6, 0x03f6}
+ ,
+ {0x0482, 0x0482}
+ ,
+ {0x0606, 0x0608}
+ ,
+ {0x060b, 0x060b}
+ ,
+ {0x060e, 0x060f}
+ ,
+ {0x06e9, 0x06e9}
+ ,
+ {0x06fd, 0x06fe}
+ ,
+ {0x07f6, 0x07f6}
+ ,
+ {0x09f2, 0x09f3}
+ ,
+ {0x09fa, 0x09fa}
+ ,
+ {0x0af1, 0x0af1}
+ ,
+ {0x0b70, 0x0b70}
+ ,
+ {0x0bf3, 0x0bfa}
+ ,
+ {0x0c7f, 0x0c7f}
+ ,
+ {0x0cf1, 0x0cf2}
+ ,
+ {0x0d79, 0x0d79}
+ ,
+ {0x0e3f, 0x0e3f}
+ ,
+ {0x0f01, 0x0f03}
+ ,
+ {0x0f13, 0x0f17}
+ ,
+ {0x0f1a, 0x0f1f}
+ ,
+ {0x0f34, 0x0f34}
+ ,
+ {0x0f36, 0x0f36}
+ ,
+ {0x0f38, 0x0f38}
+ ,
+ {0x0fbe, 0x0fc5}
+ ,
+ {0x0fc7, 0x0fcc}
+ ,
+ {0x0fce, 0x0fcf}
+ ,
+ {0x109e, 0x109f}
+ ,
+ {0x1360, 0x1360}
+ ,
+ {0x1390, 0x1399}
+ ,
+ {0x17db, 0x17db}
+ ,
+ {0x1940, 0x1940}
+ ,
+ {0x19e0, 0x19ff}
+ ,
+ {0x1b61, 0x1b6a}
+ ,
+ {0x1b74, 0x1b7c}
+ ,
+ {0x1fbd, 0x1fbd}
+ ,
+ {0x1fbf, 0x1fc1}
+ ,
+ {0x1fcd, 0x1fcf}
+ ,
+ {0x1fdd, 0x1fdf}
+ ,
+ {0x1fed, 0x1fef}
+ ,
+ {0x1ffd, 0x1ffe}
+ ,
+ {0x2044, 0x2044}
+ ,
+ {0x2052, 0x2052}
+ ,
+ {0x207a, 0x207c}
+ ,
+ {0x208a, 0x208c}
+ ,
+ {0x20a0, 0x20b5}
+ ,
+ {0x2100, 0x2101}
+ ,
+ {0x2103, 0x2106}
+ ,
+ {0x2108, 0x2109}
+ ,
+ {0x2114, 0x2114}
+ ,
+ {0x2116, 0x2118}
+ ,
+ {0x211e, 0x2123}
+ ,
+ {0x2125, 0x2125}
+ ,
+ {0x2127, 0x2127}
+ ,
+ {0x2129, 0x2129}
+ ,
+ {0x212e, 0x212e}
+ ,
+ {0x213a, 0x213b}
+ ,
+ {0x2140, 0x2144}
+ ,
+ {0x214a, 0x214d}
+ ,
+ {0x214f, 0x214f}
+ ,
+ {0x2190, 0x2328}
+ ,
+ {0x232b, 0x23e7}
+ ,
+ {0x2400, 0x2426}
+ ,
+ {0x2440, 0x244a}
+ ,
+ {0x249c, 0x24e9}
+ ,
+ {0x2500, 0x269d}
+ ,
+ {0x26a0, 0x26bc}
+ ,
+ {0x26c0, 0x26c3}
+ ,
+ {0x2701, 0x2704}
+ ,
+ {0x2706, 0x2709}
+ ,
+ {0x270c, 0x2727}
+ ,
+ {0x2729, 0x274b}
+ ,
+ {0x274d, 0x274d}
+ ,
+ {0x274f, 0x2752}
+ ,
+ {0x2756, 0x2756}
+ ,
+ {0x2758, 0x275e}
+ ,
+ {0x2761, 0x2767}
+ ,
+ {0x2794, 0x2794}
+ ,
+ {0x2798, 0x27af}
+ ,
+ {0x27b1, 0x27be}
+ ,
+ {0x27c0, 0x27c4}
+ ,
+ {0x27c7, 0x27ca}
+ ,
+ {0x27cc, 0x27cc}
+ ,
+ {0x27d0, 0x27e5}
+ ,
+ {0x27f0, 0x2982}
+ ,
+ {0x2999, 0x29d7}
+ ,
+ {0x29dc, 0x29fb}
+ ,
+ {0x29fe, 0x2b4c}
+ ,
+ {0x2b50, 0x2b54}
+ ,
+ {0x2ce5, 0x2cea}
+ ,
+ {0x2e80, 0x2e99}
+ ,
+ {0x2e9b, 0x2ef3}
+ ,
+ {0x2f00, 0x2fd5}
+ ,
+ {0x2ff0, 0x2ffb}
+ ,
+ {0x3004, 0x3004}
+ ,
+ {0x3012, 0x3013}
+ ,
+ {0x3020, 0x3020}
+ ,
+ {0x3036, 0x3037}
+ ,
+ {0x303e, 0x303f}
+ ,
+ {0x309b, 0x309c}
+ ,
+ {0x3190, 0x3191}
+ ,
+ {0x3196, 0x319f}
+ ,
+ {0x31c0, 0x31e3}
+ ,
+ {0x3200, 0x321e}
+ ,
+ {0x322a, 0x3243}
+ ,
+ {0x3250, 0x3250}
+ ,
+ {0x3260, 0x327f}
+ ,
+ {0x328a, 0x32b0}
+ ,
+ {0x32c0, 0x32fe}
+ ,
+ {0x3300, 0x33ff}
+ ,
+ {0x4dc0, 0x4dff}
+ ,
+ {0xa490, 0xa4c6}
+ ,
+ {0xa700, 0xa716}
+ ,
+ {0xa720, 0xa721}
+ ,
+ {0xa789, 0xa78a}
+ ,
+ {0xa828, 0xa82b}
+ ,
+ {0xfb29, 0xfb29}
+ ,
+ {0xfdfc, 0xfdfd}
+ ,
+ {0xfe62, 0xfe62}
+ ,
+ {0xfe64, 0xfe66}
+ ,
+ {0xfe69, 0xfe69}
+ ,
+ {0xff04, 0xff04}
+ ,
+ {0xff0b, 0xff0b}
+ ,
+ {0xff1c, 0xff1e}
+ ,
+ {0xff3e, 0xff3e}
+ ,
+ {0xff40, 0xff40}
+ ,
+ {0xff5c, 0xff5c}
+ ,
+ {0xff5e, 0xff5e}
+ ,
+ {0xffe0, 0xffe6}
+ ,
+ {0xffe8, 0xffee}
+ ,
+ {0xfffc, 0xfffd}
+ ,
+ {0x10102, 0x10102}
+ ,
+ {0x10137, 0x1013f}
+ ,
+ {0x10179, 0x10189}
+ ,
+ {0x10190, 0x1019b}
+ ,
+ {0x101d0, 0x101fc}
+ ,
+ {0x1d000, 0x1d0f5}
+ ,
+ {0x1d100, 0x1d126}
+ ,
+ {0x1d129, 0x1d164}
+ ,
+ {0x1d16a, 0x1d16c}
+ ,
+ {0x1d183, 0x1d184}
+ ,
+ {0x1d18c, 0x1d1a9}
+ ,
+ {0x1d1ae, 0x1d1dd}
+ ,
+ {0x1d200, 0x1d241}
+ ,
+ {0x1d245, 0x1d245}
+ ,
+ {0x1d300, 0x1d356}
+ ,
+ {0x1d6c1, 0x1d6c1}
+ ,
+ {0x1d6db, 0x1d6db}
+ ,
+ {0x1d6fb, 0x1d6fb}
+ ,
+ {0x1d715, 0x1d715}
+ ,
+ {0x1d735, 0x1d735}
+ ,
+ {0x1d74f, 0x1d74f}
+ ,
+ {0x1d76f, 0x1d76f}
+ ,
+ {0x1d789, 0x1d789}
+ ,
+ {0x1d7a9, 0x1d7a9}
+ ,
+ {0x1d7c3, 0x1d7c3}
+ ,
+ {0x1f000, 0x1f02b}
+ ,
+ {0x1f030, 0x1f093}
+};
+
+scm_t_char_set cs_symbol = {
+ 179,
+ cs_symbol_ranges
+};
+
+scm_t_char_range cs_blank_ranges[] = {
+ {0x0009, 0x0009}
+ ,
+ {0x0020, 0x0020}
+ ,
+ {0x00a0, 0x00a0}
+ ,
+ {0x1680, 0x1680}
+ ,
+ {0x180e, 0x180e}
+ ,
+ {0x2000, 0x200a}
+ ,
+ {0x202f, 0x202f}
+ ,
+ {0x205f, 0x205f}
+ ,
+ {0x3000, 0x3000}
+};
+
+scm_t_char_set cs_blank = {
+ 9,
+ cs_blank_ranges
+};
+
+scm_t_char_range cs_ascii_ranges[] = {
+ {0x0000, 0x007f}
+};
+
+scm_t_char_set cs_ascii = {
+ 0,
+ cs_ascii_ranges
+};
+
+scm_t_char_range cs_empty_ranges[] = {
+};
+
+scm_t_char_set cs_empty = {
+ 0,
+ cs_empty_ranges
+};
+
+scm_t_char_range cs_full_ranges[] = {
+ {0x0000, 0x0377}
+ ,
+ {0x037a, 0x037e}
+ ,
+ {0x0384, 0x038a}
+ ,
+ {0x038c, 0x038c}
+ ,
+ {0x038e, 0x03a1}
+ ,
+ {0x03a3, 0x0523}
+ ,
+ {0x0531, 0x0556}
+ ,
+ {0x0559, 0x055f}
+ ,
+ {0x0561, 0x0587}
+ ,
+ {0x0589, 0x058a}
+ ,
+ {0x0591, 0x05c7}
+ ,
+ {0x05d0, 0x05ea}
+ ,
+ {0x05f0, 0x05f4}
+ ,
+ {0x0600, 0x0603}
+ ,
+ {0x0606, 0x061b}
+ ,
+ {0x061e, 0x061f}
+ ,
+ {0x0621, 0x065e}
+ ,
+ {0x0660, 0x070d}
+ ,
+ {0x070f, 0x074a}
+ ,
+ {0x074d, 0x07b1}
+ ,
+ {0x07c0, 0x07fa}
+ ,
+ {0x0901, 0x0939}
+ ,
+ {0x093c, 0x094d}
+ ,
+ {0x0950, 0x0954}
+ ,
+ {0x0958, 0x0972}
+ ,
+ {0x097b, 0x097f}
+ ,
+ {0x0981, 0x0983}
+ ,
+ {0x0985, 0x098c}
+ ,
+ {0x098f, 0x0990}
+ ,
+ {0x0993, 0x09a8}
+ ,
+ {0x09aa, 0x09b0}
+ ,
+ {0x09b2, 0x09b2}
+ ,
+ {0x09b6, 0x09b9}
+ ,
+ {0x09bc, 0x09c4}
+ ,
+ {0x09c7, 0x09c8}
+ ,
+ {0x09cb, 0x09ce}
+ ,
+ {0x09d7, 0x09d7}
+ ,
+ {0x09dc, 0x09dd}
+ ,
+ {0x09df, 0x09e3}
+ ,
+ {0x09e6, 0x09fa}
+ ,
+ {0x0a01, 0x0a03}
+ ,
+ {0x0a05, 0x0a0a}
+ ,
+ {0x0a0f, 0x0a10}
+ ,
+ {0x0a13, 0x0a28}
+ ,
+ {0x0a2a, 0x0a30}
+ ,
+ {0x0a32, 0x0a33}
+ ,
+ {0x0a35, 0x0a36}
+ ,
+ {0x0a38, 0x0a39}
+ ,
+ {0x0a3c, 0x0a3c}
+ ,
+ {0x0a3e, 0x0a42}
+ ,
+ {0x0a47, 0x0a48}
+ ,
+ {0x0a4b, 0x0a4d}
+ ,
+ {0x0a51, 0x0a51}
+ ,
+ {0x0a59, 0x0a5c}
+ ,
+ {0x0a5e, 0x0a5e}
+ ,
+ {0x0a66, 0x0a75}
+ ,
+ {0x0a81, 0x0a83}
+ ,
+ {0x0a85, 0x0a8d}
+ ,
+ {0x0a8f, 0x0a91}
+ ,
+ {0x0a93, 0x0aa8}
+ ,
+ {0x0aaa, 0x0ab0}
+ ,
+ {0x0ab2, 0x0ab3}
+ ,
+ {0x0ab5, 0x0ab9}
+ ,
+ {0x0abc, 0x0ac5}
+ ,
+ {0x0ac7, 0x0ac9}
+ ,
+ {0x0acb, 0x0acd}
+ ,
+ {0x0ad0, 0x0ad0}
+ ,
+ {0x0ae0, 0x0ae3}
+ ,
+ {0x0ae6, 0x0aef}
+ ,
+ {0x0af1, 0x0af1}
+ ,
+ {0x0b01, 0x0b03}
+ ,
+ {0x0b05, 0x0b0c}
+ ,
+ {0x0b0f, 0x0b10}
+ ,
+ {0x0b13, 0x0b28}
+ ,
+ {0x0b2a, 0x0b30}
+ ,
+ {0x0b32, 0x0b33}
+ ,
+ {0x0b35, 0x0b39}
+ ,
+ {0x0b3c, 0x0b44}
+ ,
+ {0x0b47, 0x0b48}
+ ,
+ {0x0b4b, 0x0b4d}
+ ,
+ {0x0b56, 0x0b57}
+ ,
+ {0x0b5c, 0x0b5d}
+ ,
+ {0x0b5f, 0x0b63}
+ ,
+ {0x0b66, 0x0b71}
+ ,
+ {0x0b82, 0x0b83}
+ ,
+ {0x0b85, 0x0b8a}
+ ,
+ {0x0b8e, 0x0b90}
+ ,
+ {0x0b92, 0x0b95}
+ ,
+ {0x0b99, 0x0b9a}
+ ,
+ {0x0b9c, 0x0b9c}
+ ,
+ {0x0b9e, 0x0b9f}
+ ,
+ {0x0ba3, 0x0ba4}
+ ,
+ {0x0ba8, 0x0baa}
+ ,
+ {0x0bae, 0x0bb9}
+ ,
+ {0x0bbe, 0x0bc2}
+ ,
+ {0x0bc6, 0x0bc8}
+ ,
+ {0x0bca, 0x0bcd}
+ ,
+ {0x0bd0, 0x0bd0}
+ ,
+ {0x0bd7, 0x0bd7}
+ ,
+ {0x0be6, 0x0bfa}
+ ,
+ {0x0c01, 0x0c03}
+ ,
+ {0x0c05, 0x0c0c}
+ ,
+ {0x0c0e, 0x0c10}
+ ,
+ {0x0c12, 0x0c28}
+ ,
+ {0x0c2a, 0x0c33}
+ ,
+ {0x0c35, 0x0c39}
+ ,
+ {0x0c3d, 0x0c44}
+ ,
+ {0x0c46, 0x0c48}
+ ,
+ {0x0c4a, 0x0c4d}
+ ,
+ {0x0c55, 0x0c56}
+ ,
+ {0x0c58, 0x0c59}
+ ,
+ {0x0c60, 0x0c63}
+ ,
+ {0x0c66, 0x0c6f}
+ ,
+ {0x0c78, 0x0c7f}
+ ,
+ {0x0c82, 0x0c83}
+ ,
+ {0x0c85, 0x0c8c}
+ ,
+ {0x0c8e, 0x0c90}
+ ,
+ {0x0c92, 0x0ca8}
+ ,
+ {0x0caa, 0x0cb3}
+ ,
+ {0x0cb5, 0x0cb9}
+ ,
+ {0x0cbc, 0x0cc4}
+ ,
+ {0x0cc6, 0x0cc8}
+ ,
+ {0x0cca, 0x0ccd}
+ ,
+ {0x0cd5, 0x0cd6}
+ ,
+ {0x0cde, 0x0cde}
+ ,
+ {0x0ce0, 0x0ce3}
+ ,
+ {0x0ce6, 0x0cef}
+ ,
+ {0x0cf1, 0x0cf2}
+ ,
+ {0x0d02, 0x0d03}
+ ,
+ {0x0d05, 0x0d0c}
+ ,
+ {0x0d0e, 0x0d10}
+ ,
+ {0x0d12, 0x0d28}
+ ,
+ {0x0d2a, 0x0d39}
+ ,
+ {0x0d3d, 0x0d44}
+ ,
+ {0x0d46, 0x0d48}
+ ,
+ {0x0d4a, 0x0d4d}
+ ,
+ {0x0d57, 0x0d57}
+ ,
+ {0x0d60, 0x0d63}
+ ,
+ {0x0d66, 0x0d75}
+ ,
+ {0x0d79, 0x0d7f}
+ ,
+ {0x0d82, 0x0d83}
+ ,
+ {0x0d85, 0x0d96}
+ ,
+ {0x0d9a, 0x0db1}
+ ,
+ {0x0db3, 0x0dbb}
+ ,
+ {0x0dbd, 0x0dbd}
+ ,
+ {0x0dc0, 0x0dc6}
+ ,
+ {0x0dca, 0x0dca}
+ ,
+ {0x0dcf, 0x0dd4}
+ ,
+ {0x0dd6, 0x0dd6}
+ ,
+ {0x0dd8, 0x0ddf}
+ ,
+ {0x0df2, 0x0df4}
+ ,
+ {0x0e01, 0x0e3a}
+ ,
+ {0x0e3f, 0x0e5b}
+ ,
+ {0x0e81, 0x0e82}
+ ,
+ {0x0e84, 0x0e84}
+ ,
+ {0x0e87, 0x0e88}
+ ,
+ {0x0e8a, 0x0e8a}
+ ,
+ {0x0e8d, 0x0e8d}
+ ,
+ {0x0e94, 0x0e97}
+ ,
+ {0x0e99, 0x0e9f}
+ ,
+ {0x0ea1, 0x0ea3}
+ ,
+ {0x0ea5, 0x0ea5}
+ ,
+ {0x0ea7, 0x0ea7}
+ ,
+ {0x0eaa, 0x0eab}
+ ,
+ {0x0ead, 0x0eb9}
+ ,
+ {0x0ebb, 0x0ebd}
+ ,
+ {0x0ec0, 0x0ec4}
+ ,
+ {0x0ec6, 0x0ec6}
+ ,
+ {0x0ec8, 0x0ecd}
+ ,
+ {0x0ed0, 0x0ed9}
+ ,
+ {0x0edc, 0x0edd}
+ ,
+ {0x0f00, 0x0f47}
+ ,
+ {0x0f49, 0x0f6c}
+ ,
+ {0x0f71, 0x0f8b}
+ ,
+ {0x0f90, 0x0f97}
+ ,
+ {0x0f99, 0x0fbc}
+ ,
+ {0x0fbe, 0x0fcc}
+ ,
+ {0x0fce, 0x0fd4}
+ ,
+ {0x1000, 0x1099}
+ ,
+ {0x109e, 0x10c5}
+ ,
+ {0x10d0, 0x10fc}
+ ,
+ {0x1100, 0x1159}
+ ,
+ {0x115f, 0x11a2}
+ ,
+ {0x11a8, 0x11f9}
+ ,
+ {0x1200, 0x1248}
+ ,
+ {0x124a, 0x124d}
+ ,
+ {0x1250, 0x1256}
+ ,
+ {0x1258, 0x1258}
+ ,
+ {0x125a, 0x125d}
+ ,
+ {0x1260, 0x1288}
+ ,
+ {0x128a, 0x128d}
+ ,
+ {0x1290, 0x12b0}
+ ,
+ {0x12b2, 0x12b5}
+ ,
+ {0x12b8, 0x12be}
+ ,
+ {0x12c0, 0x12c0}
+ ,
+ {0x12c2, 0x12c5}
+ ,
+ {0x12c8, 0x12d6}
+ ,
+ {0x12d8, 0x1310}
+ ,
+ {0x1312, 0x1315}
+ ,
+ {0x1318, 0x135a}
+ ,
+ {0x135f, 0x137c}
+ ,
+ {0x1380, 0x1399}
+ ,
+ {0x13a0, 0x13f4}
+ ,
+ {0x1401, 0x1676}
+ ,
+ {0x1680, 0x169c}
+ ,
+ {0x16a0, 0x16f0}
+ ,
+ {0x1700, 0x170c}
+ ,
+ {0x170e, 0x1714}
+ ,
+ {0x1720, 0x1736}
+ ,
+ {0x1740, 0x1753}
+ ,
+ {0x1760, 0x176c}
+ ,
+ {0x176e, 0x1770}
+ ,
+ {0x1772, 0x1773}
+ ,
+ {0x1780, 0x17dd}
+ ,
+ {0x17e0, 0x17e9}
+ ,
+ {0x17f0, 0x17f9}
+ ,
+ {0x1800, 0x180e}
+ ,
+ {0x1810, 0x1819}
+ ,
+ {0x1820, 0x1877}
+ ,
+ {0x1880, 0x18aa}
+ ,
+ {0x1900, 0x191c}
+ ,
+ {0x1920, 0x192b}
+ ,
+ {0x1930, 0x193b}
+ ,
+ {0x1940, 0x1940}
+ ,
+ {0x1944, 0x196d}
+ ,
+ {0x1970, 0x1974}
+ ,
+ {0x1980, 0x19a9}
+ ,
+ {0x19b0, 0x19c9}
+ ,
+ {0x19d0, 0x19d9}
+ ,
+ {0x19de, 0x1a1b}
+ ,
+ {0x1a1e, 0x1a1f}
+ ,
+ {0x1b00, 0x1b4b}
+ ,
+ {0x1b50, 0x1b7c}
+ ,
+ {0x1b80, 0x1baa}
+ ,
+ {0x1bae, 0x1bb9}
+ ,
+ {0x1c00, 0x1c37}
+ ,
+ {0x1c3b, 0x1c49}
+ ,
+ {0x1c4d, 0x1c7f}
+ ,
+ {0x1d00, 0x1de6}
+ ,
+ {0x1dfe, 0x1f15}
+ ,
+ {0x1f18, 0x1f1d}
+ ,
+ {0x1f20, 0x1f45}
+ ,
+ {0x1f48, 0x1f4d}
+ ,
+ {0x1f50, 0x1f57}
+ ,
+ {0x1f59, 0x1f59}
+ ,
+ {0x1f5b, 0x1f5b}
+ ,
+ {0x1f5d, 0x1f5d}
+ ,
+ {0x1f5f, 0x1f7d}
+ ,
+ {0x1f80, 0x1fb4}
+ ,
+ {0x1fb6, 0x1fc4}
+ ,
+ {0x1fc6, 0x1fd3}
+ ,
+ {0x1fd6, 0x1fdb}
+ ,
+ {0x1fdd, 0x1fef}
+ ,
+ {0x1ff2, 0x1ff4}
+ ,
+ {0x1ff6, 0x1ffe}
+ ,
+ {0x2000, 0x2064}
+ ,
+ {0x206a, 0x2071}
+ ,
+ {0x2074, 0x208e}
+ ,
+ {0x2090, 0x2094}
+ ,
+ {0x20a0, 0x20b5}
+ ,
+ {0x20d0, 0x20f0}
+ ,
+ {0x2100, 0x214f}
+ ,
+ {0x2153, 0x2188}
+ ,
+ {0x2190, 0x23e7}
+ ,
+ {0x2400, 0x2426}
+ ,
+ {0x2440, 0x244a}
+ ,
+ {0x2460, 0x269d}
+ ,
+ {0x26a0, 0x26bc}
+ ,
+ {0x26c0, 0x26c3}
+ ,
+ {0x2701, 0x2704}
+ ,
+ {0x2706, 0x2709}
+ ,
+ {0x270c, 0x2727}
+ ,
+ {0x2729, 0x274b}
+ ,
+ {0x274d, 0x274d}
+ ,
+ {0x274f, 0x2752}
+ ,
+ {0x2756, 0x2756}
+ ,
+ {0x2758, 0x275e}
+ ,
+ {0x2761, 0x2794}
+ ,
+ {0x2798, 0x27af}
+ ,
+ {0x27b1, 0x27be}
+ ,
+ {0x27c0, 0x27ca}
+ ,
+ {0x27cc, 0x27cc}
+ ,
+ {0x27d0, 0x2b4c}
+ ,
+ {0x2b50, 0x2b54}
+ ,
+ {0x2c00, 0x2c2e}
+ ,
+ {0x2c30, 0x2c5e}
+ ,
+ {0x2c60, 0x2c6f}
+ ,
+ {0x2c71, 0x2c7d}
+ ,
+ {0x2c80, 0x2cea}
+ ,
+ {0x2cf9, 0x2d25}
+ ,
+ {0x2d30, 0x2d65}
+ ,
+ {0x2d6f, 0x2d6f}
+ ,
+ {0x2d80, 0x2d96}
+ ,
+ {0x2da0, 0x2da6}
+ ,
+ {0x2da8, 0x2dae}
+ ,
+ {0x2db0, 0x2db6}
+ ,
+ {0x2db8, 0x2dbe}
+ ,
+ {0x2dc0, 0x2dc6}
+ ,
+ {0x2dc8, 0x2dce}
+ ,
+ {0x2dd0, 0x2dd6}
+ ,
+ {0x2dd8, 0x2dde}
+ ,
+ {0x2de0, 0x2e30}
+ ,
+ {0x2e80, 0x2e99}
+ ,
+ {0x2e9b, 0x2ef3}
+ ,
+ {0x2f00, 0x2fd5}
+ ,
+ {0x2ff0, 0x2ffb}
+ ,
+ {0x3000, 0x303f}
+ ,
+ {0x3041, 0x3096}
+ ,
+ {0x3099, 0x30ff}
+ ,
+ {0x3105, 0x312d}
+ ,
+ {0x3131, 0x318e}
+ ,
+ {0x3190, 0x31b7}
+ ,
+ {0x31c0, 0x31e3}
+ ,
+ {0x31f0, 0x321e}
+ ,
+ {0x3220, 0x3243}
+ ,
+ {0x3250, 0x32fe}
+ ,
+ {0x3300, 0x4db5}
+ ,
+ {0x4dc0, 0x9fc3}
+ ,
+ {0xa000, 0xa48c}
+ ,
+ {0xa490, 0xa4c6}
+ ,
+ {0xa500, 0xa62b}
+ ,
+ {0xa640, 0xa65f}
+ ,
+ {0xa662, 0xa673}
+ ,
+ {0xa67c, 0xa697}
+ ,
+ {0xa700, 0xa78c}
+ ,
+ {0xa7fb, 0xa82b}
+ ,
+ {0xa840, 0xa877}
+ ,
+ {0xa880, 0xa8c4}
+ ,
+ {0xa8ce, 0xa8d9}
+ ,
+ {0xa900, 0xa953}
+ ,
+ {0xa95f, 0xa95f}
+ ,
+ {0xaa00, 0xaa36}
+ ,
+ {0xaa40, 0xaa4d}
+ ,
+ {0xaa50, 0xaa59}
+ ,
+ {0xaa5c, 0xaa5f}
+ ,
+ {0xac00, 0xd7a3}
+ ,
+ {0xd800, 0xfa2d}
+ ,
+ {0xfa30, 0xfa6a}
+ ,
+ {0xfa70, 0xfad9}
+ ,
+ {0xfb00, 0xfb06}
+ ,
+ {0xfb13, 0xfb17}
+ ,
+ {0xfb1d, 0xfb36}
+ ,
+ {0xfb38, 0xfb3c}
+ ,
+ {0xfb3e, 0xfb3e}
+ ,
+ {0xfb40, 0xfb41}
+ ,
+ {0xfb43, 0xfb44}
+ ,
+ {0xfb46, 0xfbb1}
+ ,
+ {0xfbd3, 0xfd3f}
+ ,
+ {0xfd50, 0xfd8f}
+ ,
+ {0xfd92, 0xfdc7}
+ ,
+ {0xfdf0, 0xfdfd}
+ ,
+ {0xfe00, 0xfe19}
+ ,
+ {0xfe20, 0xfe26}
+ ,
+ {0xfe30, 0xfe52}
+ ,
+ {0xfe54, 0xfe66}
+ ,
+ {0xfe68, 0xfe6b}
+ ,
+ {0xfe70, 0xfe74}
+ ,
+ {0xfe76, 0xfefc}
+ ,
+ {0xfeff, 0xfeff}
+ ,
+ {0xff01, 0xffbe}
+ ,
+ {0xffc2, 0xffc7}
+ ,
+ {0xffca, 0xffcf}
+ ,
+ {0xffd2, 0xffd7}
+ ,
+ {0xffda, 0xffdc}
+ ,
+ {0xffe0, 0xffe6}
+ ,
+ {0xffe8, 0xffee}
+ ,
+ {0xfff9, 0xfffd}
+ ,
+ {0x10000, 0x1000b}
+ ,
+ {0x1000d, 0x10026}
+ ,
+ {0x10028, 0x1003a}
+ ,
+ {0x1003c, 0x1003d}
+ ,
+ {0x1003f, 0x1004d}
+ ,
+ {0x10050, 0x1005d}
+ ,
+ {0x10080, 0x100fa}
+ ,
+ {0x10100, 0x10102}
+ ,
+ {0x10107, 0x10133}
+ ,
+ {0x10137, 0x1018a}
+ ,
+ {0x10190, 0x1019b}
+ ,
+ {0x101d0, 0x101fd}
+ ,
+ {0x10280, 0x1029c}
+ ,
+ {0x102a0, 0x102d0}
+ ,
+ {0x10300, 0x1031e}
+ ,
+ {0x10320, 0x10323}
+ ,
+ {0x10330, 0x1034a}
+ ,
+ {0x10380, 0x1039d}
+ ,
+ {0x1039f, 0x103c3}
+ ,
+ {0x103c8, 0x103d5}
+ ,
+ {0x10400, 0x1049d}
+ ,
+ {0x104a0, 0x104a9}
+ ,
+ {0x10800, 0x10805}
+ ,
+ {0x10808, 0x10808}
+ ,
+ {0x1080a, 0x10835}
+ ,
+ {0x10837, 0x10838}
+ ,
+ {0x1083c, 0x1083c}
+ ,
+ {0x1083f, 0x1083f}
+ ,
+ {0x10900, 0x10919}
+ ,
+ {0x1091f, 0x10939}
+ ,
+ {0x1093f, 0x1093f}
+ ,
+ {0x10a00, 0x10a03}
+ ,
+ {0x10a05, 0x10a06}
+ ,
+ {0x10a0c, 0x10a13}
+ ,
+ {0x10a15, 0x10a17}
+ ,
+ {0x10a19, 0x10a33}
+ ,
+ {0x10a38, 0x10a3a}
+ ,
+ {0x10a3f, 0x10a47}
+ ,
+ {0x10a50, 0x10a58}
+ ,
+ {0x12000, 0x1236e}
+ ,
+ {0x12400, 0x12462}
+ ,
+ {0x12470, 0x12473}
+ ,
+ {0x1d000, 0x1d0f5}
+ ,
+ {0x1d100, 0x1d126}
+ ,
+ {0x1d129, 0x1d1dd}
+ ,
+ {0x1d200, 0x1d245}
+ ,
+ {0x1d300, 0x1d356}
+ ,
+ {0x1d360, 0x1d371}
+ ,
+ {0x1d400, 0x1d454}
+ ,
+ {0x1d456, 0x1d49c}
+ ,
+ {0x1d49e, 0x1d49f}
+ ,
+ {0x1d4a2, 0x1d4a2}
+ ,
+ {0x1d4a5, 0x1d4a6}
+ ,
+ {0x1d4a9, 0x1d4ac}
+ ,
+ {0x1d4ae, 0x1d4b9}
+ ,
+ {0x1d4bb, 0x1d4bb}
+ ,
+ {0x1d4bd, 0x1d4c3}
+ ,
+ {0x1d4c5, 0x1d505}
+ ,
+ {0x1d507, 0x1d50a}
+ ,
+ {0x1d50d, 0x1d514}
+ ,
+ {0x1d516, 0x1d51c}
+ ,
+ {0x1d51e, 0x1d539}
+ ,
+ {0x1d53b, 0x1d53e}
+ ,
+ {0x1d540, 0x1d544}
+ ,
+ {0x1d546, 0x1d546}
+ ,
+ {0x1d54a, 0x1d550}
+ ,
+ {0x1d552, 0x1d6a5}
+ ,
+ {0x1d6a8, 0x1d7cb}
+ ,
+ {0x1d7ce, 0x1d7ff}
+ ,
+ {0x1f000, 0x1f02b}
+ ,
+ {0x1f030, 0x1f093}
+ ,
+ {0x20000, 0x2a6d6}
+ ,
+ {0x2f800, 0x2fa1d}
+ ,
+ {0xe0001, 0xe0001}
+ ,
+ {0xe0020, 0xe007f}
+ ,
+ {0xe0100, 0xe01ef}
+ ,
+ {0xf0000, 0xffffd}
+ ,
+ {0x100000, 0x10fffd}
+};
+
+scm_t_char_set cs_full = {
+ 445,
+ cs_full_ranges
+};
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index da571b0b8..67894b3e5 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -29,13 +29,17 @@
#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/srfi-4.h"
+#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
+#include "libguile/generalized-vectors.h"
+#include "libguile/uniform.h"
#include "libguile/error.h"
+#include "libguile/eval.h"
#include "libguile/read.h"
#include "libguile/ports.h"
#include "libguile/chars.h"
#include "libguile/vectors.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/dynwind.h"
@@ -496,11 +500,8 @@ uvec_to_list (int type, SCM uvec)
SCM res = SCM_EOL;
elts = uvec_elements (type, uvec, &handle, &len, &inc);
- for (i = len*inc; i > 0;)
- {
- i -= inc;
- res = scm_cons (scm_array_handle_ref (&handle, i), res);
- }
+ for (i = len - 1; i >= 0; i--)
+ res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
scm_array_handle_release (&handle);
return res;
}
@@ -573,29 +574,6 @@ list_to_uvec (int type, SCM list)
return uvec;
}
-static SCM
-coerce_to_uvec (int type, SCM obj)
-{
- if (is_uvec (type, obj))
- return obj;
- else if (scm_is_pair (obj))
- return list_to_uvec (type, obj);
- else if (scm_is_generalized_vector (obj))
- {
- scm_t_array_handle handle;
- size_t len = scm_c_generalized_vector_length (obj), i;
- SCM uvec = alloc_uvec (type, len);
- scm_array_get_handle (uvec, &handle);
- for (i = 0; i < len; i++)
- scm_array_handle_set (&handle, i,
- scm_c_generalized_vector_ref (obj, i));
- scm_array_handle_release (&handle);
- return uvec;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector");
-}
-
SCM_SYMBOL (scm_sym_a, "a");
SCM_SYMBOL (scm_sym_b, "b");
@@ -616,222 +594,6 @@ scm_i_generalized_vector_type (SCM v)
return SCM_BOOL_F;
}
-int
-scm_is_uniform_vector (SCM obj)
-{
- if (SCM_IS_UVEC (obj))
- return 1;
- if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
- {
- SCM v = SCM_I_ARRAY_V (obj);
- return SCM_IS_UVEC (v);
- }
- return 0;
-}
-
-size_t
-scm_c_uniform_vector_length (SCM uvec)
-{
- /* scm_generalized_vector_get_handle will ultimately call us to get
- the length of uniform vectors, so we can't use uvec_elements for
- naked vectors.
- */
-
- if (SCM_IS_UVEC (uvec))
- return SCM_UVEC_LENGTH (uvec);
- else
- {
- scm_t_array_handle handle;
- size_t len;
- ssize_t inc;
- uvec_elements (-1, uvec, &handle, &len, &inc);
- scm_array_handle_release (&handle);
- return len;
- }
-}
-
-SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a uniform vector.")
-#define FUNC_NAME s_scm_uniform_vector_p
-{
- return scm_from_bool (scm_is_uniform_vector (obj));
-}
-#undef FUNC_NAME
-
-SCM
-scm_c_uniform_vector_ref (SCM v, size_t idx)
-{
- scm_t_array_handle handle;
- size_t len;
- ssize_t inc;
- SCM res;
-
- uvec_elements (-1, v, &handle, &len, &inc);
- if (idx >= len)
- scm_out_of_range (NULL, scm_from_size_t (idx));
- res = scm_array_handle_ref (&handle, idx*inc);
- scm_array_handle_release (&handle);
- return res;
-}
-
-SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
- (SCM v, SCM idx),
- "Return the element at index @var{idx} of the\n"
- "homogenous numeric vector @var{v}.")
-#define FUNC_NAME s_scm_uniform_vector_ref
-{
-#if SCM_ENABLE_DEPRECATED
- /* Support old argument convention.
- */
- if (scm_is_pair (idx))
- {
- scm_c_issue_deprecation_warning
- ("Using a list as the index to uniform-vector-ref is deprecated.");
- if (!scm_is_null (SCM_CDR (idx)))
- scm_wrong_num_args (NULL);
- idx = SCM_CAR (idx);
- }
-#endif
-
- return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
-}
-#undef FUNC_NAME
-
-void
-scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
-{
- scm_t_array_handle handle;
- size_t len;
- ssize_t inc;
-
- uvec_writable_elements (-1, v, &handle, &len, &inc);
- if (idx >= len)
- scm_out_of_range (NULL, scm_from_size_t (idx));
- scm_array_handle_set (&handle, idx*inc, val);
- scm_array_handle_release (&handle);
-}
-
-SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
- (SCM v, SCM idx, SCM val),
- "Set the element at index @var{idx} of the\n"
- "homogenous numeric vector @var{v} to @var{val}.")
-#define FUNC_NAME s_scm_uniform_vector_set_x
-{
-#if SCM_ENABLE_DEPRECATED
- /* Support old argument convention.
- */
- if (scm_is_pair (idx))
- {
- scm_c_issue_deprecation_warning
- ("Using a list as the index to uniform-vector-set! is deprecated.");
- if (!scm_is_null (SCM_CDR (idx)))
- scm_wrong_num_args (NULL);
- idx = SCM_CAR (idx);
- }
-#endif
-
- scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
- (SCM uvec),
- "Convert the uniform numeric vector @var{uvec} to a list.")
-#define FUNC_NAME s_scm_uniform_vector_to_list
-{
- return uvec_to_list (-1, uvec);
-}
-#undef FUNC_NAME
-
-size_t
-scm_array_handle_uniform_element_size (scm_t_array_handle *h)
-{
- SCM vec = h->array;
- if (SCM_I_ARRAYP (vec))
- vec = SCM_I_ARRAY_V (vec);
- if (scm_is_uniform_vector (vec))
- return uvec_sizes[SCM_UVEC_TYPE(vec)];
- if (scm_is_bytevector (vec))
- return 1U;
- scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
-}
-
-#if SCM_ENABLE_DEPRECATED
-
-/* return the size of an element in a uniform array or 0 if type not
- found. */
-size_t
-scm_uniform_element_size (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("scm_uniform_element_size is deprecated. "
- "Use scm_array_handle_uniform_element_size instead.");
-
- if (SCM_IS_UVEC (obj))
- return uvec_sizes[SCM_UVEC_TYPE(obj)];
- else
- return 0;
-}
-
-#endif
-
-const void *
-scm_array_handle_uniform_elements (scm_t_array_handle *h)
-{
- return scm_array_handle_uniform_writable_elements (h);
-}
-
-void *
-scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
-{
- SCM vec = h->array;
- if (SCM_I_ARRAYP (vec))
- vec = SCM_I_ARRAY_V (vec);
- if (SCM_IS_UVEC (vec))
- {
- size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)];
- char *elts = SCM_UVEC_BASE (vec);
- return (void *) (elts + size*h->base);
- }
- if (scm_is_bytevector (vec))
- return SCM_BYTEVECTOR_CONTENTS (vec);
- scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
-}
-
-const void *
-scm_uniform_vector_elements (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp, ssize_t *incp)
-{
- return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
-}
-
-void *
-scm_uniform_vector_writable_elements (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp, ssize_t *incp)
-{
- scm_generalized_vector_get_handle (uvec, h);
- if (lenp)
- {
- scm_t_array_dim *dim = scm_array_handle_dims (h);
- *lenp = dim->ubnd - dim->lbnd + 1;
- *incp = dim->inc;
- }
- return scm_array_handle_uniform_writable_elements (h);
-}
-
-SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
- (SCM v),
- "Return the number of elements in the uniform vector @var{v}.")
-#define FUNC_NAME s_scm_uniform_vector_length
-{
- return uvec_length (-1, v);
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
(SCM uvec, SCM port_or_fd, SCM start, SCM end),
"Fill the elements of @var{uvec} by reading\n"
@@ -1067,6 +829,36 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
#define CTYPE double
#include "libguile/srfi-4.i.c"
+#define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \
+ SCM cname (SCM arg1) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
+ }
+
+#define DEFPROXY100(cname, scmname) \
+ DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
+
+#define DEFINE_SRFI_4_GNU_PROXIES(tag) \
+ DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
+
+#define MOD "srfi srfi-4 gnu"
+DEFINE_SRFI_4_GNU_PROXIES (u8);
+DEFINE_SRFI_4_GNU_PROXIES (s8);
+DEFINE_SRFI_4_GNU_PROXIES (u16);
+DEFINE_SRFI_4_GNU_PROXIES (s16);
+DEFINE_SRFI_4_GNU_PROXIES (u32);
+DEFINE_SRFI_4_GNU_PROXIES (s32);
+DEFINE_SRFI_4_GNU_PROXIES (u64);
+DEFINE_SRFI_4_GNU_PROXIES (s64);
+DEFINE_SRFI_4_GNU_PROXIES (f32);
+DEFINE_SRFI_4_GNU_PROXIES (f64);
+DEFINE_SRFI_4_GNU_PROXIES (c32);
+DEFINE_SRFI_4_GNU_PROXIES (c64);
+
+
static scm_i_t_array_ref uvec_reffers[12] = {
u8ref, s8ref,
u16ref, s16ref,
@@ -1085,18 +877,35 @@ static scm_i_t_array_set uvec_setters[12] = {
c32set, c64set
};
-scm_i_t_array_ref
-scm_i_uniform_vector_ref_proc (SCM uvec)
+static SCM
+uvec_handle_ref (scm_t_array_handle *h, size_t index)
+{
+ return uvec_reffers [SCM_UVEC_TYPE(h->array)] (h, index);
+}
+
+static void
+uvec_handle_set (scm_t_array_handle *h, size_t index, SCM val)
{
- return uvec_reffers[SCM_UVEC_TYPE(uvec)];
+ uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val);
}
-scm_i_t_array_set
-scm_i_uniform_vector_set_proc (SCM uvec)
+static void
+uvec_get_handle (SCM v, scm_t_array_handle *h)
{
- return uvec_setters[SCM_UVEC_TYPE(uvec)];
+ h->array = v;
+ h->ndims = 1;
+ h->dims = &h->dim0;
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = SCM_UVEC_LENGTH (v) - 1;
+ h->dim0.inc = 1;
+ h->element_type = SCM_UVEC_TYPE (v) + SCM_ARRAY_ELEMENT_TYPE_U8;
+ h->elements = h->writable_elements = SCM_UVEC_BASE (v);
}
+SCM_ARRAY_IMPLEMENTATION (scm_tc16_uvec, 0xffff,
+ uvec_handle_ref, uvec_handle_set,
+ uvec_get_handle);
+
void
scm_init_srfi_4 (void)
{
@@ -1119,6 +928,24 @@ scm_init_srfi_4 (void)
scm_permanent_object (scm_c_read_string ("9223372036854775807"));
#endif
+#define REGISTER(tag, TAG) \
+ scm_i_register_vector_constructor \
+ (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \
+ scm_make_##tag##vector)
+
+ REGISTER (u8, U8);
+ REGISTER (s8, S8);
+ REGISTER (u16, U16);
+ REGISTER (s16, S16);
+ REGISTER (u32, U32);
+ REGISTER (s32, S32);
+ REGISTER (u64, U64);
+ REGISTER (s64, S64);
+ REGISTER (f32, F32);
+ REGISTER (f64, F64);
+ REGISTER (c32, C32);
+ REGISTER (c64, C64);
+
#include "libguile/srfi-4.x"
}
diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h
index a1a9bafc0..3a45fd9e0 100644
--- a/libguile/srfi-4.h
+++ b/libguile/srfi-4.h
@@ -2,7 +2,7 @@
#define SCM_SRFI_4_H
/* srfi-4.c --- Homogeneous numeric vector datatypes.
*
- * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+ * Copyright (C) 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
@@ -22,35 +22,6 @@
#include "libguile/__scm.h"
-#include "libguile/unif.h"
-
-/* Generic procedures.
- */
-
-SCM_API SCM scm_uniform_vector_p (SCM v);
-SCM_API SCM scm_uniform_vector_length (SCM v);
-SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx);
-SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val);
-SCM_API SCM scm_uniform_vector_to_list (SCM v);
-SCM_API SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-SCM_API SCM scm_uniform_vector_write (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-
-SCM_API int scm_is_uniform_vector (SCM obj);
-SCM_API size_t scm_c_uniform_vector_length (SCM v);
-SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx);
-SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val);
-SCM_API size_t scm_array_handle_uniform_element_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);
-SCM_API const void *scm_uniform_vector_elements (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp, ssize_t *incp);
-SCM_API void *scm_uniform_vector_writable_elements (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp,
- ssize_t *incp);
/* Specific procedures.
*/
diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c
index 58a52c1d8..cecd6c638 100644
--- a/libguile/srfi-4.i.c
+++ b/libguile/srfi-4.i.c
@@ -121,17 +121,6 @@ SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0,
- (SCM obj),
- "Convert @var{obj}, which can be a list, vector, or\n"
- "uniform vector, to a numeric uniform vector of\n"
- "type " S(TAG)".")
-#define FUNC_NAME s_F(scm_any_to_,TAG,vector)
-{
- return coerce_to_uvec (TYPE, obj);
-}
-#undef FUNC_NAME
-
#ifdef CTYPE
SCM
@@ -187,13 +176,13 @@ F(scm_,TAG,vector_writable_elements) (SCM uvec,
#endif
static SCM
-F(,TAG,ref) (scm_t_array_handle *handle, ssize_t pos)
+F(,TAG,ref) (scm_t_array_handle *handle, size_t pos)
{
return uvec_fast_ref (TYPE, handle->elements, pos);
}
static void
-F(,TAG,set) (scm_t_array_handle *handle, ssize_t pos, SCM val)
+F(,TAG,set) (scm_t_array_handle *handle, size_t pos, SCM val)
{
uvec_fast_set_x (TYPE, handle->writable_elements, pos, val);
}
diff --git a/libguile/stime.c b/libguile/stime.c
index a6843377b..54022c296 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -46,6 +46,7 @@
#include <stdio.h>
#include <errno.h>
#include <strftime.h>
+#include <unistr.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
@@ -53,6 +54,7 @@
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/dynwind.h"
+#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/stime.h"
@@ -624,18 +626,20 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
{
struct tm t;
- char *tbuf;
+ scm_t_uint8 *tbuf;
int size = 50;
- const char *fmt;
- char *myfmt;
+ scm_t_uint8 *fmt;
+ scm_t_uint8 *myfmt;
int len;
SCM result;
SCM_VALIDATE_STRING (1, format);
bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
- fmt = scm_i_string_chars (format);
- len = scm_i_string_length (format);
+ /* Convert string to UTF-8 so that non-ASCII characters in the
+ format are passed through unchanged. */
+ fmt = scm_i_to_utf8_string (format);
+ len = strlen ((const char *) fmt);
/* Ugly hack: strftime can return 0 if its buffer is too small,
but some valid time strings (e.g. "%p") can sometimes produce
@@ -643,9 +647,11 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
character to the format string, so that valid returns are always
nonzero. */
myfmt = scm_malloc (len+2);
- *myfmt = 'x';
- strncpy(myfmt+1, fmt, len);
- myfmt[len+1] = 0;
+ *myfmt = (scm_t_uint8) 'x';
+ strncpy ((char *) myfmt + 1, (const char *) fmt, len);
+ myfmt[len + 1] = 0;
+ scm_remember_upto_here_1 (format);
+ free (fmt);
tbuf = scm_malloc (size);
{
@@ -680,7 +686,8 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
/* Use `nstrftime ()' from Gnulib, which supports all GNU extensions
supported by glibc. */
- while ((len = nstrftime (tbuf, size, myfmt, &t, 0, 0)) == 0)
+ while ((len = nstrftime ((char *) tbuf, size,
+ (const char *) myfmt, &t, 0, 0)) == 0)
{
free (tbuf);
size *= 2;
@@ -696,7 +703,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
#endif
}
- result = scm_from_locale_stringn (tbuf + 1, len - 1);
+ result = scm_i_from_utf8_string ((const scm_t_uint8 *) tbuf + 1);
free (tbuf);
free (myfmt);
#if HAVE_STRUCT_TM_TM_ZONE
@@ -722,14 +729,17 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
#define FUNC_NAME s_scm_strptime
{
struct tm t;
- const char *fmt, *str, *rest;
+ scm_t_uint8 *fmt, *str, *rest;
+ size_t used_len;
long zoff;
SCM_VALIDATE_STRING (1, format);
SCM_VALIDATE_STRING (2, string);
- fmt = scm_i_string_chars (format);
- str = scm_i_string_chars (string);
+ /* Convert strings to UTF-8 so that non-ASCII characters are passed
+ through unchanged. */
+ fmt = scm_i_to_utf8_string (format);
+ str = scm_i_to_utf8_string (string);
/* initialize the struct tm */
#define tm_init(field) t.field = 0
@@ -751,7 +761,8 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
fields, hence the use of SCM_CRITICAL_SECTION_START. */
t.tm_isdst = -1;
SCM_CRITICAL_SECTION_START;
- rest = strptime (str, fmt, &t);
+ rest = (scm_t_uint8 *) strptime ((const char *) str,
+ (const char *) fmt, &t);
SCM_CRITICAL_SECTION_END;
if (rest == NULL)
{
@@ -759,6 +770,9 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
instance it doesn't. Force a sensible value for our error
message. */
errno = EINVAL;
+ scm_remember_upto_here_2 (format, string);
+ free (str);
+ free (fmt);
SCM_SYSERROR;
}
@@ -770,8 +784,14 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
zoff = 0;
#endif
+ /* Compute the number of UTF-8 characters. */
+ used_len = u8_strnlen (str, rest-str);
+ scm_remember_upto_here_2 (format, string);
+ free (str);
+ free (fmt);
+
return scm_cons (filltime (&t, zoff, NULL),
- scm_from_signed_integer (rest - str));
+ scm_from_signed_integer (used_len));
}
#undef FUNC_NAME
#endif /* HAVE_STRPTIME */
diff --git a/libguile/strings.c b/libguile/strings.c
index 4e21f3e28..4a8390d16 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,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
@@ -24,11 +24,17 @@
#include <string.h>
#include <stdio.h>
+#include <ctype.h>
+#include <unistr.h>
+#include <uniconv.h>
+
+#include "striconveh.h"
#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/root.h"
#include "libguile/strings.h"
+#include "libguile/generalized-vectors.h"
#include "libguile/deprecation.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"
@@ -43,7 +49,7 @@
*
* XXX - keeping an accurate refcount during GC seems to be quite
* tricky, so we just keep score of whether a stringbuf might be
- * shared, not wether it definitely is.
+ * shared, not whether it definitely is.
*
* The scheme I (mvo) tried to keep an accurate reference count would
* recount all strings that point to a stringbuf during the mark-phase
@@ -60,28 +66,40 @@
* A stringbuf needs to know its length, but only so that it can be
* reported when the stringbuf is freed.
*
- * Stringbufs (and strings) are not stored very compactly: a stringbuf
- * has room for about 2*sizeof(scm_t_bits)-1 bytes additional
- * information. As a compensation, the code below is made more
- * complicated by storing small strings inline in the double cell of a
- * stringbuf. So we have fixstrings and bigstrings...
+ * There are 3 storage strategies for stringbufs: inline, outline, and
+ * wide.
+ *
+ * Inline strings are small 8-bit strings stored within the double
+ * cell itself. Outline strings are larger 8-bit strings with GC
+ * allocated storage. Wide strings are 32-bit strings with allocated
+ * storage.
+ *
+ * There was little value in making wide string inlineable, since
+ * there is only room for three inlined 32-bit characters. Thus wide
+ * stringbufs are never inlined.
*/
#define STRINGBUF_F_SHARED 0x100
#define STRINGBUF_F_INLINE 0x200
+#define STRINGBUF_F_WIDE 0x400 /* If true, strings have UCS-4
+ encoding. Otherwise, strings
+ are Latin-1. */
#define STRINGBUF_TAG scm_tc7_stringbuf
#define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
#define STRINGBUF_INLINE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)
+#define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE)
-#define STRINGBUF_OUTLINE_CHARS(buf) ((char *)SCM_CELL_WORD_1(buf))
+#define STRINGBUF_OUTLINE_CHARS(buf) ((unsigned char *) SCM_CELL_WORD_1(buf))
#define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf))
-#define STRINGBUF_INLINE_CHARS(buf) ((char *)SCM_CELL_OBJECT_LOC(buf,1))
+#define STRINGBUF_INLINE_CHARS(buf) ((unsigned char *) SCM_CELL_OBJECT_LOC(buf,1))
#define STRINGBUF_INLINE_LENGTH(buf) (((size_t)SCM_CELL_WORD_0(buf))>>16)
#define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \
? STRINGBUF_INLINE_CHARS (buf) \
: STRINGBUF_OUTLINE_CHARS (buf))
+
+#define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *) SCM_CELL_WORD_1(buf))
#define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
? STRINGBUF_INLINE_LENGTH (buf) \
: STRINGBUF_OUTLINE_LENGTH (buf))
@@ -91,10 +109,12 @@
#define SET_STRINGBUF_SHARED(buf) \
(SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))
-#if SCM_DEBUG
+#if SCM_STRING_LENGTH_HISTOGRAM
static size_t lenhist[1001];
#endif
+/* Make a stringbuf with space for LEN 8-bit Latin-1-encoded
+ characters. */
static SCM
make_stringbuf (size_t len)
{
@@ -105,7 +125,7 @@ make_stringbuf (size_t len)
can be dropped.
*/
-#if SCM_DEBUG
+#if SCM_STRING_LENGTH_HISTOGRAM
if (len < 1000)
lenhist[len]++;
else
@@ -126,6 +146,25 @@ make_stringbuf (size_t len)
}
}
+/* Make a stringbuf with space for LEN 32-bit UCS-4-encoded
+ characters. */
+static SCM
+make_wide_stringbuf (size_t len)
+{
+ scm_t_wchar *mem;
+#if SCM_STRING_LENGTH_HISTOGRAM
+ if (len < 1000)
+ lenhist[len]++;
+ else
+ lenhist[1000]++;
+#endif
+
+ mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
+ mem[len] = 0;
+ return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_WIDE, (scm_t_bits) mem,
+ (scm_t_bits) len, (scm_t_bits) 0);
+}
+
/* Return a new stringbuf whose underlying storage consists of the LEN+1
octets pointed to by STR (the last octet is zero). */
SCM
@@ -147,8 +186,90 @@ void
scm_i_stringbuf_free (SCM buf)
{
if (!STRINGBUF_INLINE (buf))
- scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
- STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
+ {
+ if (!STRINGBUF_WIDE (buf))
+ scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
+ STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
+ else
+ scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
+ sizeof (scm_t_wchar) * (STRINGBUF_OUTLINE_LENGTH (buf)
+ + 1), "string");
+ }
+
+}
+
+/* Convert a stringbuf containing 8-bit Latin-1-encoded characters to
+ one containing 32-bit UCS-4-encoded characters. */
+static void
+widen_stringbuf (SCM buf)
+{
+ size_t i, len;
+ scm_t_wchar *mem;
+
+ if (STRINGBUF_WIDE (buf))
+ return;
+
+ if (STRINGBUF_INLINE (buf))
+ {
+ len = STRINGBUF_INLINE_LENGTH (buf);
+
+ mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
+ for (i = 0; i < len; i++)
+ mem[i] =
+ (scm_t_wchar) STRINGBUF_INLINE_CHARS (buf)[i];
+ mem[len] = 0;
+
+ SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) ^ STRINGBUF_F_INLINE);
+ SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_WIDE);
+ SCM_SET_CELL_WORD_1 (buf, mem);
+ SCM_SET_CELL_WORD_2 (buf, len);
+ }
+ else
+ {
+ len = STRINGBUF_OUTLINE_LENGTH (buf);
+
+ mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
+ for (i = 0; i < len; i++)
+ mem[i] =
+ (scm_t_wchar) STRINGBUF_OUTLINE_CHARS (buf)[i];
+ mem[len] = 0;
+
+ scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), len + 1, "string");
+
+ SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_WIDE);
+ SCM_SET_CELL_WORD_1 (buf, mem);
+ SCM_SET_CELL_WORD_2 (buf, len);
+ }
+}
+
+/* Convert a stringbuf of 32-bit UCS-4-encoded characters to one
+ containing 8-bit Latin-1-encoded characters, if possible. */
+static void
+narrow_stringbuf (SCM buf)
+{
+ size_t i, len;
+ scm_t_wchar *wmem;
+ char *mem;
+
+ if (!STRINGBUF_WIDE (buf))
+ return;
+
+ len = STRINGBUF_OUTLINE_LENGTH (buf);
+ i = 0;
+ wmem = STRINGBUF_WIDE_CHARS (buf);
+ while (i < len)
+ if (wmem[i++] > 0xFF)
+ return;
+
+ mem = scm_gc_malloc (sizeof (char) * (len + 1), "string");
+ for (i = 0; i < len; i++)
+ mem[i] = (unsigned char) wmem[i];
+
+ scm_gc_free (wmem, sizeof (scm_t_wchar) * (len + 1), "string");
+
+ SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) ^ STRINGBUF_F_WIDE);
+ SCM_SET_CELL_WORD_1 (buf, mem);
+ SCM_SET_CELL_WORD_2 (buf, len);
}
scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
@@ -183,18 +304,36 @@ scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
+/* Create a scheme string with space for LEN 8-bit Latin-1-encoded
+ characters. CHARSP, if not NULL, will be set to location of the
+ char array. */
SCM
scm_i_make_string (size_t len, char **charsp)
{
SCM buf = make_stringbuf (len);
SCM res;
if (charsp)
- *charsp = STRINGBUF_CHARS (buf);
+ *charsp = (char *) STRINGBUF_CHARS (buf);
res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
(scm_t_bits)0, (scm_t_bits) len);
return res;
}
+/* Create a scheme string with space for LEN 32-bit UCS-4-encoded
+ characters. CHARSP, if not NULL, will be set to location of the
+ character array. */
+SCM
+scm_i_make_wide_string (size_t len, scm_t_wchar **charsp)
+{
+ SCM buf = make_wide_stringbuf (len);
+ SCM res;
+ if (charsp)
+ *charsp = STRINGBUF_WIDE_CHARS (buf);
+ res = scm_double_cell (STRING_TAG, SCM_UNPACK (buf),
+ (scm_t_bits) 0, (scm_t_bits) len);
+ return res;
+}
+
static void
validate_substring_args (SCM str, size_t start, size_t end)
{
@@ -253,12 +392,24 @@ scm_i_substring_copy (SCM str, size_t start, size_t end)
SCM buf, my_buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
- my_buf = make_stringbuf (len);
- memcpy (STRINGBUF_CHARS (my_buf),
- STRINGBUF_CHARS (buf) + str_start + start, len);
+ if (scm_i_is_narrow_string (str))
+ {
+ my_buf = make_stringbuf (len);
+ memcpy (STRINGBUF_CHARS (my_buf),
+ STRINGBUF_CHARS (buf) + str_start + start, len);
+ }
+ else
+ {
+ my_buf = make_wide_stringbuf (len);
+ u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (my_buf),
+ (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + str_start
+ + start), len);
+ /* Even though this string is wide, the substring may be narrow.
+ Consider adding code to narrow the string. */
+ }
scm_remember_upto_here_1 (buf);
- return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf),
- (scm_t_bits)0, (scm_t_bits) len);
+ return scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf),
+ (scm_t_bits) 0, (scm_t_bits) len);
}
SCM
@@ -324,23 +475,73 @@ scm_i_string_free (SCM str)
/* Internal accessors
*/
+/* Returns the number of characters in STR. This may be different
+ than the memory size of the string storage. */
size_t
scm_i_string_length (SCM str)
{
return STRING_LENGTH (str);
}
+/* True if the string is 'narrow', meaning it has a 8-bit Latin-1
+ encoding. False if it is 'wide', having a 32-bit UCS-4
+ encoding. */
+int
+scm_i_is_narrow_string (SCM str)
+{
+ return !STRINGBUF_WIDE (STRING_STRINGBUF (str));
+}
+
+/* Try to coerce a string to be narrow. It if is narrow already, do
+ nothing. If it is wide, shrink it to narrow if none of its
+ characters are above 0xFF. Return true if the string is narrow or
+ was made to be narrow. */
+int
+scm_i_try_narrow_string (SCM str)
+{
+ narrow_stringbuf (STRING_STRINGBUF (str));
+
+ return scm_i_is_narrow_string (str);
+}
+
+/* Returns a pointer to the 8-bit Latin-1 encoded character array of
+ STR. */
const char *
scm_i_string_chars (SCM str)
{
SCM buf;
size_t start;
get_str_buf_start (&str, &buf, &start);
- return STRINGBUF_CHARS (buf) + start;
+ if (scm_i_is_narrow_string (str))
+ return (const char *) STRINGBUF_CHARS (buf) + start;
+ else
+ scm_misc_error (NULL, "Invalid read access of chars of wide string: ~s",
+ scm_list_1 (str));
+ return NULL;
}
-char *
-scm_i_string_writable_chars (SCM orig_str)
+/* Returns a pointer to the 32-bit UCS-4 encoded character array of
+ STR. */
+const scm_t_wchar *
+scm_i_string_wide_chars (SCM str)
+{
+ SCM buf;
+ size_t start;
+
+ get_str_buf_start (&str, &buf, &start);
+ if (!scm_i_is_narrow_string (str))
+ return (const scm_t_wchar *) STRINGBUF_WIDE_CHARS (buf) + start;
+ else
+ scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s",
+ scm_list_1 (str));
+}
+
+/* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to
+ a new string buffer, so that it can be modified without modifying
+ other strings. Also, lock the string mutex. Later, one must call
+ scm_i_string_stop_writing to unlock the mutex. */
+SCM
+scm_i_string_start_writing (SCM orig_str)
{
SCM buf, str = orig_str;
size_t start;
@@ -352,18 +553,26 @@ scm_i_string_writable_chars (SCM orig_str)
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
if (STRINGBUF_SHARED (buf))
{
- /* Clone stringbuf. For this, we put all threads to sleep.
- */
-
+ /* Clone the stringbuf. */
size_t len = STRING_LENGTH (str);
SCM new_buf;
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
- new_buf = make_stringbuf (len);
- memcpy (STRINGBUF_CHARS (new_buf),
- STRINGBUF_CHARS (buf) + STRING_START (str), len);
-
+ if (scm_i_is_narrow_string (str))
+ {
+ new_buf = make_stringbuf (len);
+ memcpy (STRINGBUF_CHARS (new_buf),
+ STRINGBUF_CHARS (buf) + STRING_START (str), len);
+
+ }
+ else
+ {
+ new_buf = make_wide_stringbuf (len);
+ u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
+ (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf)
+ + STRING_START (str)), len);
+ }
scm_i_thread_put_to_sleep ();
SET_STRING_STRINGBUF (str, new_buf);
start -= STRING_START (str);
@@ -374,18 +583,133 @@ scm_i_string_writable_chars (SCM orig_str)
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
}
+ return orig_str;
+}
+
+/* Return a pointer to the 8-bit Latin-1 chars of a string. */
+char *
+scm_i_string_writable_chars (SCM str)
+{
+ SCM buf;
+ size_t start;
- return STRINGBUF_CHARS (buf) + start;
+ get_str_buf_start (&str, &buf, &start);
+ if (scm_i_is_narrow_string (str))
+ return (char *) STRINGBUF_CHARS (buf) + start;
+ else
+ scm_misc_error (NULL, "Invalid write access of chars of wide string: ~s",
+ scm_list_1 (str));
+ return NULL;
}
+/* Return a pointer to the UCS-4 codepoints of a string. */
+static scm_t_wchar *
+scm_i_string_writable_wide_chars (SCM str)
+{
+ SCM buf;
+ size_t start;
+
+ get_str_buf_start (&str, &buf, &start);
+ if (!scm_i_is_narrow_string (str))
+ return STRINGBUF_WIDE_CHARS (buf) + start;
+ else
+ scm_misc_error (NULL, "Invalid write access of chars of narrow string: ~s",
+ scm_list_1 (str));
+}
+
+/* Unlock the string mutex that was locked when
+ scm_i_string_start_writing was called. */
void
scm_i_string_stop_writing (void)
{
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
}
+/* Return the Xth character of STR as a UCS-4 codepoint. */
+scm_t_wchar
+scm_i_string_ref (SCM str, size_t x)
+{
+ if (scm_i_is_narrow_string (str))
+ return (scm_t_wchar) (unsigned char) (scm_i_string_chars (str)[x]);
+ else
+ return scm_i_string_wide_chars (str)[x];
+}
+
+/* Returns index+1 of the first char in STR that matches C, or
+ 0 if the char is not found. */
+int
+scm_i_string_contains_char (SCM str, char ch)
+{
+ size_t i;
+ size_t len = scm_i_string_length (str);
+
+ i = 0;
+ if (scm_i_is_narrow_string (str))
+ {
+ while (i < len)
+ {
+ if (scm_i_string_chars (str)[i] == ch)
+ return i+1;
+ i++;
+ }
+ }
+ else
+ {
+ while (i < len)
+ {
+ if (scm_i_string_wide_chars (str)[i]
+ == (unsigned char) ch)
+ return i+1;
+ i++;
+ }
+ }
+ return 0;
+}
+
+int
+scm_i_string_strcmp (SCM sstr, size_t start_x, const char *cstr)
+{
+ if (scm_i_is_narrow_string (sstr))
+ {
+ const char *a = scm_i_string_chars (sstr) + start_x;
+ const char *b = cstr;
+ return strncmp (a, b, strlen(b));
+ }
+ else
+ {
+ size_t i;
+ const scm_t_wchar *a = scm_i_string_wide_chars (sstr) + start_x;
+ const char *b = cstr;
+ for (i = 0; i < strlen (b); i++)
+ {
+ if (a[i] != (unsigned char) b[i])
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/* Set the Pth character of STR to UCS-4 codepoint CHR. */
+void
+scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr)
+{
+ if (chr > 0xFF && scm_i_is_narrow_string (str))
+ widen_stringbuf (STRING_STRINGBUF (str));
+
+ if (scm_i_is_narrow_string (str))
+ {
+ char *dst = scm_i_string_writable_chars (str);
+ dst[p] = chr;
+ }
+ else
+ {
+ scm_t_wchar *dst = scm_i_string_writable_wide_chars (str);
+ dst[p] = chr;
+ }
+}
+
/* Symbols.
-
+
Basic symbol creation and accessing is done here, the rest is in
symbols.[hc]. This has been done to keep stringbufs and the
internals of strings and string-like objects confined to this file.
@@ -418,10 +742,21 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
else
{
/* make new buf. */
- SCM new_buf = make_stringbuf (length);
- memcpy (STRINGBUF_CHARS (new_buf),
- STRINGBUF_CHARS (buf) + start, length);
- buf = new_buf;
+ if (scm_i_is_narrow_string (name))
+ {
+ SCM new_buf = make_stringbuf (length);
+ memcpy (STRINGBUF_CHARS (new_buf),
+ STRINGBUF_CHARS (buf) + start, length);
+ buf = new_buf;
+ }
+ else
+ {
+ SCM new_buf = make_wide_stringbuf (length);
+ u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
+ (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf) + start,
+ length);
+ buf = new_buf;
+ }
}
return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
(scm_t_bits) hash, SCM_UNPACK (props));
@@ -450,6 +785,8 @@ scm_i_c_take_symbol (char *name, size_t len,
(scm_t_bits) hash, SCM_UNPACK (props));
}
+/* Returns the number of characters in SYM. This may be different
+ from the memory size of SYM. */
size_t
scm_i_symbol_length (SCM sym)
{
@@ -466,11 +803,45 @@ scm_c_symbol_length (SCM sym)
}
#undef FUNC_NAME
+/* True if the name of SYM is stored as a Latin-1 encoded string.
+ False if it is stored as a 32-bit UCS-4-encoded string. */
+int
+scm_i_is_narrow_symbol (SCM sym)
+{
+ SCM buf;
+
+ buf = SYMBOL_STRINGBUF (sym);
+ return !STRINGBUF_WIDE (buf);
+}
+
+/* Returns a pointer to the 8-bit Latin-1 encoded character array that
+ contains the name of SYM. */
const char *
scm_i_symbol_chars (SCM sym)
{
- SCM buf = SYMBOL_STRINGBUF (sym);
- return STRINGBUF_CHARS (buf);
+ SCM buf;
+
+ buf = SYMBOL_STRINGBUF (sym);
+ if (!STRINGBUF_WIDE (buf))
+ return (const char *) STRINGBUF_CHARS (buf);
+ else
+ scm_misc_error (NULL, "Invalid access of chars of a wide symbol ~S",
+ scm_list_1 (sym));
+}
+
+/* Return a pointer to the 32-bit UCS-4-encoded character array of a
+ symbol's name. */
+const scm_t_wchar *
+scm_i_symbol_wide_chars (SCM sym)
+{
+ SCM buf;
+
+ buf = SYMBOL_STRINGBUF (sym);
+ if (STRINGBUF_WIDE (buf))
+ return (const scm_t_wchar *) STRINGBUF_WIDE_CHARS (buf);
+ else
+ scm_misc_error (NULL, "Invalid access of chars of a narrow symbol ~S",
+ scm_list_1 (sym));
}
SCM
@@ -496,64 +867,212 @@ scm_i_symbol_substring (SCM sym, size_t start, size_t end)
(scm_t_bits)start, (scm_t_bits) end - start);
}
+/* Returns the Xth character of symbol SYM as a UCS-4 codepoint. */
+scm_t_wchar
+scm_i_symbol_ref (SCM sym, size_t x)
+{
+ if (scm_i_is_narrow_symbol (sym))
+ return (scm_t_wchar) (unsigned char) (scm_i_symbol_chars (sym)[x]);
+ else
+ return scm_i_symbol_wide_chars (sym)[x];
+}
+
/* Debugging
*/
-#if SCM_DEBUG
-
-SCM scm_sys_string_dump (SCM);
-SCM scm_sys_symbol_dump (SCM);
-SCM scm_sys_stringbuf_hist (void);
-
-SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
- (SCM str),
- "")
+SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str),
+ "Returns an association list containing debugging information\n"
+ "for @var{str}. The association list has the following entries."
+ "@table @code\n"
+ "@item string\n"
+ "The string itself.\n"
+ "@item start\n"
+ "The start index of the string into its stringbuf\n"
+ "@item length\n"
+ "The length of the string\n"
+ "@item shared\n"
+ "If this string is a substring, it returns its parent string.\n"
+ "Otherwise, it returns @code{#f}\n"
+ "@item read-only\n"
+ "@code{#t} if the string is read-only\n"
+ "@item stringbuf-chars\n"
+ "A new string containing this string's stringbuf's characters\n"
+ "@item stringbuf-length\n"
+ "The number of characters in this stringbuf\n"
+ "@item stringbuf-shared\n"
+ "@code{#t} if this stringbuf is shared\n"
+ "@item stringbuf-inline\n"
+ "@code{#t} if this stringbuf's characters are stored in the\n"
+ "cell itself, or @code{#f} if they were allocated in memory\n"
+ "@item stringbuf-wide\n"
+ "@code{#t} if this stringbuf's characters are stored in a\n"
+ "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
+ "buffer\n"
+ "@end table")
#define FUNC_NAME s_scm_sys_string_dump
{
+ SCM e1, e2, e3, e4, e5, e6, e7, e8, e9, e10;
+ SCM buf;
SCM_VALIDATE_STRING (1, str);
- fprintf (stderr, "%p:\n", str);
- fprintf (stderr, " start: %u\n", STRING_START (str));
- fprintf (stderr, " len: %u\n", STRING_LENGTH (str));
+
+ /* String info */
+ e1 = scm_cons (scm_from_locale_symbol ("string"),
+ str);
+ e2 = scm_cons (scm_from_locale_symbol ("start"),
+ scm_from_size_t (STRING_START (str)));
+ e3 = scm_cons (scm_from_locale_symbol ("length"),
+ scm_from_size_t (STRING_LENGTH (str)));
+
if (IS_SH_STRING (str))
{
- fprintf (stderr, " string: %p\n", SH_STRING_STRING (str));
- fprintf (stderr, "\n");
- scm_sys_string_dump (SH_STRING_STRING (str));
+ e4 = scm_cons (scm_from_locale_symbol ("shared"),
+ SH_STRING_STRING (str));
+ buf = STRING_STRINGBUF (SH_STRING_STRING (str));
}
else
{
- SCM buf = STRING_STRINGBUF (str);
- fprintf (stderr, " buf: %p\n", buf);
- fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
- fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
- fprintf (stderr, " flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300));
+ e4 = scm_cons (scm_from_locale_symbol ("shared"),
+ SCM_BOOL_F);
+ buf = STRING_STRINGBUF (str);
}
- return SCM_UNSPECIFIED;
+
+ if (IS_RO_STRING (str))
+ e5 = scm_cons (scm_from_locale_symbol ("read-only"),
+ SCM_BOOL_T);
+ else
+ e5 = scm_cons (scm_from_locale_symbol ("read-only"),
+ SCM_BOOL_F);
+
+ /* Stringbuf info */
+ if (!STRINGBUF_WIDE (buf))
+ {
+ size_t len = STRINGBUF_LENGTH (buf);
+ char *cbuf;
+ SCM sbc = scm_i_make_string (len, &cbuf);
+ memcpy (cbuf, STRINGBUF_CHARS (buf), len);
+ e6 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
+ sbc);
+ }
+ else
+ {
+ size_t len = STRINGBUF_LENGTH (buf);
+ scm_t_wchar *cbuf;
+ SCM sbc = scm_i_make_wide_string (len, &cbuf);
+ u32_cpy ((scm_t_uint32 *) cbuf,
+ (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
+ e6 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
+ sbc);
+ }
+ e7 = scm_cons (scm_from_locale_symbol ("stringbuf-length"),
+ scm_from_size_t (STRINGBUF_LENGTH (buf)));
+ if (STRINGBUF_SHARED (buf))
+ e8 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
+ SCM_BOOL_T);
+ else
+ e8 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
+ SCM_BOOL_F);
+ if (STRINGBUF_INLINE (buf))
+ e9 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
+ SCM_BOOL_T);
+ else
+ e9 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
+ SCM_BOOL_F);
+ if (STRINGBUF_WIDE (buf))
+ e10 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ SCM_BOOL_T);
+ else
+ e10 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ SCM_BOOL_F);
+
+ return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, SCM_UNDEFINED);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0,
- (SCM sym),
- "")
+SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym),
+ "Returns an association list containing debugging information\n"
+ "for @var{sym}. The association list has the following entries."
+ "@table @code\n"
+ "@item symbol\n"
+ "The symbol itself\n"
+ "@item hash\n"
+ "Its hash value\n"
+ "@item interned\n"
+ "@code{#t} if it is an interned symbol\n"
+ "@item stringbuf-chars\n"
+ "A new string containing this symbols's stringbuf's characters\n"
+ "@item stringbuf-length\n"
+ "The number of characters in this stringbuf\n"
+ "@item stringbuf-shared\n"
+ "@code{#t} if this stringbuf is shared\n"
+ "@item stringbuf-inline\n"
+ "@code{#t} if this stringbuf's characters are stored in the\n"
+ "cell itself, or @code{#f} if they were allocated in memory\n"
+ "@item stringbuf-wide\n"
+ "@code{#t} if this stringbuf's characters are stored in a\n"
+ "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
+ "buffer\n"
+ "@end table")
#define FUNC_NAME s_scm_sys_symbol_dump
{
+ SCM e1, e2, e3, e4, e5, e6, e7, e8;
+ SCM buf;
SCM_VALIDATE_SYMBOL (1, sym);
- fprintf (stderr, "%p:\n", sym);
- fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym));
- {
- SCM buf = SYMBOL_STRINGBUF (sym);
- fprintf (stderr, " buf: %p\n", buf);
- fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
- fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
- fprintf (stderr, " shared: %u\n", STRINGBUF_SHARED (buf));
- }
- return SCM_UNSPECIFIED;
+ e1 = scm_cons (scm_from_locale_symbol ("symbol"),
+ sym);
+ e2 = scm_cons (scm_from_locale_symbol ("hash"),
+ scm_from_ulong (scm_i_symbol_hash (sym)));
+ e3 = scm_cons (scm_from_locale_symbol ("interned"),
+ scm_symbol_interned_p (sym));
+ buf = SYMBOL_STRINGBUF (sym);
+
+ /* Stringbuf info */
+ if (!STRINGBUF_WIDE (buf))
+ {
+ size_t len = STRINGBUF_LENGTH (buf);
+ char *cbuf;
+ SCM sbc = scm_i_make_string (len, &cbuf);
+ memcpy (cbuf, STRINGBUF_CHARS (buf), len);
+ e4 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
+ sbc);
+ }
+ else
+ {
+ size_t len = STRINGBUF_LENGTH (buf);
+ scm_t_wchar *cbuf;
+ SCM sbc = scm_i_make_wide_string (len, &cbuf);
+ u32_cpy ((scm_t_uint32 *) cbuf,
+ (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
+ e4 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
+ sbc);
+ }
+ e5 = scm_cons (scm_from_locale_symbol ("stringbuf-length"),
+ scm_from_size_t (STRINGBUF_LENGTH (buf)));
+ if (STRINGBUF_SHARED (buf))
+ e6 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
+ SCM_BOOL_T);
+ else
+ e6 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
+ SCM_BOOL_F);
+ if (STRINGBUF_INLINE (buf))
+ e7 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
+ SCM_BOOL_T);
+ else
+ e7 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
+ SCM_BOOL_F);
+ if (STRINGBUF_WIDE (buf))
+ e8 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ SCM_BOOL_T);
+ else
+ e8 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ SCM_BOOL_F);
+ return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, SCM_UNDEFINED);
+
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0,
- (void),
- "")
+#if SCM_STRING_LENGTH_HISTOGRAM
+
+SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, (void), "")
#define FUNC_NAME s_scm_sys_stringbuf_hist
{
int i;
@@ -588,30 +1107,70 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
"@var{chrs}.")
#define FUNC_NAME s_scm_string
{
- SCM result;
+ SCM result = SCM_BOOL_F;
+ SCM rest;
size_t len;
- char *data;
+ size_t p = 0;
+ long i;
+ int wide = 0;
- {
- long i = scm_ilength (chrs);
+ /* Verify that this is a list of chars. */
+ i = scm_ilength (chrs);
+ SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
- len = i;
- }
+ len = (size_t) i;
+ rest = chrs;
- result = scm_i_make_string (len, &data);
- while (len > 0 && scm_is_pair (chrs))
+ while (len > 0 && scm_is_pair (rest))
{
- SCM elt = SCM_CAR (chrs);
-
+ SCM elt = SCM_CAR (rest);
SCM_VALIDATE_CHAR (SCM_ARGn, elt);
- *data++ = SCM_CHAR (elt);
- chrs = SCM_CDR (chrs);
+ if (SCM_CHAR (elt) > 0xFF)
+ wide = 1;
+ rest = SCM_CDR (rest);
len--;
+ scm_remember_upto_here_1 (elt);
+ }
+
+ /* Construct a string containing this list of chars. */
+ len = (size_t) i;
+ rest = chrs;
+
+ if (wide == 0)
+ {
+ result = scm_i_make_string (len, NULL);
+ result = scm_i_string_start_writing (result);
+ char *buf = scm_i_string_writable_chars (result);
+ while (len > 0 && scm_is_pair (rest))
+ {
+ SCM elt = SCM_CAR (rest);
+ buf[p] = (unsigned char) SCM_CHAR (elt);
+ p++;
+ rest = SCM_CDR (rest);
+ len--;
+ scm_remember_upto_here_1 (elt);
+ }
}
+ else
+ {
+ result = scm_i_make_wide_string (len, NULL);
+ result = scm_i_string_start_writing (result);
+ scm_t_wchar *buf = scm_i_string_writable_wide_chars (result);
+ while (len > 0 && scm_is_pair (rest))
+ {
+ SCM elt = SCM_CAR (rest);
+ buf[p] = SCM_CHAR (elt);
+ p++;
+ rest = SCM_CDR (rest);
+ len--;
+ scm_remember_upto_here_1 (elt);
+ }
+ }
+ scm_i_string_stop_writing ();
+
if (len > 0)
scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
- if (!scm_is_null (chrs))
+ if (!scm_is_null (rest))
scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");
return result;
@@ -634,13 +1193,16 @@ SCM
scm_c_make_string (size_t len, SCM chr)
#define FUNC_NAME NULL
{
- char *dst;
- SCM res = scm_i_make_string (len, &dst);
+ size_t p;
+ SCM res = scm_i_make_string (len, NULL);
if (!SCM_UNBNDP (chr))
{
SCM_VALIDATE_CHAR (0, chr);
- memset (dst, SCM_CHAR (chr), len);
+ res = scm_i_string_start_writing (res);
+ for (p = 0; p < len; p++)
+ scm_i_string_set_x (res, p, SCM_CHAR (chr));
+ scm_i_string_stop_writing ();
}
return res;
@@ -657,6 +1219,20 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_string_bytes_per_char, "string-bytes-per-char", 1, 0, 0,
+ (SCM string),
+ "Return the bytes used to represent a character in @var{string}."
+ "This will return 1 or 4.")
+#define FUNC_NAME s_scm_string_bytes_per_char
+{
+ SCM_VALIDATE_STRING (1, string);
+ if (!scm_i_is_narrow_string (string))
+ return scm_from_int (4);
+
+ return scm_from_int (1);
+}
+#undef FUNC_NAME
+
size_t
scm_c_string_length (SCM string)
{
@@ -667,8 +1243,8 @@ scm_c_string_length (SCM string)
SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
(SCM str, SCM k),
- "Return character @var{k} of @var{str} using zero-origin\n"
- "indexing. @var{k} must be a valid index of @var{str}.")
+ "Return character @var{k} of @var{str} using zero-origin\n"
+ "indexing. @var{k} must be a valid index of @var{str}.")
#define FUNC_NAME s_scm_string_ref
{
size_t len;
@@ -682,7 +1258,10 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
else
scm_out_of_range (NULL, k);
- return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
+ if (scm_i_is_narrow_string (str))
+ return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
+ else
+ return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[idx]);
}
#undef FUNC_NAME
@@ -691,14 +1270,18 @@ scm_c_string_ref (SCM str, size_t p)
{
if (p >= scm_i_string_length (str))
scm_out_of_range (NULL, scm_from_size_t (p));
- return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
+ if (scm_i_is_narrow_string (str))
+ return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
+ else
+ return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[p]);
+
}
SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
(SCM str, SCM k, SCM chr),
- "Store @var{chr} in element @var{k} of @var{str} and return\n"
- "an unspecified value. @var{k} must be a valid index of\n"
- "@var{str}.")
+ "Store @var{chr} in element @var{k} of @var{str} and return\n"
+ "an unspecified value. @var{k} must be a valid index of\n"
+ "@var{str}.")
#define FUNC_NAME s_scm_string_set_x
{
size_t len;
@@ -713,11 +1296,10 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
scm_out_of_range (NULL, k);
SCM_VALIDATE_CHAR (3, chr);
- {
- char *dst = scm_i_string_writable_chars (str);
- dst[idx] = SCM_CHAR (chr);
- scm_i_string_stop_writing ();
- }
+ str = scm_i_string_start_writing (str);
+ scm_i_string_set_x (str, idx, SCM_CHAR (chr));
+ scm_i_string_stop_writing ();
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -727,11 +1309,9 @@ scm_c_string_set_x (SCM str, size_t p, SCM chr)
{
if (p >= scm_i_string_length (str))
scm_out_of_range (NULL, scm_from_size_t (p));
- {
- char *dst = scm_i_string_writable_chars (str);
- dst[p] = SCM_CHAR (chr);
- scm_i_string_stop_writing ();
- }
+ str = scm_i_string_start_writing (str);
+ scm_i_string_set_x (str, p, SCM_CHAR (chr));
+ scm_i_string_stop_writing ();
}
SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
@@ -832,31 +1412,59 @@ SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
(SCM args),
- "Return a newly allocated string whose characters form the\n"
+ "Return a newly allocated string whose characters form the\n"
"concatenation of the given strings, @var{args}.")
#define FUNC_NAME s_scm_string_append
{
SCM res;
- size_t i = 0;
+ size_t len = 0;
+ int wide = 0;
SCM l, s;
- char *data;
+ size_t i;
+ union
+ {
+ char *narrow;
+ scm_t_wchar *wide;
+ } data;
SCM_VALIDATE_REST_ARGUMENT (args);
- for (l = args; !scm_is_null (l); l = SCM_CDR (l))
+ for (l = args; !scm_is_null (l); l = SCM_CDR (l))
{
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
- i += scm_i_string_length (s);
+ len += scm_i_string_length (s);
+ if (!scm_i_is_narrow_string (s))
+ wide = 1;
}
- res = scm_i_make_string (i, &data);
- for (l = args; !scm_is_null (l); l = SCM_CDR (l))
+ data.narrow = NULL;
+ if (!wide)
+ res = scm_i_make_string (len, &data.narrow);
+ else
+ res = scm_i_make_wide_string (len, &data.wide);
+
+ for (l = args; !scm_is_null (l); l = SCM_CDR (l))
{
size_t len;
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
len = scm_i_string_length (s);
- memcpy (data, scm_i_string_chars (s), len);
- data += len;
+ if (!wide)
+ {
+ memcpy (data.narrow, scm_i_string_chars (s), len);
+ data.narrow += len;
+ }
+ else
+ {
+ if (scm_i_is_narrow_string (s))
+ {
+ for (i = 0; i < scm_i_string_length (s); i++)
+ data.wide[i] = (unsigned char) scm_i_string_chars (s)[i];
+ }
+ else
+ u32_cpy ((scm_t_uint32 *) data.wide,
+ (scm_t_uint32 *) scm_i_string_wide_chars (s), len);
+ data.wide += len;
+ }
scm_remember_upto_here_1 (s);
}
return res;
@@ -869,45 +1477,145 @@ scm_is_string (SCM obj)
return IS_STRING (obj);
}
+static SCM
+scm_from_stringn (const char *str, size_t len, const char *encoding,
+ scm_t_string_failed_conversion_handler handler)
+{
+ size_t u32len, i;
+ scm_t_wchar *u32;
+ int wide = 0;
+ SCM res;
+
+ if (encoding == NULL)
+ {
+ /* If encoding is null, use Latin-1. */
+ char *buf;
+ res = scm_i_make_string (len, &buf);
+ memcpy (buf, str, len);
+ return res;
+ }
+
+ u32len = 0;
+ u32 = (scm_t_wchar *) u32_conv_from_encoding (encoding,
+ (enum iconv_ilseq_handler)
+ handler,
+ str, len,
+ NULL,
+ NULL, &u32len);
+
+ if (u32 == NULL)
+ {
+ if (errno == ENOMEM)
+ scm_memory_error ("locale string conversion");
+ else
+ {
+ /* There are invalid sequences in the input string. */
+ SCM errstr;
+ char *dst;
+ errstr = scm_i_make_string (len, &dst);
+ memcpy (dst, str, len);
+ scm_misc_error (NULL, "input locale conversion error from ~s: ~s",
+ scm_list_2 (scm_from_locale_string (encoding),
+ errstr));
+ scm_remember_upto_here_1 (errstr);
+ }
+ }
+
+ i = 0;
+ while (i < u32len)
+ if (u32[i++] > 0xFF)
+ {
+ wide = 1;
+ break;
+ }
+
+ if (!wide)
+ {
+ char *dst;
+ res = scm_i_make_string (u32len, &dst);
+ for (i = 0; i < u32len; i ++)
+ dst[i] = (unsigned char) u32[i];
+ dst[u32len] = '\0';
+ }
+ else
+ {
+ scm_t_wchar *wdst;
+ res = scm_i_make_wide_string (u32len, &wdst);
+ u32_cpy ((scm_t_uint32 *) wdst, (scm_t_uint32 *) u32, u32len);
+ wdst[u32len] = 0;
+ }
+
+ free (u32);
+ return res;
+}
+
SCM
scm_from_locale_stringn (const char *str, size_t len)
{
- SCM res;
- char *dst;
+ const char *enc;
+ scm_t_string_failed_conversion_handler hndl;
+ SCM inport;
+ scm_t_port *pt;
- if (len == (size_t)-1)
+ if (len == (size_t) -1)
len = strlen (str);
- res = scm_i_make_string (len, &dst);
- memcpy (dst, str, len);
- return res;
+ if (len == 0)
+ return scm_nullstr;
+
+ inport = scm_current_input_port ();
+ if (!SCM_UNBNDP (inport) && SCM_OPINPORTP (inport))
+ {
+ pt = SCM_PTAB_ENTRY (inport);
+ enc = pt->encoding;
+ hndl = pt->ilseq_handler;
+ }
+ else
+ {
+ enc = NULL;
+ hndl = SCM_FAILED_CONVERSION_ERROR;
+ }
+
+ return scm_from_stringn (str, len, enc, hndl);
}
SCM
scm_from_locale_string (const char *str)
{
+ if (str == NULL)
+ return scm_nullstr;
+
return scm_from_locale_stringn (str, -1);
}
SCM
+scm_i_from_utf8_string (const scm_t_uint8 *str)
+{
+ return scm_from_stringn ((const char *) str,
+ strlen ((char *) str), "UTF-8",
+ SCM_FAILED_CONVERSION_ERROR);
+}
+
+/* Create a new scheme string from the C string STR. The memory of
+ STR may be used directly as storage for the new string. */
+SCM
scm_take_locale_stringn (char *str, size_t len)
{
SCM buf, res;
- if (len == (size_t)-1)
+ if (len == (size_t) -1)
len = strlen (str);
else
{
/* Ensure STR is null terminated. A realloc for 1 extra byte should
often be satisfied from the alignment padding after the block, with
no actual data movement. */
- str = scm_realloc (str, len+1);
+ str = scm_realloc (str, len + 1);
str[len] = '\0';
}
buf = scm_i_take_stringbufn (str, len);
res = scm_double_cell (STRING_TAG,
- SCM_UNPACK (buf),
- (scm_t_bits) 0, (scm_t_bits) len);
+ SCM_UNPACK (buf), (scm_t_bits) 0, (scm_t_bits) len);
return res;
}
@@ -917,33 +1625,180 @@ scm_take_locale_string (char *str)
return scm_take_locale_stringn (str, -1);
}
+/* Change libunistring escapes (\uXXXX and \UXXXXXXXX) to \xXX \uXXXX
+ and \UXXXXXX. */
+static void
+unistring_escapes_to_guile_escapes (char **bufp, size_t *lenp)
+{
+ char *before, *after;
+ size_t i, j;
+
+ before = *bufp;
+ after = *bufp;
+ i = 0;
+ j = 0;
+ while (i < *lenp)
+ {
+ if ((i <= *lenp - 6)
+ && before[i] == '\\'
+ && before[i + 1] == 'u'
+ && before[i + 2] == '0' && before[i + 3] == '0')
+ {
+ /* Convert \u00NN to \xNN */
+ after[j] = '\\';
+ after[j + 1] = 'x';
+ after[j + 2] = tolower ((int) before[i + 4]);
+ after[j + 3] = tolower ((int) before[i + 5]);
+ i += 6;
+ j += 4;
+ }
+ else if ((i <= *lenp - 10)
+ && before[i] == '\\'
+ && before[i + 1] == 'U'
+ && before[i + 2] == '0' && before[i + 3] == '0')
+ {
+ /* Convert \U00NNNNNN to \UNNNNNN */
+ after[j] = '\\';
+ after[j + 1] = 'U';
+ after[j + 2] = tolower ((int) before[i + 4]);
+ after[j + 3] = tolower ((int) before[i + 5]);
+ after[j + 4] = tolower ((int) before[i + 6]);
+ after[j + 5] = tolower ((int) before[i + 7]);
+ after[j + 6] = tolower ((int) before[i + 8]);
+ after[j + 7] = tolower ((int) before[i + 9]);
+ i += 10;
+ j += 8;
+ }
+ else
+ {
+ after[j] = before[i];
+ i++;
+ j++;
+ }
+ }
+ *lenp = j;
+ after = scm_realloc (after, j);
+}
+
char *
-scm_to_locale_stringn (SCM str, size_t *lenp)
+scm_to_locale_stringn (SCM str, size_t * lenp)
{
- char *res;
- size_t len;
+ SCM outport;
+ scm_t_port *pt;
+ const char *enc;
+
+ outport = scm_current_output_port ();
+ if (!SCM_UNBNDP (outport) && SCM_OPOUTPORTP (outport))
+ {
+ pt = SCM_PTAB_ENTRY (outport);
+ enc = pt->encoding;
+ }
+ else
+ enc = NULL;
+
+ return scm_to_stringn (str, lenp,
+ enc,
+ scm_i_get_conversion_strategy (SCM_BOOL_F));
+}
+
+/* Low-level scheme to C string conversion function. */
+char *
+scm_to_stringn (SCM str, size_t *lenp, const char *encoding,
+ scm_t_string_failed_conversion_handler handler)
+{
+ char *buf;
+ size_t ilen, len, i;
+ int ret;
+ const char *enc;
if (!scm_is_string (str))
scm_wrong_type_arg_msg (NULL, 0, str, "string");
- len = scm_i_string_length (str);
- res = scm_malloc (len + ((lenp==NULL)? 1 : 0));
- memcpy (res, scm_i_string_chars (str), len);
+ ilen = scm_i_string_length (str);
+
+ if (ilen == 0)
+ {
+ buf = scm_malloc (1);
+ buf[0] = '\0';
+ if (lenp)
+ *lenp = 0;
+ return buf;
+ }
+
if (lenp == NULL)
+ for (i = 0; i < ilen; i++)
+ if (scm_i_string_ref (str, i) == '\0')
+ scm_misc_error (NULL,
+ "string contains #\\nul character: ~S",
+ scm_list_1 (str));
+
+ if (scm_i_is_narrow_string (str) && (encoding == NULL))
{
- res[len] = '\0';
- if (strlen (res) != len)
- {
- free (res);
- scm_misc_error (NULL,
- "string contains #\\nul character: ~S",
- scm_list_1 (str));
- }
+ /* If using native Latin-1 encoding, just copy the string
+ contents. */
+ if (lenp)
+ {
+ buf = scm_malloc (ilen);
+ memcpy (buf, scm_i_string_chars (str), ilen);
+ *lenp = ilen;
+ return buf;
+ }
+ else
+ {
+ buf = scm_malloc (ilen + 1);
+ memcpy (buf, scm_i_string_chars (str), ilen);
+ buf[ilen] = '\0';
+ return buf;
+ }
+ }
+
+
+ buf = NULL;
+ len = 0;
+ enc = encoding;
+ if (enc == NULL)
+ enc = "ISO-8859-1";
+ if (scm_i_is_narrow_string (str))
+ {
+ ret = mem_iconveh (scm_i_string_chars (str), ilen,
+ "ISO-8859-1", enc,
+ (enum iconv_ilseq_handler) handler, NULL,
+ &buf, &len);
+
+ if (ret == 0 && handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ unistring_escapes_to_guile_escapes (&buf, &len);
+
+ if (ret != 0)
+ {
+ scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"",
+ scm_list_2 (scm_from_locale_string (enc),
+ str));
+ }
}
else
+ {
+ buf = u32_conv_to_encoding (enc,
+ (enum iconv_ilseq_handler) handler,
+ (scm_t_uint32 *) scm_i_string_wide_chars (str),
+ ilen,
+ NULL,
+ NULL, &len);
+ if (buf == NULL)
+ {
+ scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"",
+ scm_list_2 (scm_from_locale_string (enc),
+ str));
+ }
+ }
+ if (lenp)
*lenp = len;
+ else
+ {
+ buf = scm_realloc (buf, len + 1);
+ buf[len] = '\0';
+ }
scm_remember_upto_here_1 (str);
- return res;
+ return buf;
}
char *
@@ -952,22 +1807,33 @@ scm_to_locale_string (SCM str)
return scm_to_locale_stringn (str, NULL);
}
+scm_t_uint8 *
+scm_i_to_utf8_string (SCM str)
+{
+ char *u8str;
+ u8str = scm_to_stringn (str, NULL, "UTF-8", SCM_FAILED_CONVERSION_ERROR);
+ return (scm_t_uint8 *) u8str;
+}
+
size_t
scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len)
{
size_t len;
-
+ char *result = NULL;
if (!scm_is_string (str))
scm_wrong_type_arg_msg (NULL, 0, str, "string");
- len = scm_i_string_length (str);
- memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len);
+ result = scm_to_locale_stringn (str, &len);
+
+ memcpy (buf, result, (len > max_len) ? max_len : len);
+ free (result);
+
scm_remember_upto_here_1 (str);
return len;
}
/* converts C scm_array of strings to SCM scm_list of strings. */
/* If argc < 0, a null terminated scm_array is assumed. */
-SCM
+SCM
scm_makfromstrs (int argc, char **argv)
{
int i = argc;
@@ -1081,6 +1947,7 @@ scm_i_deprecated_string_chars (SCM str)
/* The following is still wrong, of course...
*/
+ str = scm_i_string_start_writing (str);
chars = scm_i_string_writable_chars (str);
scm_i_string_stop_writing ();
return chars;
@@ -1096,6 +1963,36 @@ scm_i_deprecated_string_length (SCM str)
#endif
+static SCM
+string_handle_ref (scm_t_array_handle *h, size_t index)
+{
+ return scm_c_string_ref (h->array, index);
+}
+
+static void
+string_handle_set (scm_t_array_handle *h, size_t index, SCM val)
+{
+ scm_c_string_set_x (h->array, index, val);
+}
+
+static void
+string_get_handle (SCM v, scm_t_array_handle *h)
+{
+ h->array = v;
+ h->ndims = 1;
+ h->dims = &h->dim0;
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = scm_c_string_length (v) - 1;
+ h->dim0.inc = 1;
+ h->element_type = SCM_ARRAY_ELEMENT_TYPE_CHAR;
+ h->elements = h->writable_elements = NULL;
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f & ~2,
+ string_handle_ref, string_handle_set,
+ string_get_handle);
+SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string);
+
void
scm_init_strings ()
{
diff --git a/libguile/strings.h b/libguile/strings.h
index 9e028d82e..2393aae91 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,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
@@ -46,26 +46,37 @@
Internal, low level interface to the character arrays
- - Use scm_i_string_chars to get a pointer to the byte array of a
- string for reading. Use scm_i_string_length to get the number of
- bytes in that array. The array is not null-terminated.
+ - Use scm_is_narrow_string to determine is the string is narrow or
+ wide.
+
+ - Use scm_i_string_chars or scm_i_string_wide_chars to get a
+ pointer to the byte or scm_t_wchar array of a string for reading.
+ Use scm_i_string_length to get the number of characters in that
+ array. The array is not null-terminated.
- The array is valid as long as the corresponding SCM object is
protected but only until the next SCM_TICK. During such a 'safe
point', strings might change their representation.
- - Use scm_i_string_writable_chars to get the same pointer as with
- scm_i_string_chars, but for reading and writing. This is a
- potentially costly operation since it implements the
- copy-on-write behavior. When done with the writing, call
- scm_i_string_stop_writing. You must do this before the next
- SCM_TICK. (This means, before calling almost any other scm_
- function and you can't allow throws, of course.)
-
- - New strings can be created with scm_i_make_string. This gives
- access to a writable pointer that remains valid as long as nobody
- else makes a copy-on-write substring of the string. Do not call
- scm_i_string_stop_writing for this pointer.
+ - Use scm_i_string_start_writing to get a version of the string
+ ready for reading and writing. This is a potentially costly
+ operation since it implements the copy-on-write behavior. When
+ done with the writing, call scm_i_string_stop_writing. You must
+ do this before the next SCM_TICK. (This means, before calling
+ almost any other scm_ function and you can't allow throws, of
+ course.)
+
+ - New strings can be created with scm_i_make_string or
+ scm_i_make_wide_string. This gives access to a writable pointer
+ that remains valid as long as nobody else makes a copy-on-write
+ substring of the string. Do not call scm_i_string_stop_writing
+ for this pointer.
+
+ - Alternately, scm_i_string_ref and scm_i_string_set_x can be used
+ to read and write strings without worrying about whether the
+ string is narrow or wide. scm_i_string_set_x still needs to be
+ bracketed by scm_i_string_start_writing and
+ scm_i_string_stop_writing.
Legacy interface
@@ -74,13 +85,24 @@
- SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately
calls scm_i_stop_writing, hoping for the best. SCM_STRING_LENGTH
is the same as scm_i_string_length. SCM_STRING_CHARS will throw
- an error for for strings that are not null-terminated.
+ an error for for strings that are not null-terminated. There is
+ no wide version of this interface.
*/
+/* A type indicating what strategy to take when string locale
+ conversion is unsuccessful. */
+typedef enum
+{
+ SCM_FAILED_CONVERSION_ERROR = SCM_ICONVEH_ERROR,
+ SCM_FAILED_CONVERSION_QUESTION_MARK = SCM_ICONVEH_QUESTION_MARK,
+ SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE = SCM_ICONVEH_ESCAPE_SEQUENCE
+} scm_t_string_failed_conversion_handler;
+
SCM_API SCM scm_string_p (SCM x);
SCM_API SCM scm_string (SCM chrs);
SCM_API SCM scm_make_string (SCM k, SCM chr);
SCM_API SCM scm_string_length (SCM str);
+SCM_API SCM scm_string_bytes_per_char (SCM str);
SCM_API SCM scm_string_ref (SCM str, SCM k);
SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr);
SCM_API SCM scm_substring (SCM str, SCM start, SCM end);
@@ -102,10 +124,16 @@ SCM_API SCM scm_c_substring_copy (SCM str, size_t start, size_t end);
SCM_API int scm_is_string (SCM x);
SCM_API SCM scm_from_locale_string (const char *str);
SCM_API SCM scm_from_locale_stringn (const char *str, size_t len);
+SCM_INTERNAL SCM scm_i_from_utf8_string (const scm_t_uint8 *str);
SCM_API SCM scm_take_locale_string (char *str);
SCM_API SCM scm_take_locale_stringn (char *str, size_t len);
SCM_API char *scm_to_locale_string (SCM str);
SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp);
+SCM_INTERNAL char *scm_to_stringn (SCM str, size_t *lenp,
+ const char *encoding,
+ scm_t_string_failed_conversion_handler
+ handler);
+SCM_INTERNAL scm_t_uint8 *scm_i_to_utf8_string (SCM str);
SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);
SCM_API SCM scm_makfromstrs (int argc, char **argv);
@@ -113,6 +141,7 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv);
/* internal accessor functions. Arguments must be valid. */
SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap);
+SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap);
SCM_INTERNAL SCM scm_i_substring (SCM str, size_t start, size_t end);
SCM_INTERNAL SCM scm_i_substring_read_only (SCM str, size_t start, size_t end);
SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end);
@@ -120,8 +149,14 @@ SCM_INTERNAL SCM scm_i_substring_copy (SCM str, size_t start, size_t end);
SCM_INTERNAL size_t scm_i_string_length (SCM str);
SCM_API /* FIXME: not internal */ const char *scm_i_string_chars (SCM str);
SCM_API /* FIXME: not internal */ char *scm_i_string_writable_chars (SCM str);
+SCM_INTERNAL const scm_t_wchar *scm_i_string_wide_chars (SCM str);
+SCM_INTERNAL SCM scm_i_string_start_writing (SCM str);
SCM_INTERNAL void scm_i_string_stop_writing (void);
-
+SCM_INTERNAL int scm_i_is_narrow_string (SCM str);
+SCM_INTERNAL scm_t_wchar scm_i_string_ref (SCM str, size_t x);
+SCM_INTERNAL int scm_i_string_contains_char (SCM str, char c);
+SCM_INTERNAL int scm_i_string_strcmp (SCM sstr, size_t start_x, const char *cstr);
+SCM_INTERNAL void scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr);
/* internal functions related to symbols. */
SCM_INTERNAL SCM scm_i_make_symbol (SCM name, scm_t_bits flags,
@@ -133,8 +168,12 @@ SCM_INTERNAL SCM
scm_i_c_take_symbol (char *name, size_t len,
scm_t_bits flags, unsigned long hash, SCM props);
SCM_INTERNAL const char *scm_i_symbol_chars (SCM sym);
+SCM_INTERNAL const scm_t_wchar *scm_i_symbol_wide_chars (SCM sym);
SCM_INTERNAL size_t scm_i_symbol_length (SCM sym);
+SCM_INTERNAL int scm_i_is_narrow_symbol (SCM str);
+SCM_INTERNAL int scm_i_try_narrow_string (SCM str);
SCM_INTERNAL SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end);
+SCM_INTERNAL scm_t_wchar scm_i_symbol_ref (SCM sym, size_t x);
/* internal GC functions. */
@@ -154,6 +193,14 @@ SCM_INTERNAL void scm_i_get_substring_spec (size_t len,
SCM end, size_t *cend);
SCM_INTERNAL SCM scm_i_take_stringbufn (char *str, size_t len);
+/* Debugging functions */
+
+SCM_API SCM scm_sys_string_dump (SCM);
+SCM_API SCM scm_sys_symbol_dump (SCM);
+#if SCM_STRING_LENGTH_HISTOGRAM
+SCM_API SCM scm_sys_stringbuf_hist (void);
+#endif
+
/* deprecated stuff */
#if SCM_ENABLE_DEPRECATED
diff --git a/libguile/strports.c b/libguile/strports.c
index 5c67bf9a8..490a15f8b 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -30,7 +30,7 @@
#include <unistd.h>
#endif
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/read.h"
@@ -39,6 +39,7 @@
#include "libguile/modules.h"
#include "libguile/validate.h"
#include "libguile/deprecation.h"
+#include "libguile/srfi-4.h"
#include "libguile/strports.h"
@@ -289,42 +290,33 @@ st_truncate (SCM port, scm_t_off length)
}
SCM
-scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
+scm_i_mkstrport (SCM pos, const char *locale_str, size_t str_len, long modes, const char *caller)
{
- SCM z;
+ SCM z, str;
scm_t_port *pt;
- size_t str_len, c_pos;
-
- SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
+ size_t c_pos;
+ char *buf;
+
+ /* Because ports are inherently 8-bit, strings need to be converted
+ 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. */
+ str = scm_i_make_string (str_len, &buf);
+ memcpy (buf, locale_str, str_len);
- str_len = scm_i_string_length (str);
c_pos = scm_to_unsigned_integer (pos, 0, str_len);
if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
- /* XXX
-
- Make a new string to isolate us from changes to the original.
- This is done so that we can rely on scm_i_string_chars to stay in
- place even across SCM_TICKs.
-
- Additionally, when we are going to write to the string, we make a
- copy so that we can write to it without having to use
- scm_i_string_writable_chars.
- */
-
- if (modes & SCM_WRTNG)
- str = scm_c_substring_copy (str, 0, str_len);
- else
- str = scm_c_substring (str, 0, str_len);
-
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
z = scm_new_port_table_entry (scm_tc16_strport);
pt = SCM_PTAB_ENTRY(z);
SCM_SETSTREAM (z, SCM_UNPACK (str));
SCM_SET_CELL_TYPE(z, scm_tc16_strport|modes);
- /* see above why we can use scm_i_string_chars here. */
pt->write_buf = pt->read_buf = (unsigned char *) scm_i_string_chars (str);
pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
pt->write_buf_size = pt->read_buf_size = str_len;
@@ -340,22 +332,60 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
return z;
}
+SCM
+scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
+{
+ SCM z;
+ size_t str_len;
+ char *buf;
+
+ SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
+
+ /* Because ports are inherently 8-bit, strings need to be converted
+ 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. */
+ buf = scm_to_locale_stringn (str, &str_len);
+ z = scm_i_mkstrport (pos, buf, str_len, modes, caller);
+ free (buf);
+ return z;
+}
+
/* create a new string from a string port's buffer. */
SCM scm_strport_to_string (SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM str;
- char *dst;
if (pt->rw_active == SCM_PORT_WRITE)
st_flush (port);
- str = scm_i_make_string (pt->read_buf_size, &dst);
- memcpy (dst, (char *) pt->read_buf, pt->read_buf_size);
+ 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);
+
+ 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);
+ scm_remember_upto_here_1 (port);
+ return vec;
+}
+
SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
(SCM obj, SCM printer),
"Return a Scheme string obtained by printing @var{obj}.\n"
@@ -380,6 +410,25 @@ 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"
@@ -424,6 +473,27 @@ 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"
@@ -456,11 +526,26 @@ 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
scm_c_read_string (const char *expr)
{
+ /* FIXME: the c string gets packed into a string, only to get
+ immediately unpacked in scm_mkstrport. */
SCM port = scm_mkstrport (SCM_INUM0,
scm_from_locale_string (expr),
SCM_OPN | SCM_RDNG,
diff --git a/libguile/strports.h b/libguile/strports.h
index 3129c03e2..b2ded01f1 100644
--- a/libguile/strports.h
+++ b/libguile/strports.h
@@ -44,13 +44,19 @@ SCM_API scm_t_bits scm_tc16_strport;
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 9cb165e2f..f78a812ab 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -30,6 +30,7 @@
#include "libguile/hashtab.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
+#include "libguile/srfi-13.h"
#include "libguile/validate.h"
#include "libguile/struct.h"
@@ -61,9 +62,9 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
{
SCM new_sym;
SCM_VALIDATE_STRING (1, fields);
+ scm_t_wchar c;
{ /* scope */
- const char * field_desc;
size_t len;
int x;
@@ -72,11 +73,9 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
SCM_MISC_ERROR ("odd length field specification: ~S",
scm_list_1 (fields));
- field_desc = scm_i_string_chars (fields);
-
for (x = 0; x < len; x += 2)
{
- switch (field_desc[x])
+ switch (c = scm_i_string_ref (fields, x))
{
case 'u':
case 'p':
@@ -88,13 +87,13 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
break;
default:
SCM_MISC_ERROR ("unrecognized field type: ~S",
- scm_list_1 (SCM_MAKE_CHAR (field_desc[x])));
+ scm_list_1 (SCM_MAKE_CHAR (c)));
}
- switch (field_desc[x + 1])
+ switch (c = scm_i_string_ref (fields, x + 1))
{
case 'w':
- if (field_desc[x] == 's')
+ if (scm_i_string_ref (fields, x) == 's')
SCM_MISC_ERROR ("self fields not writable", SCM_EOL);
case 'r':
case 'o':
@@ -102,7 +101,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
case 'R':
case 'W':
case 'O':
- if (field_desc[x] == 's')
+ if (scm_i_string_ref (fields, x) == 's')
SCM_MISC_ERROR ("self fields not allowed in tail array",
SCM_EOL);
if (x != len - 2)
@@ -111,12 +110,12 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
break;
default:
SCM_MISC_ERROR ("unrecognized ref specification: ~S",
- scm_list_1 (SCM_MAKE_CHAR (field_desc[x + 1])));
+ scm_list_1 (SCM_MAKE_CHAR (c)));
}
#if 0
- if (field_desc[x] == 'd')
+ if (scm_i_string_ref (fields, x, 'd'))
{
- if (field_desc[x + 2] != '-')
+ if (!scm_i_string_ref (fields, x+2, '-'))
SCM_MISC_ERROR ("missing dash field at position ~A",
scm_list_1 (scm_from_int (x / 2)));
x += 2;
@@ -138,18 +137,18 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
static void
scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM inits)
{
- unsigned const char *fields_desc =
- (unsigned const char *) scm_i_symbol_chars (layout) - 2;
- unsigned char prot = 0;
+ scm_t_wchar prot = 0;
int n_fields = scm_i_symbol_length (layout) / 2;
int tailp = 0;
+ int i;
+ i = -2;
while (n_fields)
{
if (!tailp)
{
- fields_desc += 2;
- prot = fields_desc[1];
+ i += 2;
+ prot = scm_i_symbol_ref (layout, i+1);
if (SCM_LAYOUT_TAILP (prot))
{
tailp = 1;
@@ -160,8 +159,7 @@ scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM in
break;
}
}
-
- switch (*fields_desc)
+ switch (scm_i_symbol_ref (layout, i))
{
#if 0
case 'i':
@@ -237,7 +235,8 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
{
SCM layout;
scm_t_bits * mem;
- int tmp;
+ SCM tmp;
+ size_t len;
if (!SCM_STRUCTP (x))
return SCM_BOOL_F;
@@ -248,11 +247,14 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
< scm_i_string_length (required_vtable_fields))
return SCM_BOOL_F;
- tmp = strncmp (scm_i_symbol_chars (layout),
- scm_i_string_chars (required_vtable_fields),
- scm_i_string_length (required_vtable_fields));
- scm_remember_upto_here_1 (required_vtable_fields);
- if (tmp)
+ len = scm_i_string_length (required_vtable_fields);
+ tmp = scm_string_eq (scm_symbol_to_string (layout),
+ required_vtable_fields,
+ scm_from_size_t (0),
+ scm_from_size_t (len),
+ scm_from_size_t (0),
+ scm_from_size_t (len));
+ if (scm_is_false (tmp))
return SCM_BOOL_F;
mem = SCM_STRUCT_DATA (x);
@@ -646,8 +648,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
size_t layout_len;
size_t p;
scm_t_bits n_fields;
- const char *fields_desc;
- char field_type = 0;
+ scm_t_wchar field_type = 0;
SCM_VALIDATE_STRUCT (1, handle);
@@ -656,7 +657,6 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
data = SCM_STRUCT_DATA (handle);
p = scm_to_size_t (pos);
- fields_desc = scm_i_symbol_chars (layout);
layout_len = scm_i_symbol_length (layout);
if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
/* no extra words */
@@ -668,9 +668,9 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
if (p * 2 < layout_len)
{
- char ref;
- field_type = fields_desc[p * 2];
- ref = fields_desc[p * 2 + 1];
+ scm_t_wchar ref;
+ field_type = scm_i_symbol_ref (layout, p * 2);
+ ref = scm_i_symbol_ref (layout, p * 2 + 1);
if ((ref != 'r') && (ref != 'w'))
{
if ((ref == 'R') || (ref == 'W'))
@@ -679,8 +679,8 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
}
}
- else if (fields_desc[layout_len - 1] != 'O')
- field_type = fields_desc[layout_len - 2];
+ else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O')
+ field_type = scm_i_symbol_ref(layout, layout_len - 2);
else
SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
@@ -728,8 +728,7 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
size_t layout_len;
size_t p;
int n_fields;
- const char *fields_desc;
- char field_type = 0;
+ scm_t_wchar field_type = 0;
SCM_VALIDATE_STRUCT (1, handle);
@@ -737,7 +736,6 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
data = SCM_STRUCT_DATA (handle);
p = scm_to_size_t (pos);
- fields_desc = scm_i_symbol_chars (layout);
layout_len = scm_i_symbol_length (layout);
if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
/* no extra words */
@@ -750,13 +748,13 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
if (p * 2 < layout_len)
{
char set_x;
- field_type = fields_desc[p * 2];
- set_x = fields_desc [p * 2 + 1];
+ field_type = scm_i_symbol_ref (layout, p * 2);
+ set_x = scm_i_symbol_ref (layout, p * 2 + 1);
if (set_x != 'w')
SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
}
- else if (fields_desc[layout_len - 1] == 'W')
- field_type = fields_desc[layout_len - 2];
+ else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
+ field_type = scm_i_symbol_ref (layout, layout_len - 2);
else
SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
diff --git a/libguile/symbols.c b/libguile/symbols.c
index c0ba2a8b4..a9320163a 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -89,11 +89,11 @@ scm_i_hash_symbol (SCM obj, unsigned long n, void *closure)
}
static SCM
-lookup_interned_symbol (const char *name, size_t len,
- unsigned long raw_hash)
+lookup_interned_symbol (SCM name, unsigned long raw_hash)
{
/* Try to find the symbol in the symbols table */
SCM l;
+ size_t len = scm_i_string_length (name);
unsigned long hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
for (l = SCM_HASHTABLE_BUCKET (symbols, hash);
@@ -104,15 +104,32 @@ lookup_interned_symbol (const char *name, size_t len,
if (scm_i_symbol_hash (sym) == raw_hash
&& scm_i_symbol_length (sym) == len)
{
- const char *chrs = scm_i_symbol_chars (sym);
- size_t i = len;
-
- while (i != 0)
- {
- --i;
- if (name[i] != chrs[i])
- goto next_symbol;
- }
+ size_t i = len;
+
+ /* Slightly faster path for comparing narrow to narrow. */
+ if (scm_i_is_narrow_string (name) && scm_i_is_narrow_symbol (sym))
+ {
+ const char *chrs = scm_i_symbol_chars (sym);
+ const char *str = scm_i_string_chars (name);
+
+ while (i != 0)
+ {
+ --i;
+ if (str[i] != chrs[i])
+ goto next_symbol;
+ }
+ }
+ else
+ {
+ /* Somewhat slower path for comparing narrow to wide or
+ wide to wide. */
+ while (i != 0)
+ {
+ --i;
+ if (scm_i_string_ref (name, i) != scm_i_symbol_ref (sym, i))
+ goto next_symbol;
+ }
+ }
return sym;
}
@@ -142,32 +159,12 @@ intern_symbol (SCM symbol)
}
static SCM
-scm_i_c_mem2symbol (const char *name, size_t len)
-{
- SCM symbol;
- size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
-
- symbol = lookup_interned_symbol (name, len, raw_hash);
- if (scm_is_false (symbol))
- {
- /* The symbol was not found, create it. */
- symbol = scm_i_c_make_symbol (name, len, 0, raw_hash,
- scm_cons (SCM_BOOL_F, SCM_EOL));
- intern_symbol (symbol);
- }
-
- return symbol;
-}
-
-static SCM
-scm_i_mem2symbol (SCM str)
+scm_i_str2symbol (SCM str)
{
SCM symbol;
- const char *name = scm_i_string_chars (str);
- size_t len = scm_i_string_length (str);
- size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
+ size_t raw_hash = scm_i_string_hash (str);
- symbol = lookup_interned_symbol (name, len, raw_hash);
+ symbol = lookup_interned_symbol (str, raw_hash);
if (scm_is_false (symbol))
{
/* The symbol was not found, create it. */
@@ -181,11 +178,9 @@ scm_i_mem2symbol (SCM str)
static SCM
-scm_i_mem2uninterned_symbol (SCM str)
+scm_i_str2uninterned_symbol (SCM str)
{
- const char *name = scm_i_string_chars (str);
- size_t len = scm_i_string_length (str);
- size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
+ size_t raw_hash = scm_i_string_hash (str);
return scm_i_make_symbol (str, SCM_I_F_SYMBOL_UNINTERNED,
raw_hash, scm_cons (SCM_BOOL_F, SCM_EOL));
@@ -220,7 +215,7 @@ SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0,
#define FUNC_NAME s_scm_make_symbol
{
SCM_VALIDATE_STRING (1, name);
- return scm_i_mem2uninterned_symbol (name);
+ return scm_i_str2uninterned_symbol (name);
}
#undef FUNC_NAME
@@ -282,7 +277,7 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0,
#define FUNC_NAME s_scm_string_to_symbol
{
SCM_VALIDATE_STRING (1, string);
- return scm_i_mem2symbol (string);
+ return scm_i_str2symbol (string);
}
#undef FUNC_NAME
@@ -389,44 +384,23 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
SCM
scm_from_locale_symbol (const char *sym)
{
- return scm_i_c_mem2symbol (sym, strlen (sym));
+ return scm_from_locale_symboln (sym, -1);
}
SCM
scm_from_locale_symboln (const char *sym, size_t len)
{
- return scm_i_c_mem2symbol (sym, len);
+ SCM str = scm_from_locale_stringn (sym, len);
+ return scm_i_str2symbol (str);
}
SCM
scm_take_locale_symboln (char *sym, size_t len)
{
- SCM res;
- unsigned long raw_hash;
-
- if (len == (size_t)-1)
- len = strlen (sym);
- else
- {
- /* Ensure STR is null terminated. A realloc for 1 extra byte should
- often be satisfied from the alignment padding after the block, with
- no actual data movement. */
- sym = scm_realloc (sym, len+1);
- sym[len] = '\0';
- }
-
- raw_hash = scm_string_hash ((unsigned char *)sym, len);
- res = lookup_interned_symbol (sym, len, raw_hash);
- if (scm_is_false (res))
- {
- res = scm_i_c_take_symbol (sym, len, 0, raw_hash,
- scm_cons (SCM_BOOL_F, SCM_EOL));
- intern_symbol (res);
- }
- else
- free (sym);
+ SCM str;
- return res;
+ str = scm_take_locale_stringn (sym, len);
+ return scm_i_str2symbol (str);
}
SCM
diff --git a/libguile/tags.h b/libguile/tags.h
index 329453341..9a11df51f 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -3,7 +3,7 @@
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -453,11 +453,11 @@ typedef unsigned long scm_t_bits;
#define scm_tc7_unused_6 55
#define scm_tc7_unused_7 71
#define scm_tc7_unused_8 77
-#define scm_tc7_unused_9 79
#define scm_tc7_dsubr 61
#define scm_tc7_gsubr 63
#define scm_tc7_rpsubr 69
+#define scm_tc7_program 79
#define scm_tc7_subr_0 85
#define scm_tc7_subr_1 87
#define scm_tc7_cxr 93
diff --git a/libguile/threads.c b/libguile/threads.c
index 9589336c1..e468f2fd5 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -312,7 +312,7 @@ unblock_from_queue (SCM queue)
var 't'
// save registers.
SCM_FLUSH_REGISTER_WINDOWS; // sparc only
- setjmp (t->regs); // here's most of the magic
+ SCM_I_SETJMP (t->regs); // here's most of the magic
... and returns.
@@ -366,7 +366,7 @@ unblock_from_queue (SCM queue)
t->top = SCM_STACK_PTR (&t);
// save registers.
SCM_FLUSH_REGISTER_WINDOWS;
- setjmp (t->regs);
+ SCM_I_SETJMP (t->regs);
res = func(data);
scm_enter_guile (t);
@@ -425,7 +425,7 @@ suspend (void)
t->top = SCM_STACK_PTR (&t);
/* save registers. */
SCM_FLUSH_REGISTER_WINDOWS;
- setjmp (t->regs);
+ SCM_I_SETJMP (t->regs);
return t;
}
@@ -1826,10 +1826,15 @@ scm_std_select (int nfds,
int
scm_pthread_mutex_lock (scm_i_pthread_mutex_t *mutex)
{
- scm_t_guile_ticket t = scm_leave_guile ();
- int res = scm_i_pthread_mutex_lock (mutex);
- scm_enter_guile (t);
- return res;
+ if (scm_i_pthread_mutex_trylock (mutex) == 0)
+ return 0;
+ else
+ {
+ scm_t_guile_ticket t = scm_leave_guile ();
+ int res = scm_i_pthread_mutex_lock (mutex);
+ scm_enter_guile (t);
+ return res;
+ }
}
static void
diff --git a/libguile/threads.h b/libguile/threads.h
index 32b0ea66a..9a1b6f011 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -123,7 +123,7 @@ typedef struct scm_i_thread {
SCM vm;
SCM_STACKITEM *base;
SCM_STACKITEM *top;
- jmp_buf regs;
+ scm_i_jmp_buf regs;
#ifdef __ia64__
void *register_backing_store_base;
scm_t_contregs *pending_rbs_continuation;
diff --git a/libguile/throw.c b/libguile/throw.c
index b48bea1d1..cf6ea4a49 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -23,6 +23,7 @@
#endif
#include <stdio.h>
+#include <unistdio.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/smob.h"
@@ -59,7 +60,7 @@ static scm_t_bits tc16_jmpbuffer;
#define DEACTIVATEJB(x) \
(SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
-#define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
+#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ))
#define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
#define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
#define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
@@ -81,7 +82,7 @@ make_jmpbuf (void)
{
SCM answer;
SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
- SETJBJMPBUF(answer, (jmp_buf *)0);
+ SETJBJMPBUF(answer, (scm_i_jmp_buf *)0);
DEACTIVATEJB(answer);
return answer;
}
@@ -91,7 +92,7 @@ make_jmpbuf (void)
struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
{
- jmp_buf buf; /* must be first */
+ scm_i_jmp_buf buf; /* must be first */
SCM throw_tag;
SCM retval;
};
@@ -194,7 +195,7 @@ scm_c_catch (SCM tag,
pre_unwind.lazy_catch_p = 0;
SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind);
- if (setjmp (jbr.buf))
+ if (SCM_I_SETJMP (jbr.buf))
{
SCM throw_tag;
SCM throw_args;
@@ -744,8 +745,12 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
*/
fprintf (stderr, "throw from within critical section.\n");
if (scm_is_symbol (key))
- fprintf (stderr, "error key: %s\n", scm_i_symbol_chars (key));
-
+ {
+ if (scm_i_is_narrow_symbol (key))
+ fprintf (stderr, "error key: %s\n", scm_i_symbol_chars (key));
+ else
+ ulc_fprintf (stderr, "error key: %llU\n", scm_i_symbol_wide_chars (key));
+ }
for (; scm_is_pair (s); s = scm_cdr (s), i++)
{
@@ -884,7 +889,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
jbr->throw_tag = key;
jbr->retval = args;
scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf));
- longjmp (*JBJMPBUF (jmpbuf), 1);
+ SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1);
}
/* Otherwise, it's some random piece of junk. */
diff --git a/libguile/unif.c b/libguile/unif.c
deleted file mode 100644
index 84b532347..000000000
--- a/libguile/unif.c
+++ /dev/null
@@ -1,3034 +0,0 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-
-/*
- This file has code for arrays in lots of variants (double, integer,
- unsigned etc. ). It suffers from hugely repetitive code because
- there is similar (but different) code for every variant included. (urg.)
-
- --hwn
-*/
-
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <stdio.h>
-#include <errno.h>
-#include <string.h>
-
-#include "libguile/_scm.h"
-#include "libguile/__scm.h"
-#include "libguile/eq.h"
-#include "libguile/chars.h"
-#include "libguile/eval.h"
-#include "libguile/fports.h"
-#include "libguile/smob.h"
-#include "libguile/feature.h"
-#include "libguile/root.h"
-#include "libguile/strings.h"
-#include "libguile/srfi-13.h"
-#include "libguile/srfi-4.h"
-#include "libguile/vectors.h"
-#include "libguile/bytevectors.h"
-#include "libguile/list.h"
-#include "libguile/deprecation.h"
-#include "libguile/dynwind.h"
-
-#include "libguile/validate.h"
-#include "libguile/unif.h"
-#include "libguile/ramap.h"
-#include "libguile/print.h"
-#include "libguile/read.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_IO_H
-#include <io.h>
-#endif
-
-
-/* The set of uniform scm_vector types is:
- * Vector of: Called: Replaced by:
- * unsigned char string
- * char byvect s8 or u8, depending on signedness of 'char'
- * boolean bvect
- * signed long ivect s32
- * unsigned long uvect u32
- * float fvect f32
- * double dvect d32
- * complex double cvect c64
- * short svect s16
- * long long llvect s64
- */
-
-scm_t_bits scm_i_tc16_array;
-scm_t_bits scm_i_tc16_enclosed_array;
-
-#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
-#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
-
-typedef SCM creator_proc (SCM len, SCM fill);
-
-struct {
- char *type_name;
- SCM type;
- creator_proc *creator;
-} type_creator_table[] = {
- { "a", SCM_UNSPECIFIED, scm_make_string },
- { "b", SCM_UNSPECIFIED, scm_make_bitvector },
- { "u8", SCM_UNSPECIFIED, scm_make_u8vector },
- { "s8", SCM_UNSPECIFIED, scm_make_s8vector },
- { "u16", SCM_UNSPECIFIED, scm_make_u16vector },
- { "s16", SCM_UNSPECIFIED, scm_make_s16vector },
- { "u32", SCM_UNSPECIFIED, scm_make_u32vector },
- { "s32", SCM_UNSPECIFIED, scm_make_s32vector },
- { "u64", SCM_UNSPECIFIED, scm_make_u64vector },
- { "s64", SCM_UNSPECIFIED, scm_make_s64vector },
- { "f32", SCM_UNSPECIFIED, scm_make_f32vector },
- { "f64", SCM_UNSPECIFIED, scm_make_f64vector },
- { "c32", SCM_UNSPECIFIED, scm_make_c32vector },
- { "c64", SCM_UNSPECIFIED, scm_make_c64vector },
- { "vu8", SCM_UNSPECIFIED, scm_make_bytevector },
- { NULL }
-};
-
-static void
-init_type_creator_table ()
-{
- int i;
- for (i = 0; type_creator_table[i].type_name; i++)
- {
- SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name);
- type_creator_table[i].type = scm_permanent_object (sym);
- }
-}
-
-static creator_proc *
-type_to_creator (SCM type)
-{
- int i;
-
- if (scm_is_eq (type, SCM_BOOL_T))
- return scm_make_vector;
- for (i = 0; type_creator_table[i].type_name; i++)
- if (scm_is_eq (type, type_creator_table[i].type))
- return type_creator_table[i].creator;
-
- scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type));
-}
-
-static SCM
-make_typed_vector (SCM type, size_t len)
-{
- creator_proc *creator = type_to_creator (type);
- return creator (scm_from_size_t (len), SCM_UNDEFINED);
-}
-
-#if SCM_ENABLE_DEPRECATED
-
-SCM_SYMBOL (scm_sym_s, "s");
-SCM_SYMBOL (scm_sym_l, "l");
-
-static int
-singp (SCM obj)
-{
- if (!SCM_REALP (obj))
- return 0;
- else
- {
- double x = SCM_REAL_VALUE (obj);
- float fx = x;
- return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x);
- }
-}
-
-SCM_API int scm_i_inump (SCM obj);
-SCM_API scm_t_signed_bits scm_i_inum (SCM obj);
-
-static SCM
-prototype_to_type (SCM proto)
-{
- const char *type_name;
-
- if (scm_is_eq (proto, SCM_BOOL_T))
- type_name = "b";
- else if (scm_is_eq (proto, SCM_MAKE_CHAR (0)))
- type_name = "s8";
- else if (SCM_CHARP (proto))
- type_name = "a";
- else if (scm_i_inump (proto))
- {
- if (scm_i_inum (proto) > 0)
- type_name = "u32";
- else
- type_name = "s32";
- }
- else if (scm_is_eq (proto, scm_sym_s))
- type_name = "s16";
- else if (scm_is_eq (proto, scm_sym_l))
- type_name = "s64";
- else if (SCM_REALP (proto)
- || scm_is_true (scm_eqv_p (proto,
- scm_divide (scm_from_int (1),
- scm_from_int (3)))))
- {
- if (singp (proto))
- type_name = "f32";
- else
- type_name = "f64";
- }
- else if (SCM_COMPLEXP (proto))
- type_name = "c64";
- else if (scm_is_null (proto))
- type_name = NULL;
- else
- type_name = NULL;
-
- if (type_name)
- return scm_from_locale_symbol (type_name);
- else
- return SCM_BOOL_T;
-}
-
-static SCM
-scm_i_get_old_prototype (SCM uvec)
-{
- if (scm_is_bitvector (uvec))
- return SCM_BOOL_T;
- else if (scm_is_string (uvec))
- return SCM_MAKE_CHAR ('a');
- else if (scm_is_true (scm_s8vector_p (uvec)))
- return SCM_MAKE_CHAR ('\0');
- else if (scm_is_true (scm_s16vector_p (uvec)))
- return scm_sym_s;
- else if (scm_is_true (scm_u32vector_p (uvec)))
- return scm_from_int (1);
- else if (scm_is_true (scm_s32vector_p (uvec)))
- return scm_from_int (-1);
- else if (scm_is_true (scm_s64vector_p (uvec)))
- return scm_sym_l;
- else if (scm_is_true (scm_f32vector_p (uvec)))
- return scm_from_double (1.0);
- else if (scm_is_true (scm_f64vector_p (uvec)))
- return scm_divide (scm_from_int (1), scm_from_int (3));
- else if (scm_is_true (scm_c64vector_p (uvec)))
- return scm_c_make_rectangular (0, 1);
- else if (scm_is_vector (uvec))
- return SCM_EOL;
- else
- scm_misc_error (NULL, "~a has no prototype", scm_list_1 (uvec));
-}
-
-SCM
-scm_make_uve (long k, SCM prot)
-#define FUNC_NAME "scm_make_uve"
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_uve' is deprecated, see the manual for alternatives.");
-
- return make_typed_vector (prototype_to_type (prot), k);
-}
-#undef FUNC_NAME
-
-#endif
-
-int
-scm_is_array (SCM obj)
-{
- return (SCM_I_ENCLOSED_ARRAYP (obj)
- || SCM_I_ARRAYP (obj)
- || scm_is_generalized_vector (obj));
-}
-
-int
-scm_is_typed_array (SCM obj, SCM type)
-{
- if (SCM_I_ENCLOSED_ARRAYP (obj))
- {
- /* Enclosed arrays are arrays but are not of any type.
- */
- return 0;
- }
-
- /* Get storage vector.
- */
- if (SCM_I_ARRAYP (obj))
- obj = SCM_I_ARRAY_V (obj);
-
- /* It must be a generalized vector (which includes vectors, strings, etc).
- */
- if (!scm_is_generalized_vector (obj))
- return 0;
-
- return scm_is_eq (type, scm_i_generalized_vector_type (obj));
-}
-
-static SCM
-enclosed_ref (scm_t_array_handle *h, ssize_t pos)
-{
- return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1);
-}
-
-static SCM
-vector_ref (scm_t_array_handle *h, ssize_t pos)
-{
- return ((const SCM *)h->elements)[pos];
-}
-
-static SCM
-string_ref (scm_t_array_handle *h, ssize_t pos)
-{
- pos += h->base;
- if (SCM_I_ARRAYP (h->array))
- return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos);
- else
- return scm_c_string_ref (h->array, pos);
-}
-
-static SCM
-bitvector_ref (scm_t_array_handle *h, ssize_t pos)
-{
- pos += scm_array_handle_bit_elements_offset (h);
- return
- scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32)));
-}
-
-static SCM
-bytevector_ref (scm_t_array_handle *h, ssize_t pos)
-{
- return scm_from_uint8 (((scm_t_uint8 *) h->elements)[pos]);
-}
-
-static SCM
-memoize_ref (scm_t_array_handle *h, ssize_t pos)
-{
- SCM v = h->array;
-
- if (SCM_I_ENCLOSED_ARRAYP (v))
- {
- h->ref = enclosed_ref;
- return enclosed_ref (h, pos);
- }
-
- if (SCM_I_ARRAYP (v))
- v = SCM_I_ARRAY_V (v);
-
- if (scm_is_vector (v))
- {
- h->elements = scm_array_handle_elements (h);
- h->ref = vector_ref;
- }
- else if (scm_is_uniform_vector (v))
- {
- h->elements = scm_array_handle_uniform_elements (h);
- h->ref = scm_i_uniform_vector_ref_proc (v);
- }
- else if (scm_is_string (v))
- {
- h->ref = string_ref;
- }
- else if (scm_is_bitvector (v))
- {
- h->elements = scm_array_handle_bit_elements (h);
- h->ref = bitvector_ref;
- }
- else if (scm_is_bytevector (v))
- {
- h->elements = scm_array_handle_uniform_elements (h);
- h->ref = bytevector_ref;
- }
- else
- scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
-
- return h->ref (h, pos);
-}
-
-static void
-enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val)
-{
- scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array");
-}
-
-static void
-vector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
-{
- ((SCM *)h->writable_elements)[pos] = val;
-}
-
-static void
-string_set (scm_t_array_handle *h, ssize_t pos, SCM val)
-{
- pos += h->base;
- if (SCM_I_ARRAYP (h->array))
- scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val);
- else
- scm_c_string_set_x (h->array, pos, val);
-}
-
-static void
-bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
-{
- scm_t_uint32 mask;
- pos += scm_array_handle_bit_elements_offset (h);
- mask = 1l << (pos % 32);
- if (scm_to_bool (val))
- ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask;
- else
- ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
-}
-
-static void
-bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
-{
- scm_t_uint8 c_value;
- scm_t_uint8 *elements;
-
- c_value = scm_to_uint8 (val);
- elements = (scm_t_uint8 *) h->elements;
- elements[pos] = (scm_t_uint8) c_value;
-}
-
-static void
-memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val)
-{
- SCM v = h->array;
-
- if (SCM_I_ENCLOSED_ARRAYP (v))
- {
- h->set = enclosed_set;
- enclosed_set (h, pos, val);
- return;
- }
-
- if (SCM_I_ARRAYP (v))
- v = SCM_I_ARRAY_V (v);
-
- if (scm_is_vector (v))
- {
- h->writable_elements = scm_array_handle_writable_elements (h);
- h->set = vector_set;
- }
- else if (scm_is_uniform_vector (v))
- {
- h->writable_elements = scm_array_handle_uniform_writable_elements (h);
- h->set = scm_i_uniform_vector_set_proc (v);
- }
- else if (scm_is_string (v))
- {
- h->set = string_set;
- }
- else if (scm_is_bitvector (v))
- {
- h->writable_elements = scm_array_handle_bit_writable_elements (h);
- h->set = bitvector_set;
- }
- else if (scm_is_bytevector (v))
- {
- h->elements = scm_array_handle_uniform_writable_elements (h);
- h->set = bytevector_set;
- }
- else
- scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
-
- h->set (h, pos, val);
-}
-
-void
-scm_array_get_handle (SCM array, scm_t_array_handle *h)
-{
- h->array = array;
- h->ref = memoize_ref;
- h->set = memoize_set;
-
- if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array))
- {
- h->dims = SCM_I_ARRAY_DIMS (array);
- h->base = SCM_I_ARRAY_BASE (array);
- }
- else if (scm_is_generalized_vector (array))
- {
- h->dim0.lbnd = 0;
- h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1;
- h->dim0.inc = 1;
- h->dims = &h->dim0;
- h->base = 0;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, array, "array");
-}
-
-void
-scm_array_handle_release (scm_t_array_handle *h)
-{
- /* Nothing to do here until arrays need to be reserved for real.
- */
-}
-
-size_t
-scm_array_handle_rank (scm_t_array_handle *h)
-{
- if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array))
- return SCM_I_ARRAY_NDIM (h->array);
- else
- return 1;
-}
-
-scm_t_array_dim *
-scm_array_handle_dims (scm_t_array_handle *h)
-{
- return h->dims;
-}
-
-const SCM *
-scm_array_handle_elements (scm_t_array_handle *h)
-{
- SCM vec = h->array;
- if (SCM_I_ARRAYP (vec))
- vec = SCM_I_ARRAY_V (vec);
- if (SCM_I_IS_VECTOR (vec))
- return SCM_I_VECTOR_ELTS (vec) + h->base;
- scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
-}
-
-SCM *
-scm_array_handle_writable_elements (scm_t_array_handle *h)
-{
- SCM vec = h->array;
- if (SCM_I_ARRAYP (vec))
- vec = SCM_I_ARRAY_V (vec);
- if (SCM_I_IS_VECTOR (vec))
- return SCM_I_VECTOR_WELTS (vec) + h->base;
- scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
-}
-
-#if SCM_ENABLE_DEPRECATED
-
-SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
- (SCM obj, SCM prot),
- "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
- "not.")
-#define FUNC_NAME s_scm_array_p
-{
- if (!SCM_UNBNDP (prot))
- {
- scm_c_issue_deprecation_warning
- ("Using prototypes with `array?' is deprecated."
- " Use `typed-array?' instead.");
-
- return scm_typed_array_p (obj, prototype_to_type (prot));
- }
- else
- return scm_from_bool (scm_is_array (obj));
-}
-#undef FUNC_NAME
-
-#else /* !SCM_ENABLE_DEPRECATED */
-
-/* We keep the old 2-argument C prototype for a while although the old
- PROT argument is always ignored now. C code should probably use
- scm_is_array or scm_is_typed_array anyway.
-*/
-
-static SCM scm_i_array_p (SCM obj);
-
-SCM_DEFINE (scm_i_array_p, "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_i_array_p
-{
- return scm_from_bool (scm_is_array (obj));
-}
-#undef FUNC_NAME
-
-SCM
-scm_array_p (SCM obj, SCM prot)
-{
- return scm_from_bool (scm_is_array (obj));
-}
-
-#endif /* !SCM_ENABLE_DEPRECATED */
-
-
-SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
- (SCM obj, SCM type),
- "Return @code{#t} if the @var{obj} is an array of type\n"
- "@var{type}, and @code{#f} if not.")
-#define FUNC_NAME s_scm_typed_array_p
-{
- return scm_from_bool (scm_is_typed_array (obj, type));
-}
-#undef FUNC_NAME
-
-size_t
-scm_c_array_rank (SCM array)
-{
- scm_t_array_handle handle;
- size_t res;
-
- scm_array_get_handle (array, &handle);
- res = scm_array_handle_rank (&handle);
- scm_array_handle_release (&handle);
- return res;
-}
-
-SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
- (SCM array),
- "Return the number of dimensions of the array @var{array.}\n")
-#define FUNC_NAME s_scm_array_rank
-{
- return scm_from_size_t (scm_c_array_rank (array));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
- (SCM ra),
- "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
- "elements with a @code{0} minimum with one greater than the maximum. So:\n"
- "@lisp\n"
- "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
- "@end lisp")
-#define FUNC_NAME s_scm_array_dimensions
-{
- scm_t_array_handle handle;
- scm_t_array_dim *s;
- SCM res = SCM_EOL;
- size_t k;
-
- scm_array_get_handle (ra, &handle);
- s = scm_array_handle_dims (&handle);
- k = scm_array_handle_rank (&handle);
-
- while (k--)
- res = scm_cons (s[k].lbnd
- ? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
- scm_from_ssize_t (s[k].ubnd),
- SCM_EOL)
- : scm_from_ssize_t (1 + s[k].ubnd),
- res);
-
- scm_array_handle_release (&handle);
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
- (SCM ra),
- "Return the root vector of a shared array.")
-#define FUNC_NAME s_scm_shared_array_root
-{
- if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra))
- return SCM_I_ARRAY_V (ra);
- else if (scm_is_generalized_vector (ra))
- return ra;
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
- (SCM ra),
- "Return the root vector index of the first element in the array.")
-#define FUNC_NAME s_scm_shared_array_offset
-{
- scm_t_array_handle handle;
- SCM res;
-
- scm_array_get_handle (ra, &handle);
- res = scm_from_size_t (handle.base);
- scm_array_handle_release (&handle);
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
- (SCM ra),
- "For each dimension, return the distance between elements in the root vector.")
-#define FUNC_NAME s_scm_shared_array_increments
-{
- scm_t_array_handle handle;
- SCM res = SCM_EOL;
- size_t k;
- scm_t_array_dim *s;
-
- scm_array_get_handle (ra, &handle);
- k = scm_array_handle_rank (&handle);
- s = scm_array_handle_dims (&handle);
- while (k--)
- res = scm_cons (scm_from_ssize_t (s[k].inc), res);
- scm_array_handle_release (&handle);
- return res;
-}
-#undef FUNC_NAME
-
-ssize_t
-scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
-{
- scm_t_array_dim *s = scm_array_handle_dims (h);
- ssize_t pos = 0, i;
- size_t k = scm_array_handle_rank (h);
-
- while (k > 0 && scm_is_pair (indices))
- {
- i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
- pos += (i - s->lbnd) * s->inc;
- k--;
- s++;
- indices = SCM_CDR (indices);
- }
- if (k > 0 || !scm_is_null (indices))
- scm_misc_error (NULL, "wrong number of indices, expecting ~a",
- scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
- return pos;
-}
-
-SCM
-scm_i_make_ra (int ndim, int enclosed)
-{
- scm_t_bits tag = enclosed? scm_i_tc16_enclosed_array : scm_i_tc16_array;
- SCM ra;
- SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag,
- scm_gc_malloc ((sizeof (scm_i_t_array) +
- ndim * sizeof (scm_t_array_dim)),
- "array"));
- SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
- return ra;
-}
-
-static char s_bad_spec[] = "Bad scm_array dimension";
-
-
-/* Increments will still need to be set. */
-
-static SCM
-scm_i_shap2ra (SCM args)
-{
- scm_t_array_dim *s;
- SCM ra, spec, sp;
- int ndim = scm_ilength (args);
- if (ndim < 0)
- scm_misc_error (NULL, s_bad_spec, SCM_EOL);
-
- ra = scm_i_make_ra (ndim, 0);
- SCM_I_ARRAY_BASE (ra) = 0;
- s = SCM_I_ARRAY_DIMS (ra);
- for (; !scm_is_null (args); s++, args = SCM_CDR (args))
- {
- spec = SCM_CAR (args);
- if (scm_is_integer (spec))
- {
- if (scm_to_long (spec) < 0)
- scm_misc_error (NULL, s_bad_spec, SCM_EOL);
- s->lbnd = 0;
- s->ubnd = scm_to_long (spec) - 1;
- s->inc = 1;
- }
- else
- {
- if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
- scm_misc_error (NULL, s_bad_spec, SCM_EOL);
- s->lbnd = scm_to_long (SCM_CAR (spec));
- sp = SCM_CDR (spec);
- if (!scm_is_pair (sp)
- || !scm_is_integer (SCM_CAR (sp))
- || !scm_is_null (SCM_CDR (sp)))
- scm_misc_error (NULL, s_bad_spec, SCM_EOL);
- s->ubnd = scm_to_long (SCM_CAR (sp));
- s->inc = 1;
- }
- }
- return ra;
-}
-
-SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
- (SCM type, SCM fill, SCM bounds),
- "Create and return an array of type @var{type}.")
-#define FUNC_NAME s_scm_make_typed_array
-{
- size_t k, rlen = 1;
- scm_t_array_dim *s;
- creator_proc *creator;
- SCM ra;
-
- creator = type_to_creator (type);
- ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
- s = SCM_I_ARRAY_DIMS (ra);
- k = SCM_I_ARRAY_NDIM (ra);
-
- while (k--)
- {
- s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
- rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- }
-
- if (scm_is_eq (fill, SCM_UNSPECIFIED))
- fill = SCM_UNDEFINED;
-
- SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill);
-
- if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
- return SCM_I_ARRAY_V (ra);
- return ra;
-}
-#undef FUNC_NAME
-
-SCM
-scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
- size_t byte_len)
-#define FUNC_NAME "scm_from_contiguous_typed_array"
-{
- size_t k, rlen = 1;
- scm_t_array_dim *s;
- creator_proc *creator;
- SCM ra;
- scm_t_array_handle h;
- void *base;
- size_t sz;
-
- creator = type_to_creator (type);
- ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
- s = SCM_I_ARRAY_DIMS (ra);
- k = SCM_I_ARRAY_NDIM (ra);
-
- while (k--)
- {
- s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
- rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- }
- SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), SCM_UNDEFINED);
-
-
- scm_array_get_handle (ra, &h);
- base = scm_array_handle_uniform_writable_elements (&h);
- sz = scm_array_handle_uniform_element_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);
-
- memcpy (base, 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))
- return SCM_I_ARRAY_V (ra);
- return ra;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
- (SCM fill, SCM bounds),
- "Create and return an array.")
-#define FUNC_NAME s_scm_make_array
-{
- return scm_make_typed_array (SCM_BOOL_T, fill, bounds);
-}
-#undef FUNC_NAME
-
-#if SCM_ENABLE_DEPRECATED
-
-SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0,
- (SCM dims, SCM prot, SCM fill),
- "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
- "Create and return a uniform array or vector of type\n"
- "corresponding to @var{prototype} with dimensions @var{dims} or\n"
- "length @var{length}. If @var{fill} is supplied, it's used to\n"
- "fill the array, otherwise @var{prototype} is used.")
-#define FUNC_NAME s_scm_dimensions_to_uniform_array
-{
- scm_c_issue_deprecation_warning
- ("`dimensions->uniform-array' is deprecated. "
- "Use `make-typed-array' instead.");
-
- if (scm_is_integer (dims))
- dims = scm_list_1 (dims);
-
- if (SCM_UNBNDP (fill))
- {
- /* Using #\nul as the prototype yields a s8 array, but numeric
- arrays can't store characters, so we have to special case this.
- */
- if (scm_is_eq (prot, SCM_MAKE_CHAR (0)))
- fill = scm_from_int (0);
- else
- fill = prot;
- }
-
- return scm_make_typed_array (prototype_to_type (prot), fill, dims);
-}
-#undef FUNC_NAME
-
-#endif
-
-static void
-scm_i_ra_set_contp (SCM ra)
-{
- size_t k = SCM_I_ARRAY_NDIM (ra);
- if (k)
- {
- long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
- while (k--)
- {
- if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
- {
- SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
- return;
- }
- inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
- - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
- }
- }
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
-}
-
-
-SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
- (SCM oldra, SCM mapfunc, SCM dims),
- "@code{make-shared-array} can be used to create shared subarrays of other\n"
- "arrays. The @var{mapper} is a function that translates coordinates in\n"
- "the new array into coordinates in the old array. A @var{mapper} must be\n"
- "linear, and its range must stay within the bounds of the old array, but\n"
- "it can be otherwise arbitrary. A simple example:\n"
- "@lisp\n"
- "(define fred (make-array #f 8 8))\n"
- "(define freds-diagonal\n"
- " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
- "(array-set! freds-diagonal 'foo 3)\n"
- "(array-ref fred 3 3) @result{} foo\n"
- "(define freds-center\n"
- " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
- "(array-ref freds-center 0 0) @result{} foo\n"
- "@end lisp")
-#define FUNC_NAME s_scm_make_shared_array
-{
- scm_t_array_handle old_handle;
- SCM ra;
- SCM inds, indptr;
- SCM imap;
- size_t k;
- ssize_t i;
- long old_base, old_min, new_min, old_max, new_max;
- scm_t_array_dim *s;
-
- SCM_VALIDATE_REST_ARGUMENT (dims);
- SCM_VALIDATE_PROC (2, mapfunc);
- ra = scm_i_shap2ra (dims);
-
- scm_array_get_handle (oldra, &old_handle);
-
- if (SCM_I_ARRAYP (oldra))
- {
- SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
- old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
- s = scm_array_handle_dims (&old_handle);
- k = scm_array_handle_rank (&old_handle);
- while (k--)
- {
- if (s[k].inc > 0)
- old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
- else
- old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
- }
- }
- else
- {
- SCM_I_ARRAY_V (ra) = oldra;
- old_base = old_min = 0;
- old_max = scm_c_generalized_vector_length (oldra) - 1;
- }
-
- inds = SCM_EOL;
- s = SCM_I_ARRAY_DIMS (ra);
- for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
- {
- inds = scm_cons (scm_from_long (s[k].lbnd), inds);
- if (s[k].ubnd < s[k].lbnd)
- {
- if (1 == SCM_I_ARRAY_NDIM (ra))
- ra = make_typed_vector (scm_array_type (ra), 0);
- else
- SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0);
- scm_array_handle_release (&old_handle);
- return ra;
- }
- }
-
- imap = scm_apply_0 (mapfunc, scm_reverse (inds));
- i = scm_array_handle_pos (&old_handle, imap);
- SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
- indptr = inds;
- k = SCM_I_ARRAY_NDIM (ra);
- while (k--)
- {
- if (s[k].ubnd > s[k].lbnd)
- {
- SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
- imap = scm_apply_0 (mapfunc, scm_reverse (inds));
- s[k].inc = scm_array_handle_pos (&old_handle, imap) - i;
- i += s[k].inc;
- if (s[k].inc > 0)
- new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
- else
- new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
- }
- else
- s[k].inc = new_max - new_min + 1; /* contiguous by default */
- indptr = SCM_CDR (indptr);
- }
-
- scm_array_handle_release (&old_handle);
-
- if (old_min > new_min || old_max < new_max)
- SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
- if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- {
- SCM v = SCM_I_ARRAY_V (ra);
- size_t length = scm_c_generalized_vector_length (v);
- if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
- return v;
- if (s->ubnd < s->lbnd)
- return make_typed_vector (scm_array_type (ra), 0);
- }
- scm_i_ra_set_contp (ra);
- return ra;
-}
-#undef FUNC_NAME
-
-
-/* args are RA . DIMS */
-SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
- (SCM ra, SCM args),
- "Return an array sharing contents with @var{array}, but with\n"
- "dimensions arranged in a different order. There must be one\n"
- "@var{dim} argument for each dimension of @var{array}.\n"
- "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
- "and the rank of the array to be returned. Each integer in that\n"
- "range must appear at least once in the argument list.\n"
- "\n"
- "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
- "dimensions in the array to be returned, their positions in the\n"
- "argument list to dimensions of @var{array}. Several @var{dim}s\n"
- "may have the same value, in which case the returned array will\n"
- "have smaller rank than @var{array}.\n"
- "\n"
- "@lisp\n"
- "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
- "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
- "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
- " #2((a 4) (b 5) (c 6))\n"
- "@end lisp")
-#define FUNC_NAME s_scm_transpose_array
-{
- SCM res, vargs;
- scm_t_array_dim *s, *r;
- int ndim, i, k;
-
- SCM_VALIDATE_REST_ARGUMENT (args);
- SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
-
- if (scm_is_generalized_vector (ra))
- {
- /* Make sure that we are called with a single zero as
- arguments.
- */
- if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
- SCM_WRONG_NUM_ARGS ();
- SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
- SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
- return ra;
- }
-
- if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra))
- {
- vargs = scm_vector (args);
- if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
- SCM_WRONG_NUM_ARGS ();
- ndim = 0;
- for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
- {
- i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
- 0, SCM_I_ARRAY_NDIM(ra));
- if (ndim < i)
- ndim = i;
- }
- ndim++;
- res = scm_i_make_ra (ndim, 0);
- SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
- SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
- for (k = ndim; k--;)
- {
- SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
- SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
- }
- for (k = SCM_I_ARRAY_NDIM (ra); k--;)
- {
- i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
- s = &(SCM_I_ARRAY_DIMS (ra)[k]);
- r = &(SCM_I_ARRAY_DIMS (res)[i]);
- if (r->ubnd < r->lbnd)
- {
- r->lbnd = s->lbnd;
- r->ubnd = s->ubnd;
- r->inc = s->inc;
- ndim--;
- }
- else
- {
- if (r->ubnd > s->ubnd)
- r->ubnd = s->ubnd;
- if (r->lbnd < s->lbnd)
- {
- SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
- r->lbnd = s->lbnd;
- }
- r->inc += s->inc;
- }
- }
- if (ndim > 0)
- SCM_MISC_ERROR ("bad argument list", SCM_EOL);
- scm_i_ra_set_contp (res);
- return res;
- }
-
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
-}
-#undef FUNC_NAME
-
-/* args are RA . AXES */
-SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
- (SCM ra, SCM axes),
- "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
- "the rank of @var{array}. @var{enclose-array} returns an array\n"
- "resembling an array of shared arrays. The dimensions of each shared\n"
- "array are the same as the @var{dim}th dimensions of the original array,\n"
- "the dimensions of the outer array are the same as those of the original\n"
- "array that did not match a @var{dim}.\n\n"
- "An enclosed array is not a general Scheme array. Its elements may not\n"
- "be set using @code{array-set!}. Two references to the same element of\n"
- "an enclosed array will be @code{equal?} but will not in general be\n"
- "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
- "enclosed array is unspecified.\n\n"
- "examples:\n"
- "@lisp\n"
- "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
- " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
- "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
- " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
- "@end lisp")
-#define FUNC_NAME s_scm_enclose_array
-{
- SCM axv, res, ra_inr;
- const char *c_axv;
- scm_t_array_dim vdim, *s = &vdim;
- int ndim, j, k, ninr, noutr;
-
- SCM_VALIDATE_REST_ARGUMENT (axes);
- if (scm_is_null (axes))
- axes = scm_cons ((SCM_I_ARRAYP (ra) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
- ninr = scm_ilength (axes);
- if (ninr < 0)
- SCM_WRONG_NUM_ARGS ();
- ra_inr = scm_i_make_ra (ninr, 0);
-
- if (scm_is_generalized_vector (ra))
- {
- s->lbnd = 0;
- s->ubnd = scm_c_generalized_vector_length (ra) - 1;
- s->inc = 1;
- SCM_I_ARRAY_V (ra_inr) = ra;
- SCM_I_ARRAY_BASE (ra_inr) = 0;
- ndim = 1;
- }
- else if (SCM_I_ARRAYP (ra))
- {
- s = SCM_I_ARRAY_DIMS (ra);
- SCM_I_ARRAY_V (ra_inr) = SCM_I_ARRAY_V (ra);
- SCM_I_ARRAY_BASE (ra_inr) = SCM_I_ARRAY_BASE (ra);
- ndim = SCM_I_ARRAY_NDIM (ra);
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
-
- noutr = ndim - ninr;
- if (noutr < 0)
- SCM_WRONG_NUM_ARGS ();
- axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0));
- res = scm_i_make_ra (noutr, 1);
- SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra_inr);
- SCM_I_ARRAY_V (res) = ra_inr;
- for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
- {
- if (!scm_is_integer (SCM_CAR (axes)))
- SCM_MISC_ERROR ("bad axis", SCM_EOL);
- j = scm_to_int (SCM_CAR (axes));
- SCM_I_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
- SCM_I_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
- SCM_I_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
- scm_c_string_set_x (axv, j, SCM_MAKE_CHAR (1));
- }
- c_axv = scm_i_string_chars (axv);
- for (j = 0, k = 0; k < noutr; k++, j++)
- {
- while (c_axv[j])
- j++;
- SCM_I_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
- SCM_I_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
- SCM_I_ARRAY_DIMS (res)[k].inc = s[j].inc;
- }
- scm_remember_upto_here_1 (axv);
- scm_i_ra_set_contp (ra_inr);
- scm_i_ra_set_contp (res);
- return res;
-}
-#undef FUNC_NAME
-
-
-
-SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
- (SCM v, SCM args),
- "Return @code{#t} if its arguments would be acceptable to\n"
- "@code{array-ref}.")
-#define FUNC_NAME s_scm_array_in_bounds_p
-{
- SCM res = SCM_BOOL_T;
-
- SCM_VALIDATE_REST_ARGUMENT (args);
-
- if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
- {
- size_t k, ndim = SCM_I_ARRAY_NDIM (v);
- scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v);
-
- for (k = 0; k < ndim; k++)
- {
- long ind;
-
- if (!scm_is_pair (args))
- SCM_WRONG_NUM_ARGS ();
- ind = scm_to_long (SCM_CAR (args));
- args = SCM_CDR (args);
-
- if (ind < s[k].lbnd || ind > s[k].ubnd)
- {
- res = SCM_BOOL_F;
- /* We do not stop the checking after finding a violation
- since we want to validate the type-correctness and
- number of arguments in any case.
- */
- }
- }
- }
- else if (scm_is_generalized_vector (v))
- {
- /* Since real arrays have been covered above, all generalized
- vectors are guaranteed to be zero-origin here.
- */
-
- long ind;
-
- if (!scm_is_pair (args))
- SCM_WRONG_NUM_ARGS ();
- ind = scm_to_long (SCM_CAR (args));
- args = SCM_CDR (args);
- res = scm_from_bool (ind >= 0
- && ind < scm_c_generalized_vector_length (v));
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "array");
-
- if (!scm_is_null (args))
- SCM_WRONG_NUM_ARGS ();
-
- return res;
-}
-#undef FUNC_NAME
-
-SCM
-scm_i_cvref (SCM v, size_t pos, int enclosed)
-{
- if (enclosed)
- {
- int k = SCM_I_ARRAY_NDIM (v);
- SCM res = scm_i_make_ra (k, 0);
- SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (v);
- SCM_I_ARRAY_BASE (res) = pos;
- while (k--)
- {
- SCM_I_ARRAY_DIMS (res)[k].ubnd = SCM_I_ARRAY_DIMS (v)[k].ubnd;
- SCM_I_ARRAY_DIMS (res)[k].lbnd = SCM_I_ARRAY_DIMS (v)[k].lbnd;
- SCM_I_ARRAY_DIMS (res)[k].inc = SCM_I_ARRAY_DIMS (v)[k].inc;
- }
- return res;
- }
- else
- return scm_c_generalized_vector_ref (v, pos);
-}
-
-SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
- (SCM v, SCM args),
- "Return the element at the @code{(index1, index2)} element in\n"
- "@var{array}.")
-#define FUNC_NAME s_scm_array_ref
-{
- scm_t_array_handle handle;
- SCM res;
-
- scm_array_get_handle (v, &handle);
- res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
- scm_array_handle_release (&handle);
- return res;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
- (SCM v, SCM obj, SCM args),
- "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
- "@var{new-value}. The value returned by array-set! is unspecified.")
-#define FUNC_NAME s_scm_array_set_x
-{
- scm_t_array_handle handle;
-
- scm_array_get_handle (v, &handle);
- scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
- scm_array_handle_release (&handle);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-/* attempts to unroll an array into a one-dimensional array.
- returns the unrolled array or #f if it can't be done. */
- /* if strict is not SCM_UNDEFINED, return #f if returned array
- wouldn't have contiguous elements. */
-SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
- (SCM ra, SCM strict),
- "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
- "without changing their order (last subscript changing fastest), then\n"
- "@code{array-contents} returns that shared array, otherwise it returns\n"
- "@code{#f}. All arrays made by @var{make-array} and\n"
- "@var{make-uniform-array} may be unrolled, some arrays made by\n"
- "@var{make-shared-array} may not be.\n\n"
- "If the optional argument @var{strict} is provided, a shared array will\n"
- "be returned only if its elements are stored internally contiguous in\n"
- "memory.")
-#define FUNC_NAME s_scm_array_contents
-{
- SCM sra;
-
- if (scm_is_generalized_vector (ra))
- return ra;
-
- if (SCM_I_ARRAYP (ra))
- {
- size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
- if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
- return SCM_BOOL_F;
- for (k = 0; k < ndim; k++)
- len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
- if (!SCM_UNBNDP (strict))
- {
- if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
- return SCM_BOOL_F;
- if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
- {
- if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
- SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
- len % SCM_LONG_BIT)
- return SCM_BOOL_F;
- }
- }
-
- {
- SCM v = SCM_I_ARRAY_V (ra);
- size_t length = scm_c_generalized_vector_length (v);
- if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
- return v;
- }
-
- sra = scm_i_make_ra (1, 0);
- SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
- SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
- SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
- SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
- SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
- return sra;
- }
- else if (SCM_I_ENCLOSED_ARRAYP (ra))
- scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
- else
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_ra2contig (SCM ra, int copy)
-{
- SCM ret;
- long inc = 1;
- size_t k, len = 1;
- for (k = SCM_I_ARRAY_NDIM (ra); k--;)
- len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
- k = SCM_I_ARRAY_NDIM (ra);
- if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
- {
- if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
- return ra;
- if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
- 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
- 0 == len % SCM_LONG_BIT))
- return ra;
- }
- ret = scm_i_make_ra (k, 0);
- SCM_I_ARRAY_BASE (ret) = 0;
- while (k--)
- {
- SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
- SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
- SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
- inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
- }
- SCM_I_ARRAY_V (ret) = make_typed_vector (scm_array_type (ra), inc);
- if (copy)
- scm_array_copy_x (ra, ret);
- return ret;
-}
-
-
-
-SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
- (SCM ura, SCM port_or_fd, SCM start, SCM end),
- "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
- "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
- "binary objects from @var{port-or-fdes}.\n"
- "If an end of file is encountered,\n"
- "the objects up to that point are put into @var{ura}\n"
- "(starting at the beginning) and the remainder of the array is\n"
- "unchanged.\n\n"
- "The optional arguments @var{start} and @var{end} allow\n"
- "a specified region of a vector (or linearized array) to be read,\n"
- "leaving the remainder of the vector unchanged.\n\n"
- "@code{uniform-array-read!} returns the number of objects read.\n"
- "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
- "returned by @code{(current-input-port)}.")
-#define FUNC_NAME s_scm_uniform_array_read_x
-{
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_input_port ();
-
- if (scm_is_uniform_vector (ura))
- {
- return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
- }
- else if (SCM_I_ARRAYP (ura))
- {
- size_t base, vlen, cstart, cend;
- SCM cra, ans;
-
- cra = scm_ra2contig (ura, 0);
- base = SCM_I_ARRAY_BASE (cra);
- vlen = SCM_I_ARRAY_DIMS (cra)->inc *
- (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
-
- cstart = 0;
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
- }
-
- ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
- scm_from_size_t (base + cstart),
- scm_from_size_t (base + cend));
-
- if (!scm_is_eq (cra, ura))
- scm_array_copy_x (cra, ura);
- return ans;
- }
- else if (SCM_I_ENCLOSED_ARRAYP (ura))
- scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
- else
- scm_wrong_type_arg_msg (NULL, 0, ura, "array");
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
- (SCM ura, SCM port_or_fd, SCM start, SCM end),
- "Writes all elements of @var{ura} as binary objects to\n"
- "@var{port-or-fdes}.\n\n"
- "The optional arguments @var{start}\n"
- "and @var{end} allow\n"
- "a specified region of a vector (or linearized array) to be written.\n\n"
- "The number of objects actually written is returned.\n"
- "@var{port-or-fdes} may be\n"
- "omitted, in which case it defaults to the value returned by\n"
- "@code{(current-output-port)}.")
-#define FUNC_NAME s_scm_uniform_array_write
-{
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_output_port ();
-
- if (scm_is_uniform_vector (ura))
- {
- return scm_uniform_vector_write (ura, port_or_fd, start, end);
- }
- else if (SCM_I_ARRAYP (ura))
- {
- size_t base, vlen, cstart, cend;
- SCM cra, ans;
-
- cra = scm_ra2contig (ura, 1);
- base = SCM_I_ARRAY_BASE (cra);
- vlen = SCM_I_ARRAY_DIMS (cra)->inc *
- (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
-
- cstart = 0;
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
- }
-
- ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
- scm_from_size_t (base + cstart),
- scm_from_size_t (base + cend));
-
- return ans;
- }
- else if (SCM_I_ENCLOSED_ARRAYP (ura))
- scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
- else
- scm_wrong_type_arg_msg (NULL, 0, ura, "array");
-}
-#undef FUNC_NAME
-
-
-/** Bit vectors */
-
-static scm_t_bits scm_tc16_bitvector;
-
-#define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
-#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)
-{
- size_t bit_len = BITVECTOR_LENGTH (vec);
- size_t word_len = (bit_len+31)/32;
- scm_t_uint32 *bits = BITVECTOR_BITS (vec);
- size_t i, j;
-
- scm_puts ("#*", port);
- for (i = 0; i < word_len; i++, bit_len -= 32)
- {
- scm_t_uint32 mask = 1;
- for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
- scm_putc ((bits[i] & mask)? '1' : '0', port);
- }
-
- return 1;
-}
-
-static SCM
-bitvector_equalp (SCM vec1, SCM vec2)
-{
- size_t bit_len = BITVECTOR_LENGTH (vec1);
- size_t word_len = (bit_len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len);
- scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1);
- scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2);
-
- /* compare lengths */
- if (BITVECTOR_LENGTH (vec2) != bit_len)
- return SCM_BOOL_F;
- /* avoid underflow in word_len-1 below. */
- if (bit_len == 0)
- return SCM_BOOL_T;
- /* compare full words */
- if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1)))
- return SCM_BOOL_F;
- /* compare partial last words */
- if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask))
- return SCM_BOOL_F;
- return SCM_BOOL_T;
-}
-
-int
-scm_is_bitvector (SCM vec)
-{
- return IS_BITVECTOR (vec);
-}
-
-SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} when @var{obj} is a bitvector, else\n"
- "return @code{#f}.")
-#define FUNC_NAME s_scm_bitvector_p
-{
- return scm_from_bool (scm_is_bitvector (obj));
-}
-#undef FUNC_NAME
-
-SCM
-scm_c_make_bitvector (size_t len, SCM fill)
-{
- size_t word_len = (len + 31) / 32;
- scm_t_uint32 *bits;
- SCM res;
-
- bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len,
- "bitvector");
- SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
-
- if (!SCM_UNBNDP (fill))
- scm_bitvector_fill_x (res, fill);
-
- return res;
-}
-
-SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0,
- (SCM len, SCM fill),
- "Create a new bitvector of length @var{len} and\n"
- "optionally initialize all elements to @var{fill}.")
-#define FUNC_NAME s_scm_make_bitvector
-{
- return scm_c_make_bitvector (scm_to_size_t (len), fill);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1,
- (SCM bits),
- "Create a new bitvector with the arguments as elements.")
-#define FUNC_NAME s_scm_bitvector
-{
- return scm_list_to_bitvector (bits);
-}
-#undef FUNC_NAME
-
-size_t
-scm_c_bitvector_length (SCM vec)
-{
- scm_assert_smob_type (scm_tc16_bitvector, vec);
- return BITVECTOR_LENGTH (vec);
-}
-
-SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0,
- (SCM vec),
- "Return the length of the bitvector @var{vec}.")
-#define FUNC_NAME s_scm_bitvector_length
-{
- return scm_from_size_t (scm_c_bitvector_length (vec));
-}
-#undef FUNC_NAME
-
-const scm_t_uint32 *
-scm_array_handle_bit_elements (scm_t_array_handle *h)
-{
- return scm_array_handle_bit_writable_elements (h);
-}
-
-scm_t_uint32 *
-scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
-{
- SCM vec = h->array;
- if (SCM_I_ARRAYP (vec))
- vec = SCM_I_ARRAY_V (vec);
- if (IS_BITVECTOR (vec))
- return BITVECTOR_BITS (vec) + h->base/32;
- scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
-}
-
-size_t
-scm_array_handle_bit_elements_offset (scm_t_array_handle *h)
-{
- return h->base % 32;
-}
-
-const scm_t_uint32 *
-scm_bitvector_elements (SCM vec,
- scm_t_array_handle *h,
- size_t *offp,
- size_t *lenp,
- ssize_t *incp)
-{
- return scm_bitvector_writable_elements (vec, h, offp, lenp, incp);
-}
-
-
-scm_t_uint32 *
-scm_bitvector_writable_elements (SCM vec,
- scm_t_array_handle *h,
- size_t *offp,
- size_t *lenp,
- ssize_t *incp)
-{
- scm_generalized_vector_get_handle (vec, h);
- if (offp)
- {
- scm_t_array_dim *dim = scm_array_handle_dims (h);
- *offp = scm_array_handle_bit_elements_offset (h);
- *lenp = dim->ubnd - dim->lbnd + 1;
- *incp = dim->inc;
- }
- return scm_array_handle_bit_writable_elements (h);
-}
-
-SCM
-scm_c_bitvector_ref (SCM vec, size_t idx)
-{
- scm_t_array_handle handle;
- const scm_t_uint32 *bits;
-
- if (IS_BITVECTOR (vec))
- {
- if (idx >= BITVECTOR_LENGTH (vec))
- scm_out_of_range (NULL, scm_from_size_t (idx));
- bits = BITVECTOR_BITS(vec);
- return scm_from_bool (bits[idx/32] & (1L << (idx%32)));
- }
- else
- {
- SCM res;
- size_t len, off;
- ssize_t inc;
-
- bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
- if (idx >= len)
- scm_out_of_range (NULL, scm_from_size_t (idx));
- idx = idx*inc + off;
- res = scm_from_bool (bits[idx/32] & (1L << (idx%32)));
- scm_array_handle_release (&handle);
- return res;
- }
-}
-
-SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0,
- (SCM vec, SCM idx),
- "Return the element at index @var{idx} of the bitvector\n"
- "@var{vec}.")
-#define FUNC_NAME s_scm_bitvector_ref
-{
- return scm_c_bitvector_ref (vec, scm_to_size_t (idx));
-}
-#undef FUNC_NAME
-
-void
-scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
-{
- scm_t_array_handle handle;
- scm_t_uint32 *bits, mask;
-
- if (IS_BITVECTOR (vec))
- {
- if (idx >= BITVECTOR_LENGTH (vec))
- scm_out_of_range (NULL, scm_from_size_t (idx));
- bits = BITVECTOR_BITS(vec);
- }
- else
- {
- size_t len, off;
- ssize_t inc;
-
- bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
- if (idx >= len)
- scm_out_of_range (NULL, scm_from_size_t (idx));
- idx = idx*inc + off;
- }
-
- mask = 1L << (idx%32);
- if (scm_is_true (val))
- bits[idx/32] |= mask;
- else
- bits[idx/32] &= ~mask;
-
- if (!IS_BITVECTOR (vec))
- scm_array_handle_release (&handle);
-}
-
-SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0,
- (SCM vec, SCM idx, SCM val),
- "Set the element at index @var{idx} of the bitvector\n"
- "@var{vec} when @var{val} is true, else clear it.")
-#define FUNC_NAME s_scm_bitvector_set_x
-{
- scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0,
- (SCM vec, SCM val),
- "Set all elements of the bitvector\n"
- "@var{vec} when @var{val} is true, else clear them.")
-#define FUNC_NAME s_scm_bitvector_fill_x
-{
- scm_t_array_handle handle;
- size_t off, len;
- ssize_t inc;
- scm_t_uint32 *bits;
-
- bits = scm_bitvector_writable_elements (vec, &handle,
- &off, &len, &inc);
-
- if (off == 0 && inc == 1 && len > 0)
- {
- /* the usual case
- */
- size_t word_len = (len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
-
- if (scm_is_true (val))
- {
- memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1));
- bits[word_len-1] |= last_mask;
- }
- else
- {
- memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1));
- bits[word_len-1] &= ~last_mask;
- }
- }
- else
- {
- size_t i;
- for (i = 0; i < len; i++)
- scm_array_handle_set (&handle, i*inc, val);
- }
-
- scm_array_handle_release (&handle);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0,
- (SCM list),
- "Return a new bitvector initialized with the elements\n"
- "of @var{list}.")
-#define FUNC_NAME s_scm_list_to_bitvector
-{
- size_t bit_len = scm_to_size_t (scm_length (list));
- SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED);
- size_t word_len = (bit_len+31)/32;
- scm_t_array_handle handle;
- scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle,
- NULL, NULL, NULL);
- size_t i, j;
-
- for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32)
- {
- scm_t_uint32 mask = 1;
- bits[i] = 0;
- for (j = 0; j < 32 && j < bit_len;
- j++, mask <<= 1, list = SCM_CDR (list))
- if (scm_is_true (SCM_CAR (list)))
- bits[i] |= mask;
- }
-
- scm_array_handle_release (&handle);
-
- return vec;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0,
- (SCM vec),
- "Return a new list initialized with the elements\n"
- "of the bitvector @var{vec}.")
-#define FUNC_NAME s_scm_bitvector_to_list
-{
- scm_t_array_handle handle;
- size_t off, len;
- ssize_t inc;
- scm_t_uint32 *bits;
- SCM res = SCM_EOL;
-
- bits = scm_bitvector_writable_elements (vec, &handle,
- &off, &len, &inc);
-
- if (off == 0 && inc == 1)
- {
- /* the usual case
- */
- size_t word_len = (len + 31) / 32;
- size_t i, j;
-
- for (i = 0; i < word_len; i++, len -= 32)
- {
- scm_t_uint32 mask = 1;
- for (j = 0; j < 32 && j < len; j++, mask <<= 1)
- res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res);
- }
- }
- else
- {
- size_t i;
- for (i = 0; i < len; i++)
- res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
- }
-
- scm_array_handle_release (&handle);
-
- return scm_reverse_x (res, SCM_EOL);
-}
-#undef FUNC_NAME
-
-/* From mmix-arith.w by Knuth.
-
- Here's a fun way to count the number of bits in a tetrabyte.
-
- [This classical trick is called the ``Gillies--Miller method for
- sideways addition'' in {\sl The Preparation of Programs for an
- Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
- edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
- the tricks used here were suggested by Balbir Singh, Peter
- Rossmanith, and Stefan Schwoon.]
-*/
-
-static size_t
-count_ones (scm_t_uint32 x)
-{
- x=x-((x>>1)&0x55555555);
- x=(x&0x33333333)+((x>>2)&0x33333333);
- x=(x+(x>>4))&0x0f0f0f0f;
- x=x+(x>>8);
- return (x+(x>>16)) & 0xff;
-}
-
-SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
- (SCM b, SCM bitvector),
- "Return the number of occurrences of the boolean @var{b} in\n"
- "@var{bitvector}.")
-#define FUNC_NAME s_scm_bit_count
-{
- scm_t_array_handle handle;
- size_t off, len;
- ssize_t inc;
- scm_t_uint32 *bits;
- int bit = scm_to_bool (b);
- size_t count = 0;
-
- bits = scm_bitvector_writable_elements (bitvector, &handle,
- &off, &len, &inc);
-
- if (off == 0 && inc == 1 && len > 0)
- {
- /* the usual case
- */
- size_t word_len = (len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
- size_t i;
-
- for (i = 0; i < word_len-1; i++)
- count += count_ones (bits[i]);
- count += count_ones (bits[i] & last_mask);
- }
- else
- {
- size_t i;
- for (i = 0; i < len; i++)
- if (scm_is_true (scm_array_handle_ref (&handle, i*inc)))
- count++;
- }
-
- scm_array_handle_release (&handle);
-
- return scm_from_size_t (bit? count : len-count);
-}
-#undef FUNC_NAME
-
-/* returns 32 for x == 0.
-*/
-static size_t
-find_first_one (scm_t_uint32 x)
-{
- size_t pos = 0;
- /* do a binary search in x. */
- if ((x & 0xFFFF) == 0)
- x >>= 16, pos += 16;
- if ((x & 0xFF) == 0)
- x >>= 8, pos += 8;
- if ((x & 0xF) == 0)
- x >>= 4, pos += 4;
- if ((x & 0x3) == 0)
- x >>= 2, pos += 2;
- if ((x & 0x1) == 0)
- pos += 1;
- return pos;
-}
-
-SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
- (SCM item, SCM v, SCM k),
- "Return the index of the first occurrance of @var{item} in bit\n"
- "vector @var{v}, starting from @var{k}. If there is no\n"
- "@var{item} entry between @var{k} and the end of\n"
- "@var{bitvector}, then return @code{#f}. For example,\n"
- "\n"
- "@example\n"
- "(bit-position #t #*000101 0) @result{} 3\n"
- "(bit-position #f #*0001111 3) @result{} #f\n"
- "@end example")
-#define FUNC_NAME s_scm_bit_position
-{
- scm_t_array_handle handle;
- size_t off, len, first_bit;
- ssize_t inc;
- const scm_t_uint32 *bits;
- int bit = scm_to_bool (item);
- SCM res = SCM_BOOL_F;
-
- bits = scm_bitvector_elements (v, &handle, &off, &len, &inc);
- first_bit = scm_to_unsigned_integer (k, 0, len);
-
- if (off == 0 && inc == 1 && len > 0)
- {
- size_t i, word_len = (len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
- size_t first_word = first_bit / 32;
- scm_t_uint32 first_mask =
- ((scm_t_uint32)-1) << (first_bit - 32*first_word);
- scm_t_uint32 w;
-
- for (i = first_word; i < word_len; i++)
- {
- w = (bit? bits[i] : ~bits[i]);
- if (i == first_word)
- w &= first_mask;
- if (i == word_len-1)
- w &= last_mask;
- if (w)
- {
- res = scm_from_size_t (32*i + find_first_one (w));
- break;
- }
- }
- }
- else
- {
- size_t i;
- for (i = first_bit; i < len; i++)
- {
- SCM elt = scm_array_handle_ref (&handle, i*inc);
- if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
- {
- res = scm_from_size_t (i);
- break;
- }
- }
- }
-
- scm_array_handle_release (&handle);
-
- return res;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
- (SCM v, SCM kv, SCM obj),
- "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
- "selecting the entries to change. The return value is\n"
- "unspecified.\n"
- "\n"
- "If @var{kv} is a bit vector, then those entries where it has\n"
- "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
- "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
- "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
- "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
- "\n"
- "@example\n"
- "(define bv #*01000010)\n"
- "(bit-set*! bv #*10010001 #t)\n"
- "bv\n"
- "@result{} #*11010011\n"
- "@end example\n"
- "\n"
- "If @var{kv} is a u32vector, then its elements are\n"
- "indices into @var{v} which are set to @var{obj}.\n"
- "\n"
- "@example\n"
- "(define bv #*01000010)\n"
- "(bit-set*! bv #u32(5 2 7) #t)\n"
- "bv\n"
- "@result{} #*01100111\n"
- "@end example")
-#define FUNC_NAME s_scm_bit_set_star_x
-{
- scm_t_array_handle v_handle;
- size_t v_off, v_len;
- ssize_t v_inc;
- scm_t_uint32 *v_bits;
- int bit;
-
- /* Validate that OBJ is a boolean so this is done even if we don't
- need BIT.
- */
- bit = scm_to_bool (obj);
-
- v_bits = scm_bitvector_writable_elements (v, &v_handle,
- &v_off, &v_len, &v_inc);
-
- if (scm_is_bitvector (kv))
- {
- scm_t_array_handle kv_handle;
- size_t kv_off, kv_len;
- ssize_t kv_inc;
- const scm_t_uint32 *kv_bits;
-
- kv_bits = scm_bitvector_elements (v, &kv_handle,
- &kv_off, &kv_len, &kv_inc);
-
- if (v_len != kv_len)
- scm_misc_error (NULL,
- "bit vectors must have equal length",
- SCM_EOL);
-
- if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
- {
- size_t word_len = (kv_len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
- size_t i;
-
- if (bit == 0)
- {
- for (i = 0; i < word_len-1; i++)
- v_bits[i] &= ~kv_bits[i];
- v_bits[i] &= ~(kv_bits[i] & last_mask);
- }
- else
- {
- for (i = 0; i < word_len-1; i++)
- v_bits[i] |= kv_bits[i];
- v_bits[i] |= kv_bits[i] & last_mask;
- }
- }
- else
- {
- size_t i;
- for (i = 0; i < kv_len; i++)
- if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc)))
- scm_array_handle_set (&v_handle, i*v_inc, obj);
- }
-
- scm_array_handle_release (&kv_handle);
-
- }
- else if (scm_is_true (scm_u32vector_p (kv)))
- {
- scm_t_array_handle kv_handle;
- size_t i, kv_len;
- ssize_t kv_inc;
- const scm_t_uint32 *kv_elts;
-
- kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
- for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
- scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj);
-
- scm_array_handle_release (&kv_handle);
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
-
- scm_array_handle_release (&v_handle);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
- (SCM v, SCM kv, SCM obj),
- "Return a count of how many entries in bit vector @var{v} are\n"
- "equal to @var{obj}, with @var{kv} selecting the entries to\n"
- "consider.\n"
- "\n"
- "If @var{kv} is a bit vector, then those entries where it has\n"
- "@code{#t} are the ones in @var{v} which are considered.\n"
- "@var{kv} and @var{v} must be the same length.\n"
- "\n"
- "If @var{kv} is a u32vector, then it contains\n"
- "the indexes in @var{v} to consider.\n"
- "\n"
- "For example,\n"
- "\n"
- "@example\n"
- "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
- "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
- "@end example")
-#define FUNC_NAME s_scm_bit_count_star
-{
- scm_t_array_handle v_handle;
- size_t v_off, v_len;
- ssize_t v_inc;
- const scm_t_uint32 *v_bits;
- size_t count = 0;
- int bit;
-
- /* Validate that OBJ is a boolean so this is done even if we don't
- need BIT.
- */
- bit = scm_to_bool (obj);
-
- v_bits = scm_bitvector_elements (v, &v_handle,
- &v_off, &v_len, &v_inc);
-
- if (scm_is_bitvector (kv))
- {
- scm_t_array_handle kv_handle;
- size_t kv_off, kv_len;
- ssize_t kv_inc;
- const scm_t_uint32 *kv_bits;
-
- kv_bits = scm_bitvector_elements (v, &kv_handle,
- &kv_off, &kv_len, &kv_inc);
-
- if (v_len != kv_len)
- scm_misc_error (NULL,
- "bit vectors must have equal length",
- SCM_EOL);
-
- if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
- {
- size_t i, word_len = (kv_len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
- scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1);
-
- for (i = 0; i < word_len-1; i++)
- count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]);
- count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask);
- }
- else
- {
- size_t i;
- for (i = 0; i < kv_len; i++)
- if (scm_is_true (scm_array_handle_ref (&kv_handle, i)))
- {
- SCM elt = scm_array_handle_ref (&v_handle, i*v_inc);
- if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
- count++;
- }
- }
-
- scm_array_handle_release (&kv_handle);
-
- }
- else if (scm_is_true (scm_u32vector_p (kv)))
- {
- scm_t_array_handle kv_handle;
- size_t i, kv_len;
- ssize_t kv_inc;
- const scm_t_uint32 *kv_elts;
-
- kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
- for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
- {
- SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc);
- if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
- count++;
- }
-
- scm_array_handle_release (&kv_handle);
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
-
- scm_array_handle_release (&v_handle);
-
- return scm_from_size_t (count);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
- (SCM v),
- "Modify the bit vector @var{v} by replacing each element with\n"
- "its negation.")
-#define FUNC_NAME s_scm_bit_invert_x
-{
- scm_t_array_handle handle;
- size_t off, len;
- ssize_t inc;
- scm_t_uint32 *bits;
-
- bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc);
-
- if (off == 0 && inc == 1 && len > 0)
- {
- size_t word_len = (len + 31) / 32;
- scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
- size_t i;
-
- for (i = 0; i < word_len-1; i++)
- bits[i] = ~bits[i];
- bits[i] = bits[i] ^ last_mask;
- }
- else
- {
- size_t i;
- for (i = 0; i < len; i++)
- scm_array_handle_set (&handle, i*inc,
- scm_not (scm_array_handle_ref (&handle, i*inc)));
- }
-
- scm_array_handle_release (&handle);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_istr2bve (SCM str)
-{
- scm_t_array_handle handle;
- size_t len = scm_i_string_length (str);
- SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED);
- SCM res = vec;
-
- scm_t_uint32 mask;
- size_t k, j;
- const char *c_str;
- scm_t_uint32 *data;
-
- data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
- c_str = scm_i_string_chars (str);
-
- for (k = 0; k < (len + 31) / 32; k++)
- {
- data[k] = 0L;
- j = len - k * 32;
- if (j > 32)
- j = 32;
- for (mask = 1L; j--; mask <<= 1)
- switch (*c_str++)
- {
- case '0':
- break;
- case '1':
- data[k] |= mask;
- break;
- default:
- res = SCM_BOOL_F;
- goto exit;
- }
- }
-
- exit:
- scm_array_handle_release (&handle);
- scm_remember_upto_here_1 (str);
- return res;
-}
-
-
-
-static SCM
-ra2l (SCM ra, unsigned long base, unsigned long k)
-{
- SCM res = SCM_EOL;
- long inc;
- size_t i;
- int enclosed = SCM_I_ENCLOSED_ARRAYP (ra);
-
- if (k == SCM_I_ARRAY_NDIM (ra))
- return scm_i_cvref (SCM_I_ARRAY_V (ra), base, enclosed);
-
- inc = SCM_I_ARRAY_DIMS (ra)[k].inc;
- if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd)
- return SCM_EOL;
- i = base + (1 + SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * inc;
- do
- {
- i -= inc;
- res = scm_cons (ra2l (ra, i, k + 1), res);
- }
- while (i != base);
- return res;
-}
-
-
-SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
- (SCM v),
- "Return a list consisting of all the elements, in order, of\n"
- "@var{array}.")
-#define FUNC_NAME s_scm_array_to_list
-{
- if (scm_is_generalized_vector (v))
- return scm_generalized_vector_to_list (v);
- else if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
- return ra2l (v, SCM_I_ARRAY_BASE (v), 0);
-
- scm_wrong_type_arg_msg (NULL, 0, v, "array");
-}
-#undef FUNC_NAME
-
-
-static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k);
-
-SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
- (SCM type, SCM shape, SCM lst),
- "Return an array of the type @var{type}\n"
- "with elements the same as those of @var{lst}.\n"
- "\n"
- "The argument @var{shape} determines the number of dimensions\n"
- "of the array and their shape. It is either an exact integer,\n"
- "giving the\n"
- "number of dimensions directly, or a list whose length\n"
- "specifies the number of dimensions and each element specified\n"
- "the lower and optionally the upper bound of the corresponding\n"
- "dimension.\n"
- "When the element is list of two elements, these elements\n"
- "give the lower and upper bounds. When it is an exact\n"
- "integer, it gives only the lower bound.")
-#define FUNC_NAME s_scm_list_to_typed_array
-{
- SCM row;
- SCM ra;
- scm_t_array_handle handle;
-
- row = lst;
- if (scm_is_integer (shape))
- {
- size_t k = scm_to_size_t (shape);
- shape = SCM_EOL;
- while (k-- > 0)
- {
- shape = scm_cons (scm_length (row), shape);
- if (k > 0 && !scm_is_null (row))
- row = scm_car (row);
- }
- }
- else
- {
- SCM shape_spec = shape;
- shape = SCM_EOL;
- while (1)
- {
- SCM spec = scm_car (shape_spec);
- if (scm_is_pair (spec))
- shape = scm_cons (spec, shape);
- else
- shape = scm_cons (scm_list_2 (spec,
- scm_sum (scm_sum (spec,
- scm_length (row)),
- scm_from_int (-1))),
- shape);
- shape_spec = scm_cdr (shape_spec);
- if (scm_is_pair (shape_spec))
- {
- if (!scm_is_null (row))
- row = scm_car (row);
- }
- else
- break;
- }
- }
-
- ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
- scm_reverse_x (shape, SCM_EOL));
-
- scm_array_get_handle (ra, &handle);
- l2ra (lst, &handle, 0, 0);
- scm_array_handle_release (&handle);
-
- return ra;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
- (SCM ndim, SCM lst),
- "Return an array with elements the same as those of @var{lst}.")
-#define FUNC_NAME s_scm_list_to_array
-{
- return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst);
-}
-#undef FUNC_NAME
-
-static void
-l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
-{
- if (k == scm_array_handle_rank (handle))
- scm_array_handle_set (handle, pos, lst);
- else
- {
- scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
- ssize_t inc = dim->inc;
- size_t len = 1 + dim->ubnd - dim->lbnd, n;
- char *errmsg = NULL;
-
- n = len;
- while (n > 0 && scm_is_pair (lst))
- {
- l2ra (SCM_CAR (lst), handle, pos, k + 1);
- pos += inc;
- lst = SCM_CDR (lst);
- n -= 1;
- }
- if (n != 0)
- errmsg = "too few elements for array dimension ~a, need ~a";
- if (!scm_is_null (lst))
- errmsg = "too many elements for array dimension ~a, want ~a";
- if (errmsg)
- scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
- scm_from_size_t (len)));
- }
-}
-
-#if SCM_ENABLE_DEPRECATED
-
-SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
- (SCM ndim, SCM prot, SCM lst),
- "Return a uniform array of the type indicated by prototype\n"
- "@var{prot} with elements the same as those of @var{lst}.\n"
- "Elements must be of the appropriate type, no coercions are\n"
- "done.\n"
- "\n"
- "The argument @var{ndim} determines the number of dimensions\n"
- "of the array. It is either an exact integer, giving the\n"
- "number directly, or a list of exact integers, whose length\n"
- "specifies the number of dimensions and each element is the\n"
- "lower index bound of its dimension.")
-#define FUNC_NAME s_scm_list_to_uniform_array
-{
- return scm_list_to_typed_array (prototype_to_type (prot), ndim, lst);
-}
-#undef FUNC_NAME
-
-#endif
-
-/* Print dimension DIM of ARRAY.
- */
-
-static int
-scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed,
- SCM port, scm_print_state *pstate)
-{
- scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim;
- long idx;
-
- scm_putc ('(', port);
-
- for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++)
- {
- if (dim < SCM_I_ARRAY_NDIM(array)-1)
- scm_i_print_array_dimension (array, dim+1, base, enclosed,
- port, pstate);
- else
- scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array), base, enclosed),
- port, pstate);
- if (idx < dim_spec->ubnd)
- scm_putc (' ', port);
- base += dim_spec->inc;
- }
-
- scm_putc (')', port);
- return 1;
-}
-
-/* Print an array. (Only for strict arrays, not for generalized vectors.)
-*/
-
-static int
-scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
-{
- long ndim = SCM_I_ARRAY_NDIM (array);
- scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array);
- SCM v = SCM_I_ARRAY_V (array);
- unsigned long base = SCM_I_ARRAY_BASE (array);
- long i;
- int print_lbnds = 0, zero_size = 0, print_lens = 0;
-
- scm_putc ('#', port);
- if (ndim != 1 || dim_specs[0].lbnd != 0)
- scm_intprint (ndim, 10, port);
- if (scm_is_uniform_vector (v))
- scm_puts (scm_i_uniform_vector_tag (v), port);
- else if (scm_is_bitvector (v))
- scm_puts ("b", port);
- else if (scm_is_string (v))
- scm_puts ("a", port);
- else if (!scm_is_vector (v))
- scm_puts ("?", port);
-
- for (i = 0; i < ndim; i++)
- {
- if (dim_specs[i].lbnd != 0)
- print_lbnds = 1;
- if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0)
- zero_size = 1;
- else if (zero_size)
- print_lens = 1;
- }
-
- if (print_lbnds || print_lens)
- for (i = 0; i < ndim; i++)
- {
- if (print_lbnds)
- {
- scm_putc ('@', port);
- scm_intprint (dim_specs[i].lbnd, 10, port);
- }
- if (print_lens)
- {
- scm_putc (':', port);
- scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1,
- 10, port);
- }
- }
-
- if (ndim == 0)
- {
- /* Rank zero arrays, which are really just scalars, are printed
- specially. The consequent way would be to print them as
-
- #0 OBJ
-
- where OBJ is the printed representation of the scalar, but we
- print them instead as
-
- #0(OBJ)
-
- to make them look less strange.
-
- Just printing them as
-
- OBJ
-
- would be correct in a way as well, but zero rank arrays are
- not really the same as Scheme values since they are boxed and
- can be modified with array-set!, say.
- */
- scm_putc ('(', port);
- scm_iprin1 (scm_i_cvref (v, base, 0), port, pstate);
- scm_putc (')', port);
- return 1;
- }
- else
- return scm_i_print_array_dimension (array, 0, base, 0, port, pstate);
-}
-
-static int
-scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate)
-{
- size_t base;
-
- scm_putc ('#', port);
- base = SCM_I_ARRAY_BASE (array);
- scm_puts ("<enclosed-array ", port);
- scm_i_print_array_dimension (array, 0, base, 1, port, pstate);
- scm_putc ('>', port);
- return 1;
-}
-
-/* Read an array. This function can also read vectors and uniform
- vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
- handled here.
-
- C is the first character read after the '#'.
-*/
-
-static SCM
-tag_to_type (const char *tag, SCM port)
-{
-#if SCM_ENABLE_DEPRECATED
- {
- /* Recognize the old syntax.
- */
- const char *instead;
- switch (tag[0])
- {
- case 'u':
- instead = "u32";
- break;
- case 'e':
- instead = "s32";
- break;
- case 's':
- instead = "f32";
- break;
- case 'i':
- instead = "f64";
- break;
- case 'y':
- instead = "s8";
- break;
- case 'h':
- instead = "s16";
- break;
- case 'l':
- instead = "s64";
- break;
- case 'c':
- instead = "c64";
- break;
- default:
- instead = NULL;
- break;
- }
-
- if (instead && tag[1] == '\0')
- {
- scm_c_issue_deprecation_warning_fmt
- ("The tag '%c' is deprecated for uniform vectors. "
- "Use '%s' instead.", tag[0], instead);
- return scm_from_locale_symbol (instead);
- }
- }
-#endif
-
- if (*tag == '\0')
- return SCM_BOOL_T;
- else
- return scm_from_locale_symbol (tag);
-}
-
-static int
-read_decimal_integer (SCM port, int c, ssize_t *resp)
-{
- ssize_t sign = 1;
- ssize_t res = 0;
- int got_it = 0;
-
- if (c == '-')
- {
- sign = -1;
- c = scm_getc (port);
- }
-
- while ('0' <= c && c <= '9')
- {
- res = 10*res + c-'0';
- got_it = 1;
- c = scm_getc (port);
- }
-
- if (got_it)
- *resp = sign * res;
- return c;
-}
-
-SCM
-scm_i_read_array (SCM port, int c)
-{
- ssize_t rank;
- int got_rank;
- char tag[80];
- int tag_len;
-
- SCM shape = SCM_BOOL_F, elements;
-
- /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
- the array code can not deal with zero-length dimensions yet, and
- we want to allow zero-length vectors, of course.
- */
- if (c == '(')
- {
- scm_ungetc (c, port);
- return scm_vector (scm_read (port));
- }
-
- /* Disambiguate between '#f' and uniform floating point vectors.
- */
- if (c == 'f')
- {
- c = scm_getc (port);
- if (c != '3' && c != '6')
- {
- if (c != EOF)
- scm_ungetc (c, port);
- return SCM_BOOL_F;
- }
- rank = 1;
- got_rank = 1;
- tag[0] = 'f';
- tag_len = 1;
- goto continue_reading_tag;
- }
-
- /* Read rank.
- */
- rank = 1;
- c = read_decimal_integer (port, c, &rank);
- if (rank < 0)
- scm_i_input_error (NULL, port, "array rank must be non-negative",
- SCM_EOL);
-
- /* Read tag.
- */
- tag_len = 0;
- continue_reading_tag:
- while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
- {
- tag[tag_len++] = c;
- c = scm_getc (port);
- }
- tag[tag_len] = '\0';
-
- /* Read shape.
- */
- if (c == '@' || c == ':')
- {
- shape = SCM_EOL;
-
- do
- {
- ssize_t lbnd = 0, len = 0;
- SCM s;
-
- if (c == '@')
- {
- c = scm_getc (port);
- c = read_decimal_integer (port, c, &lbnd);
- }
-
- s = scm_from_ssize_t (lbnd);
-
- if (c == ':')
- {
- c = scm_getc (port);
- c = read_decimal_integer (port, c, &len);
- if (len < 0)
- scm_i_input_error (NULL, port,
- "array length must be non-negative",
- SCM_EOL);
-
- s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
- }
-
- shape = scm_cons (s, shape);
- } while (c == '@' || c == ':');
-
- shape = scm_reverse_x (shape, SCM_EOL);
- }
-
- /* Read nested lists of elements.
- */
- if (c != '(')
- scm_i_input_error (NULL, port,
- "missing '(' in vector or array literal",
- SCM_EOL);
- scm_ungetc (c, port);
- elements = scm_read (port);
-
- if (scm_is_false (shape))
- shape = scm_from_ssize_t (rank);
- else if (scm_ilength (shape) != rank)
- scm_i_input_error
- (NULL, port,
- "the number of shape specifications must match the array rank",
- SCM_EOL);
-
- /* Handle special print syntax of rank zero arrays; see
- scm_i_print_array for a rationale.
- */
- if (rank == 0)
- {
- if (!scm_is_pair (elements))
- scm_i_input_error (NULL, port,
- "too few elements in array literal, need 1",
- SCM_EOL);
- if (!scm_is_null (SCM_CDR (elements)))
- scm_i_input_error (NULL, port,
- "too many elements in array literal, want 1",
- SCM_EOL);
- elements = SCM_CAR (elements);
- }
-
- /* Construct array.
- */
- return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
-}
-
-SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
- (SCM ra),
- "")
-#define FUNC_NAME s_scm_array_type
-{
- if (SCM_I_ARRAYP (ra))
- return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra));
- else if (scm_is_generalized_vector (ra))
- return scm_i_generalized_vector_type (ra);
- else if (SCM_I_ENCLOSED_ARRAYP (ra))
- scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
- else
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
-}
-#undef FUNC_NAME
-
-#if SCM_ENABLE_DEPRECATED
-
-SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
- (SCM ra),
- "Return an object that would produce an array of the same type\n"
- "as @var{array}, if used as the @var{prototype} for\n"
- "@code{make-uniform-array}.")
-#define FUNC_NAME s_scm_array_prototype
-{
- if (SCM_I_ARRAYP (ra))
- return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra));
- else if (scm_is_generalized_vector (ra))
- return scm_i_get_old_prototype (ra);
- else if (SCM_I_ENCLOSED_ARRAYP (ra))
- return SCM_UNSPECIFIED;
- else
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
-}
-#undef FUNC_NAME
-
-#endif
-
-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;
-}
-
-#if SCM_ENABLE_DEPRECATED
-
-SCM
-scm_make_ra (int ndim)
-{
- scm_c_issue_deprecation_warning
- ("scm_make_ra is deprecated. Use scm_make_array or similar instead.");
- return scm_i_make_ra (ndim, 0);
-}
-
-SCM
-scm_shap2ra (SCM args, const char *what)
-{
- scm_c_issue_deprecation_warning
- ("scm_shap2ra is deprecated. Use scm_make_array or similar instead.");
- return scm_i_shap2ra (args);
-}
-
-SCM
-scm_cvref (SCM v, unsigned long pos, SCM last)
-{
- scm_c_issue_deprecation_warning
- ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead.");
- return scm_c_generalized_vector_ref (v, pos);
-}
-
-void
-scm_ra_set_contp (SCM ra)
-{
- scm_c_issue_deprecation_warning
- ("scm_ra_set_contp is deprecated. There should be no need for it.");
- scm_i_ra_set_contp (ra);
-}
-
-long
-scm_aind (SCM ra, SCM args, const char *what)
-{
- scm_t_array_handle handle;
- ssize_t pos;
-
- scm_c_issue_deprecation_warning
- ("scm_aind is deprecated. Use scm_array_handle_pos instead.");
-
- if (scm_is_integer (args))
- args = scm_list_1 (args);
-
- scm_array_get_handle (ra, &handle);
- pos = scm_array_handle_pos (&handle, args) + SCM_I_ARRAY_BASE (ra);
- scm_array_handle_release (&handle);
- return pos;
-}
-
-int
-scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
-{
- scm_c_issue_deprecation_warning
- ("scm_raprin1 is deprecated. Use scm_display or scm_write instead.");
-
- scm_iprin1 (exp, port, pstate);
- return 1;
-}
-
-#endif
-
-void
-scm_init_unif ()
-{
- 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);
-
- scm_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0);
- scm_set_smob_mark (scm_i_tc16_enclosed_array, array_mark);
- scm_set_smob_free (scm_i_tc16_enclosed_array, array_free);
- scm_set_smob_print (scm_i_tc16_enclosed_array, scm_i_print_enclosed_array);
- scm_set_smob_equalp (scm_i_tc16_enclosed_array, scm_array_equal_p);
-
- scm_add_feature ("array");
-
- 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);
-
- init_type_creator_table ();
-
-#include "libguile/unif.x"
-
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/unif.h b/libguile/unif.h
deleted file mode 100644
index 91d26c861..000000000
--- a/libguile/unif.h
+++ /dev/null
@@ -1,198 +0,0 @@
-/* classes: h_files */
-
-#ifndef SCM_UNIF_H
-#define SCM_UNIF_H
-
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 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"
-#include "libguile/print.h"
-
-
-
-/* This file contains the definitions for arrays and bit vectors.
- Uniform numeric vectors are now in srfi-4.c.
-*/
-
-
-/** Arrays */
-
-typedef struct scm_t_array_dim
-{
- ssize_t lbnd;
- ssize_t ubnd;
- ssize_t inc;
-} scm_t_array_dim;
-
-SCM_API SCM scm_array_p (SCM v, SCM prot);
-SCM_API SCM scm_typed_array_p (SCM v, SCM type);
-SCM_API SCM scm_make_array (SCM fill, SCM bounds);
-SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
-SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
- const void *bytes,
- size_t byte_len);
-SCM_API SCM scm_array_rank (SCM ra);
-SCM_API size_t scm_c_array_rank (SCM ra);
-SCM_API SCM scm_array_dimensions (SCM ra);
-SCM_API SCM scm_shared_array_root (SCM ra);
-SCM_API SCM scm_shared_array_offset (SCM ra);
-SCM_API SCM scm_shared_array_increments (SCM ra);
-SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
-SCM_API SCM scm_transpose_array (SCM ra, SCM args);
-SCM_API SCM scm_enclose_array (SCM ra, SCM axes);
-SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);
-SCM_API SCM scm_array_ref (SCM v, SCM args);
-SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
-SCM_API SCM scm_array_contents (SCM ra, SCM strict);
-SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
- SCM start, SCM end);
-SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-SCM_API SCM scm_array_to_list (SCM v);
-SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
-SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
-SCM_API SCM scm_array_type (SCM ra);
-
-SCM_API int scm_is_array (SCM obj);
-SCM_API int scm_is_typed_array (SCM obj, SCM type);
-
-SCM_API SCM scm_ra2contig (SCM ra, int copy);
-
-struct scm_t_array_handle;
-
-typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, ssize_t);
-typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, ssize_t, SCM);
-
-typedef struct scm_t_array_handle {
- SCM array;
- size_t base;
- scm_t_array_dim *dims;
- scm_t_array_dim dim0;
- scm_i_t_array_ref ref;
- scm_i_t_array_set set;
- const void *elements;
- void *writable_elements;
-} scm_t_array_handle;
-
-SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h);
-SCM_API size_t scm_array_handle_rank (scm_t_array_handle *h);
-SCM_API scm_t_array_dim *scm_array_handle_dims (scm_t_array_handle *h);
-SCM_API ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices);
-SCM_API const SCM *scm_array_handle_elements (scm_t_array_handle *h);
-SCM_API SCM *scm_array_handle_writable_elements (scm_t_array_handle *h);
-SCM_API void scm_array_handle_release (scm_t_array_handle *h);
-
-/* See inline.h for scm_array_handle_ref and scm_array_handle_set */
-
-
-/** Bit vectors */
-
-SCM_API SCM scm_bitvector_p (SCM vec);
-SCM_API SCM scm_bitvector (SCM bits);
-SCM_API SCM scm_make_bitvector (SCM len, SCM fill);
-SCM_API SCM scm_bitvector_length (SCM vec);
-SCM_API SCM scm_bitvector_ref (SCM vec, SCM idx);
-SCM_API SCM scm_bitvector_set_x (SCM vec, SCM idx, SCM val);
-SCM_API SCM scm_list_to_bitvector (SCM list);
-SCM_API SCM scm_bitvector_to_list (SCM vec);
-SCM_API SCM scm_bitvector_fill_x (SCM vec, SCM val);
-
-SCM_API SCM scm_bit_count (SCM item, SCM seq);
-SCM_API SCM scm_bit_position (SCM item, SCM v, SCM k);
-SCM_API SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj);
-SCM_API SCM scm_bit_count_star (SCM v, SCM kv, SCM obj);
-SCM_API SCM scm_bit_invert_x (SCM v);
-SCM_API SCM scm_istr2bve (SCM str);
-
-SCM_API int scm_is_bitvector (SCM obj);
-SCM_API SCM scm_c_make_bitvector (size_t len, SCM fill);
-SCM_API size_t scm_c_bitvector_length (SCM vec);
-SCM_API SCM scm_c_bitvector_ref (SCM vec, size_t idx);
-SCM_API void scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val);
-SCM_API const scm_t_uint32 *scm_array_handle_bit_elements (scm_t_array_handle *h);
-SCM_API scm_t_uint32 *scm_array_handle_bit_writable_elements (scm_t_array_handle *h);
-SCM_API size_t scm_array_handle_bit_elements_offset (scm_t_array_handle *h);
-SCM_API const scm_t_uint32 *scm_bitvector_elements (SCM vec,
- scm_t_array_handle *h,
- size_t *offp,
- size_t *lenp,
- ssize_t *incp);
-SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec,
- scm_t_array_handle *h,
- size_t *offp,
- size_t *lenp,
- ssize_t *incp);
-
-/* internal. */
-
-typedef struct scm_i_t_array
-{
- SCM v; /* the contents of the array, e.g., a vector or uniform vector. */
- unsigned long base;
-} scm_i_t_array;
-
-SCM_API scm_t_bits scm_i_tc16_array;
-SCM_API scm_t_bits scm_i_tc16_enclosed_array;
-
-#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 16)
-
-#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a)
-#define SCM_I_ENCLOSED_ARRAYP(a) \
- SCM_TYP16_PREDICATE (scm_i_tc16_enclosed_array, a)
-#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17))
-#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
-
-#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
-#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v)
-#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
-#define SCM_I_ARRAY_DIMS(a) \
- ((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array)))
-
-SCM_INTERNAL SCM scm_i_make_ra (int ndim, int enclosed);
-SCM_INTERNAL SCM scm_i_cvref (SCM v, size_t p, int enclosed);
-SCM_INTERNAL SCM scm_i_read_array (SCM port, int c);
-
-/* deprecated. */
-
-#if SCM_ENABLE_DEPRECATED
-
-SCM_API SCM scm_make_uve (long k, SCM prot);
-SCM_API SCM scm_array_prototype (SCM ra);
-SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst);
-SCM_API SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill);
-SCM_API SCM scm_make_ra (int ndim);
-SCM_API SCM scm_shap2ra (SCM args, const char *what);
-SCM_API SCM scm_cvref (SCM v, unsigned long pos, SCM last);
-SCM_API void scm_ra_set_contp (SCM ra);
-SCM_API long scm_aind (SCM ra, SCM args, const char *what);
-SCM_API int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate);
-
-#endif
-
-SCM_INTERNAL void scm_init_unif (void);
-
-#endif /* SCM_UNIF_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/uniform.c b/libguile/uniform.c
new file mode 100644
index 000000000..28125da8b
--- /dev/null
+++ b/libguile/uniform.c
@@ -0,0 +1,254 @@
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 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 <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/__scm.h"
+
+#include "libguile/uniform.h"
+
+
+const size_t scm_i_array_element_type_sizes[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = {
+ 0,
+ 0,
+ 1,
+ 8,
+ 8, 8,
+ 16, 16,
+ 32, 32,
+ 64, 64,
+ 32, 64,
+ 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
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
+}
+
+const void *
+scm_array_handle_uniform_elements (scm_t_array_handle *h)
+{
+ return scm_array_handle_uniform_writable_elements (h);
+}
+
+void *
+scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
+{
+ size_t esize;
+ scm_t_uint8 *ret;
+
+ esize = scm_array_handle_uniform_element_size (h);
+ ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize;
+ return ret;
+}
+
+int
+scm_is_uniform_vector (SCM obj)
+{
+ scm_t_array_handle h;
+ int ret = 0;
+
+ if (scm_is_generalized_vector (obj))
+ {
+ scm_generalized_vector_get_handle (obj, &h);
+ ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
+ scm_array_handle_release (&h);
+ }
+ return ret;
+}
+
+size_t
+scm_c_uniform_vector_length (SCM uvec)
+{
+ scm_t_array_handle h;
+ size_t len;
+ ssize_t inc;
+
+ scm_uniform_vector_elements (uvec, &h, &len, &inc);
+ scm_array_handle_release (&h);
+ return len;
+}
+
+SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a uniform vector.")
+#define FUNC_NAME s_scm_uniform_vector_p
+{
+ return scm_from_bool (scm_is_uniform_vector (obj));
+}
+#undef FUNC_NAME
+
+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}.")
+#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);
+ ret = scm_array_handle_element_type (&h);
+ scm_array_handle_release (&h);
+ return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1, 0, 0,
+ (SCM v),
+ "Return the number of bytes allocated to each element in the\n"
+ "uniform vector, @var{v}.")
+#define FUNC_NAME s_scm_uniform_vector_element_size
+{
+ scm_t_array_handle h;
+ size_t len;
+ ssize_t inc;
+ SCM ret;
+ scm_uniform_vector_elements (v, &h, &len, &inc);
+ ret = scm_from_size_t (scm_array_handle_uniform_element_size (&h));
+ scm_array_handle_release (&h);
+ return ret;
+}
+#undef FUNC_NAME
+
+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;
+}
+
+SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
+ (SCM v, SCM idx),
+ "Return the element at index @var{idx} of the\n"
+ "homogenous numeric vector @var{v}.")
+#define FUNC_NAME s_scm_uniform_vector_ref
+{
+ return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
+}
+#undef FUNC_NAME
+
+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);
+}
+
+SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
+ (SCM v, SCM idx, SCM val),
+ "Set the element at index @var{idx} of the\n"
+ "homogenous numeric vector @var{v} to @var{val}.")
+#define FUNC_NAME s_scm_uniform_vector_set_x
+{
+ scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
+ (SCM uvec),
+ "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;
+}
+#undef FUNC_NAME
+
+const void *
+scm_uniform_vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
+}
+
+void *
+scm_uniform_vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ void *ret;
+ scm_generalized_vector_get_handle (uvec, h);
+ /* FIXME nonlocal exit */
+ ret = scm_array_handle_uniform_writable_elements (h);
+ if (lenp)
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+ *lenp = dim->ubnd - dim->lbnd + 1;
+ *incp = dim->inc;
+ }
+ return ret;
+}
+
+SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
+ (SCM v),
+ "Return the number of elements in the uniform vector @var{v}.")
+#define FUNC_NAME s_scm_uniform_vector_length
+{
+ return scm_from_size_t (scm_c_uniform_vector_length (v));
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_uniform (void)
+{
+#include "libguile/uniform.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/uniform.h b/libguile/uniform.h
new file mode 100644
index 000000000..b1f396594
--- /dev/null
+++ b/libguile/uniform.h
@@ -0,0 +1,77 @@
+/* classes: h_files */
+
+#ifndef SCM_UNIFORM_H
+#define SCM_UNIFORM_H
+
+/* Copyright (C) 1995,1996,1997,1999,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
+ * 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"
+#include "libguile/generalized-vectors.h"
+
+
+
+/*
+ * Uniform vectors contain unboxed values. They are not necessarily contiguous.
+ */
+
+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 */
+SCM_API size_t scm_array_handle_uniform_element_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);
+
+SCM_API SCM scm_uniform_vector_p (SCM v);
+SCM_API SCM scm_uniform_vector_length (SCM v);
+SCM_API SCM scm_uniform_vector_element_type (SCM v);
+SCM_API SCM scm_uniform_vector_element_size (SCM v);
+SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx);
+SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val);
+SCM_API SCM scm_uniform_vector_to_list (SCM v);
+SCM_API SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd,
+ SCM start, SCM end);
+SCM_API SCM scm_uniform_vector_write (SCM v, SCM port_or_fd,
+ SCM start, SCM end);
+
+SCM_API int scm_is_uniform_vector (SCM obj);
+SCM_API size_t scm_c_uniform_vector_length (SCM v);
+SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx);
+SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val);
+SCM_API const void *scm_uniform_vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API void *scm_uniform_vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_INTERNAL void scm_init_uniform (void);
+
+#endif /* SCM_UNIFORM_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 6dc994f55..89b822a76 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -30,9 +30,11 @@
#include "libguile/validate.h"
#include "libguile/vectors.h"
-#include "libguile/unif.h"
+#include "libguile/generalized-vectors.h"
+#include "libguile/arrays.h"
+#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
-#include "libguile/ramap.h"
+#include "libguile/array-map.h"
#include "libguile/srfi-4.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
@@ -525,135 +527,42 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
#undef FUNC_NAME
-/* Generalized vectors. */
-
-int
-scm_is_generalized_vector (SCM obj)
-{
- return (scm_is_vector (obj)
- || scm_is_string (obj)
- || scm_is_bitvector (obj)
- || scm_is_uniform_vector (obj)
- || scm_is_bytevector (obj));
-}
-
-SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a vector, string,\n"
- "bitvector, or uniform numeric vector.")
-#define FUNC_NAME s_scm_generalized_vector_p
-{
- return scm_from_bool (scm_is_generalized_vector (obj));
-}
-#undef FUNC_NAME
-
-void
-scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
-{
- scm_array_get_handle (vec, h);
- if (scm_array_handle_rank (h) != 1)
- scm_wrong_type_arg_msg (NULL, 0, vec, "vector");
-}
-
-size_t
-scm_c_generalized_vector_length (SCM v)
+static SCM
+vector_handle_ref (scm_t_array_handle *h, size_t idx)
{
- if (scm_is_vector (v))
- return scm_c_vector_length (v);
- else if (scm_is_string (v))
- return scm_c_string_length (v);
- else if (scm_is_bitvector (v))
- return scm_c_bitvector_length (v);
- else if (scm_is_uniform_vector (v))
- return scm_c_uniform_vector_length (v);
- else if (scm_is_bytevector (v))
- return scm_c_bytevector_length (v);
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
+ if (idx > h->dims[0].ubnd)
+ scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
+ return ((SCM*)h->elements)[idx];
}
-SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
- (SCM v),
- "Return the length of the generalized vector @var{v}.")
-#define FUNC_NAME s_scm_generalized_vector_length
+static void
+vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
{
- return scm_from_size_t (scm_c_generalized_vector_length (v));
+ if (idx > h->dims[0].ubnd)
+ scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
+ ((SCM*)h->writable_elements)[idx] = val;
}
-#undef FUNC_NAME
-SCM
-scm_c_generalized_vector_ref (SCM v, size_t idx)
+static void
+vector_get_handle (SCM v, scm_t_array_handle *h)
{
- if (scm_is_vector (v))
- return scm_c_vector_ref (v, idx);
- else if (scm_is_string (v))
- return scm_c_string_ref (v, idx);
- else if (scm_is_bitvector (v))
- return scm_c_bitvector_ref (v, idx);
- else if (scm_is_uniform_vector (v))
- return scm_c_uniform_vector_ref (v, idx);
- else if (scm_is_bytevector (v))
- return scm_from_uint8 (scm_c_bytevector_ref (v, idx));
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
+ h->array = v;
+ h->ndims = 1;
+ h->dims = &h->dim0;
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1;
+ h->dim0.inc = 1;
+ h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
+ h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
}
-SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
- (SCM v, SCM idx),
- "Return the element at index @var{idx} of the\n"
- "generalized vector @var{v}.")
-#define FUNC_NAME s_scm_generalized_vector_ref
-{
- return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
-}
-#undef FUNC_NAME
-
-void
-scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
-{
- if (scm_is_vector (v))
- scm_c_vector_set_x (v, idx, val);
- else if (scm_is_string (v))
- scm_c_string_set_x (v, idx, val);
- else if (scm_is_bitvector (v))
- scm_c_bitvector_set_x (v, idx, val);
- else if (scm_is_uniform_vector (v))
- scm_c_uniform_vector_set_x (v, idx, val);
- else if (scm_is_bytevector (v))
- scm_i_bytevector_generalized_set_x (v, idx, val);
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
-}
-
-SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
- (SCM v, SCM idx, SCM val),
- "Set the element at index @var{idx} of the\n"
- "generalized vector @var{v} to @var{val}.")
-#define FUNC_NAME s_scm_generalized_vector_set_x
-{
- scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
- (SCM v),
- "Return a new list whose elements are the elements of the\n"
- "generalized vector @var{v}.")
-#define FUNC_NAME s_scm_generalized_vector_to_list
-{
- if (scm_is_vector (v))
- return scm_vector_to_list (v);
- else if (scm_is_string (v))
- return scm_string_to_list (v);
- else if (scm_is_bitvector (v))
- return scm_bitvector_to_list (v);
- else if (scm_is_uniform_vector (v))
- return scm_uniform_vector_to_list (v);
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
-}
-#undef FUNC_NAME
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
+ vector_handle_ref, vector_handle_set,
+ vector_get_handle);
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_wvect, 0x7f & ~2,
+ vector_handle_ref, vector_handle_set,
+ vector_get_handle);
+SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector);
void
diff --git a/libguile/vectors.h b/libguile/vectors.h
index 902e15a63..bc5b41cb9 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -24,7 +24,7 @@
#include "libguile/__scm.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
@@ -61,21 +61,6 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
#define SCM_SIMPLE_VECTOR_REF(x,idx) ((SCM_I_VECTOR_ELTS(x))[idx])
#define SCM_SIMPLE_VECTOR_SET(x,idx,val) ((SCM_I_VECTOR_WELTS(x))[idx]=(val))
-/* Generalized vectors */
-
-SCM_API SCM scm_generalized_vector_p (SCM v);
-SCM_API SCM scm_generalized_vector_length (SCM v);
-SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx);
-SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val);
-SCM_API SCM scm_generalized_vector_to_list (SCM v);
-
-SCM_API int scm_is_generalized_vector (SCM obj);
-SCM_API size_t scm_c_generalized_vector_length (SCM v);
-SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx);
-SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val);
-SCM_API void scm_generalized_vector_get_handle (SCM vec,
- scm_t_array_handle *h);
-
/* Internals */
#define SCM_I_IS_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector))
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 98a6e491b..b373cd017 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -41,7 +41,7 @@ static SCM
VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
{
/* VM registers */
- register scm_byte_t *ip IP_REG; /* instruction pointer */
+ register scm_t_uint8 *ip IP_REG; /* instruction pointer */
register SCM *sp SP_REG; /* stack pointer */
register SCM *fp FP_REG; /* frame pointer */
@@ -107,11 +107,17 @@ 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 */
CACHE_PROGRAM ();
PUSH (program);
- NEW_FRAME ();
-
- /* Initial arguments */
+ fp = sp + 1;
+ INIT_FRAME ();
+ /* MV-call frame, function & arguments */
+ PUSH ((SCM)fp); /* dynamic link */
+ PUSH (0); /* ra */
+ PUSH (0); /* mvra */
PUSH (prog);
if (SCM_UNLIKELY (sp + nargs >= stack_limit))
goto vm_error_too_many_args;
@@ -152,12 +158,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
SCM err_msg;
vm_error_bad_instruction:
- err_msg = scm_from_locale_string ("VM: Bad instruction: ~A");
+ err_msg = scm_from_locale_string ("VM: Bad instruction: ~s");
finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
goto vm_error;
vm_error_unbound:
- err_msg = scm_from_locale_string ("VM: Unbound variable: ~A");
+ err_msg = scm_from_locale_string ("VM: Unbound variable: ~s");
goto vm_error;
vm_error_wrong_type_arg:
@@ -178,10 +184,9 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_wrong_type_apply:
- err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S "
- "[IP offset: ~a]");
- finish_args = scm_list_2 (program,
- SCM_I_MAKINUM (ip - bp->base));
+ SYNC_ALL ();
+ scm_error (scm_misc_error_key, FUNC_NAME, "Wrong type to apply: ~S",
+ scm_list_1 (program), SCM_BOOL_F);
goto vm_error;
vm_error_stack_overflow:
@@ -195,7 +200,7 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_improper_list:
- err_msg = scm_from_locale_string ("VM: Attempt to unroll an improper list: tail is ~A");
+ err_msg = scm_from_locale_string ("Expected a proper list, but got object with tail ~s");
goto vm_error;
vm_error_not_a_pair:
@@ -211,15 +216,19 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
goto vm_error;
vm_error_no_values:
- err_msg = scm_from_locale_string ("VM: 0-valued return");
+ err_msg = scm_from_locale_string ("Zero values returned to single-valued continuation");
finish_args = SCM_EOL;
goto vm_error;
vm_error_not_enough_values:
- err_msg = scm_from_locale_string ("VM: Not enough values for mv-bind");
+ err_msg = scm_from_locale_string ("Too few values returned to continuation");
finish_args = SCM_EOL;
goto vm_error;
+ vm_error_bad_wide_string_length:
+ err_msg = scm_from_locale_string ("VM: Bad wide string length: ~S");
+ goto vm_error;
+
#if VM_CHECK_IP
vm_error_invalid_address:
err_msg = scm_from_locale_string ("VM: Invalid program address");
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index c0f772fb8..36d4d2867 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -336,6 +336,7 @@ 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
@@ -385,34 +386,29 @@ do { \
/* 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 NEW_FRAME() \
+#define INIT_FRAME() \
{ \
int i; \
- SCM *dl, *data; \
- scm_byte_t *ra = ip; \
- \
- /* Save old registers */ \
- ra = ip; \
- dl = fp; \
\
/* New registers */ \
- fp = sp - bp->nargs + 1; \
- data = SCM_FRAME_DATA_ADDRESS (fp); \
- sp = data + 2; \
+ sp += bp->nlocs; \
CHECK_OVERFLOW (); \
stack_base = sp; \
ip = bp->base; \
\
/* Init local variables */ \
- for (i=bp->nlocs; i; i--) \
- data[-i] = SCM_UNDEFINED; \
- \
- /* Set frame data */ \
- data[2] = (SCM)ra; \
- data[1] = 0x0; \
- data[0] = (SCM)dl; \
+ for (i=bp->nlocs; i;) \
+ sp[-(--i)] = SCM_UNDEFINED; \
}
+#define DROP_FRAME() \
+ { \
+ sp -= 3; \
+ NULLSTACK (3); \
+ CHECK_UNDERFLOW (); \
+ }
+
+
/*
Local Variables:
c-file-style: "gnu"
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 9ae49ed65..e242ef9bf 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -20,42 +20,6 @@
/* This file is included in vm_engine.c */
-VM_DEFINE_LOADER (80, load_unsigned_integer, "load-unsigned-integer")
-{
- size_t len;
-
- FETCH_LENGTH (len);
- if (SCM_LIKELY (len <= 8))
- {
- scm_t_uint64 val = 0;
- while (len-- > 0)
- val = (val << 8U) + FETCH ();
- SYNC_REGISTER ();
- PUSH (scm_from_uint64 (val));
- NEXT;
- }
- else
- SCM_MISC_ERROR ("load-unsigned-integer: not implemented yet", SCM_EOL);
-}
-
-VM_DEFINE_LOADER (81, load_integer, "load-integer")
-{
- size_t len;
-
- FETCH_LENGTH (len);
- if (SCM_LIKELY (len <= 4))
- {
- int val = 0;
- while (len-- > 0)
- val = (val << 8) + FETCH ();
- SYNC_REGISTER ();
- PUSH (scm_from_int (val));
- NEXT;
- }
- else
- SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
-}
-
VM_DEFINE_LOADER (82, load_number, "load-number")
{
size_t len;
@@ -72,30 +36,23 @@ VM_DEFINE_LOADER (82, load_number, "load-number")
VM_DEFINE_LOADER (83, load_string, "load-string")
{
size_t len;
- FETCH_LENGTH (len);
- SYNC_REGISTER ();
- PUSH (scm_from_locale_stringn ((char *)ip, len));
- /* Was: scm_makfromstr (ip, len, 0) */
- ip += len;
- NEXT;
-}
+ char *buf;
-VM_DEFINE_LOADER (84, load_symbol, "load-symbol")
-{
- size_t len;
FETCH_LENGTH (len);
SYNC_REGISTER ();
- PUSH (scm_from_locale_symboln ((char *)ip, len));
+ PUSH (scm_i_make_string (len, &buf));
+ memcpy (buf, (char *) ip, len);
ip += len;
NEXT;
}
-VM_DEFINE_LOADER (85, load_keyword, "load-keyword")
+VM_DEFINE_LOADER (84, load_symbol, "load-symbol")
{
size_t len;
FETCH_LENGTH (len);
SYNC_REGISTER ();
- PUSH (scm_from_locale_keywordn ((char *)ip, len));
+ /* FIXME: should be scm_from_latin1_symboln */
+ PUSH (scm_from_locale_symboln ((const char*)ip, len));
ip += len;
NEXT;
}
@@ -130,30 +87,33 @@ VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1)
NEXT;
}
-VM_DEFINE_LOADER (88, define, "define")
+VM_DEFINE_LOADER (89, load_array, "load-array")
{
- SCM sym;
+ SCM type, shape;
size_t len;
-
FETCH_LENGTH (len);
+ POP (shape);
+ POP (type);
SYNC_REGISTER ();
- sym = scm_from_locale_symboln ((char *)ip, len);
+ PUSH (scm_from_contiguous_typed_array (type, shape, ip, len));
ip += len;
-
- SYNC_REGISTER ();
- PUSH (scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T));
NEXT;
}
-VM_DEFINE_LOADER (89, load_array, "load-array")
+VM_DEFINE_LOADER (90, load_wide_string, "load-wide-string")
{
- SCM type, shape;
size_t len;
+ scm_t_wchar *wbuf;
+
FETCH_LENGTH (len);
- POP (shape);
- POP (type);
+ if (SCM_UNLIKELY (len % 4))
+ { finish_args = scm_list_1 (scm_from_size_t (len));
+ goto vm_error_bad_wide_string_length;
+ }
+
SYNC_REGISTER ();
- PUSH (scm_from_contiguous_typed_array (type, shape, ip, len));
+ PUSH (scm_i_make_wide_string (len / 4, &wbuf));
+ memcpy ((char *) wbuf, (char *) ip, len);
ip += len;
NEXT;
}
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index dce9b5fbc..0cace147d 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -215,11 +215,37 @@ VM_DEFINE_FUNCTION (120, add, "add", 2)
FUNC2 (+, scm_sum);
}
+VM_DEFINE_FUNCTION (167, add1, "add1", 1)
+{
+ ARGS1 (x);
+ if (SCM_I_INUMP (x))
+ {
+ scm_t_int64 n = SCM_I_INUM (x) + 1;
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_I_MAKINUM (n));
+ }
+ SYNC_REGISTER ();
+ RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
+}
+
VM_DEFINE_FUNCTION (121, sub, "sub", 2)
{
FUNC2 (-, scm_difference);
}
+VM_DEFINE_FUNCTION (168, sub1, "sub1", 1)
+{
+ ARGS1 (x);
+ if (SCM_I_INUMP (x))
+ {
+ scm_t_int64 n = SCM_I_INUM (x) - 1;
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_I_MAKINUM (n));
+ }
+ SYNC_REGISTER ();
+ RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
+}
+
VM_DEFINE_FUNCTION (122, mul, "mul", 2)
{
ARGS2 (x, y);
@@ -289,7 +315,10 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
&& i < SCM_I_VECTOR_LENGTH (vect)))
RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
else
- RETURN (scm_vector_ref (vect, idx));
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_vector_ref (vect, idx));
+ }
}
VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
@@ -303,7 +332,10 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
&& i < SCM_I_VECTOR_LENGTH (vect)))
SCM_I_VECTOR_WELTS (vect)[i] = val;
else
- scm_vector_set_x (vect, idx, val);
+ {
+ SYNC_REGISTER ();
+ scm_vector_set_x (vect, idx, val);
+ }
NEXT;
}
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index ad0ec547e..377cbf916 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -71,13 +71,7 @@ VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (4, mark, "mark", 0, 0, 1)
-{
- PUSH (SCM_UNDEFINED);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (5, dup, "dup", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (4, dup, "dup", 0, 0, 1)
{
SCM x = *sp;
PUSH (x);
@@ -89,25 +83,25 @@ VM_DEFINE_INSTRUCTION (5, dup, "dup", 0, 0, 1)
* Object creation
*/
-VM_DEFINE_INSTRUCTION (6, void, "void", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (5, void, "void", 0, 0, 1)
{
PUSH (SCM_UNSPECIFIED);
NEXT;
}
-VM_DEFINE_INSTRUCTION (7, make_true, "make-true", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (6, make_true, "make-true", 0, 0, 1)
{
PUSH (SCM_BOOL_T);
NEXT;
}
-VM_DEFINE_INSTRUCTION (8, make_false, "make-false", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (7, make_false, "make-false", 0, 0, 1)
{
PUSH (SCM_BOOL_F);
NEXT;
}
-VM_DEFINE_INSTRUCTION (57, make_nil, "make-nil", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (8, make_nil, "make-nil", 0, 0, 1)
{
PUSH (SCM_ELISP_NIL);
NEXT;
@@ -187,7 +181,7 @@ VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (42, make_char32, "make-char32", 4, 0, 1)
+VM_DEFINE_INSTRUCTION (17, make_char32, "make-char32", 4, 0, 1)
{
scm_t_wchar v = 0;
v += FETCH ();
@@ -200,7 +194,7 @@ VM_DEFINE_INSTRUCTION (42, make_char32, "make-char32", 4, 0, 1)
-VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (18, list, "list", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@@ -209,7 +203,7 @@ VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (19, vector, "vector", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@@ -227,34 +221,6 @@ VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (19, list_mark, "list-mark", 0, 0, 0)
-{
- POP_LIST_MARK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (20, cons_mark, "cons-mark", 0, 0, 0)
-{
- POP_CONS_MARK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (21, vector_mark, "vector-mark", 0, 0, 0)
-{
- POP_LIST_MARK ();
- SYNC_REGISTER ();
- *sp = scm_vector (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0)
-{
- SCM l;
- POP (l);
- PUSH_LIST (l, SCM_NULLP);
- NEXT;
-}
-
/*
* Variable access
@@ -277,7 +243,7 @@ VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0)
/* ref */
-VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (20, object_ref, "object-ref", 1, 0, 1)
{
register unsigned objnum = FETCH ();
CHECK_OBJECT (objnum);
@@ -286,7 +252,7 @@ VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1)
}
/* FIXME: necessary? elt 255 of the vector could be a vector... */
-VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (21, long_object_ref, "long-object-ref", 2, 0, 1)
{
unsigned int objnum = FETCH ();
objnum <<= 8;
@@ -296,14 +262,14 @@ VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
{
PUSH (LOCAL_REF (FETCH ()));
ASSERT_BOUND (*sp);
NEXT;
}
-VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (23, long_local_ref, "long-local-ref", 2, 0, 1)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -313,7 +279,7 @@ VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1)
{
SCM x = *sp;
@@ -332,7 +298,7 @@ VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM what;
@@ -355,7 +321,7 @@ VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
+VM_DEFINE_INSTRUCTION (26, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -382,14 +348,14 @@ VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
/* set */
-VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (27, local_set, "local-set", 1, 1, 0)
{
LOCAL_SET (FETCH (), *sp);
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (28, long_local_set, "long-local-set", 2, 1, 0)
{
unsigned int i = FETCH ();
i <<= 8;
@@ -399,14 +365,14 @@ VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (29, variable_set, "variable-set", 0, 1, 0)
{
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
}
-VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (30, toplevel_set, "toplevel-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM what;
@@ -425,7 +391,7 @@ VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
+VM_DEFINE_INSTRUCTION (31, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
{
SCM what;
unsigned int objnum = FETCH ();
@@ -470,7 +436,7 @@ VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
NEXT; \
}
-VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (32, br, "br", 2, 0, 0)
{
scm_t_int16 offset;
FETCH_OFFSET (offset);
@@ -478,34 +444,34 @@ VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (33, br_if, "br-if", 2, 0, 0)
{
BR (!SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (34, br_if_not, "br-if-not", 2, 0, 0)
{
BR (SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br_if_eq, "br-if-eq", 2, 0, 0)
{
sp--; /* underflow? */
BR (SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
{
sp--; /* underflow? */
BR (!SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_null, "br-if-null", 2, 0, 0)
{
BR (SCM_NULLP (*sp));
}
-VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (38, br_if_not_null, "br-if-not-null", 2, 0, 0)
{
BR (!SCM_NULLP (*sp));
}
@@ -515,7 +481,15 @@ VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0)
* Subprogram call
*/
-VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (39, new_frame, "new-frame", 0, 0, 3)
+{
+ PUSH ((SCM)fp); /* dynamic link */
+ PUSH (0); /* mvra */
+ PUSH (0); /* ra */
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (40, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
@@ -534,71 +508,32 @@ VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
program = x;
CACHE_PROGRAM ();
INIT_ARGS ();
- NEW_FRAME ();
+ fp = sp - bp->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 ();
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
-#ifdef ENABLE_TRAMPOLINE
- /* Seems to slow down the fibo test, dunno why */
- /*
- * Subr call
- */
- switch (nargs)
- {
- case 0:
- {
- scm_t_trampoline_0 call = scm_trampoline_0 (x);
- if (call)
- {
- SYNC_ALL ();
- *sp = call (x);
- NEXT;
- }
- break;
- }
- case 1:
- {
- scm_t_trampoline_1 call = scm_trampoline_1 (x);
- if (call)
- {
- SCM arg1;
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1);
- NEXT;
- }
- break;
- }
- case 2:
- {
- scm_t_trampoline_2 call = scm_trampoline_2 (x);
- if (call)
- {
- SCM arg1, arg2;
- POP (arg2);
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1, arg2);
- NEXT;
- }
- break;
- }
- }
-#endif
/*
* Other interpreted or compiled call
*/
if (!SCM_FALSEP (scm_procedure_p (x)))
{
- /* At this point, the stack contains the procedure and each one of its
- arguments. */
+ SCM args;
+ /* At this point, the stack contains the frame, the procedure and each one
+ of its arguments. */
POP_LIST (nargs);
+ POP (args);
+ DROP (); /* drop the procedure */
+ DROP_FRAME ();
+
SYNC_REGISTER ();
- /* keep args on stack so they are marked */
- sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ PUSH (scm_apply (x, args, SCM_EOL));
NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROP ();
if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
{
/* truncate values */
@@ -611,32 +546,12 @@ VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
}
NEXT;
}
- /*
- * Continuation call
- */
- if (SCM_VM_CONT_P (x))
- {
- program = x;
- vm_call_continuation:
- /* Check the number of arguments */
- /* FIXME multiple args */
- if (nargs != 1)
- scm_wrong_num_args (program);
-
- /* Reinstate the continuation */
- EXIT_HOOK ();
- reinstate_vm_cont (vp, program);
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- NEXT;
- }
program = x;
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (41, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
@@ -647,151 +562,55 @@ VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
SCM_TICK; /* allow interrupt here */
/*
- * Tail recursive call
- */
- if (SCM_EQ_P (x, program))
- {
- int i;
-
- /* Move arguments */
- INIT_ARGS ();
- sp -= bp->nargs - 1;
- for (i = 0; i < bp->nargs; i++)
- LOCAL_SET (i, sp[i]);
-
- /* Drop the first argument and the program itself. */
- sp -= 2;
- NULLSTACK (bp->nargs + 1);
-
- /* Init locals to valid SCM values */
- for (i = 0; i < bp->nlocs; i++)
- LOCAL_SET (i + bp->nargs, SCM_UNDEFINED);
-
- /* Call itself */
- ip = bp->base;
- APPLY_HOOK ();
- NEXT;
- }
-
- /*
- * Tail call, but not to self -- reuse the frame, keeping the ra and dl
+ * Tail call
*/
if (SCM_PROGRAM_P (x))
{
- SCM *data, *tail_args, *dl;
int i;
- scm_byte_t *ra, *mvra;
#ifdef VM_ENABLE_STACK_NULLING
SCM *old_sp;
#endif
EXIT_HOOK ();
- /* save registers */
- tail_args = stack_base + 2;
- ra = SCM_FRAME_RETURN_ADDRESS (fp);
- mvra = SCM_FRAME_MV_RETURN_ADDRESS (fp);
- dl = SCM_FRAME_DYNAMIC_LINK (fp);
-
/* switch programs */
program = x;
CACHE_PROGRAM ();
INIT_ARGS ();
- /* delay updating the frame so that if INIT_ARGS has to cons up a rest
- arg, going into GC, the stack still makes sense */
- fp[-1] = program;
- nargs = bp->nargs;
#ifdef VM_ENABLE_STACK_NULLING
old_sp = sp;
CHECK_STACK_LEAK ();
#endif
- /* new registers -- logically this would be better later, but let's make
- sure we have space for the locals now */
- data = SCM_FRAME_DATA_ADDRESS (fp);
- ip = bp->base;
- stack_base = data + 2;
- sp = stack_base;
- CHECK_OVERFLOW ();
-
- /* copy args, bottom-up */
- for (i = 0; i < nargs; i++)
- fp[i] = tail_args[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 locals */
- for (i = bp->nlocs; i; i--)
- data[-i] = SCM_UNDEFINED;
-
- /* Set frame data */
- data[2] = (SCM)ra;
- data[1] = (SCM)mvra;
- data[0] = (SCM)dl;
+ INIT_FRAME ();
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
}
-#ifdef ENABLE_TRAMPOLINE
- /* This seems to actually slow down the fibo test -- dunno why */
- /*
- * Subr call
- */
- switch (nargs)
- {
- case 0:
- {
- scm_t_trampoline_0 call = scm_trampoline_0 (x);
- if (call)
- {
- SYNC_ALL ();
- *sp = call (x);
- goto vm_return;
- }
- break;
- }
- case 1:
- {
- scm_t_trampoline_1 call = scm_trampoline_1 (x);
- if (call)
- {
- SCM arg1;
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1);
- goto vm_return;
- }
- break;
- }
- case 2:
- {
- scm_t_trampoline_2 call = scm_trampoline_2 (x);
- if (call)
- {
- SCM arg1, arg2;
- POP (arg2);
- POP (arg1);
- SYNC_ALL ();
- *sp = call (x, arg1, arg2);
- goto vm_return;
- }
- break;
- }
- }
-#endif
/*
* Other interpreted or compiled call
*/
if (!SCM_FALSEP (scm_procedure_p (x)))
{
+ SCM args;
POP_LIST (nargs);
+ POP (args);
+
SYNC_REGISTER ();
- sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ *sp = scm_apply (x, args, SCM_EOL);
NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROP ();
+
if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
{
/* multiple values returned to continuation */
@@ -802,21 +621,16 @@ VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
PUSH_LIST (values, SCM_NULLP);
goto vm_return_values;
}
- goto vm_return;
+ else
+ goto vm_return;
}
program = x;
- /*
- * Continuation call
- */
- if (SCM_VM_CONT_P (program))
- goto vm_call_continuation;
-
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (42, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -825,7 +639,7 @@ VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (43, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -834,7 +648,7 @@ VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (44, mv_call, "mv-call", 3, -1, 1)
{
SCM x;
scm_t_int16 offset;
@@ -854,8 +668,12 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
program = x;
CACHE_PROGRAM ();
INIT_ARGS ();
- NEW_FRAME ();
- SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)mvra;
+ fp = sp - bp->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 ();
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
@@ -865,13 +683,17 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
*/
if (!SCM_FALSEP (scm_procedure_p (x)))
{
+ SCM args;
/* At this point, the stack contains the procedure and each one of its
arguments. */
POP_LIST (nargs);
+ POP (args);
+ DROP (); /* drop the procedure */
+ DROP_FRAME ();
+
SYNC_REGISTER ();
- sp[-1] = scm_apply (x, sp[0], SCM_EOL);
+ PUSH (scm_apply (x, args, SCM_EOL));
NULLSTACK_FOR_NONLOCAL_EXIT ();
- DROP ();
if (SCM_VALUESP (*sp))
{
SCM values, len;
@@ -884,20 +706,12 @@ VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
}
NEXT;
}
- /*
- * Continuation call
- */
- if (SCM_VM_CONT_P (x))
- {
- program = x;
- goto vm_call_continuation;
- }
program = x;
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (45, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -916,7 +730,7 @@ VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (46, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -935,7 +749,7 @@ VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (47, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -944,6 +758,9 @@ VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
cont = scm_make_continuation (&first);
if (first)
{
+ PUSH ((SCM)fp); /* dynamic link */
+ PUSH (0); /* mvra */
+ PUSH (0); /* ra */
PUSH (proc);
PUSH (cont);
nargs = 1;
@@ -969,7 +786,7 @@ VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (48, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -1001,7 +818,7 @@ VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (49, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
@@ -1009,17 +826,16 @@ VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
SYNC_REGISTER ();
SCM_TICK; /* allow interrupt here */
{
- SCM ret, *data;
- data = SCM_FRAME_DATA_ADDRESS (fp);
+ SCM ret;
POP (ret);
ASSERT (sp == stack_base);
- ASSERT (stack_base == data + 2);
+ ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp);
- ip = SCM_FRAME_BYTE_CAST (data[2]);
- fp = SCM_FRAME_STACK_CAST (data[0]);
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
+ fp = SCM_FRAME_DYNAMIC_LINK (fp);
{
#ifdef VM_ENABLE_STACK_NULLING
int nullcount = stack_base - sp;
@@ -1039,28 +855,25 @@ VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (50, 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. */
- SCM *data;
-
nvalues = FETCH ();
vm_return_values:
EXIT_HOOK ();
RETURN_HOOK ();
- data = SCM_FRAME_DATA_ADDRESS (fp);
- ASSERT (stack_base == data + 2);
+ ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1);
/* data[1] is the mv return address */
- if (nvalues != 1 && data[1])
+ if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp))
{
int i;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_BYTE_CAST (data[1]); /* multiple value ra */
- fp = SCM_FRAME_STACK_CAST (data[0]);
+ ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
+ fp = SCM_FRAME_DYNAMIC_LINK (fp);
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
@@ -1079,8 +892,8 @@ VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
continuation.) */
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_BYTE_CAST (data[2]); /* single value ra */
- fp = SCM_FRAME_STACK_CAST (data[0]);
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
+ fp = SCM_FRAME_DYNAMIC_LINK (fp);
/* Push first value */
*++sp = stack_base[1];
@@ -1099,7 +912,7 @@ VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (51, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -1122,7 +935,7 @@ VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (52, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -1145,7 +958,7 @@ VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (53, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@@ -1159,7 +972,7 @@ VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
-VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (54, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@@ -1167,7 +980,7 @@ VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (55, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@@ -1175,7 +988,7 @@ VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (56, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@@ -1185,7 +998,7 @@ VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (57, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@@ -1196,7 +1009,7 @@ VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
-VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (58, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@@ -1207,7 +1020,7 @@ VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (59, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@@ -1219,18 +1032,18 @@ VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1)
+VM_DEFINE_INSTRUCTION (60, make_closure, "make-closure", 0, 2, 1)
{
SCM vect;
POP (vect);
SYNC_BEFORE_GC ();
/* fixme underflow */
- SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
- SCM_PROGRAM_OBJTABLE (*sp), vect);
+ *sp = scm_double_cell (scm_tc7_program, (scm_t_bits)SCM_PROGRAM_OBJCODE (*sp),
+ (scm_t_bits)SCM_PROGRAM_OBJTABLE (*sp), (scm_t_bits)vect);
NEXT;
}
-VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (61, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@@ -1238,6 +1051,48 @@ VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
NEXT;
}
+VM_DEFINE_INSTRUCTION (62, fix_closure, "fix-closure", 2, 0, 1)
+{
+ SCM x, vect;
+ unsigned int i = FETCH ();
+ i <<= 8;
+ i += FETCH ();
+ POP (vect);
+ /* FIXME CHECK_LOCAL (i) */
+ x = LOCAL_REF (i);
+ /* FIXME ASSERT_PROGRAM (x); */
+ SCM_SET_CELL_WORD_3 (x, vect);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (63, define, "define", 0, 0, 2)
+{
+ SCM sym, val;
+ POP (sym);
+ POP (val);
+ SYNC_REGISTER ();
+ VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
+ SCM_BOOL_T),
+ val);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (64, make_keyword, "make-keyword", 0, 1, 1)
+{
+ CHECK_UNDERFLOW ();
+ SYNC_REGISTER ();
+ *sp = scm_symbol_to_keyword (*sp);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (65, make_symbol, "make-symbol", 0, 1, 1)
+{
+ CHECK_UNDERFLOW ();
+ SYNC_REGISTER ();
+ *sp = scm_string_to_symbol (*sp);
+ NEXT;
+}
+
/*
(defun renumber-ops ()
@@ -1249,6 +1104,7 @@ VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
(replace-match
(number-to-string (setq counter (1+ counter)))
t t nil 1)))))
+(renumber-ops)
*/
/*
Local Variables:
diff --git a/libguile/vm.c b/libguile/vm.c
index cc5e4f924..660f25cb4 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -66,21 +66,20 @@ scm_t_bits scm_tc16_vm_cont;
static void
vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
{
- SCM *sp, *upper, *lower;
+ SCM *sp, *mark;
sp = base + size - 1;
while (sp > base && fp)
{
- upper = SCM_FRAME_UPPER_ADDRESS (fp);
- lower = SCM_FRAME_LOWER_ADDRESS (fp);
+ mark = SCM_FRAME_LOWER_ADDRESS (fp) + 3;
- for (; sp >= upper; sp--)
+ for (; sp >= mark; sp--)
if (SCM_NIMP (*sp))
{
if (scm_in_heap_p (*sp))
scm_gc_mark (*sp);
- else
- fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp);
+ /* this can happen for open frames */
+ /* else fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp); */
}
@@ -89,11 +88,6 @@ vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
/* update fp from the dynamic link */
fp = (SCM*)*sp-- + reloc;
-
- /* mark from the el down to the lower address */
- for (; sp >= lower; sp--)
- if (*sp && SCM_NIMP (*sp))
- scm_gc_mark (*sp);
}
}
@@ -224,7 +218,6 @@ static SCM
really_make_boot_program (long nargs)
{
SCM u8vec;
- /* Make sure "bytes" is 64-bit aligned. */
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 };
diff --git a/libguile/vm.h b/libguile/vm.h
index b079c7aa0..eace1cb69 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,4 +1,4 @@
-/* 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 License
@@ -41,7 +41,7 @@ typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp, SCM program, SCM *argv, int n
#define SCM_VM_NUM_ENGINES 2
struct scm_vm {
- scm_byte_t *ip; /* instruction pointer */
+ scm_t_uint8 *ip; /* instruction pointer */
SCM *sp; /* stack pointer */
SCM *fp; /* frame pointer */
size_t stack_size; /* stack size */
@@ -88,7 +88,7 @@ SCM_API SCM scm_vm_stats (SCM vm);
SCM_API SCM scm_vm_trace_frame (SCM vm);
struct scm_vm_cont {
- scm_byte_t *ip;
+ scm_t_uint8 *ip;
SCM *sp;
SCM *fp;
scm_t_ptrdiff stack_size;
diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4
index 7f64af27c..930cce6cd 100644
--- a/m4/gnulib-cache.m4
+++ b/m4/gnulib-cache.m4
@@ -15,7 +15,7 @@
# Specification in the form of a command-line invocation:
-# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf
+# gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl --libtool --macro-prefix=gl --no-vc-files alloca-opt autobuild byteswap canonicalize-lgpl count-one-bits environ extensions flock fpieee full-read full-write havelib iconv_open-utf lib-symbol-versions lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh string verify vsnprintf
# Specification in the form of a few gnulib-tool.m4 macro invocations:
gl_LOCAL_DIR([])
@@ -33,6 +33,7 @@ gl_MODULES([
full-write
havelib
iconv_open-utf
+ lib-symbol-versions
lib-symbol-visibility
libunistring
putenv
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index 0c2b968ef..00b3f3ff7 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -15,7 +15,7 @@
# In projects using CVS, this file can be treated like other built files.
-# This macro should be invoked from ./configure.in, in the section
+# This macro should be invoked from ./configure.ac, in the section
# "Checks for programs", right after AC_PROG_CC, and certainly before
# any checks for libraries, header files, types and library functions.
AC_DEFUN([gl_EARLY],
@@ -31,7 +31,7 @@ AC_DEFUN([gl_EARLY],
AC_REQUIRE([gl_FP_IEEE])
])
-# This macro should be invoked from ./configure.in, in the section
+# This macro should be invoked from ./configure.ac, in the section
# "Check for header files, types and library functions".
AC_DEFUN([gl_INIT],
[
@@ -62,6 +62,7 @@ AC_DEFUN([gl_INIT],
gl_FUNC_ICONV_OPEN
gl_FUNC_ICONV_OPEN_UTF
gl_INLINE
+ gl_LD_VERSION_SCRIPT
gl_VISIBILITY
gl_LIBUNISTRING
gl_LOCALCHARSET
@@ -361,6 +362,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/inline.m4
m4/intmax_t.m4
m4/inttypes_h.m4
+ m4/ld-version-script.m4
m4/lib-ld.m4
m4/lib-link.m4
m4/lib-prefix.m4
diff --git a/m4/iconv.m4 b/m4/iconv.m4
index 3cc626829..ce21b0b87 100644
--- a/m4/iconv.m4
+++ b/m4/iconv.m4
@@ -1,4 +1,4 @@
-# iconv.m4 serial AM7 (gettext-0.18)
+# iconv.m4 serial AM8 (gettext-0.18)
dnl Copyright (C) 2000-2002, 2007-2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -172,8 +172,8 @@ size_t iconv();
], [], [am_cv_proto_iconv_arg1=""], [am_cv_proto_iconv_arg1="const"])
am_cv_proto_iconv="extern size_t iconv (iconv_t cd, $am_cv_proto_iconv_arg1 char * *inbuf, size_t *inbytesleft, char * *outbuf, size_t *outbytesleft);"])
am_cv_proto_iconv=`echo "[$]am_cv_proto_iconv" | tr -s ' ' | sed -e 's/( /(/'`
- AC_MSG_RESULT([${ac_t:-
- }$am_cv_proto_iconv])
+ AC_MSG_RESULT([
+ $am_cv_proto_iconv])
AC_DEFINE_UNQUOTED([ICONV_CONST], [$am_cv_proto_iconv_arg1],
[Define as const if the declaration of iconv() needs const.])
fi
diff --git a/m4/ld-version-script.m4 b/m4/ld-version-script.m4
new file mode 100644
index 000000000..a97888f24
--- /dev/null
+++ b/m4/ld-version-script.m4
@@ -0,0 +1,44 @@
+# ld-version-script.m4 serial 1
+dnl Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl From Simon Josefsson
+
+# FIXME: The test below returns a false positive for mingw
+# cross-compiles, 'local:' statements does not reduce number of
+# exported symbols in a DLL. Use --disable-ld-version-script to work
+# around the problem.
+
+# gl_LD_VERSION_SCRIPT
+# --------------------
+# Check if LD supports linker scripts, and define automake conditional
+# HAVE_LD_VERSION_SCRIPT if so.
+AC_DEFUN([gl_LD_VERSION_SCRIPT],
+[
+ AC_ARG_ENABLE([ld-version-script],
+ AS_HELP_STRING([--enable-ld-version-script],
+ [enable linker version script (default is enabled when possible)]),
+ [have_ld_version_script=$enableval], [])
+ if test -z "$have_ld_version_script"; then
+ AC_MSG_CHECKING([if LD -Wl,--version-script works])
+ save_LDFLAGS="$LDFLAGS"
+ LDFLAGS="$LDFLAGS -Wl,--version-script=conftest.map"
+ cat > conftest.map <<EOF
+VERS_1 {
+ global: sym;
+};
+
+VERS_2 {
+ global: sym;
+} VERS_1;
+EOF
+ AC_LINK_IFELSE(AC_LANG_PROGRAM([], []),
+ [have_ld_version_script=yes], [have_ld_version_script=no])
+ rm -f conftest.map
+ LDFLAGS="$save_LDFLAGS"
+ AC_MSG_RESULT($have_ld_version_script)
+ fi
+ AM_CONDITIONAL(HAVE_LD_VERSION_SCRIPT, test "$have_ld_version_script" = "yes")
+])
diff --git a/m4/time_h.m4 b/m4/time_h.m4
index d42a635ec..16fefa197 100644
--- a/m4/time_h.m4
+++ b/m4/time_h.m4
@@ -1,7 +1,6 @@
# Configure a more-standard replacement for <time.h>.
-# Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2007 Free Software
-# Foundation, Inc.
+# Copyright (C) 2000-2001, 2003-2007, 2009 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -30,6 +29,7 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS],
dnl Otherwise, replace only if someone compiles with -DGNULIB_PORTCHECK;
dnl this lets maintainers check for portability.
REPLACE_LOCALTIME_R=GNULIB_PORTCHECK; AC_SUBST([REPLACE_LOCALTIME_R])
+ REPLACE_MKTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_MKTIME])
REPLACE_NANOSLEEP=GNULIB_PORTCHECK; AC_SUBST([REPLACE_NANOSLEEP])
REPLACE_STRPTIME=GNULIB_PORTCHECK; AC_SUBST([REPLACE_STRPTIME])
REPLACE_TIMEGM=GNULIB_PORTCHECK; AC_SUBST([REPLACE_TIMEGM])
diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4
index ff9a4ea0a..96fddba7f 100644
--- a/m4/unistd_h.m4
+++ b/m4/unistd_h.m4
@@ -1,4 +1,4 @@
-# unistd_h.m4 serial 17
+# unistd_h.m4 serial 18
dnl Copyright (C) 2006-2009 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -73,6 +73,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
HAVE_SYS_PARAM_H=0; AC_SUBST([HAVE_SYS_PARAM_H])
REPLACE_CHOWN=0; AC_SUBST([REPLACE_CHOWN])
REPLACE_CLOSE=0; AC_SUBST([REPLACE_CLOSE])
+ REPLACE_DUP2=0; AC_SUBST([REPLACE_DUP2])
REPLACE_FCHDIR=0; AC_SUBST([REPLACE_FCHDIR])
REPLACE_GETCWD=0; AC_SUBST([REPLACE_GETCWD])
REPLACE_GETPAGESIZE=0; AC_SUBST([REPLACE_GETPAGESIZE])
diff --git a/meta/Makefile.am b/meta/Makefile.am
index e047038aa..34e7f2cf3 100644
--- a/meta/Makefile.am
+++ b/meta/Makefile.am
@@ -1,7 +1,7 @@
## Process this file with Automake to create Makefile.in
## Jim Blandy <jimb@red-bean.com> --- September 1997
##
-## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -20,13 +20,14 @@
## write to the Free Software Foundation, Inc., 51 Franklin Street,
## Fifth Floor, Boston, MA 02110-1301 USA
-bin_SCRIPTS=guile-config guile-tools
-EXTRA_DIST= $(bin_SCRIPTS) \
- guile.m4 ChangeLog-2008 \
- guile-1.8.pc.in guile-1.8-uninstalled.pc.in
+bin_SCRIPTS = guile-config guile-tools
+EXTRA_DIST= $(bin_SCRIPTS) \
+ guile.m4 ChangeLog-2008 \
+ guile-2.0.pc.in guile-2.0-uninstalled.pc.in \
+ guile-tools.in
pkgconfigdir = $(libdir)/pkgconfig
-pkgconfig_DATA = guile-1.8.pc
+pkgconfig_DATA = guile-2.0.pc
## FIXME: in the future there will be direct automake support for
## doing this. When that happens, switch over.
diff --git a/meta/gdb-uninstalled-guile.in b/meta/gdb-uninstalled-guile.in
index 1151dbc3a..d55e215cb 100644
--- a/meta/gdb-uninstalled-guile.in
+++ b/meta/gdb-uninstalled-guile.in
@@ -1,6 +1,6 @@
#!/bin/sh
-# Copyright (C) 2002, 2006, 2008 Free Software Foundation
+# Copyright (C) 2002, 2006, 2008, 2009 Free Software Foundation
#
# This file is part of GUILE.
#
@@ -34,5 +34,7 @@
set -e
# env (set by configure)
top_builddir="@top_builddir_absolute@"
+XDG_CACHE_HOME=${top_builddir}/cache
+export XDG_CACHE_HOME
exec ${top_builddir}/meta/uninstalled-env libtool --mode=execute \
gdb --args ${top_builddir}/libguile/guile "$@"
diff --git a/meta/guile-1.8-uninstalled.pc.in b/meta/guile-2.0-uninstalled.pc.in
index 50d337fd3..50d337fd3 100644
--- a/meta/guile-1.8-uninstalled.pc.in
+++ b/meta/guile-2.0-uninstalled.pc.in
diff --git a/meta/guile-1.8.pc.in b/meta/guile-2.0.pc.in
index 1b43cbc5e..1b43cbc5e 100644
--- a/meta/guile-1.8.pc.in
+++ b/meta/guile-2.0.pc.in
diff --git a/meta/guile-config b/meta/guile-config
index 7304ae2a8..6c640c40c 100755
--- a/meta/guile-config
+++ b/meta/guile-config
@@ -4,7 +4,7 @@ exec guile -e main -s $0 "$@"
;;;; guile-config --- utility for linking programs with Guile
;;;; Jim Blandy <jim@red-bean.com> --- September 1997
;;;;
-;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998, 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
@@ -71,7 +71,7 @@ exec guile -e main -s $0 "$@"
(dle " " p " --help - show usage info (this message)")
(dle " " p " --help SUBCOMMAND - show help for SUBCOMMAND")))
-(define guile-module "guile-1.8")
+(define guile-module "guile-2.0")
(define (pkg-config . args)
(let* ((real-args (cons "pkg-config" args))
diff --git a/meta/guile-tools b/meta/guile-tools.in
index 0c66c7200..51d103fe8 100755
--- a/meta/guile-tools
+++ b/meta/guile-tools.in
@@ -25,6 +25,12 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@"
(define-module (guile-tools))
+;; Hack to provide scripts with the bug-report address.
+(module-define! the-scm-module
+ '%guile-bug-report-address
+ "@PACKAGE_BUGREPORT@")
+
+
;; We can't import srfi-1, unfortunately, as we are used early in the
;; boot process, before the srfi-1 shlib is built.
diff --git a/meta/guile.in b/meta/guile.in
index ab1fe3706..d1ae0d4fa 100644
--- a/meta/guile.in
+++ b/meta/guile.in
@@ -1,6 +1,6 @@
#!/bin/sh
-# Copyright (C) 2002, 2006, 2008 Free Software Foundation
+# Copyright (C) 2002, 2006, 2008, 2009 Free Software Foundation
#
# This file is part of GUILE.
#
@@ -41,6 +41,8 @@ top_builddir="@top_builddir_absolute@"
# set GUILE (clobber)
GUILE=${top_builddir}/libguile/guile
export GUILE
+XDG_CACHE_HOME=${top_builddir}/cache
+export XDG_CACHE_HOME
# do it
exec ${top_builddir}/meta/uninstalled-env $GUILE "$@"
diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in
index 8ee690ccf..9a6227230 100644
--- a/meta/uninstalled-env.in
+++ b/meta/uninstalled-env.in
@@ -1,6 +1,6 @@
#!/bin/sh
-# Copyright (C) 2003, 2006, 2008 Free Software Foundation
+# Copyright (C) 2003, 2006, 2008, 2009 Free Software Foundation
#
# This file is part of GUILE.
#
@@ -112,6 +112,7 @@ export PKG_CONFIG_PATH
# handle PATH (no clobber)
PATH="${top_builddir}/libguile:${PATH}"
PATH="${top_srcdir}/meta:${PATH}"
+PATH="${top_builddir}/meta:${PATH}"
export PATH
exec "$@"
diff --git a/module/Makefile.am b/module/Makefile.am
index 2971fc6b5..d1c2d95ce 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -37,11 +37,11 @@ SOURCES = \
system/base/message.scm \
\
language/tree-il.scm \
- language/ghil.scm language/glil.scm language/assembly.scm \
+ language/glil.scm language/assembly.scm \
\
$(SCHEME_LANG_SOURCES) \
$(TREE_IL_LANG_SOURCES) \
- $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
+ $(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \
\
@@ -50,9 +50,10 @@ SOURCES = \
$(RNRS_SOURCES) \
$(OOP_SOURCES) \
$(SYSTEM_SOURCES) \
+ $(SCRIPTS_SOURCES) \
+ $(GHIL_LANG_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
- $(BRAINFUCK_LANG_SOURCES) \
- $(SCRIPTS_SOURCES)
+ $(BRAINFUCK_LANG_SOURCES)
## test.scm is not currently installed.
EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008
@@ -77,12 +78,14 @@ SCHEME_LANG_SOURCES = \
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/optimize.scm \
+ language/tree-il/inline.scm \
+ language/tree-il/fix-letrec.scm \
language/tree-il/analyze.scm \
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm
-GHIL_LANG_SOURCES = \
- language/ghil/spec.scm language/ghil/compile-glil.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 \
@@ -111,7 +114,7 @@ ECMASCRIPT_LANG_SOURCES = \
language/ecmascript/base.scm \
language/ecmascript/function.scm \
language/ecmascript/array.scm \
- language/ecmascript/compile-ghil.scm \
+ language/ecmascript/compile-tree-il.scm \
language/ecmascript/spec.scm
BRAINFUCK_LANG_SOURCES = \
@@ -200,6 +203,7 @@ SRFI_SOURCES = \
srfi/srfi-1.scm \
srfi/srfi-2.scm \
srfi/srfi-4.scm \
+ srfi/srfi-4/gnu.scm \
srfi/srfi-6.scm \
srfi/srfi-8.scm \
srfi/srfi-9.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 36a463ad3..a3a1e0384 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -308,6 +308,38 @@
(syntax-rules ()
((_ exp) (make-promise (lambda () exp)))))
+;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
+;;; Please let the Guile developers know if you are using this macro.
+;;;
+(define-syntax @bind
+ (lambda (x)
+ (define (bound-member id ids)
+ (cond ((null? ids) #f)
+ ((bound-identifier=? id (car ids)) #t)
+ ((bound-member (car ids) (cdr ids)))))
+
+ (syntax-case x ()
+ ((_ () b0 b1 ...)
+ #'(let () b0 b1 ...))
+ ((_ ((id val) ...) b0 b1 ...)
+ (and-map identifier? #'(id ...))
+ (if (let lp ((ids #'(id ...)))
+ (cond ((null? ids) #f)
+ ((bound-member (car ids) (cdr ids)) #t)
+ (else (lp (cdr ids)))))
+ (syntax-violation '@bind "duplicate bound identifier" x)
+ (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
+ ((v ...) (generate-temporaries #'(id ...))))
+ #'(let ((old-v id) ...
+ (v val) ...)
+ (dynamic-wind
+ (lambda ()
+ (set! id v) ...)
+ (lambda () b0 b1 ...)
+ (lambda ()
+ (set! id old-v) ...)))))))))
+
+
;;; {Defmacros}
@@ -867,11 +899,46 @@
(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)
(with-fluid* current-reader (and (pair? reader) (car reader))
(lambda ()
- (start-stack 'load-stack
- (primitive-load name)))))
+ (let ((cfn (autocompiled-file-name name)))
+ (if cfn
+ (load-compiled cfn)
+ (start-stack 'load-stack
+ (primitive-load name)))))))
@@ -1982,8 +2049,13 @@
(let ((accessor (record-accessor module-type 'name)))
(lambda (mod)
(or (accessor mod)
- (begin
- (set-module-name! mod (list (gensym)))
+ (let ((name (list (gensym))))
+ ;; Name MOD and bind it in THE-ROOT-MODULE so that it's visible
+ ;; to `resolve-module'. This is important as `psyntax' stores
+ ;; module names and relies on being able to `resolve-module'
+ ;; them.
+ (set-module-name! mod name)
+ (nested-define! the-root-module `(%app modules ,@name) mod)
(accessor mod))))))
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 53fc741c8..c8d762143 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2003, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2005, 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
@@ -169,16 +169,6 @@
;; The strange prototype system for uniform arrays has been
;; deprecated.
-(define uniform-vector-fill! array-fill!)
-
-(define make-uniform-vector dimensions->uniform-array)
-
-(define (make-uniform-array prot . bounds)
- (dimensions->uniform-array bounds prot))
-
-(define (list->uniform-vector prot lst)
- (list->uniform-array 1 prot lst))
-
(define-macro (eval-case . clauses)
(issue-deprecation-warning
"`eval-case' is deprecated. Use `eval-when' instead.")
diff --git a/module/ice-9/lineio.scm b/module/ice-9/lineio.scm
index 055eb6eb4..68f290369 100644
--- a/module/ice-9/lineio.scm
+++ b/module/ice-9/lineio.scm
@@ -20,7 +20,7 @@
(define-module (ice-9 lineio)
- :use-module (ice-9 readline)
+ :use-module (ice-9 rdelim)
:export (unread-string read-string lineio-port?
make-line-buffering-input-port))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index de0db95de..fecd2b25d 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1,91 +1,122 @@
(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
(if #f #f)
-(letrec ((and-map*17
- (lambda (f57 first56 . rest55)
- (let ((t58 (null? first56)))
- (if t58
- t58
- (if (null? rest55)
- (letrec ((andmap59
- (lambda (first60)
- (let ((x61 (car first60))
- (first62 (cdr first60)))
- (if (null? first62)
- (f57 x61)
- (if (f57 x61) (andmap59 first62) #f))))))
- (andmap59 first56))
- (letrec ((andmap63
- (lambda (first64 rest65)
- (let ((x66 (car first64))
- (xr67 (map car rest65))
- (first68 (cdr first64))
- (rest69 (map cdr rest65)))
- (if (null? first68)
- (apply f57 (cons x66 xr67))
- (if (apply f57 (cons x66 xr67))
- (andmap63 first68 rest69)
+(letrec ((#{and-map*\ 1199}#
+ (lambda (#{f\ 1239}# #{first\ 1238}# . #{rest\ 1237}#)
+ (let ((#{t\ 1240}# (null? #{first\ 1238}#)))
+ (if #{t\ 1240}#
+ #{t\ 1240}#
+ (if (null? #{rest\ 1237}#)
+ (letrec ((#{andmap\ 1241}#
+ (lambda (#{first\ 1242}#)
+ (let ((#{x\ 1243}# (car #{first\ 1242}#))
+ (#{first\ 1244}# (cdr #{first\ 1242}#)))
+ (if (null? #{first\ 1244}#)
+ (#{f\ 1239}# #{x\ 1243}#)
+ (if (#{f\ 1239}# #{x\ 1243}#)
+ (#{andmap\ 1241}# #{first\ 1244}#)
#f))))))
- (andmap63 first56 rest55))))))))
- (letrec ((lambda-var-list163
- (lambda (vars287)
- (letrec ((lvl288
- (lambda (vars289 ls290 w291)
- (if (pair? vars289)
- (lvl288
- (cdr vars289)
- (cons (wrap143 (car vars289) w291 #f) ls290)
- w291)
- (if (id?115 vars289)
- (cons (wrap143 vars289 w291 #f) ls290)
- (if (null? vars289)
- ls290
- (if (syntax-object?99 vars289)
- (lvl288
- (syntax-object-expression100 vars289)
- ls290
- (join-wraps134
- w291
- (syntax-object-wrap101 vars289)))
- (cons vars289 ls290))))))))
- (lvl288 vars287 (quote ()) (quote (()))))))
- (gen-var162
- (lambda (id292)
- (let ((id293 (if (syntax-object?99 id292)
- (syntax-object-expression100 id292)
- id292)))
+ (#{andmap\ 1241}# #{first\ 1238}#))
+ (letrec ((#{andmap\ 1245}#
+ (lambda (#{first\ 1246}# #{rest\ 1247}#)
+ (let ((#{x\ 1248}# (car #{first\ 1246}#))
+ (#{xr\ 1249}# (map car #{rest\ 1247}#))
+ (#{first\ 1250}# (cdr #{first\ 1246}#))
+ (#{rest\ 1251}#
+ (map cdr #{rest\ 1247}#)))
+ (if (null? #{first\ 1250}#)
+ (apply #{f\ 1239}#
+ (cons #{x\ 1248}# #{xr\ 1249}#))
+ (if (apply #{f\ 1239}#
+ (cons #{x\ 1248}# #{xr\ 1249}#))
+ (#{andmap\ 1245}#
+ #{first\ 1250}#
+ #{rest\ 1251}#)
+ #f))))))
+ (#{andmap\ 1245}# #{first\ 1238}# #{rest\ 1237}#))))))))
+ (letrec ((#{lambda-var-list\ 1345}#
+ (lambda (#{vars\ 1469}#)
+ (letrec ((#{lvl\ 1470}#
+ (lambda (#{vars\ 1471}# #{ls\ 1472}# #{w\ 1473}#)
+ (if (pair? #{vars\ 1471}#)
+ (#{lvl\ 1470}#
+ (cdr #{vars\ 1471}#)
+ (cons (#{wrap\ 1325}#
+ (car #{vars\ 1471}#)
+ #{w\ 1473}#
+ #f)
+ #{ls\ 1472}#)
+ #{w\ 1473}#)
+ (if (#{id?\ 1297}# #{vars\ 1471}#)
+ (cons (#{wrap\ 1325}#
+ #{vars\ 1471}#
+ #{w\ 1473}#
+ #f)
+ #{ls\ 1472}#)
+ (if (null? #{vars\ 1471}#)
+ #{ls\ 1472}#
+ (if (#{syntax-object?\ 1281}# #{vars\ 1471}#)
+ (#{lvl\ 1470}#
+ (#{syntax-object-expression\ 1282}#
+ #{vars\ 1471}#)
+ #{ls\ 1472}#
+ (#{join-wraps\ 1316}#
+ #{w\ 1473}#
+ (#{syntax-object-wrap\ 1283}#
+ #{vars\ 1471}#)))
+ (cons #{vars\ 1471}# #{ls\ 1472}#))))))))
+ (#{lvl\ 1470}#
+ #{vars\ 1469}#
+ '()
+ '(())))))
+ (#{gen-var\ 1344}#
+ (lambda (#{id\ 1474}#)
+ (let ((#{id\ 1475}#
+ (if (#{syntax-object?\ 1281}# #{id\ 1474}#)
+ (#{syntax-object-expression\ 1282}# #{id\ 1474}#)
+ #{id\ 1474}#)))
(gensym
- (string-append (symbol->string id293) " ")))))
- (strip161
- (lambda (x294 w295)
- (if (memq (quote top) (wrap-marks118 w295))
- x294
- (letrec ((f296 (lambda (x297)
- (if (syntax-object?99 x297)
- (strip161
- (syntax-object-expression100 x297)
- (syntax-object-wrap101 x297))
- (if (pair? x297)
- (let ((a298 (f296 (car x297)))
- (d299 (f296 (cdr x297))))
- (if (if (eq? a298 (car x297))
- (eq? d299 (cdr x297))
- #f)
- x297
- (cons a298 d299)))
- (if (vector? x297)
- (let ((old300 (vector->list x297)))
- (let ((new301 (map f296 old300)))
- (if (and-map*17 eq? old300 new301)
- x297
- (list->vector new301))))
- x297))))))
- (f296 x294)))))
- (ellipsis?160
- (lambda (x302)
- (if (nonsymbol-id?114 x302)
- (free-id=?138
- x302
+ (string-append (symbol->string #{id\ 1475}#) " ")))))
+ (#{strip\ 1343}#
+ (lambda (#{x\ 1476}# #{w\ 1477}#)
+ (if (memq 'top
+ (#{wrap-marks\ 1300}# #{w\ 1477}#))
+ #{x\ 1476}#
+ (letrec ((#{f\ 1478}#
+ (lambda (#{x\ 1479}#)
+ (if (#{syntax-object?\ 1281}# #{x\ 1479}#)
+ (#{strip\ 1343}#
+ (#{syntax-object-expression\ 1282}#
+ #{x\ 1479}#)
+ (#{syntax-object-wrap\ 1283}# #{x\ 1479}#))
+ (if (pair? #{x\ 1479}#)
+ (let ((#{a\ 1480}#
+ (#{f\ 1478}# (car #{x\ 1479}#)))
+ (#{d\ 1481}#
+ (#{f\ 1478}# (cdr #{x\ 1479}#))))
+ (if (if (eq? #{a\ 1480}# (car #{x\ 1479}#))
+ (eq? #{d\ 1481}# (cdr #{x\ 1479}#))
+ #f)
+ #{x\ 1479}#
+ (cons #{a\ 1480}# #{d\ 1481}#)))
+ (if (vector? #{x\ 1479}#)
+ (let ((#{old\ 1482}#
+ (vector->list #{x\ 1479}#)))
+ (let ((#{new\ 1483}#
+ (map #{f\ 1478}# #{old\ 1482}#)))
+ (if (#{and-map*\ 1199}#
+ eq?
+ #{old\ 1482}#
+ #{new\ 1483}#)
+ #{x\ 1479}#
+ (list->vector #{new\ 1483}#))))
+ #{x\ 1479}#))))))
+ (#{f\ 1478}# #{x\ 1476}#)))))
+ (#{ellipsis?\ 1342}#
+ (lambda (#{x\ 1484}#)
+ (if (#{nonsymbol-id?\ 1296}# #{x\ 1484}#)
+ (#{free-id=?\ 1320}#
+ #{x\ 1484}#
'#(syntax-object
...
((top)
@@ -435,1129 +466,1401 @@
("i" "i")))
(hygiene guile)))
#f)))
- (chi-void159 (lambda () (build-void81 #f)))
- (eval-local-transformer158
- (lambda (expanded303 mod304)
- (let ((p305 (local-eval-hook77 expanded303 mod304)))
- (if (procedure? p305)
- p305
+ (#{chi-void\ 1341}#
+ (lambda () (#{build-void\ 1263}# #f)))
+ (#{eval-local-transformer\ 1340}#
+ (lambda (#{expanded\ 1485}# #{mod\ 1486}#)
+ (let ((#{p\ 1487}#
+ (#{local-eval-hook\ 1259}#
+ #{expanded\ 1485}#
+ #{mod\ 1486}#)))
+ (if (procedure? #{p\ 1487}#)
+ #{p\ 1487}#
(syntax-violation
#f
"nonprocedure transformer"
- p305)))))
- (chi-local-syntax157
- (lambda (rec?306 e307 r308 w309 s310 mod311 k312)
- ((lambda (tmp313)
- ((lambda (tmp314)
- (if tmp314
- (apply (lambda (_315 id316 val317 e1318 e2319)
- (let ((ids320 id316))
- (if (not (valid-bound-ids?140 ids320))
+ #{p\ 1487}#)))))
+ (#{chi-local-syntax\ 1339}#
+ (lambda (#{rec?\ 1488}#
+ #{e\ 1489}#
+ #{r\ 1490}#
+ #{w\ 1491}#
+ #{s\ 1492}#
+ #{mod\ 1493}#
+ #{k\ 1494}#)
+ ((lambda (#{tmp\ 1495}#)
+ ((lambda (#{tmp\ 1496}#)
+ (if #{tmp\ 1496}#
+ (apply (lambda (#{_\ 1497}#
+ #{id\ 1498}#
+ #{val\ 1499}#
+ #{e1\ 1500}#
+ #{e2\ 1501}#)
+ (let ((#{ids\ 1502}# #{id\ 1498}#))
+ (if (not (#{valid-bound-ids?\ 1322}#
+ #{ids\ 1502}#))
(syntax-violation
#f
"duplicate bound keyword"
- e307)
- (let ((labels322 (gen-labels121 ids320)))
- (let ((new-w323
- (make-binding-wrap132
- ids320
- labels322
- w309)))
- (k312 (cons e1318 e2319)
- (extend-env109
- labels322
- (let ((w325 (if rec?306
- new-w323
- w309))
- (trans-r326
- (macros-only-env111
- r308)))
- (map (lambda (x327)
- (cons 'macro
- (eval-local-transformer158
- (chi151
- x327
- trans-r326
- w325
- mod311)
- mod311)))
- val317))
- r308)
- new-w323
- s310
- mod311))))))
- tmp314)
- ((lambda (_329)
+ #{e\ 1489}#)
+ (let ((#{labels\ 1504}#
+ (#{gen-labels\ 1303}#
+ #{ids\ 1502}#)))
+ (let ((#{new-w\ 1505}#
+ (#{make-binding-wrap\ 1314}#
+ #{ids\ 1502}#
+ #{labels\ 1504}#
+ #{w\ 1491}#)))
+ (#{k\ 1494}#
+ (cons #{e1\ 1500}# #{e2\ 1501}#)
+ (#{extend-env\ 1291}#
+ #{labels\ 1504}#
+ (let ((#{w\ 1507}#
+ (if #{rec?\ 1488}#
+ #{new-w\ 1505}#
+ #{w\ 1491}#))
+ (#{trans-r\ 1508}#
+ (#{macros-only-env\ 1293}#
+ #{r\ 1490}#)))
+ (map (lambda (#{x\ 1509}#)
+ (cons 'macro
+ (#{eval-local-transformer\ 1340}#
+ (#{chi\ 1333}#
+ #{x\ 1509}#
+ #{trans-r\ 1508}#
+ #{w\ 1507}#
+ #{mod\ 1493}#)
+ #{mod\ 1493}#)))
+ #{val\ 1499}#))
+ #{r\ 1490}#)
+ #{new-w\ 1505}#
+ #{s\ 1492}#
+ #{mod\ 1493}#))))))
+ #{tmp\ 1496}#)
+ ((lambda (#{_\ 1511}#)
(syntax-violation
#f
"bad local syntax definition"
- (source-wrap144 e307 w309 s310 mod311)))
- tmp313)))
+ (#{source-wrap\ 1326}#
+ #{e\ 1489}#
+ #{w\ 1491}#
+ #{s\ 1492}#
+ #{mod\ 1493}#)))
+ #{tmp\ 1495}#)))
($sc-dispatch
- tmp313
+ #{tmp\ 1495}#
'(any #(each (any any)) any . each-any))))
- e307)))
- (chi-lambda-clause156
- (lambda (e330 docstring331 c332 r333 w334 mod335 k336)
- ((lambda (tmp337)
- ((lambda (tmp338)
- (if (if tmp338
- (apply (lambda (args339 doc340 e1341 e2342)
- (if (string? (syntax->datum doc340))
- (not docstring331)
+ #{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))
- tmp338)
+ #{tmp\ 1520}#)
#f)
- (apply (lambda (args343 doc344 e1345 e2346)
- (chi-lambda-clause156
- e330
- doc344
- (cons args343 (cons e1345 e2346))
- r333
- w334
- mod335
- k336))
- tmp338)
- ((lambda (tmp348)
- (if tmp348
- (apply (lambda (id349 e1350 e2351)
- (let ((ids352 id349))
- (if (not (valid-bound-ids?140 ids352))
+ (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"
- e330)
- (let ((labels354
- (gen-labels121 ids352))
- (new-vars355
- (map gen-var162 ids352)))
- (k336 (map syntax->datum ids352)
- new-vars355
- (if docstring331
- (syntax->datum docstring331)
- #f)
- (chi-body155
- (cons e1350 e2351)
- e330
- (extend-var-env110
- labels354
- new-vars355
- r333)
- (make-binding-wrap132
- ids352
- labels354
- w334)
- mod335))))))
- tmp348)
- ((lambda (tmp357)
- (if tmp357
- (apply (lambda (ids358 e1359 e2360)
- (let ((old-ids361
- (lambda-var-list163 ids358)))
- (if (not (valid-bound-ids?140
- old-ids361))
+ #{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"
- e330)
- (let ((labels362
- (gen-labels121
- old-ids361))
- (new-vars363
- (map gen-var162
- old-ids361)))
- (k336 (letrec ((f364 (lambda (ls1365
- ls2366)
- (if (null? ls1365)
- (syntax->datum
- ls2366)
- (f364 (cdr ls1365)
- (cons (syntax->datum
- (car ls1365))
- ls2366))))))
- (f364 (cdr old-ids361)
- (car old-ids361)))
- (letrec ((f367 (lambda (ls1368
- ls2369)
- (if (null? ls1368)
- ls2369
- (f367 (cdr ls1368)
- (cons (car ls1368)
- ls2369))))))
- (f367 (cdr new-vars363)
- (car new-vars363)))
- (if docstring331
- (syntax->datum
- docstring331)
- #f)
- (chi-body155
- (cons e1359 e2360)
- e330
- (extend-var-env110
- labels362
- new-vars363
- r333)
- (make-binding-wrap132
- old-ids361
- labels362
- w334)
- mod335))))))
- tmp357)
- ((lambda (_371)
+ #{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"
- e330))
- tmp337)))
+ #{e\ 1512}#))
+ #{tmp\ 1519}#)))
($sc-dispatch
- tmp337
+ #{tmp\ 1519}#
'(any any . each-any)))))
($sc-dispatch
- tmp337
+ #{tmp\ 1519}#
'(each-any any . each-any)))))
($sc-dispatch
- tmp337
+ #{tmp\ 1519}#
'(any any any . each-any))))
- c332)))
- (chi-body155
- (lambda (body372 outer-form373 r374 w375 mod376)
- (let ((r377 (cons (quote ("placeholder" placeholder)) r374)))
- (let ((ribcage378
- (make-ribcage122
+ #{c\ 1514}#)))
+ (#{chi-body\ 1337}#
+ (lambda (#{body\ 1554}#
+ #{outer-form\ 1555}#
+ #{r\ 1556}#
+ #{w\ 1557}#
+ #{mod\ 1558}#)
+ (let ((#{r\ 1559}#
+ (cons '("placeholder" placeholder)
+ #{r\ 1556}#)))
+ (let ((#{ribcage\ 1560}#
+ (#{make-ribcage\ 1304}#
'()
'()
'())))
- (let ((w379 (make-wrap117
- (wrap-marks118 w375)
- (cons ribcage378 (wrap-subst119 w375)))))
- (letrec ((parse380
- (lambda (body381
- ids382
- labels383
- var-ids384
- vars385
- vals386
- bindings387)
- (if (null? body381)
+ (let ((#{w\ 1561}#
+ (#{make-wrap\ 1299}#
+ (#{wrap-marks\ 1300}# #{w\ 1557}#)
+ (cons #{ribcage\ 1560}#
+ (#{wrap-subst\ 1301}# #{w\ 1557}#)))))
+ (letrec ((#{parse\ 1562}#
+ (lambda (#{body\ 1563}#
+ #{ids\ 1564}#
+ #{labels\ 1565}#
+ #{var-ids\ 1566}#
+ #{vars\ 1567}#
+ #{vals\ 1568}#
+ #{bindings\ 1569}#)
+ (if (null? #{body\ 1563}#)
(syntax-violation
#f
"no expressions in body"
- outer-form373)
- (let ((e389 (cdar body381))
- (er390 (caar body381)))
+ #{outer-form\ 1555}#)
+ (let ((#{e\ 1571}# (cdar #{body\ 1563}#))
+ (#{er\ 1572}# (caar #{body\ 1563}#)))
(call-with-values
(lambda ()
- (syntax-type149
- e389
- er390
+ (#{syntax-type\ 1331}#
+ #{e\ 1571}#
+ #{er\ 1572}#
'(())
- (source-annotation106 er390)
- ribcage378
- mod376
+ (#{source-annotation\ 1288}#
+ #{er\ 1572}#)
+ #{ribcage\ 1560}#
+ #{mod\ 1558}#
#f))
- (lambda (type391
- value392
- e393
- w394
- s395
- mod396)
- (if (memv type391
+ (lambda (#{type\ 1573}#
+ #{value\ 1574}#
+ #{e\ 1575}#
+ #{w\ 1576}#
+ #{s\ 1577}#
+ #{mod\ 1578}#)
+ (if (memv #{type\ 1573}#
'(define-form))
- (let ((id397 (wrap143
- value392
- w394
- mod396))
- (label398 (gen-label120)))
- (let ((var399
- (gen-var162 id397)))
+ (let ((#{id\ 1579}#
+ (#{wrap\ 1325}#
+ #{value\ 1574}#
+ #{w\ 1576}#
+ #{mod\ 1578}#))
+ (#{label\ 1580}#
+ (#{gen-label\ 1302}#)))
+ (let ((#{var\ 1581}#
+ (#{gen-var\ 1344}#
+ #{id\ 1579}#)))
(begin
- (extend-ribcage!131
- ribcage378
- id397
- label398)
- (parse380
- (cdr body381)
- (cons id397 ids382)
- (cons label398 labels383)
- (cons id397 var-ids384)
- (cons var399 vars385)
- (cons (cons er390
- (wrap143
- e393
- w394
- mod396))
- vals386)
+ (#{extend-ribcage!\ 1313}#
+ #{ribcage\ 1560}#
+ #{id\ 1579}#
+ #{label\ 1580}#)
+ (#{parse\ 1562}#
+ (cdr #{body\ 1563}#)
+ (cons #{id\ 1579}#
+ #{ids\ 1564}#)
+ (cons #{label\ 1580}#
+ #{labels\ 1565}#)
+ (cons #{id\ 1579}#
+ #{var-ids\ 1566}#)
+ (cons #{var\ 1581}#
+ #{vars\ 1567}#)
+ (cons (cons #{er\ 1572}#
+ (#{wrap\ 1325}#
+ #{e\ 1575}#
+ #{w\ 1576}#
+ #{mod\ 1578}#))
+ #{vals\ 1568}#)
(cons (cons 'lexical
- var399)
- bindings387)))))
- (if (memv type391
+ #{var\ 1581}#)
+ #{bindings\ 1569}#)))))
+ (if (memv #{type\ 1573}#
'(define-syntax-form))
- (let ((id400 (wrap143
- value392
- w394
- mod396))
- (label401 (gen-label120)))
+ (let ((#{id\ 1582}#
+ (#{wrap\ 1325}#
+ #{value\ 1574}#
+ #{w\ 1576}#
+ #{mod\ 1578}#))
+ (#{label\ 1583}#
+ (#{gen-label\ 1302}#)))
(begin
- (extend-ribcage!131
- ribcage378
- id400
- label401)
- (parse380
- (cdr body381)
- (cons id400 ids382)
- (cons label401 labels383)
- var-ids384
- vars385
- vals386
+ (#{extend-ribcage!\ 1313}#
+ #{ribcage\ 1560}#
+ #{id\ 1582}#
+ #{label\ 1583}#)
+ (#{parse\ 1562}#
+ (cdr #{body\ 1563}#)
+ (cons #{id\ 1582}#
+ #{ids\ 1564}#)
+ (cons #{label\ 1583}#
+ #{labels\ 1565}#)
+ #{var-ids\ 1566}#
+ #{vars\ 1567}#
+ #{vals\ 1568}#
(cons (cons 'macro
- (cons er390
- (wrap143
- e393
- w394
- mod396)))
- bindings387))))
- (if (memv type391
+ (cons #{er\ 1572}#
+ (#{wrap\ 1325}#
+ #{e\ 1575}#
+ #{w\ 1576}#
+ #{mod\ 1578}#)))
+ #{bindings\ 1569}#))))
+ (if (memv #{type\ 1573}#
'(begin-form))
- ((lambda (tmp402)
- ((lambda (tmp403)
- (if tmp403
- (apply (lambda (_404
- e1405)
- (parse380
- (letrec ((f406 (lambda (forms407)
- (if (null? forms407)
- (cdr body381)
- (cons (cons er390
- (wrap143
- (car forms407)
- w394
- mod396))
- (f406 (cdr forms407)))))))
- (f406 e1405))
- ids382
- labels383
- var-ids384
- vars385
- vals386
- bindings387))
- tmp403)
+ ((lambda (#{tmp\ 1584}#)
+ ((lambda (#{tmp\ 1585}#)
+ (if #{tmp\ 1585}#
+ (apply (lambda (#{_\ 1586}#
+ #{e1\ 1587}#)
+ (#{parse\ 1562}#
+ (letrec ((#{f\ 1588}#
+ (lambda (#{forms\ 1589}#)
+ (if (null? #{forms\ 1589}#)
+ (cdr #{body\ 1563}#)
+ (cons (cons #{er\ 1572}#
+ (#{wrap\ 1325}#
+ (car #{forms\ 1589}#)
+ #{w\ 1576}#
+ #{mod\ 1578}#))
+ (#{f\ 1588}#
+ (cdr #{forms\ 1589}#)))))))
+ (#{f\ 1588}#
+ #{e1\ 1587}#))
+ #{ids\ 1564}#
+ #{labels\ 1565}#
+ #{var-ids\ 1566}#
+ #{vars\ 1567}#
+ #{vals\ 1568}#
+ #{bindings\ 1569}#))
+ #{tmp\ 1585}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp402)))
+ #{tmp\ 1584}#)))
($sc-dispatch
- tmp402
+ #{tmp\ 1584}#
'(any . each-any))))
- e393)
- (if (memv type391
+ #{e\ 1575}#)
+ (if (memv #{type\ 1573}#
'(local-syntax-form))
- (chi-local-syntax157
- value392
- e393
- er390
- w394
- s395
- mod396
- (lambda (forms409
- er410
- w411
- s412
- mod413)
- (parse380
- (letrec ((f414 (lambda (forms415)
- (if (null? forms415)
- (cdr body381)
- (cons (cons er410
- (wrap143
- (car forms415)
- w411
- mod413))
- (f414 (cdr forms415)))))))
- (f414 forms409))
- ids382
- labels383
- var-ids384
- vars385
- vals386
- bindings387)))
- (if (null? ids382)
- (build-sequence94
+ (#{chi-local-syntax\ 1339}#
+ #{value\ 1574}#
+ #{e\ 1575}#
+ #{er\ 1572}#
+ #{w\ 1576}#
+ #{s\ 1577}#
+ #{mod\ 1578}#
+ (lambda (#{forms\ 1591}#
+ #{er\ 1592}#
+ #{w\ 1593}#
+ #{s\ 1594}#
+ #{mod\ 1595}#)
+ (#{parse\ 1562}#
+ (letrec ((#{f\ 1596}#
+ (lambda (#{forms\ 1597}#)
+ (if (null? #{forms\ 1597}#)
+ (cdr #{body\ 1563}#)
+ (cons (cons #{er\ 1592}#
+ (#{wrap\ 1325}#
+ (car #{forms\ 1597}#)
+ #{w\ 1593}#
+ #{mod\ 1595}#))
+ (#{f\ 1596}#
+ (cdr #{forms\ 1597}#)))))))
+ (#{f\ 1596}#
+ #{forms\ 1591}#))
+ #{ids\ 1564}#
+ #{labels\ 1565}#
+ #{var-ids\ 1566}#
+ #{vars\ 1567}#
+ #{vals\ 1568}#
+ #{bindings\ 1569}#)))
+ (if (null? #{ids\ 1564}#)
+ (#{build-sequence\ 1276}#
#f
- (map (lambda (x416)
- (chi151
- (cdr x416)
- (car x416)
+ (map (lambda (#{x\ 1598}#)
+ (#{chi\ 1333}#
+ (cdr #{x\ 1598}#)
+ (car #{x\ 1598}#)
'(())
- mod396))
- (cons (cons er390
- (source-wrap144
- e393
- w394
- s395
- mod396))
- (cdr body381))))
+ #{mod\ 1578}#))
+ (cons (cons #{er\ 1572}#
+ (#{source-wrap\ 1326}#
+ #{e\ 1575}#
+ #{w\ 1576}#
+ #{s\ 1577}#
+ #{mod\ 1578}#))
+ (cdr #{body\ 1563}#))))
(begin
- (if (not (valid-bound-ids?140
- ids382))
+ (if (not (#{valid-bound-ids?\ 1322}#
+ #{ids\ 1564}#))
(syntax-violation
#f
"invalid or duplicate identifier in definition"
- outer-form373))
- (letrec ((loop417
- (lambda (bs418
- er-cache419
- r-cache420)
- (if (not (null? bs418))
- (let ((b421 (car bs418)))
- (if (eq? (car b421)
+ #{outer-form\ 1555}#))
+ (letrec ((#{loop\ 1599}#
+ (lambda (#{bs\ 1600}#
+ #{er-cache\ 1601}#
+ #{r-cache\ 1602}#)
+ (if (not (null? #{bs\ 1600}#))
+ (let ((#{b\ 1603}#
+ (car #{bs\ 1600}#)))
+ (if (eq? (car #{b\ 1603}#)
'macro)
- (let ((er422 (cadr b421)))
- (let ((r-cache423
- (if (eq? er422
- er-cache419)
- r-cache420
- (macros-only-env111
- er422))))
+ (let ((#{er\ 1604}#
+ (cadr #{b\ 1603}#)))
+ (let ((#{r-cache\ 1605}#
+ (if (eq? #{er\ 1604}#
+ #{er-cache\ 1601}#)
+ #{r-cache\ 1602}#
+ (#{macros-only-env\ 1293}#
+ #{er\ 1604}#))))
(begin
(set-cdr!
- b421
- (eval-local-transformer158
- (chi151
- (cddr b421)
- r-cache423
+ #{b\ 1603}#
+ (#{eval-local-transformer\ 1340}#
+ (#{chi\ 1333}#
+ (cddr #{b\ 1603}#)
+ #{r-cache\ 1605}#
'(())
- mod396)
- mod396))
- (loop417
- (cdr bs418)
- er422
- r-cache423))))
- (loop417
- (cdr bs418)
- er-cache419
- r-cache420)))))))
- (loop417
- bindings387
+ #{mod\ 1578}#)
+ #{mod\ 1578}#))
+ (#{loop\ 1599}#
+ (cdr #{bs\ 1600}#)
+ #{er\ 1604}#
+ #{r-cache\ 1605}#))))
+ (#{loop\ 1599}#
+ (cdr #{bs\ 1600}#)
+ #{er-cache\ 1601}#
+ #{r-cache\ 1602}#)))))))
+ (#{loop\ 1599}#
+ #{bindings\ 1569}#
#f
#f))
(set-cdr!
- r377
- (extend-env109
- labels383
- bindings387
- (cdr r377)))
- (build-letrec97
+ #{r\ 1559}#
+ (#{extend-env\ 1291}#
+ #{labels\ 1565}#
+ #{bindings\ 1569}#
+ (cdr #{r\ 1559}#)))
+ (#{build-letrec\ 1279}#
#f
(map syntax->datum
- var-ids384)
- vars385
- (map (lambda (x424)
- (chi151
- (cdr x424)
- (car x424)
+ #{var-ids\ 1566}#)
+ #{vars\ 1567}#
+ (map (lambda (#{x\ 1606}#)
+ (#{chi\ 1333}#
+ (cdr #{x\ 1606}#)
+ (car #{x\ 1606}#)
'(())
- mod396))
- vals386)
- (build-sequence94
+ #{mod\ 1578}#))
+ #{vals\ 1568}#)
+ (#{build-sequence\ 1276}#
#f
- (map (lambda (x425)
- (chi151
- (cdr x425)
- (car x425)
+ (map (lambda (#{x\ 1607}#)
+ (#{chi\ 1333}#
+ (cdr #{x\ 1607}#)
+ (car #{x\ 1607}#)
'(())
- mod396))
- (cons (cons er390
- (source-wrap144
- e393
- w394
- s395
- mod396))
- (cdr body381))))))))))))))))))
- (parse380
- (map (lambda (x388)
- (cons r377 (wrap143 x388 w379 mod376)))
- body372)
+ #{mod\ 1578}#))
+ (cons (cons #{er\ 1572}#
+ (#{source-wrap\ 1326}#
+ #{e\ 1575}#
+ #{w\ 1576}#
+ #{s\ 1577}#
+ #{mod\ 1578}#))
+ (cdr #{body\ 1563}#))))))))))))))))))
+ (#{parse\ 1562}#
+ (map (lambda (#{x\ 1570}#)
+ (cons #{r\ 1559}#
+ (#{wrap\ 1325}#
+ #{x\ 1570}#
+ #{w\ 1561}#
+ #{mod\ 1558}#)))
+ #{body\ 1554}#)
'()
'()
'()
'()
'()
'())))))))
- (chi-macro154
- (lambda (p426 e427 r428 w429 rib430 mod431)
- (letrec ((rebuild-macro-output432
- (lambda (x433 m434)
- (if (pair? x433)
- (cons (rebuild-macro-output432 (car x433) m434)
- (rebuild-macro-output432 (cdr x433) m434))
- (if (syntax-object?99 x433)
- (let ((w435 (syntax-object-wrap101 x433)))
- (let ((ms436 (wrap-marks118 w435))
- (s437 (wrap-subst119 w435)))
- (if (if (pair? ms436)
- (eq? (car ms436) #f)
+ (#{chi-macro\ 1336}#
+ (lambda (#{p\ 1608}#
+ #{e\ 1609}#
+ #{r\ 1610}#
+ #{w\ 1611}#
+ #{rib\ 1612}#
+ #{mod\ 1613}#)
+ (letrec ((#{rebuild-macro-output\ 1614}#
+ (lambda (#{x\ 1615}# #{m\ 1616}#)
+ (if (pair? #{x\ 1615}#)
+ (cons (#{rebuild-macro-output\ 1614}#
+ (car #{x\ 1615}#)
+ #{m\ 1616}#)
+ (#{rebuild-macro-output\ 1614}#
+ (cdr #{x\ 1615}#)
+ #{m\ 1616}#))
+ (if (#{syntax-object?\ 1281}# #{x\ 1615}#)
+ (let ((#{w\ 1617}#
+ (#{syntax-object-wrap\ 1283}#
+ #{x\ 1615}#)))
+ (let ((#{ms\ 1618}#
+ (#{wrap-marks\ 1300}# #{w\ 1617}#))
+ (#{s\ 1619}#
+ (#{wrap-subst\ 1301}# #{w\ 1617}#)))
+ (if (if (pair? #{ms\ 1618}#)
+ (eq? (car #{ms\ 1618}#) #f)
#f)
- (make-syntax-object98
- (syntax-object-expression100 x433)
- (make-wrap117
- (cdr ms436)
- (if rib430
- (cons rib430 (cdr s437))
- (cdr s437)))
- (syntax-object-module102 x433))
- (make-syntax-object98
- (syntax-object-expression100 x433)
- (make-wrap117
- (cons m434 ms436)
- (if rib430
- (cons rib430
- (cons (quote shift) s437))
- (cons (quote shift) s437)))
- (let ((pmod438
- (procedure-module p426)))
- (if pmod438
+ (#{make-syntax-object\ 1280}#
+ (#{syntax-object-expression\ 1282}#
+ #{x\ 1615}#)
+ (#{make-wrap\ 1299}#
+ (cdr #{ms\ 1618}#)
+ (if #{rib\ 1612}#
+ (cons #{rib\ 1612}#
+ (cdr #{s\ 1619}#))
+ (cdr #{s\ 1619}#)))
+ (#{syntax-object-module\ 1284}#
+ #{x\ 1615}#))
+ (#{make-syntax-object\ 1280}#
+ (#{syntax-object-expression\ 1282}#
+ #{x\ 1615}#)
+ (#{make-wrap\ 1299}#
+ (cons #{m\ 1616}# #{ms\ 1618}#)
+ (if #{rib\ 1612}#
+ (cons #{rib\ 1612}#
+ (cons 'shift
+ #{s\ 1619}#))
+ (cons (quote shift) #{s\ 1619}#)))
+ (let ((#{pmod\ 1620}#
+ (procedure-module
+ #{p\ 1608}#)))
+ (if #{pmod\ 1620}#
(cons 'hygiene
- (module-name pmod438))
+ (module-name #{pmod\ 1620}#))
'(hygiene guile)))))))
- (if (vector? x433)
- (let ((n439 (vector-length x433)))
- (let ((v440 (make-vector n439)))
- (letrec ((loop441
- (lambda (i442)
- (if (fx=74 i442 n439)
- (begin (if #f #f) v440)
+ (if (vector? #{x\ 1615}#)
+ (let ((#{n\ 1621}#
+ (vector-length #{x\ 1615}#)))
+ (let ((#{v\ 1622}#
+ (make-vector #{n\ 1621}#)))
+ (letrec ((#{loop\ 1623}#
+ (lambda (#{i\ 1624}#)
+ (if (#{fx=\ 1256}#
+ #{i\ 1624}#
+ #{n\ 1621}#)
+ (begin
+ (if #f #f)
+ #{v\ 1622}#)
(begin
(vector-set!
- v440
- i442
- (rebuild-macro-output432
+ #{v\ 1622}#
+ #{i\ 1624}#
+ (#{rebuild-macro-output\ 1614}#
(vector-ref
- x433
- i442)
- m434))
- (loop441
- (fx+72 i442 1)))))))
- (loop441 0))))
- (if (symbol? x433)
+ #{x\ 1615}#
+ #{i\ 1624}#)
+ #{m\ 1616}#))
+ (#{loop\ 1623}#
+ (#{fx+\ 1254}#
+ #{i\ 1624}#
+ 1)))))))
+ (#{loop\ 1623}# 0))))
+ (if (symbol? #{x\ 1615}#)
(syntax-violation
#f
"encountered raw symbol in macro output"
- (source-wrap144 e427 w429 s mod431)
- x433)
- x433)))))))
- (rebuild-macro-output432
- (p426 (wrap143 e427 (anti-mark130 w429) mod431))
+ (#{source-wrap\ 1326}#
+ #{e\ 1609}#
+ #{w\ 1611}#
+ s
+ #{mod\ 1613}#)
+ #{x\ 1615}#)
+ #{x\ 1615}#)))))))
+ (#{rebuild-macro-output\ 1614}#
+ (#{p\ 1608}#
+ (#{wrap\ 1325}#
+ #{e\ 1609}#
+ (#{anti-mark\ 1312}# #{w\ 1611}#)
+ #{mod\ 1613}#))
(string #\m)))))
- (chi-application153
- (lambda (x443 e444 r445 w446 s447 mod448)
- ((lambda (tmp449)
- ((lambda (tmp450)
- (if tmp450
- (apply (lambda (e0451 e1452)
- (build-application82
- s447
- x443
- (map (lambda (e453)
- (chi151 e453 r445 w446 mod448))
- e1452)))
- tmp450)
+ (#{chi-application\ 1335}#
+ (lambda (#{x\ 1625}#
+ #{e\ 1626}#
+ #{r\ 1627}#
+ #{w\ 1628}#
+ #{s\ 1629}#
+ #{mod\ 1630}#)
+ ((lambda (#{tmp\ 1631}#)
+ ((lambda (#{tmp\ 1632}#)
+ (if #{tmp\ 1632}#
+ (apply (lambda (#{e0\ 1633}# #{e1\ 1634}#)
+ (#{build-application\ 1264}#
+ #{s\ 1629}#
+ #{x\ 1625}#
+ (map (lambda (#{e\ 1635}#)
+ (#{chi\ 1333}#
+ #{e\ 1635}#
+ #{r\ 1627}#
+ #{w\ 1628}#
+ #{mod\ 1630}#))
+ #{e1\ 1634}#)))
+ #{tmp\ 1632}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp449)))
- ($sc-dispatch tmp449 (quote (any . each-any)))))
- e444)))
- (chi-expr152
- (lambda (type455 value456 e457 r458 w459 s460 mod461)
- (if (memv type455 (quote (lexical)))
- (build-lexical-reference84
+ #{tmp\ 1631}#)))
+ ($sc-dispatch
+ #{tmp\ 1631}#
+ '(any . each-any))))
+ #{e\ 1626}#)))
+ (#{chi-expr\ 1334}#
+ (lambda (#{type\ 1637}#
+ #{value\ 1638}#
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (lexical)))
+ (#{build-lexical-reference\ 1266}#
'value
- s460
- e457
- value456)
- (if (memv type455 (quote (core core-form)))
- (value456 e457 r458 w459 s460 mod461)
- (if (memv type455 (quote (module-ref)))
+ #{s\ 1642}#
+ #{e\ 1639}#
+ #{value\ 1638}#)
+ (if (memv #{type\ 1637}# (quote (core core-form)))
+ (#{value\ 1638}#
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (module-ref)))
(call-with-values
- (lambda () (value456 e457))
- (lambda (id462 mod463)
- (build-global-reference87 s460 id462 mod463)))
- (if (memv type455 (quote (lexical-call)))
- (chi-application153
- (build-lexical-reference84
+ (lambda () (#{value\ 1638}# #{e\ 1639}#))
+ (lambda (#{id\ 1644}# #{mod\ 1645}#)
+ (#{build-global-reference\ 1269}#
+ #{s\ 1642}#
+ #{id\ 1644}#
+ #{mod\ 1645}#)))
+ (if (memv #{type\ 1637}# (quote (lexical-call)))
+ (#{chi-application\ 1335}#
+ (#{build-lexical-reference\ 1266}#
'fun
- (source-annotation106 (car e457))
- (car e457)
- value456)
- e457
- r458
- w459
- s460
- mod461)
- (if (memv type455 (quote (global-call)))
- (chi-application153
- (build-global-reference87
- (source-annotation106 (car e457))
- (if (syntax-object?99 value456)
- (syntax-object-expression100 value456)
- value456)
- (if (syntax-object?99 value456)
- (syntax-object-module102 value456)
- mod461))
- e457
- r458
- w459
- s460
- mod461)
- (if (memv type455 (quote (constant)))
- (build-data93
- s460
- (strip161
- (source-wrap144 e457 w459 s460 mod461)
+ (#{source-annotation\ 1288}# (car #{e\ 1639}#))
+ (car #{e\ 1639}#)
+ #{value\ 1638}#)
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (global-call)))
+ (#{chi-application\ 1335}#
+ (#{build-global-reference\ 1269}#
+ (#{source-annotation\ 1288}# (car #{e\ 1639}#))
+ (if (#{syntax-object?\ 1281}# #{value\ 1638}#)
+ (#{syntax-object-expression\ 1282}#
+ #{value\ 1638}#)
+ #{value\ 1638}#)
+ (if (#{syntax-object?\ 1281}# #{value\ 1638}#)
+ (#{syntax-object-module\ 1284}# #{value\ 1638}#)
+ #{mod\ 1643}#))
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (constant)))
+ (#{build-data\ 1275}#
+ #{s\ 1642}#
+ (#{strip\ 1343}#
+ (#{source-wrap\ 1326}#
+ #{e\ 1639}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
'(())))
- (if (memv type455 (quote (global)))
- (build-global-reference87 s460 value456 mod461)
- (if (memv type455 (quote (call)))
- (chi-application153
- (chi151 (car e457) r458 w459 mod461)
- e457
- r458
- w459
- s460
- mod461)
- (if (memv type455 (quote (begin-form)))
- ((lambda (tmp464)
- ((lambda (tmp465)
- (if tmp465
- (apply (lambda (_466 e1467 e2468)
- (chi-sequence145
- (cons e1467 e2468)
- r458
- w459
- s460
- mod461))
- tmp465)
+ (if (memv #{type\ 1637}# (quote (global)))
+ (#{build-global-reference\ 1269}#
+ #{s\ 1642}#
+ #{value\ 1638}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (call)))
+ (#{chi-application\ 1335}#
+ (#{chi\ 1333}#
+ (car #{e\ 1639}#)
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{mod\ 1643}#)
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (if (memv #{type\ 1637}# (quote (begin-form)))
+ ((lambda (#{tmp\ 1646}#)
+ ((lambda (#{tmp\ 1647}#)
+ (if #{tmp\ 1647}#
+ (apply (lambda (#{_\ 1648}#
+ #{e1\ 1649}#
+ #{e2\ 1650}#)
+ (#{chi-sequence\ 1327}#
+ (cons #{e1\ 1649}#
+ #{e2\ 1650}#)
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#))
+ #{tmp\ 1647}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp464)))
+ #{tmp\ 1646}#)))
($sc-dispatch
- tmp464
+ #{tmp\ 1646}#
'(any any . each-any))))
- e457)
- (if (memv type455 (quote (local-syntax-form)))
- (chi-local-syntax157
- value456
- e457
- r458
- w459
- s460
- mod461
- chi-sequence145)
- (if (memv type455 (quote (eval-when-form)))
- ((lambda (tmp470)
- ((lambda (tmp471)
- (if tmp471
- (apply (lambda (_472
- x473
- e1474
- e2475)
- (let ((when-list476
- (chi-when-list148
- e457
- x473
- w459)))
+ #{e\ 1639}#)
+ (if (memv #{type\ 1637}#
+ '(local-syntax-form))
+ (#{chi-local-syntax\ 1339}#
+ #{value\ 1638}#
+ #{e\ 1639}#
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#
+ #{chi-sequence\ 1327}#)
+ (if (memv #{type\ 1637}#
+ '(eval-when-form))
+ ((lambda (#{tmp\ 1652}#)
+ ((lambda (#{tmp\ 1653}#)
+ (if #{tmp\ 1653}#
+ (apply (lambda (#{_\ 1654}#
+ #{x\ 1655}#
+ #{e1\ 1656}#
+ #{e2\ 1657}#)
+ (let ((#{when-list\ 1658}#
+ (#{chi-when-list\ 1330}#
+ #{e\ 1639}#
+ #{x\ 1655}#
+ #{w\ 1641}#)))
(if (memq 'eval
- when-list476)
- (chi-sequence145
- (cons e1474 e2475)
- r458
- w459
- s460
- mod461)
- (chi-void159))))
- tmp471)
+ #{when-list\ 1658}#)
+ (#{chi-sequence\ 1327}#
+ (cons #{e1\ 1656}#
+ #{e2\ 1657}#)
+ #{r\ 1640}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#)
+ (#{chi-void\ 1341}#))))
+ #{tmp\ 1653}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp470)))
+ #{tmp\ 1652}#)))
($sc-dispatch
- tmp470
+ #{tmp\ 1652}#
'(any each-any any . each-any))))
- e457)
- (if (memv type455
+ #{e\ 1639}#)
+ (if (memv #{type\ 1637}#
'(define-form
define-syntax-form))
(syntax-violation
#f
"definition in expression context"
- e457
- (wrap143 value456 w459 mod461))
- (if (memv type455 (quote (syntax)))
+ #{e\ 1639}#
+ (#{wrap\ 1325}#
+ #{value\ 1638}#
+ #{w\ 1641}#
+ #{mod\ 1643}#))
+ (if (memv #{type\ 1637}#
+ '(syntax))
(syntax-violation
#f
"reference to pattern variable outside syntax form"
- (source-wrap144
- e457
- w459
- s460
- mod461))
- (if (memv type455
+ (#{source-wrap\ 1326}#
+ #{e\ 1639}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#))
+ (if (memv #{type\ 1637}#
'(displaced-lexical))
(syntax-violation
#f
"reference to identifier outside its scope"
- (source-wrap144
- e457
- w459
- s460
- mod461))
+ (#{source-wrap\ 1326}#
+ #{e\ 1639}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#))
(syntax-violation
#f
"unexpected syntax"
- (source-wrap144
- e457
- w459
- s460
- mod461))))))))))))))))))
- (chi151
- (lambda (e479 r480 w481 mod482)
+ (#{source-wrap\ 1326}#
+ #{e\ 1639}#
+ #{w\ 1641}#
+ #{s\ 1642}#
+ #{mod\ 1643}#))))))))))))))))))
+ (#{chi\ 1333}#
+ (lambda (#{e\ 1661}#
+ #{r\ 1662}#
+ #{w\ 1663}#
+ #{mod\ 1664}#)
(call-with-values
(lambda ()
- (syntax-type149
- e479
- r480
- w481
- (source-annotation106 e479)
+ (#{syntax-type\ 1331}#
+ #{e\ 1661}#
+ #{r\ 1662}#
+ #{w\ 1663}#
+ (#{source-annotation\ 1288}# #{e\ 1661}#)
#f
- mod482
+ #{mod\ 1664}#
#f))
- (lambda (type483 value484 e485 w486 s487 mod488)
- (chi-expr152
- type483
- value484
- e485
- r480
- w486
- s487
- mod488)))))
- (chi-top150
- (lambda (e489 r490 w491 m492 esew493 mod494)
+ (lambda (#{type\ 1665}#
+ #{value\ 1666}#
+ #{e\ 1667}#
+ #{w\ 1668}#
+ #{s\ 1669}#
+ #{mod\ 1670}#)
+ (#{chi-expr\ 1334}#
+ #{type\ 1665}#
+ #{value\ 1666}#
+ #{e\ 1667}#
+ #{r\ 1662}#
+ #{w\ 1668}#
+ #{s\ 1669}#
+ #{mod\ 1670}#)))))
+ (#{chi-top\ 1332}#
+ (lambda (#{e\ 1671}#
+ #{r\ 1672}#
+ #{w\ 1673}#
+ #{m\ 1674}#
+ #{esew\ 1675}#
+ #{mod\ 1676}#)
(call-with-values
(lambda ()
- (syntax-type149
- e489
- r490
- w491
- (source-annotation106 e489)
+ (#{syntax-type\ 1331}#
+ #{e\ 1671}#
+ #{r\ 1672}#
+ #{w\ 1673}#
+ (#{source-annotation\ 1288}# #{e\ 1671}#)
#f
- mod494
+ #{mod\ 1676}#
#f))
- (lambda (type502 value503 e504 w505 s506 mod507)
- (if (memv type502 (quote (begin-form)))
- ((lambda (tmp508)
- ((lambda (tmp509)
- (if tmp509
- (apply (lambda (_510) (chi-void159)) tmp509)
- ((lambda (tmp511)
- (if tmp511
- (apply (lambda (_512 e1513 e2514)
- (chi-top-sequence146
- (cons e1513 e2514)
- r490
- w505
- s506
- m492
- esew493
- mod507))
- tmp511)
+ (lambda (#{type\ 1684}#
+ #{value\ 1685}#
+ #{e\ 1686}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ #{mod\ 1689}#)
+ (if (memv #{type\ 1684}# (quote (begin-form)))
+ ((lambda (#{tmp\ 1690}#)
+ ((lambda (#{tmp\ 1691}#)
+ (if #{tmp\ 1691}#
+ (apply (lambda (#{_\ 1692}#) (#{chi-void\ 1341}#))
+ #{tmp\ 1691}#)
+ ((lambda (#{tmp\ 1693}#)
+ (if #{tmp\ 1693}#
+ (apply (lambda (#{_\ 1694}#
+ #{e1\ 1695}#
+ #{e2\ 1696}#)
+ (#{chi-top-sequence\ 1328}#
+ (cons #{e1\ 1695}# #{e2\ 1696}#)
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ #{m\ 1674}#
+ #{esew\ 1675}#
+ #{mod\ 1689}#))
+ #{tmp\ 1693}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp508)))
+ #{tmp\ 1690}#)))
($sc-dispatch
- tmp508
+ #{tmp\ 1690}#
'(any any . each-any)))))
- ($sc-dispatch tmp508 (quote (any)))))
- e504)
- (if (memv type502 (quote (local-syntax-form)))
- (chi-local-syntax157
- value503
- e504
- r490
- w505
- s506
- mod507
- (lambda (body516 r517 w518 s519 mod520)
- (chi-top-sequence146
- body516
- r517
- w518
- s519
- m492
- esew493
- mod520)))
- (if (memv type502 (quote (eval-when-form)))
- ((lambda (tmp521)
- ((lambda (tmp522)
- (if tmp522
- (apply (lambda (_523 x524 e1525 e2526)
- (let ((when-list527
- (chi-when-list148
- e504
- x524
- w505))
- (body528 (cons e1525 e2526)))
- (if (eq? m492 (quote e))
+ ($sc-dispatch #{tmp\ 1690}# (quote (any)))))
+ #{e\ 1686}#)
+ (if (memv #{type\ 1684}# (quote (local-syntax-form)))
+ (#{chi-local-syntax\ 1339}#
+ #{value\ 1685}#
+ #{e\ 1686}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ #{mod\ 1689}#
+ (lambda (#{body\ 1698}#
+ #{r\ 1699}#
+ #{w\ 1700}#
+ #{s\ 1701}#
+ #{mod\ 1702}#)
+ (#{chi-top-sequence\ 1328}#
+ #{body\ 1698}#
+ #{r\ 1699}#
+ #{w\ 1700}#
+ #{s\ 1701}#
+ #{m\ 1674}#
+ #{esew\ 1675}#
+ #{mod\ 1702}#)))
+ (if (memv #{type\ 1684}# (quote (eval-when-form)))
+ ((lambda (#{tmp\ 1703}#)
+ ((lambda (#{tmp\ 1704}#)
+ (if #{tmp\ 1704}#
+ (apply (lambda (#{_\ 1705}#
+ #{x\ 1706}#
+ #{e1\ 1707}#
+ #{e2\ 1708}#)
+ (let ((#{when-list\ 1709}#
+ (#{chi-when-list\ 1330}#
+ #{e\ 1686}#
+ #{x\ 1706}#
+ #{w\ 1687}#))
+ (#{body\ 1710}#
+ (cons #{e1\ 1707}#
+ #{e2\ 1708}#)))
+ (if (eq? #{m\ 1674}# (quote e))
(if (memq 'eval
- when-list527)
- (chi-top-sequence146
- body528
- r490
- w505
- s506
+ #{when-list\ 1709}#)
+ (#{chi-top-sequence\ 1328}#
+ #{body\ 1710}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
'e
'(eval)
- mod507)
- (chi-void159))
+ #{mod\ 1689}#)
+ (#{chi-void\ 1341}#))
(if (memq 'load
- when-list527)
- (if (let ((t531 (memq 'compile
- when-list527)))
- (if t531
- t531
- (if (eq? m492
+ #{when-list\ 1709}#)
+ (if (let ((#{t\ 1713}#
+ (memq 'compile
+ #{when-list\ 1709}#)))
+ (if #{t\ 1713}#
+ #{t\ 1713}#
+ (if (eq? #{m\ 1674}#
'c&e)
(memq 'eval
- when-list527)
+ #{when-list\ 1709}#)
#f)))
- (chi-top-sequence146
- body528
- r490
- w505
- s506
+ (#{chi-top-sequence\ 1328}#
+ #{body\ 1710}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
'c&e
'(compile load)
- mod507)
- (if (memq m492
+ #{mod\ 1689}#)
+ (if (memq #{m\ 1674}#
'(c c&e))
- (chi-top-sequence146
- body528
- r490
- w505
- s506
+ (#{chi-top-sequence\ 1328}#
+ #{body\ 1710}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
'c
'(load)
- mod507)
- (chi-void159)))
- (if (let ((t532 (memq 'compile
- when-list527)))
- (if t532
- t532
- (if (eq? m492
+ #{mod\ 1689}#)
+ (#{chi-void\ 1341}#)))
+ (if (let ((#{t\ 1714}#
+ (memq 'compile
+ #{when-list\ 1709}#)))
+ (if #{t\ 1714}#
+ #{t\ 1714}#
+ (if (eq? #{m\ 1674}#
'c&e)
(memq 'eval
- when-list527)
+ #{when-list\ 1709}#)
#f)))
(begin
- (top-level-eval-hook76
- (chi-top-sequence146
- body528
- r490
- w505
- s506
+ (#{top-level-eval-hook\ 1258}#
+ (#{chi-top-sequence\ 1328}#
+ #{body\ 1710}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
'e
'(eval)
- mod507)
- mod507)
- (chi-void159))
- (chi-void159))))))
- tmp522)
+ #{mod\ 1689}#)
+ #{mod\ 1689}#)
+ (#{chi-void\ 1341}#))
+ (#{chi-void\ 1341}#))))))
+ #{tmp\ 1704}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp521)))
+ #{tmp\ 1703}#)))
($sc-dispatch
- tmp521
+ #{tmp\ 1703}#
'(any each-any any . each-any))))
- e504)
- (if (memv type502 (quote (define-syntax-form)))
- (let ((n533 (id-var-name137 value503 w505))
- (r534 (macros-only-env111 r490)))
- (if (memv m492 (quote (c)))
- (if (memq (quote compile) esew493)
- (let ((e535 (chi-install-global147
- n533
- (chi151
- e504
- r534
- w505
- mod507))))
+ #{e\ 1686}#)
+ (if (memv #{type\ 1684}#
+ '(define-syntax-form))
+ (let ((#{n\ 1715}#
+ (#{id-var-name\ 1319}#
+ #{value\ 1685}#
+ #{w\ 1687}#))
+ (#{r\ 1716}#
+ (#{macros-only-env\ 1293}# #{r\ 1672}#)))
+ (if (memv #{m\ 1674}# (quote (c)))
+ (if (memq (quote compile) #{esew\ 1675}#)
+ (let ((#{e\ 1717}#
+ (#{chi-install-global\ 1329}#
+ #{n\ 1715}#
+ (#{chi\ 1333}#
+ #{e\ 1686}#
+ #{r\ 1716}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))))
(begin
- (top-level-eval-hook76 e535 mod507)
- (if (memq (quote load) esew493)
- e535
- (chi-void159))))
- (if (memq (quote load) esew493)
- (chi-install-global147
- n533
- (chi151 e504 r534 w505 mod507))
- (chi-void159)))
- (if (memv m492 (quote (c&e)))
- (let ((e536 (chi-install-global147
- n533
- (chi151
- e504
- r534
- w505
- mod507))))
+ (#{top-level-eval-hook\ 1258}#
+ #{e\ 1717}#
+ #{mod\ 1689}#)
+ (if (memq (quote load) #{esew\ 1675}#)
+ #{e\ 1717}#
+ (#{chi-void\ 1341}#))))
+ (if (memq (quote load) #{esew\ 1675}#)
+ (#{chi-install-global\ 1329}#
+ #{n\ 1715}#
+ (#{chi\ 1333}#
+ #{e\ 1686}#
+ #{r\ 1716}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))
+ (#{chi-void\ 1341}#)))
+ (if (memv #{m\ 1674}# (quote (c&e)))
+ (let ((#{e\ 1718}#
+ (#{chi-install-global\ 1329}#
+ #{n\ 1715}#
+ (#{chi\ 1333}#
+ #{e\ 1686}#
+ #{r\ 1716}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))))
(begin
- (top-level-eval-hook76 e536 mod507)
- e536))
+ (#{top-level-eval-hook\ 1258}#
+ #{e\ 1718}#
+ #{mod\ 1689}#)
+ #{e\ 1718}#))
(begin
- (if (memq (quote eval) esew493)
- (top-level-eval-hook76
- (chi-install-global147
- n533
- (chi151 e504 r534 w505 mod507))
- mod507))
- (chi-void159)))))
- (if (memv type502 (quote (define-form)))
- (let ((n537 (id-var-name137 value503 w505)))
- (let ((type538
- (binding-type107
- (lookup112 n537 r490 mod507))))
- (if (memv type538
+ (if (memq (quote eval) #{esew\ 1675}#)
+ (#{top-level-eval-hook\ 1258}#
+ (#{chi-install-global\ 1329}#
+ #{n\ 1715}#
+ (#{chi\ 1333}#
+ #{e\ 1686}#
+ #{r\ 1716}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))
+ #{mod\ 1689}#))
+ (#{chi-void\ 1341}#)))))
+ (if (memv #{type\ 1684}# (quote (define-form)))
+ (let ((#{n\ 1719}#
+ (#{id-var-name\ 1319}#
+ #{value\ 1685}#
+ #{w\ 1687}#)))
+ (let ((#{type\ 1720}#
+ (#{binding-type\ 1289}#
+ (#{lookup\ 1294}#
+ #{n\ 1719}#
+ #{r\ 1672}#
+ #{mod\ 1689}#))))
+ (if (memv #{type\ 1720}#
'(global core macro module-ref))
(begin
(if (if (not (module-local-variable
(current-module)
- n537))
+ #{n\ 1719}#))
(current-module)
#f)
- (module-define!
- (current-module)
- n537
- #f))
- (let ((x539 (build-global-definition90
- s506
- n537
- (chi151
- e504
- r490
- w505
- mod507))))
+ (let ((#{old\ 1721}#
+ (module-variable
+ (current-module)
+ #{n\ 1719}#)))
+ (module-define!
+ (current-module)
+ #{n\ 1719}#
+ (if (variable? #{old\ 1721}#)
+ (variable-ref #{old\ 1721}#)
+ #f))))
+ (let ((#{x\ 1722}#
+ (#{build-global-definition\ 1272}#
+ #{s\ 1688}#
+ #{n\ 1719}#
+ (#{chi\ 1333}#
+ #{e\ 1686}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))))
(begin
- (if (eq? m492 (quote c&e))
- (top-level-eval-hook76 x539 mod507))
- x539)))
- (if (memv type538
+ (if (eq? #{m\ 1674}# (quote c&e))
+ (#{top-level-eval-hook\ 1258}#
+ #{x\ 1722}#
+ #{mod\ 1689}#))
+ #{x\ 1722}#)))
+ (if (memv #{type\ 1720}#
'(displaced-lexical))
(syntax-violation
#f
"identifier out of context"
- e504
- (wrap143 value503 w505 mod507))
+ #{e\ 1686}#
+ (#{wrap\ 1325}#
+ #{value\ 1685}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))
(syntax-violation
#f
"cannot define keyword at top level"
- e504
- (wrap143 value503 w505 mod507))))))
- (let ((x540 (chi-expr152
- type502
- value503
- e504
- r490
- w505
- s506
- mod507)))
+ #{e\ 1686}#
+ (#{wrap\ 1325}#
+ #{value\ 1685}#
+ #{w\ 1687}#
+ #{mod\ 1689}#))))))
+ (let ((#{x\ 1723}#
+ (#{chi-expr\ 1334}#
+ #{type\ 1684}#
+ #{value\ 1685}#
+ #{e\ 1686}#
+ #{r\ 1672}#
+ #{w\ 1687}#
+ #{s\ 1688}#
+ #{mod\ 1689}#)))
(begin
- (if (eq? m492 (quote c&e))
- (top-level-eval-hook76 x540 mod507))
- x540)))))))))))
- (syntax-type149
- (lambda (e541 r542 w543 s544 rib545 mod546 for-car?547)
- (if (symbol? e541)
- (let ((n548 (id-var-name137 e541 w543)))
- (let ((b549 (lookup112 n548 r542 mod546)))
- (let ((type550 (binding-type107 b549)))
- (if (memv type550 (quote (lexical)))
+ (if (eq? #{m\ 1674}# (quote c&e))
+ (#{top-level-eval-hook\ 1258}#
+ #{x\ 1723}#
+ #{mod\ 1689}#))
+ #{x\ 1723}#)))))))))))
+ (#{syntax-type\ 1331}#
+ (lambda (#{e\ 1724}#
+ #{r\ 1725}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ #{mod\ 1729}#
+ #{for-car?\ 1730}#)
+ (if (symbol? #{e\ 1724}#)
+ (let ((#{n\ 1731}#
+ (#{id-var-name\ 1319}# #{e\ 1724}# #{w\ 1726}#)))
+ (let ((#{b\ 1732}#
+ (#{lookup\ 1294}#
+ #{n\ 1731}#
+ #{r\ 1725}#
+ #{mod\ 1729}#)))
+ (let ((#{type\ 1733}#
+ (#{binding-type\ 1289}# #{b\ 1732}#)))
+ (if (memv #{type\ 1733}# (quote (lexical)))
(values
- type550
- (binding-value108 b549)
- e541
- w543
- s544
- mod546)
- (if (memv type550 (quote (global)))
- (values type550 n548 e541 w543 s544 mod546)
- (if (memv type550 (quote (macro)))
- (if for-car?547
+ #{type\ 1733}#
+ (#{binding-value\ 1290}# #{b\ 1732}#)
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{type\ 1733}# (quote (global)))
+ (values
+ #{type\ 1733}#
+ #{n\ 1731}#
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{type\ 1733}# (quote (macro)))
+ (if #{for-car?\ 1730}#
(values
- type550
- (binding-value108 b549)
- e541
- w543
- s544
- mod546)
- (syntax-type149
- (chi-macro154
- (binding-value108 b549)
- e541
- r542
- w543
- rib545
- mod546)
- r542
+ #{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}#
'(())
- s544
- rib545
- mod546
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ #{mod\ 1729}#
#f))
(values
- type550
- (binding-value108 b549)
- e541
- w543
- s544
- mod546)))))))
- (if (pair? e541)
- (let ((first551 (car e541)))
+ #{type\ 1733}#
+ (#{binding-value\ 1290}# #{b\ 1732}#)
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)))))))
+ (if (pair? #{e\ 1724}#)
+ (let ((#{first\ 1734}# (car #{e\ 1724}#)))
(call-with-values
(lambda ()
- (syntax-type149
- first551
- r542
- w543
- s544
- rib545
- mod546
+ (#{syntax-type\ 1331}#
+ #{first\ 1734}#
+ #{r\ 1725}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ #{mod\ 1729}#
#t))
- (lambda (ftype552 fval553 fe554 fw555 fs556 fmod557)
- (if (memv ftype552 (quote (lexical)))
+ (lambda (#{ftype\ 1735}#
+ #{fval\ 1736}#
+ #{fe\ 1737}#
+ #{fw\ 1738}#
+ #{fs\ 1739}#
+ #{fmod\ 1740}#)
+ (if (memv #{ftype\ 1735}# (quote (lexical)))
(values
'lexical-call
- fval553
- e541
- w543
- s544
- mod546)
- (if (memv ftype552 (quote (global)))
+ #{fval\ 1736}#
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}# (quote (global)))
(values
'global-call
- (make-syntax-object98 fval553 w543 fmod557)
- e541
- w543
- s544
- mod546)
- (if (memv ftype552 (quote (macro)))
- (syntax-type149
- (chi-macro154
- fval553
- e541
- r542
- w543
- rib545
- mod546)
- r542
+ (#{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}#
'(())
- s544
- rib545
- mod546
- for-car?547)
- (if (memv ftype552 (quote (module-ref)))
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ #{mod\ 1729}#
+ #{for-car?\ 1730}#)
+ (if (memv #{ftype\ 1735}# (quote (module-ref)))
(call-with-values
- (lambda () (fval553 e541))
- (lambda (sym558 mod559)
- (syntax-type149
- sym558
- r542
- w543
- s544
- rib545
- mod559
- for-car?547)))
- (if (memv ftype552 (quote (core)))
+ (lambda () (#{fval\ 1736}# #{e\ 1724}#))
+ (lambda (#{sym\ 1741}# #{mod\ 1742}#)
+ (#{syntax-type\ 1331}#
+ #{sym\ 1741}#
+ #{r\ 1725}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ #{mod\ 1742}#
+ #{for-car?\ 1730}#)))
+ (if (memv #{ftype\ 1735}# (quote (core)))
(values
'core-form
- fval553
- e541
- w543
- s544
- mod546)
- (if (memv ftype552 (quote (local-syntax)))
+ #{fval\ 1736}#
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}#
+ '(local-syntax))
(values
'local-syntax-form
- fval553
- e541
- w543
- s544
- mod546)
- (if (memv ftype552 (quote (begin)))
+ #{fval\ 1736}#
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}# (quote (begin)))
(values
'begin-form
#f
- e541
- w543
- s544
- mod546)
- (if (memv ftype552 (quote (eval-when)))
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}#
+ '(eval-when))
(values
'eval-when-form
#f
- e541
- w543
- s544
- mod546)
- (if (memv ftype552 (quote (define)))
- ((lambda (tmp560)
- ((lambda (tmp561)
- (if (if tmp561
- (apply (lambda (_562
- name563
- val564)
- (id?115
- name563))
- tmp561)
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (if (memv #{ftype\ 1735}#
+ '(define))
+ ((lambda (#{tmp\ 1743}#)
+ ((lambda (#{tmp\ 1744}#)
+ (if (if #{tmp\ 1744}#
+ (apply (lambda (#{_\ 1745}#
+ #{name\ 1746}#
+ #{val\ 1747}#)
+ (#{id?\ 1297}#
+ #{name\ 1746}#))
+ #{tmp\ 1744}#)
#f)
- (apply (lambda (_565
- name566
- val567)
+ (apply (lambda (#{_\ 1748}#
+ #{name\ 1749}#
+ #{val\ 1750}#)
(values
'define-form
- name566
- val567
- w543
- s544
- mod546))
- tmp561)
- ((lambda (tmp568)
- (if (if tmp568
- (apply (lambda (_569
- name570
- args571
- e1572
- e2573)
- (if (id?115
- name570)
- (valid-bound-ids?140
- (lambda-var-list163
- args571))
+ #{name\ 1749}#
+ #{val\ 1750}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#))
+ #{tmp\ 1744}#)
+ ((lambda (#{tmp\ 1751}#)
+ (if (if #{tmp\ 1751}#
+ (apply (lambda (#{_\ 1752}#
+ #{name\ 1753}#
+ #{args\ 1754}#
+ #{e1\ 1755}#
+ #{e2\ 1756}#)
+ (if (#{id?\ 1297}#
+ #{name\ 1753}#)
+ (#{valid-bound-ids?\ 1322}#
+ (#{lambda-var-list\ 1345}#
+ #{args\ 1754}#))
#f))
- tmp568)
+ #{tmp\ 1751}#)
#f)
- (apply (lambda (_574
- name575
- args576
- e1577
- e2578)
+ (apply (lambda (#{_\ 1757}#
+ #{name\ 1758}#
+ #{args\ 1759}#
+ #{e1\ 1760}#
+ #{e2\ 1761}#)
(values
'define-form
- (wrap143
- name575
- w543
- mod546)
- (decorate-source80
+ (#{wrap\ 1325}#
+ #{name\ 1758}#
+ #{w\ 1726}#
+ #{mod\ 1729}#)
+ (#{decorate-source\ 1262}#
(cons '#(syntax-object
lambda
((top)
@@ -1992,33 +2295,33 @@
"i")))
(hygiene
guile))
- (wrap143
- (cons args576
- (cons e1577
- e2578))
- w543
- mod546))
- s544)
+ (#{wrap\ 1325}#
+ (cons #{args\ 1759}#
+ (cons #{e1\ 1760}#
+ #{e2\ 1761}#))
+ #{w\ 1726}#
+ #{mod\ 1729}#))
+ #{s\ 1727}#)
'(())
- s544
- mod546))
- tmp568)
- ((lambda (tmp580)
- (if (if tmp580
- (apply (lambda (_581
- name582)
- (id?115
- name582))
- tmp580)
+ #{s\ 1727}#
+ #{mod\ 1729}#))
+ #{tmp\ 1751}#)
+ ((lambda (#{tmp\ 1763}#)
+ (if (if #{tmp\ 1763}#
+ (apply (lambda (#{_\ 1764}#
+ #{name\ 1765}#)
+ (#{id?\ 1297}#
+ #{name\ 1765}#))
+ #{tmp\ 1763}#)
#f)
- (apply (lambda (_583
- name584)
+ (apply (lambda (#{_\ 1766}#
+ #{name\ 1767}#)
(values
'define-form
- (wrap143
- name584
- w543
- mod546)
+ (#{wrap\ 1325}#
+ #{name\ 1767}#
+ #{w\ 1726}#
+ #{mod\ 1729}#)
'(#(syntax-object
if
((top)
@@ -3295,2820 +3598,3179 @@
(hygiene
guile)))
'(())
- s544
- mod546))
- tmp580)
+ #{s\ 1727}#
+ #{mod\ 1729}#))
+ #{tmp\ 1763}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp560)))
+ #{tmp\ 1743}#)))
($sc-dispatch
- tmp560
+ #{tmp\ 1743}#
'(any any)))))
($sc-dispatch
- tmp560
+ #{tmp\ 1743}#
'(any (any . any)
any
.
each-any)))))
($sc-dispatch
- tmp560
+ #{tmp\ 1743}#
'(any any any))))
- e541)
- (if (memv ftype552
+ #{e\ 1724}#)
+ (if (memv #{ftype\ 1735}#
'(define-syntax))
- ((lambda (tmp585)
- ((lambda (tmp586)
- (if (if tmp586
- (apply (lambda (_587
- name588
- val589)
- (id?115
- name588))
- tmp586)
+ ((lambda (#{tmp\ 1768}#)
+ ((lambda (#{tmp\ 1769}#)
+ (if (if #{tmp\ 1769}#
+ (apply (lambda (#{_\ 1770}#
+ #{name\ 1771}#
+ #{val\ 1772}#)
+ (#{id?\ 1297}#
+ #{name\ 1771}#))
+ #{tmp\ 1769}#)
#f)
- (apply (lambda (_590
- name591
- val592)
+ (apply (lambda (#{_\ 1773}#
+ #{name\ 1774}#
+ #{val\ 1775}#)
(values
'define-syntax-form
- name591
- val592
- w543
- s544
- mod546))
- tmp586)
+ #{name\ 1774}#
+ #{val\ 1775}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#))
+ #{tmp\ 1769}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp585)))
+ #{tmp\ 1768}#)))
($sc-dispatch
- tmp585
+ #{tmp\ 1768}#
'(any any any))))
- e541)
+ #{e\ 1724}#)
(values
'call
#f
- e541
- w543
- s544
- mod546))))))))))))))
- (if (syntax-object?99 e541)
- (syntax-type149
- (syntax-object-expression100 e541)
- r542
- (join-wraps134 w543 (syntax-object-wrap101 e541))
- s544
- rib545
- (let ((t593 (syntax-object-module102 e541)))
- (if t593 t593 mod546))
- for-car?547)
- (if (self-evaluating? e541)
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#))))))))))))))
+ (if (#{syntax-object?\ 1281}# #{e\ 1724}#)
+ (#{syntax-type\ 1331}#
+ (#{syntax-object-expression\ 1282}# #{e\ 1724}#)
+ #{r\ 1725}#
+ (#{join-wraps\ 1316}#
+ #{w\ 1726}#
+ (#{syntax-object-wrap\ 1283}# #{e\ 1724}#))
+ #{s\ 1727}#
+ #{rib\ 1728}#
+ (let ((#{t\ 1776}#
+ (#{syntax-object-module\ 1284}# #{e\ 1724}#)))
+ (if #{t\ 1776}# #{t\ 1776}# #{mod\ 1729}#))
+ #{for-car?\ 1730}#)
+ (if (self-evaluating? #{e\ 1724}#)
(values
'constant
#f
- e541
- w543
- s544
- mod546)
- (values (quote other) #f e541 w543 s544 mod546)))))))
- (chi-when-list148
- (lambda (e594 when-list595 w596)
- (letrec ((f597 (lambda (when-list598 situations599)
- (if (null? when-list598)
- situations599
- (f597 (cdr when-list598)
- (cons (let ((x600 (car when-list598)))
- (if (free-id=?138
- x600
- '#(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=?138
- x600
- '#(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=?138
- x600
- '#(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"
- e594
- (wrap143
- x600
- w596
- #f))))))
- situations599))))))
- (f597 when-list595 (quote ())))))
- (chi-install-global147
- (lambda (name601 e602)
- (build-global-definition90
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)
+ (values
+ 'other
+ #f
+ #{e\ 1724}#
+ #{w\ 1726}#
+ #{s\ 1727}#
+ #{mod\ 1729}#)))))))
+ (#{chi-when-list\ 1330}#
+ (lambda (#{e\ 1777}# #{when-list\ 1778}# #{w\ 1779}#)
+ (letrec ((#{f\ 1780}#
+ (lambda (#{when-list\ 1781}# #{situations\ 1782}#)
+ (if (null? #{when-list\ 1781}#)
+ #{situations\ 1782}#
+ (#{f\ 1780}#
+ (cdr #{when-list\ 1781}#)
+ (cons (let ((#{x\ 1783}#
+ (car #{when-list\ 1781}#)))
+ (if (#{free-id=?\ 1320}#
+ #{x\ 1783}#
+ '#(syntax-object
+ compile
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(f when-list situations)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e when-list w)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-lambda-clause
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure and-map*)
+ ((top) (top))
+ ("i" "i")))
+ (hygiene guile)))
+ 'compile
+ (if (#{free-id=?\ 1320}#
+ #{x\ 1783}#
+ '#(syntax-object
+ load
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(f when-list situations)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e when-list w)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-lambda-clause
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top) (top))
+ ("i" "i")))
+ (hygiene guile)))
+ 'load
+ (if (#{free-id=?\ 1320}#
+ #{x\ 1783}#
+ '#(syntax-object
+ eval
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(f
+ when-list
+ situations)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e when-list w)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ ellipsis?
+ chi-void
+ eval-local-transformer
+ chi-local-syntax
+ chi-lambda-clause
+ chi-body
+ chi-macro
+ chi-application
+ chi-expr
+ chi
+ chi-top
+ syntax-type
+ chi-when-list
+ chi-install-global
+ chi-top-sequence
+ chi-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ lookup
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-lambda
+ build-global-definition
+ maybe-name-value!
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-conditional
+ build-application
+ build-void
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ *mode*
+ noexpand)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ (define-structure
+ and-map*)
+ ((top) (top))
+ ("i" "i")))
+ (hygiene guile)))
+ 'eval
+ (syntax-violation
+ 'eval-when
+ "invalid situation"
+ #{e\ 1777}#
+ (#{wrap\ 1325}#
+ #{x\ 1783}#
+ #{w\ 1779}#
+ #f))))))
+ #{situations\ 1782}#))))))
+ (#{f\ 1780}# #{when-list\ 1778}# (quote ())))))
+ (#{chi-install-global\ 1329}#
+ (lambda (#{name\ 1784}# #{e\ 1785}#)
+ (#{build-global-definition\ 1272}#
#f
- name601
- (if (let ((v603 (module-variable (current-module) name601)))
- (if v603
- (if (variable-bound? v603)
- (if (macro? (variable-ref v603))
- (not (eq? (macro-type (variable-ref v603))
+ #{name\ 1784}#
+ (if (let ((#{v\ 1786}#
+ (module-variable
+ (current-module)
+ #{name\ 1784}#)))
+ (if #{v\ 1786}#
+ (if (variable-bound? #{v\ 1786}#)
+ (if (macro? (variable-ref #{v\ 1786}#))
+ (not (eq? (macro-type (variable-ref #{v\ 1786}#))
'syncase-macro))
#f)
#f)
#f))
- (build-application82
+ (#{build-application\ 1264}#
#f
- (build-primref92
+ (#{build-primref\ 1274}#
#f
'make-extended-syncase-macro)
- (list (build-application82
+ (list (#{build-application\ 1264}#
#f
- (build-primref92 #f (quote module-ref))
- (list (build-application82
+ (#{build-primref\ 1274}# #f (quote module-ref))
+ (list (#{build-application\ 1264}#
#f
- (build-primref92
+ (#{build-primref\ 1274}#
#f
'current-module)
'())
- (build-data93 #f name601)))
- (build-data93 #f (quote macro))
- e602))
- (build-application82
+ (#{build-data\ 1275}# #f #{name\ 1784}#)))
+ (#{build-data\ 1275}# #f (quote macro))
+ #{e\ 1785}#))
+ (#{build-application\ 1264}#
#f
- (build-primref92 #f (quote make-syncase-macro))
- (list (build-data93 #f (quote macro)) e602))))))
- (chi-top-sequence146
- (lambda (body604 r605 w606 s607 m608 esew609 mod610)
- (build-sequence94
- s607
- (letrec ((dobody611
- (lambda (body612 r613 w614 m615 esew616 mod617)
- (if (null? body612)
+ (#{build-primref\ 1274}#
+ #f
+ 'make-syncase-macro)
+ (list (#{build-data\ 1275}# #f (quote macro))
+ #{e\ 1785}#))))))
+ (#{chi-top-sequence\ 1328}#
+ (lambda (#{body\ 1787}#
+ #{r\ 1788}#
+ #{w\ 1789}#
+ #{s\ 1790}#
+ #{m\ 1791}#
+ #{esew\ 1792}#
+ #{mod\ 1793}#)
+ (#{build-sequence\ 1276}#
+ #{s\ 1790}#
+ (letrec ((#{dobody\ 1794}#
+ (lambda (#{body\ 1795}#
+ #{r\ 1796}#
+ #{w\ 1797}#
+ #{m\ 1798}#
+ #{esew\ 1799}#
+ #{mod\ 1800}#)
+ (if (null? #{body\ 1795}#)
'()
- (let ((first618
- (chi-top150
- (car body612)
- r613
- w614
- m615
- esew616
- mod617)))
- (cons first618
- (dobody611
- (cdr body612)
- r613
- w614
- m615
- esew616
- mod617)))))))
- (dobody611 body604 r605 w606 m608 esew609 mod610)))))
- (chi-sequence145
- (lambda (body619 r620 w621 s622 mod623)
- (build-sequence94
- s622
- (letrec ((dobody624
- (lambda (body625 r626 w627 mod628)
- (if (null? body625)
+ (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 ((first629
- (chi151
- (car body625)
- r626
- w627
- mod628)))
- (cons first629
- (dobody624
- (cdr body625)
- r626
- w627
- mod628)))))))
- (dobody624 body619 r620 w621 mod623)))))
- (source-wrap144
- (lambda (x630 w631 s632 defmod633)
- (wrap143
- (decorate-source80 x630 s632)
- w631
- defmod633)))
- (wrap143
- (lambda (x634 w635 defmod636)
- (if (if (null? (wrap-marks118 w635))
- (null? (wrap-subst119 w635))
+ (let ((#{first\ 1812}#
+ (#{chi\ 1333}#
+ (car #{body\ 1808}#)
+ #{r\ 1809}#
+ #{w\ 1810}#
+ #{mod\ 1811}#)))
+ (cons #{first\ 1812}#
+ (#{dobody\ 1807}#
+ (cdr #{body\ 1808}#)
+ #{r\ 1809}#
+ #{w\ 1810}#
+ #{mod\ 1811}#)))))))
+ (#{dobody\ 1807}#
+ #{body\ 1802}#
+ #{r\ 1803}#
+ #{w\ 1804}#
+ #{mod\ 1806}#)))))
+ (#{source-wrap\ 1326}#
+ (lambda (#{x\ 1813}#
+ #{w\ 1814}#
+ #{s\ 1815}#
+ #{defmod\ 1816}#)
+ (#{wrap\ 1325}#
+ (#{decorate-source\ 1262}#
+ #{x\ 1813}#
+ #{s\ 1815}#)
+ #{w\ 1814}#
+ #{defmod\ 1816}#)))
+ (#{wrap\ 1325}#
+ (lambda (#{x\ 1817}# #{w\ 1818}# #{defmod\ 1819}#)
+ (if (if (null? (#{wrap-marks\ 1300}# #{w\ 1818}#))
+ (null? (#{wrap-subst\ 1301}# #{w\ 1818}#))
#f)
- x634
- (if (syntax-object?99 x634)
- (make-syntax-object98
- (syntax-object-expression100 x634)
- (join-wraps134 w635 (syntax-object-wrap101 x634))
- (syntax-object-module102 x634))
- (if (null? x634)
- x634
- (make-syntax-object98 x634 w635 defmod636))))))
- (bound-id-member?142
- (lambda (x637 list638)
- (if (not (null? list638))
- (let ((t639 (bound-id=?139 x637 (car list638))))
- (if t639
- t639
- (bound-id-member?142 x637 (cdr list638))))
+ #{x\ 1817}#
+ (if (#{syntax-object?\ 1281}# #{x\ 1817}#)
+ (#{make-syntax-object\ 1280}#
+ (#{syntax-object-expression\ 1282}# #{x\ 1817}#)
+ (#{join-wraps\ 1316}#
+ #{w\ 1818}#
+ (#{syntax-object-wrap\ 1283}# #{x\ 1817}#))
+ (#{syntax-object-module\ 1284}# #{x\ 1817}#))
+ (if (null? #{x\ 1817}#)
+ #{x\ 1817}#
+ (#{make-syntax-object\ 1280}#
+ #{x\ 1817}#
+ #{w\ 1818}#
+ #{defmod\ 1819}#))))))
+ (#{bound-id-member?\ 1324}#
+ (lambda (#{x\ 1820}# #{list\ 1821}#)
+ (if (not (null? #{list\ 1821}#))
+ (let ((#{t\ 1822}#
+ (#{bound-id=?\ 1321}#
+ #{x\ 1820}#
+ (car #{list\ 1821}#))))
+ (if #{t\ 1822}#
+ #{t\ 1822}#
+ (#{bound-id-member?\ 1324}#
+ #{x\ 1820}#
+ (cdr #{list\ 1821}#))))
#f)))
- (distinct-bound-ids?141
- (lambda (ids640)
- (letrec ((distinct?641
- (lambda (ids642)
- (let ((t643 (null? ids642)))
- (if t643
- t643
- (if (not (bound-id-member?142
- (car ids642)
- (cdr ids642)))
- (distinct?641 (cdr ids642))
+ (#{distinct-bound-ids?\ 1323}#
+ (lambda (#{ids\ 1823}#)
+ (letrec ((#{distinct?\ 1824}#
+ (lambda (#{ids\ 1825}#)
+ (let ((#{t\ 1826}# (null? #{ids\ 1825}#)))
+ (if #{t\ 1826}#
+ #{t\ 1826}#
+ (if (not (#{bound-id-member?\ 1324}#
+ (car #{ids\ 1825}#)
+ (cdr #{ids\ 1825}#)))
+ (#{distinct?\ 1824}# (cdr #{ids\ 1825}#))
#f))))))
- (distinct?641 ids640))))
- (valid-bound-ids?140
- (lambda (ids644)
- (if (letrec ((all-ids?645
- (lambda (ids646)
- (let ((t647 (null? ids646)))
- (if t647
- t647
- (if (id?115 (car ids646))
- (all-ids?645 (cdr ids646))
+ (#{distinct?\ 1824}# #{ids\ 1823}#))))
+ (#{valid-bound-ids?\ 1322}#
+ (lambda (#{ids\ 1827}#)
+ (if (letrec ((#{all-ids?\ 1828}#
+ (lambda (#{ids\ 1829}#)
+ (let ((#{t\ 1830}# (null? #{ids\ 1829}#)))
+ (if #{t\ 1830}#
+ #{t\ 1830}#
+ (if (#{id?\ 1297}# (car #{ids\ 1829}#))
+ (#{all-ids?\ 1828}# (cdr #{ids\ 1829}#))
#f))))))
- (all-ids?645 ids644))
- (distinct-bound-ids?141 ids644)
+ (#{all-ids?\ 1828}# #{ids\ 1827}#))
+ (#{distinct-bound-ids?\ 1323}# #{ids\ 1827}#)
#f)))
- (bound-id=?139
- (lambda (i648 j649)
- (if (if (syntax-object?99 i648)
- (syntax-object?99 j649)
+ (#{bound-id=?\ 1321}#
+ (lambda (#{i\ 1831}# #{j\ 1832}#)
+ (if (if (#{syntax-object?\ 1281}# #{i\ 1831}#)
+ (#{syntax-object?\ 1281}# #{j\ 1832}#)
#f)
- (if (eq? (syntax-object-expression100 i648)
- (syntax-object-expression100 j649))
- (same-marks?136
- (wrap-marks118 (syntax-object-wrap101 i648))
- (wrap-marks118 (syntax-object-wrap101 j649)))
+ (if (eq? (#{syntax-object-expression\ 1282}# #{i\ 1831}#)
+ (#{syntax-object-expression\ 1282}# #{j\ 1832}#))
+ (#{same-marks?\ 1318}#
+ (#{wrap-marks\ 1300}#
+ (#{syntax-object-wrap\ 1283}# #{i\ 1831}#))
+ (#{wrap-marks\ 1300}#
+ (#{syntax-object-wrap\ 1283}# #{j\ 1832}#)))
#f)
- (eq? i648 j649))))
- (free-id=?138
- (lambda (i650 j651)
- (if (eq? (let ((x652 i650))
- (if (syntax-object?99 x652)
- (syntax-object-expression100 x652)
- x652))
- (let ((x653 j651))
- (if (syntax-object?99 x653)
- (syntax-object-expression100 x653)
- x653)))
- (eq? (id-var-name137 i650 (quote (())))
- (id-var-name137 j651 (quote (()))))
+ (eq? #{i\ 1831}# #{j\ 1832}#))))
+ (#{free-id=?\ 1320}#
+ (lambda (#{i\ 1833}# #{j\ 1834}#)
+ (if (eq? (let ((#{x\ 1835}# #{i\ 1833}#))
+ (if (#{syntax-object?\ 1281}# #{x\ 1835}#)
+ (#{syntax-object-expression\ 1282}# #{x\ 1835}#)
+ #{x\ 1835}#))
+ (let ((#{x\ 1836}# #{j\ 1834}#))
+ (if (#{syntax-object?\ 1281}# #{x\ 1836}#)
+ (#{syntax-object-expression\ 1282}# #{x\ 1836}#)
+ #{x\ 1836}#)))
+ (eq? (#{id-var-name\ 1319}# #{i\ 1833}# (quote (())))
+ (#{id-var-name\ 1319}# #{j\ 1834}# (quote (()))))
#f)))
- (id-var-name137
- (lambda (id654 w655)
- (letrec ((search-vector-rib658
- (lambda (sym664
- subst665
- marks666
- symnames667
- ribcage668)
- (let ((n669 (vector-length symnames667)))
- (letrec ((f670 (lambda (i671)
- (if (fx=74 i671 n669)
- (search656
- sym664
- (cdr subst665)
- marks666)
- (if (if (eq? (vector-ref
- symnames667
- i671)
- sym664)
- (same-marks?136
- marks666
- (vector-ref
- (ribcage-marks125
- ribcage668)
- i671))
- #f)
- (values
+ (#{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-labels126
- ribcage668)
- i671)
- marks666)
- (f670 (fx+72 i671 1)))))))
- (f670 0)))))
- (search-list-rib657
- (lambda (sym672
- subst673
- marks674
- symnames675
- ribcage676)
- (letrec ((f677 (lambda (symnames678 i679)
- (if (null? symnames678)
- (search656
- sym672
- (cdr subst673)
- marks674)
- (if (if (eq? (car symnames678)
- sym672)
- (same-marks?136
- marks674
- (list-ref
- (ribcage-marks125
- ribcage676)
- i679))
- #f)
- (values
+ (#{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-labels126
- ribcage676)
- i679)
- marks674)
- (f677 (cdr symnames678)
- (fx+72 i679 1)))))))
- (f677 symnames675 0))))
- (search656
- (lambda (sym680 subst681 marks682)
- (if (null? subst681)
- (values #f marks682)
- (let ((fst683 (car subst681)))
- (if (eq? fst683 (quote shift))
- (search656
- sym680
- (cdr subst681)
- (cdr marks682))
- (let ((symnames684
- (ribcage-symnames124 fst683)))
- (if (vector? symnames684)
- (search-vector-rib658
- sym680
- subst681
- marks682
- symnames684
- fst683)
- (search-list-rib657
- sym680
- subst681
- marks682
- symnames684
- fst683)))))))))
- (if (symbol? id654)
- (let ((t685 (call-with-values
- (lambda ()
- (search656
- id654
- (wrap-subst119 w655)
- (wrap-marks118 w655)))
- (lambda (x687 . ignore686) x687))))
- (if t685 t685 id654))
- (if (syntax-object?99 id654)
- (let ((id688 (syntax-object-expression100 id654))
- (w1689 (syntax-object-wrap101 id654)))
- (let ((marks690
- (join-marks135
- (wrap-marks118 w655)
- (wrap-marks118 w1689))))
+ (#{ribcage-marks\ 1307}#
+ #{ribcage\ 1859}#)
+ #{i\ 1862}#))
+ #f)
+ (values
+ (list-ref
+ (#{ribcage-labels\ 1308}#
+ #{ribcage\ 1859}#)
+ #{i\ 1862}#)
+ #{marks\ 1857}#)
+ (#{f\ 1860}#
+ (cdr #{symnames\ 1861}#)
+ (#{fx+\ 1254}#
+ #{i\ 1862}#
+ 1)))))))
+ (#{f\ 1860}# #{symnames\ 1858}# 0))))
+ (#{search\ 1839}#
+ (lambda (#{sym\ 1863}#
+ #{subst\ 1864}#
+ #{marks\ 1865}#)
+ (if (null? #{subst\ 1864}#)
+ (values #f #{marks\ 1865}#)
+ (let ((#{fst\ 1866}# (car #{subst\ 1864}#)))
+ (if (eq? #{fst\ 1866}# (quote shift))
+ (#{search\ 1839}#
+ #{sym\ 1863}#
+ (cdr #{subst\ 1864}#)
+ (cdr #{marks\ 1865}#))
+ (let ((#{symnames\ 1867}#
+ (#{ribcage-symnames\ 1306}#
+ #{fst\ 1866}#)))
+ (if (vector? #{symnames\ 1867}#)
+ (#{search-vector-rib\ 1841}#
+ #{sym\ 1863}#
+ #{subst\ 1864}#
+ #{marks\ 1865}#
+ #{symnames\ 1867}#
+ #{fst\ 1866}#)
+ (#{search-list-rib\ 1840}#
+ #{sym\ 1863}#
+ #{subst\ 1864}#
+ #{marks\ 1865}#
+ #{symnames\ 1867}#
+ #{fst\ 1866}#)))))))))
+ (if (symbol? #{id\ 1837}#)
+ (let ((#{t\ 1868}#
+ (call-with-values
+ (lambda ()
+ (#{search\ 1839}#
+ #{id\ 1837}#
+ (#{wrap-subst\ 1301}# #{w\ 1838}#)
+ (#{wrap-marks\ 1300}# #{w\ 1838}#)))
+ (lambda (#{x\ 1870}# . #{ignore\ 1869}#)
+ #{x\ 1870}#))))
+ (if #{t\ 1868}# #{t\ 1868}# #{id\ 1837}#))
+ (if (#{syntax-object?\ 1281}# #{id\ 1837}#)
+ (let ((#{id\ 1871}#
+ (#{syntax-object-expression\ 1282}# #{id\ 1837}#))
+ (#{w1\ 1872}#
+ (#{syntax-object-wrap\ 1283}# #{id\ 1837}#)))
+ (let ((#{marks\ 1873}#
+ (#{join-marks\ 1317}#
+ (#{wrap-marks\ 1300}# #{w\ 1838}#)
+ (#{wrap-marks\ 1300}# #{w1\ 1872}#))))
(call-with-values
(lambda ()
- (search656 id688 (wrap-subst119 w655) marks690))
- (lambda (new-id691 marks692)
- (let ((t693 new-id691))
- (if t693
- t693
- (let ((t694 (call-with-values
- (lambda ()
- (search656
- id688
- (wrap-subst119 w1689)
- marks692))
- (lambda (x696 . ignore695)
- x696))))
- (if t694 t694 id688))))))))
+ (#{search\ 1839}#
+ #{id\ 1871}#
+ (#{wrap-subst\ 1301}# #{w\ 1838}#)
+ #{marks\ 1873}#))
+ (lambda (#{new-id\ 1874}# #{marks\ 1875}#)
+ (let ((#{t\ 1876}# #{new-id\ 1874}#))
+ (if #{t\ 1876}#
+ #{t\ 1876}#
+ (let ((#{t\ 1877}#
+ (call-with-values
+ (lambda ()
+ (#{search\ 1839}#
+ #{id\ 1871}#
+ (#{wrap-subst\ 1301}#
+ #{w1\ 1872}#)
+ #{marks\ 1875}#))
+ (lambda (#{x\ 1879}#
+ .
+ #{ignore\ 1878}#)
+ #{x\ 1879}#))))
+ (if #{t\ 1877}#
+ #{t\ 1877}#
+ #{id\ 1871}#))))))))
(syntax-violation
'id-var-name
"invalid id"
- id654))))))
- (same-marks?136
- (lambda (x697 y698)
- (let ((t699 (eq? x697 y698)))
- (if t699
- t699
- (if (not (null? x697))
- (if (not (null? y698))
- (if (eq? (car x697) (car y698))
- (same-marks?136 (cdr x697) (cdr y698))
+ #{id\ 1837}#))))))
+ (#{same-marks?\ 1318}#
+ (lambda (#{x\ 1880}# #{y\ 1881}#)
+ (let ((#{t\ 1882}# (eq? #{x\ 1880}# #{y\ 1881}#)))
+ (if #{t\ 1882}#
+ #{t\ 1882}#
+ (if (not (null? #{x\ 1880}#))
+ (if (not (null? #{y\ 1881}#))
+ (if (eq? (car #{x\ 1880}#) (car #{y\ 1881}#))
+ (#{same-marks?\ 1318}#
+ (cdr #{x\ 1880}#)
+ (cdr #{y\ 1881}#))
#f)
#f)
#f)))))
- (join-marks135
- (lambda (m1700 m2701)
- (smart-append133 m1700 m2701)))
- (join-wraps134
- (lambda (w1702 w2703)
- (let ((m1704 (wrap-marks118 w1702))
- (s1705 (wrap-subst119 w1702)))
- (if (null? m1704)
- (if (null? s1705)
- w2703
- (make-wrap117
- (wrap-marks118 w2703)
- (smart-append133 s1705 (wrap-subst119 w2703))))
- (make-wrap117
- (smart-append133 m1704 (wrap-marks118 w2703))
- (smart-append133 s1705 (wrap-subst119 w2703)))))))
- (smart-append133
- (lambda (m1706 m2707)
- (if (null? m2707) m1706 (append m1706 m2707))))
- (make-binding-wrap132
- (lambda (ids708 labels709 w710)
- (if (null? ids708)
- w710
- (make-wrap117
- (wrap-marks118 w710)
- (cons (let ((labelvec711 (list->vector labels709)))
- (let ((n712 (vector-length labelvec711)))
- (let ((symnamevec713 (make-vector n712))
- (marksvec714 (make-vector n712)))
+ (#{join-marks\ 1317}#
+ (lambda (#{m1\ 1883}# #{m2\ 1884}#)
+ (#{smart-append\ 1315}#
+ #{m1\ 1883}#
+ #{m2\ 1884}#)))
+ (#{join-wraps\ 1316}#
+ (lambda (#{w1\ 1885}# #{w2\ 1886}#)
+ (let ((#{m1\ 1887}#
+ (#{wrap-marks\ 1300}# #{w1\ 1885}#))
+ (#{s1\ 1888}#
+ (#{wrap-subst\ 1301}# #{w1\ 1885}#)))
+ (if (null? #{m1\ 1887}#)
+ (if (null? #{s1\ 1888}#)
+ #{w2\ 1886}#
+ (#{make-wrap\ 1299}#
+ (#{wrap-marks\ 1300}# #{w2\ 1886}#)
+ (#{smart-append\ 1315}#
+ #{s1\ 1888}#
+ (#{wrap-subst\ 1301}# #{w2\ 1886}#))))
+ (#{make-wrap\ 1299}#
+ (#{smart-append\ 1315}#
+ #{m1\ 1887}#
+ (#{wrap-marks\ 1300}# #{w2\ 1886}#))
+ (#{smart-append\ 1315}#
+ #{s1\ 1888}#
+ (#{wrap-subst\ 1301}# #{w2\ 1886}#)))))))
+ (#{smart-append\ 1315}#
+ (lambda (#{m1\ 1889}# #{m2\ 1890}#)
+ (if (null? #{m2\ 1890}#)
+ #{m1\ 1889}#
+ (append #{m1\ 1889}# #{m2\ 1890}#))))
+ (#{make-binding-wrap\ 1314}#
+ (lambda (#{ids\ 1891}# #{labels\ 1892}# #{w\ 1893}#)
+ (if (null? #{ids\ 1891}#)
+ #{w\ 1893}#
+ (#{make-wrap\ 1299}#
+ (#{wrap-marks\ 1300}# #{w\ 1893}#)
+ (cons (let ((#{labelvec\ 1894}#
+ (list->vector #{labels\ 1892}#)))
+ (let ((#{n\ 1895}#
+ (vector-length #{labelvec\ 1894}#)))
+ (let ((#{symnamevec\ 1896}#
+ (make-vector #{n\ 1895}#))
+ (#{marksvec\ 1897}#
+ (make-vector #{n\ 1895}#)))
(begin
- (letrec ((f715 (lambda (ids716 i717)
- (if (not (null? ids716))
- (call-with-values
- (lambda ()
- (id-sym-name&marks116
- (car ids716)
- w710))
- (lambda (symname718
- marks719)
- (begin
- (vector-set!
- symnamevec713
- i717
- symname718)
- (vector-set!
- marksvec714
- i717
- marks719)
- (f715 (cdr ids716)
- (fx+72 i717
- 1)))))))))
- (f715 ids708 0))
- (make-ribcage122
- symnamevec713
- marksvec714
- labelvec711)))))
- (wrap-subst119 w710))))))
- (extend-ribcage!131
- (lambda (ribcage720 id721 label722)
+ (letrec ((#{f\ 1898}#
+ (lambda (#{ids\ 1899}# #{i\ 1900}#)
+ (if (not (null? #{ids\ 1899}#))
+ (call-with-values
+ (lambda ()
+ (#{id-sym-name&marks\ 1298}#
+ (car #{ids\ 1899}#)
+ #{w\ 1893}#))
+ (lambda (#{symname\ 1901}#
+ #{marks\ 1902}#)
+ (begin
+ (vector-set!
+ #{symnamevec\ 1896}#
+ #{i\ 1900}#
+ #{symname\ 1901}#)
+ (vector-set!
+ #{marksvec\ 1897}#
+ #{i\ 1900}#
+ #{marks\ 1902}#)
+ (#{f\ 1898}#
+ (cdr #{ids\ 1899}#)
+ (#{fx+\ 1254}#
+ #{i\ 1900}#
+ 1)))))))))
+ (#{f\ 1898}# #{ids\ 1891}# 0))
+ (#{make-ribcage\ 1304}#
+ #{symnamevec\ 1896}#
+ #{marksvec\ 1897}#
+ #{labelvec\ 1894}#)))))
+ (#{wrap-subst\ 1301}# #{w\ 1893}#))))))
+ (#{extend-ribcage!\ 1313}#
+ (lambda (#{ribcage\ 1903}# #{id\ 1904}# #{label\ 1905}#)
(begin
- (set-ribcage-symnames!127
- ribcage720
- (cons (syntax-object-expression100 id721)
- (ribcage-symnames124 ribcage720)))
- (set-ribcage-marks!128
- ribcage720
- (cons (wrap-marks118 (syntax-object-wrap101 id721))
- (ribcage-marks125 ribcage720)))
- (set-ribcage-labels!129
- ribcage720
- (cons label722 (ribcage-labels126 ribcage720))))))
- (anti-mark130
- (lambda (w723)
- (make-wrap117
- (cons #f (wrap-marks118 w723))
- (cons (quote shift) (wrap-subst119 w723)))))
- (set-ribcage-labels!129
- (lambda (x724 update725)
- (vector-set! x724 3 update725)))
- (set-ribcage-marks!128
- (lambda (x726 update727)
- (vector-set! x726 2 update727)))
- (set-ribcage-symnames!127
- (lambda (x728 update729)
- (vector-set! x728 1 update729)))
- (ribcage-labels126
- (lambda (x730) (vector-ref x730 3)))
- (ribcage-marks125
- (lambda (x731) (vector-ref x731 2)))
- (ribcage-symnames124
- (lambda (x732) (vector-ref x732 1)))
- (ribcage?123
- (lambda (x733)
- (if (vector? x733)
- (if (= (vector-length x733) 4)
- (eq? (vector-ref x733 0) (quote ribcage))
+ (#{set-ribcage-symnames!\ 1309}#
+ #{ribcage\ 1903}#
+ (cons (#{syntax-object-expression\ 1282}# #{id\ 1904}#)
+ (#{ribcage-symnames\ 1306}# #{ribcage\ 1903}#)))
+ (#{set-ribcage-marks!\ 1310}#
+ #{ribcage\ 1903}#
+ (cons (#{wrap-marks\ 1300}#
+ (#{syntax-object-wrap\ 1283}# #{id\ 1904}#))
+ (#{ribcage-marks\ 1307}# #{ribcage\ 1903}#)))
+ (#{set-ribcage-labels!\ 1311}#
+ #{ribcage\ 1903}#
+ (cons #{label\ 1905}#
+ (#{ribcage-labels\ 1308}# #{ribcage\ 1903}#))))))
+ (#{anti-mark\ 1312}#
+ (lambda (#{w\ 1906}#)
+ (#{make-wrap\ 1299}#
+ (cons #f (#{wrap-marks\ 1300}# #{w\ 1906}#))
+ (cons 'shift
+ (#{wrap-subst\ 1301}# #{w\ 1906}#)))))
+ (#{set-ribcage-labels!\ 1311}#
+ (lambda (#{x\ 1907}# #{update\ 1908}#)
+ (vector-set! #{x\ 1907}# 3 #{update\ 1908}#)))
+ (#{set-ribcage-marks!\ 1310}#
+ (lambda (#{x\ 1909}# #{update\ 1910}#)
+ (vector-set! #{x\ 1909}# 2 #{update\ 1910}#)))
+ (#{set-ribcage-symnames!\ 1309}#
+ (lambda (#{x\ 1911}# #{update\ 1912}#)
+ (vector-set! #{x\ 1911}# 1 #{update\ 1912}#)))
+ (#{ribcage-labels\ 1308}#
+ (lambda (#{x\ 1913}#) (vector-ref #{x\ 1913}# 3)))
+ (#{ribcage-marks\ 1307}#
+ (lambda (#{x\ 1914}#) (vector-ref #{x\ 1914}# 2)))
+ (#{ribcage-symnames\ 1306}#
+ (lambda (#{x\ 1915}#) (vector-ref #{x\ 1915}# 1)))
+ (#{ribcage?\ 1305}#
+ (lambda (#{x\ 1916}#)
+ (if (vector? #{x\ 1916}#)
+ (if (= (vector-length #{x\ 1916}#) 4)
+ (eq? (vector-ref #{x\ 1916}# 0) (quote ribcage))
#f)
#f)))
- (make-ribcage122
- (lambda (symnames734 marks735 labels736)
+ (#{make-ribcage\ 1304}#
+ (lambda (#{symnames\ 1917}#
+ #{marks\ 1918}#
+ #{labels\ 1919}#)
(vector
'ribcage
- symnames734
- marks735
- labels736)))
- (gen-labels121
- (lambda (ls737)
- (if (null? ls737)
+ #{symnames\ 1917}#
+ #{marks\ 1918}#
+ #{labels\ 1919}#)))
+ (#{gen-labels\ 1303}#
+ (lambda (#{ls\ 1920}#)
+ (if (null? #{ls\ 1920}#)
'()
- (cons (gen-label120) (gen-labels121 (cdr ls737))))))
- (gen-label120 (lambda () (string #\i)))
- (wrap-subst119 cdr)
- (wrap-marks118 car)
- (make-wrap117 cons)
- (id-sym-name&marks116
- (lambda (x738 w739)
- (if (syntax-object?99 x738)
+ (cons (#{gen-label\ 1302}#)
+ (#{gen-labels\ 1303}# (cdr #{ls\ 1920}#))))))
+ (#{gen-label\ 1302}# (lambda () (string #\i)))
+ (#{wrap-subst\ 1301}# cdr)
+ (#{wrap-marks\ 1300}# car)
+ (#{make-wrap\ 1299}# cons)
+ (#{id-sym-name&marks\ 1298}#
+ (lambda (#{x\ 1921}# #{w\ 1922}#)
+ (if (#{syntax-object?\ 1281}# #{x\ 1921}#)
(values
- (syntax-object-expression100 x738)
- (join-marks135
- (wrap-marks118 w739)
- (wrap-marks118 (syntax-object-wrap101 x738))))
- (values x738 (wrap-marks118 w739)))))
- (id?115
- (lambda (x740)
- (if (symbol? x740)
+ (#{syntax-object-expression\ 1282}# #{x\ 1921}#)
+ (#{join-marks\ 1317}#
+ (#{wrap-marks\ 1300}# #{w\ 1922}#)
+ (#{wrap-marks\ 1300}#
+ (#{syntax-object-wrap\ 1283}# #{x\ 1921}#))))
+ (values
+ #{x\ 1921}#
+ (#{wrap-marks\ 1300}# #{w\ 1922}#)))))
+ (#{id?\ 1297}#
+ (lambda (#{x\ 1923}#)
+ (if (symbol? #{x\ 1923}#)
#t
- (if (syntax-object?99 x740)
- (symbol? (syntax-object-expression100 x740))
+ (if (#{syntax-object?\ 1281}# #{x\ 1923}#)
+ (symbol?
+ (#{syntax-object-expression\ 1282}# #{x\ 1923}#))
#f))))
- (nonsymbol-id?114
- (lambda (x741)
- (if (syntax-object?99 x741)
- (symbol? (syntax-object-expression100 x741))
+ (#{nonsymbol-id?\ 1296}#
+ (lambda (#{x\ 1924}#)
+ (if (#{syntax-object?\ 1281}# #{x\ 1924}#)
+ (symbol?
+ (#{syntax-object-expression\ 1282}# #{x\ 1924}#))
#f)))
- (global-extend113
- (lambda (type742 sym743 val744)
- (put-global-definition-hook78
- sym743
- type742
- val744)))
- (lookup112
- (lambda (x745 r746 mod747)
- (let ((t748 (assq x745 r746)))
- (if t748
- (cdr t748)
- (if (symbol? x745)
- (let ((t749 (get-global-definition-hook79 x745 mod747)))
- (if t749 t749 (quote (global))))
+ (#{global-extend\ 1295}#
+ (lambda (#{type\ 1925}# #{sym\ 1926}# #{val\ 1927}#)
+ (#{put-global-definition-hook\ 1260}#
+ #{sym\ 1926}#
+ #{type\ 1925}#
+ #{val\ 1927}#)))
+ (#{lookup\ 1294}#
+ (lambda (#{x\ 1928}# #{r\ 1929}# #{mod\ 1930}#)
+ (let ((#{t\ 1931}# (assq #{x\ 1928}# #{r\ 1929}#)))
+ (if #{t\ 1931}#
+ (cdr #{t\ 1931}#)
+ (if (symbol? #{x\ 1928}#)
+ (let ((#{t\ 1932}#
+ (#{get-global-definition-hook\ 1261}#
+ #{x\ 1928}#
+ #{mod\ 1930}#)))
+ (if #{t\ 1932}# #{t\ 1932}# (quote (global))))
'(displaced-lexical))))))
- (macros-only-env111
- (lambda (r750)
- (if (null? r750)
+ (#{macros-only-env\ 1293}#
+ (lambda (#{r\ 1933}#)
+ (if (null? #{r\ 1933}#)
'()
- (let ((a751 (car r750)))
- (if (eq? (cadr a751) (quote macro))
- (cons a751 (macros-only-env111 (cdr r750)))
- (macros-only-env111 (cdr r750)))))))
- (extend-var-env110
- (lambda (labels752 vars753 r754)
- (if (null? labels752)
- r754
- (extend-var-env110
- (cdr labels752)
- (cdr vars753)
- (cons (cons (car labels752)
- (cons (quote lexical) (car vars753)))
- r754)))))
- (extend-env109
- (lambda (labels755 bindings756 r757)
- (if (null? labels755)
- r757
- (extend-env109
- (cdr labels755)
- (cdr bindings756)
- (cons (cons (car labels755) (car bindings756))
- r757)))))
- (binding-value108 cdr)
- (binding-type107 car)
- (source-annotation106
- (lambda (x758)
- (if (syntax-object?99 x758)
- (source-annotation106
- (syntax-object-expression100 x758))
- (if (pair? x758)
- (let ((props759 (source-properties x758)))
- (if (pair? props759) props759 #f))
+ (let ((#{a\ 1934}# (car #{r\ 1933}#)))
+ (if (eq? (cadr #{a\ 1934}#) (quote macro))
+ (cons #{a\ 1934}#
+ (#{macros-only-env\ 1293}# (cdr #{r\ 1933}#)))
+ (#{macros-only-env\ 1293}# (cdr #{r\ 1933}#)))))))
+ (#{extend-var-env\ 1292}#
+ (lambda (#{labels\ 1935}# #{vars\ 1936}# #{r\ 1937}#)
+ (if (null? #{labels\ 1935}#)
+ #{r\ 1937}#
+ (#{extend-var-env\ 1292}#
+ (cdr #{labels\ 1935}#)
+ (cdr #{vars\ 1936}#)
+ (cons (cons (car #{labels\ 1935}#)
+ (cons (quote lexical) (car #{vars\ 1936}#)))
+ #{r\ 1937}#)))))
+ (#{extend-env\ 1291}#
+ (lambda (#{labels\ 1938}# #{bindings\ 1939}# #{r\ 1940}#)
+ (if (null? #{labels\ 1938}#)
+ #{r\ 1940}#
+ (#{extend-env\ 1291}#
+ (cdr #{labels\ 1938}#)
+ (cdr #{bindings\ 1939}#)
+ (cons (cons (car #{labels\ 1938}#)
+ (car #{bindings\ 1939}#))
+ #{r\ 1940}#)))))
+ (#{binding-value\ 1290}# cdr)
+ (#{binding-type\ 1289}# car)
+ (#{source-annotation\ 1288}#
+ (lambda (#{x\ 1941}#)
+ (if (#{syntax-object?\ 1281}# #{x\ 1941}#)
+ (#{source-annotation\ 1288}#
+ (#{syntax-object-expression\ 1282}# #{x\ 1941}#))
+ (if (pair? #{x\ 1941}#)
+ (let ((#{props\ 1942}# (source-properties #{x\ 1941}#)))
+ (if (pair? #{props\ 1942}#) #{props\ 1942}# #f))
#f))))
- (set-syntax-object-module!105
- (lambda (x760 update761)
- (vector-set! x760 3 update761)))
- (set-syntax-object-wrap!104
- (lambda (x762 update763)
- (vector-set! x762 2 update763)))
- (set-syntax-object-expression!103
- (lambda (x764 update765)
- (vector-set! x764 1 update765)))
- (syntax-object-module102
- (lambda (x766) (vector-ref x766 3)))
- (syntax-object-wrap101
- (lambda (x767) (vector-ref x767 2)))
- (syntax-object-expression100
- (lambda (x768) (vector-ref x768 1)))
- (syntax-object?99
- (lambda (x769)
- (if (vector? x769)
- (if (= (vector-length x769) 4)
- (eq? (vector-ref x769 0) (quote syntax-object))
+ (#{set-syntax-object-module!\ 1287}#
+ (lambda (#{x\ 1943}# #{update\ 1944}#)
+ (vector-set! #{x\ 1943}# 3 #{update\ 1944}#)))
+ (#{set-syntax-object-wrap!\ 1286}#
+ (lambda (#{x\ 1945}# #{update\ 1946}#)
+ (vector-set! #{x\ 1945}# 2 #{update\ 1946}#)))
+ (#{set-syntax-object-expression!\ 1285}#
+ (lambda (#{x\ 1947}# #{update\ 1948}#)
+ (vector-set! #{x\ 1947}# 1 #{update\ 1948}#)))
+ (#{syntax-object-module\ 1284}#
+ (lambda (#{x\ 1949}#) (vector-ref #{x\ 1949}# 3)))
+ (#{syntax-object-wrap\ 1283}#
+ (lambda (#{x\ 1950}#) (vector-ref #{x\ 1950}# 2)))
+ (#{syntax-object-expression\ 1282}#
+ (lambda (#{x\ 1951}#) (vector-ref #{x\ 1951}# 1)))
+ (#{syntax-object?\ 1281}#
+ (lambda (#{x\ 1952}#)
+ (if (vector? #{x\ 1952}#)
+ (if (= (vector-length #{x\ 1952}#) 4)
+ (eq? (vector-ref #{x\ 1952}# 0)
+ 'syntax-object)
#f)
#f)))
- (make-syntax-object98
- (lambda (expression770 wrap771 module772)
+ (#{make-syntax-object\ 1280}#
+ (lambda (#{expression\ 1953}#
+ #{wrap\ 1954}#
+ #{module\ 1955}#)
(vector
'syntax-object
- expression770
- wrap771
- module772)))
- (build-letrec97
- (lambda (src773 ids774 vars775 val-exps776 body-exp777)
- (if (null? vars775)
- body-exp777
- (let ((atom-key778 (fluid-ref *mode*71)))
- (if (memv atom-key778 (quote (c)))
+ #{expression\ 1953}#
+ #{wrap\ 1954}#
+ #{module\ 1955}#)))
+ (#{build-letrec\ 1279}#
+ (lambda (#{src\ 1956}#
+ #{ids\ 1957}#
+ #{vars\ 1958}#
+ #{val-exps\ 1959}#
+ #{body-exp\ 1960}#)
+ (if (null? #{vars\ 1958}#)
+ #{body-exp\ 1960}#
+ (let ((#{atom-key\ 1961}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1961}# (quote (c)))
(begin
- (for-each maybe-name-value!89 ids774 val-exps776)
+ (for-each
+ #{maybe-name-value!\ 1271}#
+ #{ids\ 1957}#
+ #{val-exps\ 1959}#)
((@ (language tree-il) make-letrec)
- src773
- ids774
- vars775
- val-exps776
- body-exp777))
- (decorate-source80
+ #{src\ 1956}#
+ #{ids\ 1957}#
+ #{vars\ 1958}#
+ #{val-exps\ 1959}#
+ #{body-exp\ 1960}#))
+ (#{decorate-source\ 1262}#
(list 'letrec
- (map list vars775 val-exps776)
- body-exp777)
- src773))))))
- (build-named-let96
- (lambda (src779 ids780 vars781 val-exps782 body-exp783)
- (let ((f784 (car vars781))
- (f-name785 (car ids780))
- (vars786 (cdr vars781))
- (ids787 (cdr ids780)))
- (let ((atom-key788 (fluid-ref *mode*71)))
- (if (memv atom-key788 (quote (c)))
- (let ((proc789
- (build-lambda91
- src779
- ids787
- vars786
+ (map list #{vars\ 1958}# #{val-exps\ 1959}#)
+ #{body-exp\ 1960}#)
+ #{src\ 1956}#))))))
+ (#{build-named-let\ 1278}#
+ (lambda (#{src\ 1962}#
+ #{ids\ 1963}#
+ #{vars\ 1964}#
+ #{val-exps\ 1965}#
+ #{body-exp\ 1966}#)
+ (let ((#{f\ 1967}# (car #{vars\ 1964}#))
+ (#{f-name\ 1968}# (car #{ids\ 1963}#))
+ (#{vars\ 1969}# (cdr #{vars\ 1964}#))
+ (#{ids\ 1970}# (cdr #{ids\ 1963}#)))
+ (let ((#{atom-key\ 1971}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1971}# (quote (c)))
+ (let ((#{proc\ 1972}#
+ (#{build-lambda\ 1273}#
+ #{src\ 1962}#
+ #{ids\ 1970}#
+ #{vars\ 1969}#
#f
- body-exp783)))
+ #{body-exp\ 1966}#)))
(begin
- (maybe-name-value!89 f-name785 proc789)
- (for-each maybe-name-value!89 ids787 val-exps782)
+ (#{maybe-name-value!\ 1271}#
+ #{f-name\ 1968}#
+ #{proc\ 1972}#)
+ (for-each
+ #{maybe-name-value!\ 1271}#
+ #{ids\ 1970}#
+ #{val-exps\ 1965}#)
((@ (language tree-il) make-letrec)
- src779
- (list f-name785)
- (list f784)
- (list proc789)
- (build-application82
- src779
- (build-lexical-reference84
+ #{src\ 1962}#
+ (list #{f-name\ 1968}#)
+ (list #{f\ 1967}#)
+ (list #{proc\ 1972}#)
+ (#{build-application\ 1264}#
+ #{src\ 1962}#
+ (#{build-lexical-reference\ 1266}#
'fun
- src779
- f-name785
- f784)
- val-exps782))))
- (decorate-source80
+ #{src\ 1962}#
+ #{f-name\ 1968}#
+ #{f\ 1967}#)
+ #{val-exps\ 1965}#))))
+ (#{decorate-source\ 1262}#
(list 'let
- f784
- (map list vars786 val-exps782)
- body-exp783)
- src779))))))
- (build-let95
- (lambda (src790 ids791 vars792 val-exps793 body-exp794)
- (if (null? vars792)
- body-exp794
- (let ((atom-key795 (fluid-ref *mode*71)))
- (if (memv atom-key795 (quote (c)))
+ #{f\ 1967}#
+ (map list #{vars\ 1969}# #{val-exps\ 1965}#)
+ #{body-exp\ 1966}#)
+ #{src\ 1962}#))))))
+ (#{build-let\ 1277}#
+ (lambda (#{src\ 1973}#
+ #{ids\ 1974}#
+ #{vars\ 1975}#
+ #{val-exps\ 1976}#
+ #{body-exp\ 1977}#)
+ (if (null? #{vars\ 1975}#)
+ #{body-exp\ 1977}#
+ (let ((#{atom-key\ 1978}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1978}# (quote (c)))
(begin
- (for-each maybe-name-value!89 ids791 val-exps793)
+ (for-each
+ #{maybe-name-value!\ 1271}#
+ #{ids\ 1974}#
+ #{val-exps\ 1976}#)
((@ (language tree-il) make-let)
- src790
- ids791
- vars792
- val-exps793
- body-exp794))
- (decorate-source80
+ #{src\ 1973}#
+ #{ids\ 1974}#
+ #{vars\ 1975}#
+ #{val-exps\ 1976}#
+ #{body-exp\ 1977}#))
+ (#{decorate-source\ 1262}#
(list 'let
- (map list vars792 val-exps793)
- body-exp794)
- src790))))))
- (build-sequence94
- (lambda (src796 exps797)
- (if (null? (cdr exps797))
- (car exps797)
- (let ((atom-key798 (fluid-ref *mode*71)))
- (if (memv atom-key798 (quote (c)))
+ (map list #{vars\ 1975}# #{val-exps\ 1976}#)
+ #{body-exp\ 1977}#)
+ #{src\ 1973}#))))))
+ (#{build-sequence\ 1276}#
+ (lambda (#{src\ 1979}# #{exps\ 1980}#)
+ (if (null? (cdr #{exps\ 1980}#))
+ (car #{exps\ 1980}#)
+ (let ((#{atom-key\ 1981}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1981}# (quote (c)))
((@ (language tree-il) make-sequence)
- src796
- exps797)
- (decorate-source80
- (cons (quote begin) exps797)
- src796))))))
- (build-data93
- (lambda (src799 exp800)
- (let ((atom-key801 (fluid-ref *mode*71)))
- (if (memv atom-key801 (quote (c)))
- ((@ (language tree-il) make-const) src799 exp800)
- (decorate-source80
- (if (if (self-evaluating? exp800)
- (not (vector? exp800))
+ #{src\ 1979}#
+ #{exps\ 1980}#)
+ (#{decorate-source\ 1262}#
+ (cons (quote begin) #{exps\ 1980}#)
+ #{src\ 1979}#))))))
+ (#{build-data\ 1275}#
+ (lambda (#{src\ 1982}# #{exp\ 1983}#)
+ (let ((#{atom-key\ 1984}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1984}# (quote (c)))
+ ((@ (language tree-il) make-const)
+ #{src\ 1982}#
+ #{exp\ 1983}#)
+ (#{decorate-source\ 1262}#
+ (if (if (self-evaluating? #{exp\ 1983}#)
+ (not (vector? #{exp\ 1983}#))
#f)
- exp800
- (list (quote quote) exp800))
- src799)))))
- (build-primref92
- (lambda (src802 name803)
+ #{exp\ 1983}#
+ (list (quote quote) #{exp\ 1983}#))
+ #{src\ 1982}#)))))
+ (#{build-primref\ 1274}#
+ (lambda (#{src\ 1985}# #{name\ 1986}#)
(if (equal?
(module-name (current-module))
'(guile))
- (let ((atom-key804 (fluid-ref *mode*71)))
- (if (memv atom-key804 (quote (c)))
+ (let ((#{atom-key\ 1987}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1987}# (quote (c)))
((@ (language tree-il) make-toplevel-ref)
- src802
- name803)
- (decorate-source80 name803 src802)))
- (let ((atom-key805 (fluid-ref *mode*71)))
- (if (memv atom-key805 (quote (c)))
+ #{src\ 1985}#
+ #{name\ 1986}#)
+ (#{decorate-source\ 1262}#
+ #{name\ 1986}#
+ #{src\ 1985}#)))
+ (let ((#{atom-key\ 1988}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1988}# (quote (c)))
((@ (language tree-il) make-module-ref)
- src802
+ #{src\ 1985}#
'(guile)
- name803
+ #{name\ 1986}#
#f)
- (decorate-source80
- (list (quote @@) (quote (guile)) name803)
- src802))))))
- (build-lambda91
- (lambda (src806 ids807 vars808 docstring809 exp810)
- (let ((atom-key811 (fluid-ref *mode*71)))
- (if (memv atom-key811 (quote (c)))
+ (#{decorate-source\ 1262}#
+ (list (quote @@) (quote (guile)) #{name\ 1986}#)
+ #{src\ 1985}#))))))
+ (#{build-lambda\ 1273}#
+ (lambda (#{src\ 1989}#
+ #{ids\ 1990}#
+ #{vars\ 1991}#
+ #{docstring\ 1992}#
+ #{exp\ 1993}#)
+ (let ((#{atom-key\ 1994}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1994}# (quote (c)))
((@ (language tree-il) make-lambda)
- src806
- ids807
- vars808
- (if docstring809
- (list (cons (quote documentation) docstring809))
+ #{src\ 1989}#
+ #{ids\ 1990}#
+ #{vars\ 1991}#
+ (if #{docstring\ 1992}#
+ (list (cons (quote documentation) #{docstring\ 1992}#))
'())
- exp810)
- (decorate-source80
+ #{exp\ 1993}#)
+ (#{decorate-source\ 1262}#
(cons 'lambda
- (cons vars808
+ (cons #{vars\ 1991}#
(append
- (if docstring809
- (list docstring809)
+ (if #{docstring\ 1992}#
+ (list #{docstring\ 1992}#)
'())
- (list exp810))))
- src806)))))
- (build-global-definition90
- (lambda (source812 var813 exp814)
- (let ((atom-key815 (fluid-ref *mode*71)))
- (if (memv atom-key815 (quote (c)))
+ (list #{exp\ 1993}#))))
+ #{src\ 1989}#)))))
+ (#{build-global-definition\ 1272}#
+ (lambda (#{source\ 1995}# #{var\ 1996}# #{exp\ 1997}#)
+ (let ((#{atom-key\ 1998}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 1998}# (quote (c)))
(begin
- (maybe-name-value!89 var813 exp814)
+ (#{maybe-name-value!\ 1271}#
+ #{var\ 1996}#
+ #{exp\ 1997}#)
((@ (language tree-il) make-toplevel-define)
- source812
- var813
- exp814))
- (decorate-source80
- (list (quote define) var813 exp814)
- source812)))))
- (maybe-name-value!89
- (lambda (name816 val817)
- (if ((@ (language tree-il) lambda?) val817)
- (let ((meta818
- ((@ (language tree-il) lambda-meta) val817)))
- (if (not (assq (quote name) meta818))
+ #{source\ 1995}#
+ #{var\ 1996}#
+ #{exp\ 1997}#))
+ (#{decorate-source\ 1262}#
+ (list (quote define) #{var\ 1996}# #{exp\ 1997}#)
+ #{source\ 1995}#)))))
+ (#{maybe-name-value!\ 1271}#
+ (lambda (#{name\ 1999}# #{val\ 2000}#)
+ (if ((@ (language tree-il) lambda?) #{val\ 2000}#)
+ (let ((#{meta\ 2001}#
+ ((@ (language tree-il) lambda-meta)
+ #{val\ 2000}#)))
+ (if (not (assq (quote name) #{meta\ 2001}#))
((setter (@ (language tree-il) lambda-meta))
- val817
- (acons (quote name) name816 meta818)))))))
- (build-global-assignment88
- (lambda (source819 var820 exp821 mod822)
- (analyze-variable86
- mod822
- var820
- (lambda (mod823 var824 public?825)
- (let ((atom-key826 (fluid-ref *mode*71)))
- (if (memv atom-key826 (quote (c)))
+ #{val\ 2000}#
+ (acons 'name
+ #{name\ 1999}#
+ #{meta\ 2001}#)))))))
+ (#{build-global-assignment\ 1270}#
+ (lambda (#{source\ 2002}#
+ #{var\ 2003}#
+ #{exp\ 2004}#
+ #{mod\ 2005}#)
+ (#{analyze-variable\ 1268}#
+ #{mod\ 2005}#
+ #{var\ 2003}#
+ (lambda (#{mod\ 2006}# #{var\ 2007}# #{public?\ 2008}#)
+ (let ((#{atom-key\ 2009}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2009}# (quote (c)))
((@ (language tree-il) make-module-set)
- source819
- mod823
- var824
- public?825
- exp821)
- (decorate-source80
+ #{source\ 2002}#
+ #{mod\ 2006}#
+ #{var\ 2007}#
+ #{public?\ 2008}#
+ #{exp\ 2004}#)
+ (#{decorate-source\ 1262}#
(list 'set!
- (list (if public?825 (quote @) (quote @@))
- mod823
- var824)
- exp821)
- source819))))
- (lambda (var827)
- (let ((atom-key828 (fluid-ref *mode*71)))
- (if (memv atom-key828 (quote (c)))
+ (list (if #{public?\ 2008}#
+ '@
+ '@@)
+ #{mod\ 2006}#
+ #{var\ 2007}#)
+ #{exp\ 2004}#)
+ #{source\ 2002}#))))
+ (lambda (#{var\ 2010}#)
+ (let ((#{atom-key\ 2011}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2011}# (quote (c)))
((@ (language tree-il) make-toplevel-set)
- source819
- var827
- exp821)
- (decorate-source80
- (list (quote set!) var827 exp821)
- source819)))))))
- (build-global-reference87
- (lambda (source829 var830 mod831)
- (analyze-variable86
- mod831
- var830
- (lambda (mod832 var833 public?834)
- (let ((atom-key835 (fluid-ref *mode*71)))
- (if (memv atom-key835 (quote (c)))
+ #{source\ 2002}#
+ #{var\ 2010}#
+ #{exp\ 2004}#)
+ (#{decorate-source\ 1262}#
+ (list (quote set!) #{var\ 2010}# #{exp\ 2004}#)
+ #{source\ 2002}#)))))))
+ (#{build-global-reference\ 1269}#
+ (lambda (#{source\ 2012}# #{var\ 2013}# #{mod\ 2014}#)
+ (#{analyze-variable\ 1268}#
+ #{mod\ 2014}#
+ #{var\ 2013}#
+ (lambda (#{mod\ 2015}# #{var\ 2016}# #{public?\ 2017}#)
+ (let ((#{atom-key\ 2018}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2018}# (quote (c)))
((@ (language tree-il) make-module-ref)
- source829
- mod832
- var833
- public?834)
- (decorate-source80
- (list (if public?834 (quote @) (quote @@))
- mod832
- var833)
- source829))))
- (lambda (var836)
- (let ((atom-key837 (fluid-ref *mode*71)))
- (if (memv atom-key837 (quote (c)))
+ #{source\ 2012}#
+ #{mod\ 2015}#
+ #{var\ 2016}#
+ #{public?\ 2017}#)
+ (#{decorate-source\ 1262}#
+ (list (if #{public?\ 2017}# (quote @) (quote @@))
+ #{mod\ 2015}#
+ #{var\ 2016}#)
+ #{source\ 2012}#))))
+ (lambda (#{var\ 2019}#)
+ (let ((#{atom-key\ 2020}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2020}# (quote (c)))
((@ (language tree-il) make-toplevel-ref)
- source829
- var836)
- (decorate-source80 var836 source829)))))))
- (analyze-variable86
- (lambda (mod838 var839 modref-cont840 bare-cont841)
- (if (not mod838)
- (bare-cont841 var839)
- (let ((kind842 (car mod838)) (mod843 (cdr mod838)))
- (if (memv kind842 (quote (public)))
- (modref-cont840 mod843 var839 #t)
- (if (memv kind842 (quote (private)))
- (if (not (equal? mod843 (module-name (current-module))))
- (modref-cont840 mod843 var839 #f)
- (bare-cont841 var839))
- (if (memv kind842 (quote (bare)))
- (bare-cont841 var839)
- (if (memv kind842 (quote (hygiene)))
+ #{source\ 2012}#
+ #{var\ 2019}#)
+ (#{decorate-source\ 1262}#
+ #{var\ 2019}#
+ #{source\ 2012}#)))))))
+ (#{analyze-variable\ 1268}#
+ (lambda (#{mod\ 2021}#
+ #{var\ 2022}#
+ #{modref-cont\ 2023}#
+ #{bare-cont\ 2024}#)
+ (if (not #{mod\ 2021}#)
+ (#{bare-cont\ 2024}# #{var\ 2022}#)
+ (let ((#{kind\ 2025}# (car #{mod\ 2021}#))
+ (#{mod\ 2026}# (cdr #{mod\ 2021}#)))
+ (if (memv #{kind\ 2025}# (quote (public)))
+ (#{modref-cont\ 2023}#
+ #{mod\ 2026}#
+ #{var\ 2022}#
+ #t)
+ (if (memv #{kind\ 2025}# (quote (private)))
+ (if (not (equal?
+ #{mod\ 2026}#
+ (module-name (current-module))))
+ (#{modref-cont\ 2023}#
+ #{mod\ 2026}#
+ #{var\ 2022}#
+ #f)
+ (#{bare-cont\ 2024}# #{var\ 2022}#))
+ (if (memv #{kind\ 2025}# (quote (bare)))
+ (#{bare-cont\ 2024}# #{var\ 2022}#)
+ (if (memv #{kind\ 2025}# (quote (hygiene)))
(if (if (not (equal?
- mod843
+ #{mod\ 2026}#
(module-name (current-module))))
(module-variable
- (resolve-module mod843)
- var839)
+ (resolve-module #{mod\ 2026}#)
+ #{var\ 2022}#)
#f)
- (modref-cont840 mod843 var839 #f)
- (bare-cont841 var839))
+ (#{modref-cont\ 2023}#
+ #{mod\ 2026}#
+ #{var\ 2022}#
+ #f)
+ (#{bare-cont\ 2024}# #{var\ 2022}#))
(syntax-violation
#f
"bad module kind"
- var839
- mod843)))))))))
- (build-lexical-assignment85
- (lambda (source844 name845 var846 exp847)
- (let ((atom-key848 (fluid-ref *mode*71)))
- (if (memv atom-key848 (quote (c)))
+ #{var\ 2022}#
+ #{mod\ 2026}#)))))))))
+ (#{build-lexical-assignment\ 1267}#
+ (lambda (#{source\ 2027}#
+ #{name\ 2028}#
+ #{var\ 2029}#
+ #{exp\ 2030}#)
+ (let ((#{atom-key\ 2031}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2031}# (quote (c)))
((@ (language tree-il) make-lexical-set)
- source844
- name845
- var846
- exp847)
- (decorate-source80
- (list (quote set!) var846 exp847)
- source844)))))
- (build-lexical-reference84
- (lambda (type849 source850 name851 var852)
- (let ((atom-key853 (fluid-ref *mode*71)))
- (if (memv atom-key853 (quote (c)))
+ #{source\ 2027}#
+ #{name\ 2028}#
+ #{var\ 2029}#
+ #{exp\ 2030}#)
+ (#{decorate-source\ 1262}#
+ (list (quote set!) #{var\ 2029}# #{exp\ 2030}#)
+ #{source\ 2027}#)))))
+ (#{build-lexical-reference\ 1266}#
+ (lambda (#{type\ 2032}#
+ #{source\ 2033}#
+ #{name\ 2034}#
+ #{var\ 2035}#)
+ (let ((#{atom-key\ 2036}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2036}# (quote (c)))
((@ (language tree-il) make-lexical-ref)
- source850
- name851
- var852)
- (decorate-source80 var852 source850)))))
- (build-conditional83
- (lambda (source854 test-exp855 then-exp856 else-exp857)
- (let ((atom-key858 (fluid-ref *mode*71)))
- (if (memv atom-key858 (quote (c)))
+ #{source\ 2033}#
+ #{name\ 2034}#
+ #{var\ 2035}#)
+ (#{decorate-source\ 1262}#
+ #{var\ 2035}#
+ #{source\ 2033}#)))))
+ (#{build-conditional\ 1265}#
+ (lambda (#{source\ 2037}#
+ #{test-exp\ 2038}#
+ #{then-exp\ 2039}#
+ #{else-exp\ 2040}#)
+ (let ((#{atom-key\ 2041}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2041}# (quote (c)))
((@ (language tree-il) make-conditional)
- source854
- test-exp855
- then-exp856
- else-exp857)
- (decorate-source80
- (if (equal? else-exp857 (quote (if #f #f)))
- (list (quote if) test-exp855 then-exp856)
+ #{source\ 2037}#
+ #{test-exp\ 2038}#
+ #{then-exp\ 2039}#
+ #{else-exp\ 2040}#)
+ (#{decorate-source\ 1262}#
+ (if (equal? #{else-exp\ 2040}# (quote (if #f #f)))
+ (list 'if
+ #{test-exp\ 2038}#
+ #{then-exp\ 2039}#)
(list 'if
- test-exp855
- then-exp856
- else-exp857))
- source854)))))
- (build-application82
- (lambda (source859 fun-exp860 arg-exps861)
- (let ((atom-key862 (fluid-ref *mode*71)))
- (if (memv atom-key862 (quote (c)))
+ #{test-exp\ 2038}#
+ #{then-exp\ 2039}#
+ #{else-exp\ 2040}#))
+ #{source\ 2037}#)))))
+ (#{build-application\ 1264}#
+ (lambda (#{source\ 2042}#
+ #{fun-exp\ 2043}#
+ #{arg-exps\ 2044}#)
+ (let ((#{atom-key\ 2045}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2045}# (quote (c)))
((@ (language tree-il) make-application)
- source859
- fun-exp860
- arg-exps861)
- (decorate-source80
- (cons fun-exp860 arg-exps861)
- source859)))))
- (build-void81
- (lambda (source863)
- (let ((atom-key864 (fluid-ref *mode*71)))
- (if (memv atom-key864 (quote (c)))
- ((@ (language tree-il) make-void) source863)
- (decorate-source80 (quote (if #f #f)) source863)))))
- (decorate-source80
- (lambda (e865 s866)
+ #{source\ 2042}#
+ #{fun-exp\ 2043}#
+ #{arg-exps\ 2044}#)
+ (#{decorate-source\ 1262}#
+ (cons #{fun-exp\ 2043}# #{arg-exps\ 2044}#)
+ #{source\ 2042}#)))))
+ (#{build-void\ 1263}#
+ (lambda (#{source\ 2046}#)
+ (let ((#{atom-key\ 2047}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2047}# (quote (c)))
+ ((@ (language tree-il) make-void)
+ #{source\ 2046}#)
+ (#{decorate-source\ 1262}#
+ '(if #f #f)
+ #{source\ 2046}#)))))
+ (#{decorate-source\ 1262}#
+ (lambda (#{e\ 2048}# #{s\ 2049}#)
(begin
- (if (if (pair? e865) s866 #f)
- (set-source-properties! e865 s866))
- e865)))
- (get-global-definition-hook79
- (lambda (symbol867 module868)
+ (if (if (pair? #{e\ 2048}#) #{s\ 2049}# #f)
+ (set-source-properties! #{e\ 2048}# #{s\ 2049}#))
+ #{e\ 2048}#)))
+ (#{get-global-definition-hook\ 1261}#
+ (lambda (#{symbol\ 2050}# #{module\ 2051}#)
(begin
- (if (if (not module868) (current-module) #f)
+ (if (if (not #{module\ 2051}#) (current-module) #f)
(warn "module system is booted, we should have a module"
- symbol867))
- (let ((v869 (module-variable
- (if module868
- (resolve-module (cdr module868))
- (current-module))
- symbol867)))
- (if v869
- (if (variable-bound? v869)
- (let ((val870 (variable-ref v869)))
- (if (macro? val870)
- (if (syncase-macro-type val870)
- (cons (syncase-macro-type val870)
- (syncase-macro-binding val870))
+ #{symbol\ 2050}#))
+ (let ((#{v\ 2052}#
+ (module-variable
+ (if #{module\ 2051}#
+ (resolve-module (cdr #{module\ 2051}#))
+ (current-module))
+ #{symbol\ 2050}#)))
+ (if #{v\ 2052}#
+ (if (variable-bound? #{v\ 2052}#)
+ (let ((#{val\ 2053}# (variable-ref #{v\ 2052}#)))
+ (if (macro? #{val\ 2053}#)
+ (if (syncase-macro-type #{val\ 2053}#)
+ (cons (syncase-macro-type #{val\ 2053}#)
+ (syncase-macro-binding #{val\ 2053}#))
#f)
#f))
#f)
#f)))))
- (put-global-definition-hook78
- (lambda (symbol871 type872 val873)
- (let ((existing874
- (let ((v875 (module-variable
- (current-module)
- symbol871)))
- (if v875
- (if (variable-bound? v875)
- (let ((val876 (variable-ref v875)))
- (if (macro? val876)
- (if (not (syncase-macro-type val876))
- val876
+ (#{put-global-definition-hook\ 1260}#
+ (lambda (#{symbol\ 2054}# #{type\ 2055}# #{val\ 2056}#)
+ (let ((#{existing\ 2057}#
+ (let ((#{v\ 2058}#
+ (module-variable
+ (current-module)
+ #{symbol\ 2054}#)))
+ (if #{v\ 2058}#
+ (if (variable-bound? #{v\ 2058}#)
+ (let ((#{val\ 2059}# (variable-ref #{v\ 2058}#)))
+ (if (macro? #{val\ 2059}#)
+ (if (not (syncase-macro-type #{val\ 2059}#))
+ #{val\ 2059}#
#f)
#f))
#f)
#f))))
(module-define!
(current-module)
- symbol871
- (if existing874
+ #{symbol\ 2054}#
+ (if #{existing\ 2057}#
(make-extended-syncase-macro
- existing874
- type872
- val873)
- (make-syncase-macro type872 val873))))))
- (local-eval-hook77
- (lambda (x877 mod878)
+ #{existing\ 2057}#
+ #{type\ 2055}#
+ #{val\ 2056}#)
+ (make-syncase-macro #{type\ 2055}# #{val\ 2056}#))))))
+ (#{local-eval-hook\ 1259}#
+ (lambda (#{x\ 2060}# #{mod\ 2061}#)
(primitive-eval
- (list noexpand70
- (let ((atom-key879 (fluid-ref *mode*71)))
- (if (memv atom-key879 (quote (c)))
- ((@ (language tree-il) tree-il->scheme) x877)
- x877))))))
- (top-level-eval-hook76
- (lambda (x880 mod881)
+ (list #{noexpand\ 1252}#
+ (let ((#{atom-key\ 2062}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2062}# (quote (c)))
+ ((@ (language tree-il) tree-il->scheme)
+ #{x\ 2060}#)
+ #{x\ 2060}#))))))
+ (#{top-level-eval-hook\ 1258}#
+ (lambda (#{x\ 2063}# #{mod\ 2064}#)
(primitive-eval
- (list noexpand70
- (let ((atom-key882 (fluid-ref *mode*71)))
- (if (memv atom-key882 (quote (c)))
- ((@ (language tree-il) tree-il->scheme) x880)
- x880))))))
- (fx<75 <)
- (fx=74 =)
- (fx-73 -)
- (fx+72 +)
- (*mode*71 (make-fluid))
- (noexpand70 "noexpand"))
+ (list #{noexpand\ 1252}#
+ (let ((#{atom-key\ 2065}# (fluid-ref #{*mode*\ 1253}#)))
+ (if (memv #{atom-key\ 2065}# (quote (c)))
+ ((@ (language tree-il) tree-il->scheme)
+ #{x\ 2063}#)
+ #{x\ 2063}#))))))
+ (#{fx<\ 1257}# <)
+ (#{fx=\ 1256}# =)
+ (#{fx-\ 1255}# -)
+ (#{fx+\ 1254}# +)
+ (#{*mode*\ 1253}# (make-fluid))
+ (#{noexpand\ 1252}# "noexpand"))
(begin
- (global-extend113
+ (#{global-extend\ 1295}#
'local-syntax
'letrec-syntax
#t)
- (global-extend113
+ (#{global-extend\ 1295}#
'local-syntax
'let-syntax
#f)
- (global-extend113
+ (#{global-extend\ 1295}#
'core
'fluid-let-syntax
- (lambda (e883 r884 w885 s886 mod887)
- ((lambda (tmp888)
- ((lambda (tmp889)
- (if (if tmp889
- (apply (lambda (_890 var891 val892 e1893 e2894)
- (valid-bound-ids?140 var891))
- tmp889)
+ (lambda (#{e\ 2066}#
+ #{r\ 2067}#
+ #{w\ 2068}#
+ #{s\ 2069}#
+ #{mod\ 2070}#)
+ ((lambda (#{tmp\ 2071}#)
+ ((lambda (#{tmp\ 2072}#)
+ (if (if #{tmp\ 2072}#
+ (apply (lambda (#{_\ 2073}#
+ #{var\ 2074}#
+ #{val\ 2075}#
+ #{e1\ 2076}#
+ #{e2\ 2077}#)
+ (#{valid-bound-ids?\ 1322}# #{var\ 2074}#))
+ #{tmp\ 2072}#)
#f)
- (apply (lambda (_896 var897 val898 e1899 e2900)
- (let ((names901
- (map (lambda (x902)
- (id-var-name137 x902 w885))
- var897)))
+ (apply (lambda (#{_\ 2079}#
+ #{var\ 2080}#
+ #{val\ 2081}#
+ #{e1\ 2082}#
+ #{e2\ 2083}#)
+ (let ((#{names\ 2084}#
+ (map (lambda (#{x\ 2085}#)
+ (#{id-var-name\ 1319}#
+ #{x\ 2085}#
+ #{w\ 2068}#))
+ #{var\ 2080}#)))
(begin
(for-each
- (lambda (id904 n905)
- (let ((atom-key906
- (binding-type107
- (lookup112 n905 r884 mod887))))
- (if (memv atom-key906
+ (lambda (#{id\ 2087}# #{n\ 2088}#)
+ (let ((#{atom-key\ 2089}#
+ (#{binding-type\ 1289}#
+ (#{lookup\ 1294}#
+ #{n\ 2088}#
+ #{r\ 2067}#
+ #{mod\ 2070}#))))
+ (if (memv #{atom-key\ 2089}#
'(displaced-lexical))
(syntax-violation
'fluid-let-syntax
"identifier out of context"
- e883
- (source-wrap144
- id904
- w885
- s886
- mod887)))))
- var897
- names901)
- (chi-body155
- (cons e1899 e2900)
- (source-wrap144 e883 w885 s886 mod887)
- (extend-env109
- names901
- (let ((trans-r909
- (macros-only-env111 r884)))
- (map (lambda (x910)
+ #{e\ 2066}#
+ (#{source-wrap\ 1326}#
+ #{id\ 2087}#
+ #{w\ 2068}#
+ #{s\ 2069}#
+ #{mod\ 2070}#)))))
+ #{var\ 2080}#
+ #{names\ 2084}#)
+ (#{chi-body\ 1337}#
+ (cons #{e1\ 2082}# #{e2\ 2083}#)
+ (#{source-wrap\ 1326}#
+ #{e\ 2066}#
+ #{w\ 2068}#
+ #{s\ 2069}#
+ #{mod\ 2070}#)
+ (#{extend-env\ 1291}#
+ #{names\ 2084}#
+ (let ((#{trans-r\ 2092}#
+ (#{macros-only-env\ 1293}#
+ #{r\ 2067}#)))
+ (map (lambda (#{x\ 2093}#)
(cons 'macro
- (eval-local-transformer158
- (chi151
- x910
- trans-r909
- w885
- mod887)
- mod887)))
- val898))
- r884)
- w885
- mod887))))
- tmp889)
- ((lambda (_912)
+ (#{eval-local-transformer\ 1340}#
+ (#{chi\ 1333}#
+ #{x\ 2093}#
+ #{trans-r\ 2092}#
+ #{w\ 2068}#
+ #{mod\ 2070}#)
+ #{mod\ 2070}#)))
+ #{val\ 2081}#))
+ #{r\ 2067}#)
+ #{w\ 2068}#
+ #{mod\ 2070}#))))
+ #{tmp\ 2072}#)
+ ((lambda (#{_\ 2095}#)
(syntax-violation
'fluid-let-syntax
"bad syntax"
- (source-wrap144 e883 w885 s886 mod887)))
- tmp888)))
+ (#{source-wrap\ 1326}#
+ #{e\ 2066}#
+ #{w\ 2068}#
+ #{s\ 2069}#
+ #{mod\ 2070}#)))
+ #{tmp\ 2071}#)))
($sc-dispatch
- tmp888
+ #{tmp\ 2071}#
'(any #(each (any any)) any . each-any))))
- e883)))
- (global-extend113
+ #{e\ 2066}#)))
+ (#{global-extend\ 1295}#
'core
'quote
- (lambda (e913 r914 w915 s916 mod917)
- ((lambda (tmp918)
- ((lambda (tmp919)
- (if tmp919
- (apply (lambda (_920 e921)
- (build-data93 s916 (strip161 e921 w915)))
- tmp919)
- ((lambda (_922)
+ (lambda (#{e\ 2096}#
+ #{r\ 2097}#
+ #{w\ 2098}#
+ #{s\ 2099}#
+ #{mod\ 2100}#)
+ ((lambda (#{tmp\ 2101}#)
+ ((lambda (#{tmp\ 2102}#)
+ (if #{tmp\ 2102}#
+ (apply (lambda (#{_\ 2103}# #{e\ 2104}#)
+ (#{build-data\ 1275}#
+ #{s\ 2099}#
+ (#{strip\ 1343}# #{e\ 2104}# #{w\ 2098}#)))
+ #{tmp\ 2102}#)
+ ((lambda (#{_\ 2105}#)
(syntax-violation
'quote
"bad syntax"
- (source-wrap144 e913 w915 s916 mod917)))
- tmp918)))
- ($sc-dispatch tmp918 (quote (any any)))))
- e913)))
- (global-extend113
+ (#{source-wrap\ 1326}#
+ #{e\ 2096}#
+ #{w\ 2098}#
+ #{s\ 2099}#
+ #{mod\ 2100}#)))
+ #{tmp\ 2101}#)))
+ ($sc-dispatch #{tmp\ 2101}# (quote (any any)))))
+ #{e\ 2096}#)))
+ (#{global-extend\ 1295}#
'core
'syntax
- (letrec ((regen930
- (lambda (x931)
- (let ((atom-key932 (car x931)))
- (if (memv atom-key932 (quote (ref)))
- (build-lexical-reference84
+ (letrec ((#{regen\ 2113}#
+ (lambda (#{x\ 2114}#)
+ (let ((#{atom-key\ 2115}# (car #{x\ 2114}#)))
+ (if (memv #{atom-key\ 2115}# (quote (ref)))
+ (#{build-lexical-reference\ 1266}#
'value
#f
- (cadr x931)
- (cadr x931))
- (if (memv atom-key932 (quote (primitive)))
- (build-primref92 #f (cadr x931))
- (if (memv atom-key932 (quote (quote)))
- (build-data93 #f (cadr x931))
- (if (memv atom-key932 (quote (lambda)))
- (build-lambda91
+ (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 x931)
- (cadr x931)
+ (cadr #{x\ 2114}#)
+ (cadr #{x\ 2114}#)
#f
- (regen930 (caddr x931)))
- (build-application82
+ (#{regen\ 2113}# (caddr #{x\ 2114}#)))
+ (#{build-application\ 1264}#
#f
- (build-primref92 #f (car x931))
- (map regen930 (cdr x931))))))))))
- (gen-vector929
- (lambda (x933)
- (if (eq? (car x933) (quote list))
- (cons (quote vector) (cdr x933))
- (if (eq? (car x933) (quote quote))
- (list (quote quote) (list->vector (cadr x933)))
- (list (quote list->vector) x933)))))
- (gen-append928
- (lambda (x934 y935)
- (if (equal? y935 (quote (quote ())))
- x934
- (list (quote append) x934 y935))))
- (gen-cons927
- (lambda (x936 y937)
- (let ((atom-key938 (car y937)))
- (if (memv atom-key938 (quote (quote)))
- (if (eq? (car x936) (quote quote))
+ (#{build-primref\ 1274}# #f (car #{x\ 2114}#))
+ (map #{regen\ 2113}#
+ (cdr #{x\ 2114}#))))))))))
+ (#{gen-vector\ 2112}#
+ (lambda (#{x\ 2116}#)
+ (if (eq? (car #{x\ 2116}#) (quote list))
+ (cons (quote vector) (cdr #{x\ 2116}#))
+ (if (eq? (car #{x\ 2116}#) (quote quote))
+ (list 'quote
+ (list->vector (cadr #{x\ 2116}#)))
+ (list (quote list->vector) #{x\ 2116}#)))))
+ (#{gen-append\ 2111}#
+ (lambda (#{x\ 2117}# #{y\ 2118}#)
+ (if (equal? #{y\ 2118}# (quote (quote ())))
+ #{x\ 2117}#
+ (list (quote append) #{x\ 2117}# #{y\ 2118}#))))
+ (#{gen-cons\ 2110}#
+ (lambda (#{x\ 2119}# #{y\ 2120}#)
+ (let ((#{atom-key\ 2121}# (car #{y\ 2120}#)))
+ (if (memv #{atom-key\ 2121}# (quote (quote)))
+ (if (eq? (car #{x\ 2119}#) (quote quote))
(list 'quote
- (cons (cadr x936) (cadr y937)))
- (if (eq? (cadr y937) (quote ()))
- (list (quote list) x936)
- (list (quote cons) x936 y937)))
- (if (memv atom-key938 (quote (list)))
- (cons (quote list) (cons x936 (cdr y937)))
- (list (quote cons) x936 y937))))))
- (gen-map926
- (lambda (e939 map-env940)
- (let ((formals941 (map cdr map-env940))
- (actuals942
- (map (lambda (x943) (list (quote ref) (car x943)))
- map-env940)))
- (if (eq? (car e939) (quote ref))
- (car actuals942)
+ (cons (cadr #{x\ 2119}#) (cadr #{y\ 2120}#)))
+ (if (eq? (cadr #{y\ 2120}#) (quote ()))
+ (list (quote list) #{x\ 2119}#)
+ (list (quote cons) #{x\ 2119}# #{y\ 2120}#)))
+ (if (memv #{atom-key\ 2121}# (quote (list)))
+ (cons 'list
+ (cons #{x\ 2119}# (cdr #{y\ 2120}#)))
+ (list (quote cons) #{x\ 2119}# #{y\ 2120}#))))))
+ (#{gen-map\ 2109}#
+ (lambda (#{e\ 2122}# #{map-env\ 2123}#)
+ (let ((#{formals\ 2124}# (map cdr #{map-env\ 2123}#))
+ (#{actuals\ 2125}#
+ (map (lambda (#{x\ 2126}#)
+ (list (quote ref) (car #{x\ 2126}#)))
+ #{map-env\ 2123}#)))
+ (if (eq? (car #{e\ 2122}#) (quote ref))
+ (car #{actuals\ 2125}#)
(if (and-map
- (lambda (x944)
- (if (eq? (car x944) (quote ref))
- (memq (cadr x944) formals941)
+ (lambda (#{x\ 2127}#)
+ (if (eq? (car #{x\ 2127}#) (quote ref))
+ (memq (cadr #{x\ 2127}#) #{formals\ 2124}#)
#f))
- (cdr e939))
+ (cdr #{e\ 2122}#))
(cons 'map
- (cons (list (quote primitive) (car e939))
- (map (let ((r945 (map cons
- formals941
- actuals942)))
- (lambda (x946)
- (cdr (assq (cadr x946) r945))))
- (cdr e939))))
+ (cons (list 'primitive
+ (car #{e\ 2122}#))
+ (map (let ((#{r\ 2128}#
+ (map cons
+ #{formals\ 2124}#
+ #{actuals\ 2125}#)))
+ (lambda (#{x\ 2129}#)
+ (cdr (assq (cadr #{x\ 2129}#)
+ #{r\ 2128}#))))
+ (cdr #{e\ 2122}#))))
(cons 'map
- (cons (list (quote lambda) formals941 e939)
- actuals942)))))))
- (gen-mappend925
- (lambda (e947 map-env948)
+ (cons (list 'lambda
+ #{formals\ 2124}#
+ #{e\ 2122}#)
+ #{actuals\ 2125}#)))))))
+ (#{gen-mappend\ 2108}#
+ (lambda (#{e\ 2130}# #{map-env\ 2131}#)
(list 'apply
'(primitive append)
- (gen-map926 e947 map-env948))))
- (gen-ref924
- (lambda (src949 var950 level951 maps952)
- (if (fx=74 level951 0)
- (values var950 maps952)
- (if (null? maps952)
+ (#{gen-map\ 2109}# #{e\ 2130}# #{map-env\ 2131}#))))
+ (#{gen-ref\ 2107}#
+ (lambda (#{src\ 2132}#
+ #{var\ 2133}#
+ #{level\ 2134}#
+ #{maps\ 2135}#)
+ (if (#{fx=\ 1256}# #{level\ 2134}# 0)
+ (values #{var\ 2133}# #{maps\ 2135}#)
+ (if (null? #{maps\ 2135}#)
(syntax-violation
'syntax
"missing ellipsis"
- src949)
+ #{src\ 2132}#)
(call-with-values
(lambda ()
- (gen-ref924
- src949
- var950
- (fx-73 level951 1)
- (cdr maps952)))
- (lambda (outer-var953 outer-maps954)
- (let ((b955 (assq outer-var953 (car maps952))))
- (if b955
- (values (cdr b955) maps952)
- (let ((inner-var956 (gen-var162 (quote tmp))))
+ (#{gen-ref\ 2107}#
+ #{src\ 2132}#
+ #{var\ 2133}#
+ (#{fx-\ 1255}# #{level\ 2134}# 1)
+ (cdr #{maps\ 2135}#)))
+ (lambda (#{outer-var\ 2136}# #{outer-maps\ 2137}#)
+ (let ((#{b\ 2138}#
+ (assq #{outer-var\ 2136}#
+ (car #{maps\ 2135}#))))
+ (if #{b\ 2138}#
+ (values (cdr #{b\ 2138}#) #{maps\ 2135}#)
+ (let ((#{inner-var\ 2139}#
+ (#{gen-var\ 1344}# (quote tmp))))
(values
- inner-var956
- (cons (cons (cons outer-var953
- inner-var956)
- (car maps952))
- outer-maps954)))))))))))
- (gen-syntax923
- (lambda (src957 e958 r959 maps960 ellipsis?961 mod962)
- (if (id?115 e958)
- (let ((label963 (id-var-name137 e958 (quote (())))))
- (let ((b964 (lookup112 label963 r959 mod962)))
- (if (eq? (binding-type107 b964) (quote syntax))
+ #{inner-var\ 2139}#
+ (cons (cons (cons #{outer-var\ 2136}#
+ #{inner-var\ 2139}#)
+ (car #{maps\ 2135}#))
+ #{outer-maps\ 2137}#)))))))))))
+ (#{gen-syntax\ 2106}#
+ (lambda (#{src\ 2140}#
+ #{e\ 2141}#
+ #{r\ 2142}#
+ #{maps\ 2143}#
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#)
+ (if (#{id?\ 1297}# #{e\ 2141}#)
+ (let ((#{label\ 2146}#
+ (#{id-var-name\ 1319}#
+ #{e\ 2141}#
+ '(()))))
+ (let ((#{b\ 2147}#
+ (#{lookup\ 1294}#
+ #{label\ 2146}#
+ #{r\ 2142}#
+ #{mod\ 2145}#)))
+ (if (eq? (#{binding-type\ 1289}# #{b\ 2147}#)
+ 'syntax)
(call-with-values
(lambda ()
- (let ((var.lev965 (binding-value108 b964)))
- (gen-ref924
- src957
- (car var.lev965)
- (cdr var.lev965)
- maps960)))
- (lambda (var966 maps967)
- (values (list (quote ref) var966) maps967)))
- (if (ellipsis?961 e958)
+ (let ((#{var.lev\ 2148}#
+ (#{binding-value\ 1290}#
+ #{b\ 2147}#)))
+ (#{gen-ref\ 2107}#
+ #{src\ 2140}#
+ (car #{var.lev\ 2148}#)
+ (cdr #{var.lev\ 2148}#)
+ #{maps\ 2143}#)))
+ (lambda (#{var\ 2149}# #{maps\ 2150}#)
+ (values
+ (list (quote ref) #{var\ 2149}#)
+ #{maps\ 2150}#)))
+ (if (#{ellipsis?\ 2144}# #{e\ 2141}#)
(syntax-violation
'syntax
"misplaced ellipsis"
- src957)
- (values (list (quote quote) e958) maps960)))))
- ((lambda (tmp968)
- ((lambda (tmp969)
- (if (if tmp969
- (apply (lambda (dots970 e971)
- (ellipsis?961 dots970))
- tmp969)
+ #{src\ 2140}#)
+ (values
+ (list (quote quote) #{e\ 2141}#)
+ #{maps\ 2143}#)))))
+ ((lambda (#{tmp\ 2151}#)
+ ((lambda (#{tmp\ 2152}#)
+ (if (if #{tmp\ 2152}#
+ (apply (lambda (#{dots\ 2153}# #{e\ 2154}#)
+ (#{ellipsis?\ 2144}#
+ #{dots\ 2153}#))
+ #{tmp\ 2152}#)
#f)
- (apply (lambda (dots972 e973)
- (gen-syntax923
- src957
- e973
- r959
- maps960
- (lambda (x974) #f)
- mod962))
- tmp969)
- ((lambda (tmp975)
- (if (if tmp975
- (apply (lambda (x976 dots977 y978)
- (ellipsis?961 dots977))
- tmp975)
+ (apply (lambda (#{dots\ 2155}# #{e\ 2156}#)
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ #{e\ 2156}#
+ #{r\ 2142}#
+ #{maps\ 2143}#
+ (lambda (#{x\ 2157}#) #f)
+ #{mod\ 2145}#))
+ #{tmp\ 2152}#)
+ ((lambda (#{tmp\ 2158}#)
+ (if (if #{tmp\ 2158}#
+ (apply (lambda (#{x\ 2159}#
+ #{dots\ 2160}#
+ #{y\ 2161}#)
+ (#{ellipsis?\ 2144}#
+ #{dots\ 2160}#))
+ #{tmp\ 2158}#)
#f)
- (apply (lambda (x979 dots980 y981)
- (letrec ((f982 (lambda (y983 k984)
- ((lambda (tmp988)
- ((lambda (tmp989)
- (if (if tmp989
- (apply (lambda (dots990
- y991)
- (ellipsis?961
- dots990))
- tmp989)
- #f)
- (apply (lambda (dots992
- y993)
- (f982 y993
- (lambda (maps994)
- (call-with-values
- (lambda ()
- (k984 (cons '()
- maps994)))
- (lambda (x995
- maps996)
- (if (null? (car maps996))
- (syntax-violation
- 'syntax
- "extra ellipsis"
- src957)
- (values
- (gen-mappend925
- x995
- (car maps996))
- (cdr maps996))))))))
- tmp989)
- ((lambda (_997)
+ (apply (lambda (#{x\ 2162}#
+ #{dots\ 2163}#
+ #{y\ 2164}#)
+ (letrec ((#{f\ 2165}#
+ (lambda (#{y\ 2166}#
+ #{k\ 2167}#)
+ ((lambda (#{tmp\ 2171}#)
+ ((lambda (#{tmp\ 2172}#)
+ (if (if #{tmp\ 2172}#
+ (apply (lambda (#{dots\ 2173}#
+ #{y\ 2174}#)
+ (#{ellipsis?\ 2144}#
+ #{dots\ 2173}#))
+ #{tmp\ 2172}#)
+ #f)
+ (apply (lambda (#{dots\ 2175}#
+ #{y\ 2176}#)
+ (#{f\ 2165}#
+ #{y\ 2176}#
+ (lambda (#{maps\ 2177}#)
+ (call-with-values
+ (lambda ()
+ (#{k\ 2167}#
+ (cons '()
+ #{maps\ 2177}#)))
+ (lambda (#{x\ 2178}#
+ #{maps\ 2179}#)
+ (if (null? (car #{maps\ 2179}#))
+ (syntax-violation
+ 'syntax
+ "extra ellipsis"
+ #{src\ 2140}#)
+ (values
+ (#{gen-mappend\ 2108}#
+ #{x\ 2178}#
+ (car #{maps\ 2179}#))
+ (cdr #{maps\ 2179}#))))))))
+ #{tmp\ 2172}#)
+ ((lambda (#{_\ 2180}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ #{y\ 2166}#
+ #{r\ 2142}#
+ #{maps\ 2143}#
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#))
+ (lambda (#{y\ 2181}#
+ #{maps\ 2182}#)
(call-with-values
(lambda ()
- (gen-syntax923
- src957
- y983
- r959
- maps960
- ellipsis?961
- mod962))
- (lambda (y998
- maps999)
- (call-with-values
- (lambda ()
- (k984 maps999))
- (lambda (x1000
- maps1001)
- (values
- (gen-append928
- x1000
- y998)
- maps1001))))))
- tmp988)))
- ($sc-dispatch
- tmp988
- '(any .
- any))))
- y983))))
- (f982 y981
- (lambda (maps985)
- (call-with-values
- (lambda ()
- (gen-syntax923
- src957
- x979
- r959
- (cons '()
- maps985)
- ellipsis?961
- mod962))
- (lambda (x986 maps987)
- (if (null? (car maps987))
- (syntax-violation
- 'syntax
- "extra ellipsis"
- src957)
- (values
- (gen-map926
- x986
- (car maps987))
- (cdr maps987)))))))))
- tmp975)
- ((lambda (tmp1002)
- (if tmp1002
- (apply (lambda (x1003 y1004)
+ (#{k\ 2167}#
+ #{maps\ 2182}#))
+ (lambda (#{x\ 2183}#
+ #{maps\ 2184}#)
+ (values
+ (#{gen-append\ 2111}#
+ #{x\ 2183}#
+ #{y\ 2181}#)
+ #{maps\ 2184}#))))))
+ #{tmp\ 2171}#)))
+ ($sc-dispatch
+ #{tmp\ 2171}#
+ '(any . any))))
+ #{y\ 2166}#))))
+ (#{f\ 2165}#
+ #{y\ 2164}#
+ (lambda (#{maps\ 2168}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ #{x\ 2162}#
+ #{r\ 2142}#
+ (cons '()
+ #{maps\ 2168}#)
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#))
+ (lambda (#{x\ 2169}#
+ #{maps\ 2170}#)
+ (if (null? (car #{maps\ 2170}#))
+ (syntax-violation
+ 'syntax
+ "extra ellipsis"
+ #{src\ 2140}#)
+ (values
+ (#{gen-map\ 2109}#
+ #{x\ 2169}#
+ (car #{maps\ 2170}#))
+ (cdr #{maps\ 2170}#)))))))))
+ #{tmp\ 2158}#)
+ ((lambda (#{tmp\ 2185}#)
+ (if #{tmp\ 2185}#
+ (apply (lambda (#{x\ 2186}#
+ #{y\ 2187}#)
(call-with-values
(lambda ()
- (gen-syntax923
- src957
- x1003
- r959
- maps960
- ellipsis?961
- mod962))
- (lambda (x1005 maps1006)
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ #{x\ 2186}#
+ #{r\ 2142}#
+ #{maps\ 2143}#
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#))
+ (lambda (#{x\ 2188}#
+ #{maps\ 2189}#)
(call-with-values
(lambda ()
- (gen-syntax923
- src957
- y1004
- r959
- maps1006
- ellipsis?961
- mod962))
- (lambda (y1007
- maps1008)
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ #{y\ 2187}#
+ #{r\ 2142}#
+ #{maps\ 2189}#
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#))
+ (lambda (#{y\ 2190}#
+ #{maps\ 2191}#)
(values
- (gen-cons927
- x1005
- y1007)
- maps1008))))))
- tmp1002)
- ((lambda (tmp1009)
- (if tmp1009
- (apply (lambda (e11010 e21011)
+ (#{gen-cons\ 2110}#
+ #{x\ 2188}#
+ #{y\ 2190}#)
+ #{maps\ 2191}#))))))
+ #{tmp\ 2185}#)
+ ((lambda (#{tmp\ 2192}#)
+ (if #{tmp\ 2192}#
+ (apply (lambda (#{e1\ 2193}#
+ #{e2\ 2194}#)
(call-with-values
(lambda ()
- (gen-syntax923
- src957
- (cons e11010
- e21011)
- r959
- maps960
- ellipsis?961
- mod962))
- (lambda (e1013
- maps1014)
+ (#{gen-syntax\ 2106}#
+ #{src\ 2140}#
+ (cons #{e1\ 2193}#
+ #{e2\ 2194}#)
+ #{r\ 2142}#
+ #{maps\ 2143}#
+ #{ellipsis?\ 2144}#
+ #{mod\ 2145}#))
+ (lambda (#{e\ 2196}#
+ #{maps\ 2197}#)
(values
- (gen-vector929
- e1013)
- maps1014))))
- tmp1009)
- ((lambda (_1015)
+ (#{gen-vector\ 2112}#
+ #{e\ 2196}#)
+ #{maps\ 2197}#))))
+ #{tmp\ 2192}#)
+ ((lambda (#{_\ 2198}#)
(values
- (list (quote quote) e958)
- maps960))
- tmp968)))
+ (list 'quote
+ #{e\ 2141}#)
+ #{maps\ 2143}#))
+ #{tmp\ 2151}#)))
($sc-dispatch
- tmp968
+ #{tmp\ 2151}#
'#(vector (any . each-any))))))
($sc-dispatch
- tmp968
+ #{tmp\ 2151}#
'(any . any)))))
($sc-dispatch
- tmp968
+ #{tmp\ 2151}#
'(any any . any)))))
- ($sc-dispatch tmp968 (quote (any any)))))
- e958)))))
- (lambda (e1016 r1017 w1018 s1019 mod1020)
- (let ((e1021 (source-wrap144 e1016 w1018 s1019 mod1020)))
- ((lambda (tmp1022)
- ((lambda (tmp1023)
- (if tmp1023
- (apply (lambda (_1024 x1025)
+ ($sc-dispatch #{tmp\ 2151}# (quote (any any)))))
+ #{e\ 2141}#)))))
+ (lambda (#{e\ 2199}#
+ #{r\ 2200}#
+ #{w\ 2201}#
+ #{s\ 2202}#
+ #{mod\ 2203}#)
+ (let ((#{e\ 2204}#
+ (#{source-wrap\ 1326}#
+ #{e\ 2199}#
+ #{w\ 2201}#
+ #{s\ 2202}#
+ #{mod\ 2203}#)))
+ ((lambda (#{tmp\ 2205}#)
+ ((lambda (#{tmp\ 2206}#)
+ (if #{tmp\ 2206}#
+ (apply (lambda (#{_\ 2207}# #{x\ 2208}#)
(call-with-values
(lambda ()
- (gen-syntax923
- e1021
- x1025
- r1017
+ (#{gen-syntax\ 2106}#
+ #{e\ 2204}#
+ #{x\ 2208}#
+ #{r\ 2200}#
'()
- ellipsis?160
- mod1020))
- (lambda (e1026 maps1027) (regen930 e1026))))
- tmp1023)
- ((lambda (_1028)
+ #{ellipsis?\ 1342}#
+ #{mod\ 2203}#))
+ (lambda (#{e\ 2209}# #{maps\ 2210}#)
+ (#{regen\ 2113}# #{e\ 2209}#))))
+ #{tmp\ 2206}#)
+ ((lambda (#{_\ 2211}#)
(syntax-violation
'syntax
"bad `syntax' form"
- e1021))
- tmp1022)))
- ($sc-dispatch tmp1022 (quote (any any)))))
- e1021)))))
- (global-extend113
+ #{e\ 2204}#))
+ #{tmp\ 2205}#)))
+ ($sc-dispatch #{tmp\ 2205}# (quote (any any)))))
+ #{e\ 2204}#)))))
+ (#{global-extend\ 1295}#
'core
'lambda
- (lambda (e1029 r1030 w1031 s1032 mod1033)
- ((lambda (tmp1034)
- ((lambda (tmp1035)
- (if tmp1035
- (apply (lambda (_1036 c1037)
- (chi-lambda-clause156
- (source-wrap144 e1029 w1031 s1032 mod1033)
+ (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
- c1037
- r1030
- w1031
- mod1033
- (lambda (names1038
- vars1039
- docstring1040
- body1041)
- (build-lambda91
- s1032
- names1038
- vars1039
- docstring1040
- body1041))))
- tmp1035)
+ #{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"
- tmp1034)))
- ($sc-dispatch tmp1034 (quote (any . any)))))
- e1029)))
- (global-extend113
+ #{tmp\ 2217}#)))
+ ($sc-dispatch #{tmp\ 2217}# (quote (any . any)))))
+ #{e\ 2212}#)))
+ (#{global-extend\ 1295}#
'core
'let
- (letrec ((chi-let1042
- (lambda (e1043
- r1044
- w1045
- s1046
- mod1047
- constructor1048
- ids1049
- vals1050
- exps1051)
- (if (not (valid-bound-ids?140 ids1049))
+ (letrec ((#{chi-let\ 2225}#
+ (lambda (#{e\ 2226}#
+ #{r\ 2227}#
+ #{w\ 2228}#
+ #{s\ 2229}#
+ #{mod\ 2230}#
+ #{constructor\ 2231}#
+ #{ids\ 2232}#
+ #{vals\ 2233}#
+ #{exps\ 2234}#)
+ (if (not (#{valid-bound-ids?\ 1322}# #{ids\ 2232}#))
(syntax-violation
'let
"duplicate bound variable"
- e1043)
- (let ((labels1052 (gen-labels121 ids1049))
- (new-vars1053 (map gen-var162 ids1049)))
- (let ((nw1054
- (make-binding-wrap132
- ids1049
- labels1052
- w1045))
- (nr1055
- (extend-var-env110
- labels1052
- new-vars1053
- r1044)))
- (constructor1048
- s1046
- (map syntax->datum ids1049)
- new-vars1053
- (map (lambda (x1056)
- (chi151 x1056 r1044 w1045 mod1047))
- vals1050)
- (chi-body155
- exps1051
- (source-wrap144 e1043 nw1054 s1046 mod1047)
- nr1055
- nw1054
- mod1047))))))))
- (lambda (e1057 r1058 w1059 s1060 mod1061)
- ((lambda (tmp1062)
- ((lambda (tmp1063)
- (if (if tmp1063
- (apply (lambda (_1064 id1065 val1066 e11067 e21068)
- (and-map id?115 id1065))
- tmp1063)
+ #{e\ 2226}#)
+ (let ((#{labels\ 2235}#
+ (#{gen-labels\ 1303}# #{ids\ 2232}#))
+ (#{new-vars\ 2236}#
+ (map #{gen-var\ 1344}# #{ids\ 2232}#)))
+ (let ((#{nw\ 2237}#
+ (#{make-binding-wrap\ 1314}#
+ #{ids\ 2232}#
+ #{labels\ 2235}#
+ #{w\ 2228}#))
+ (#{nr\ 2238}#
+ (#{extend-var-env\ 1292}#
+ #{labels\ 2235}#
+ #{new-vars\ 2236}#
+ #{r\ 2227}#)))
+ (#{constructor\ 2231}#
+ #{s\ 2229}#
+ (map syntax->datum #{ids\ 2232}#)
+ #{new-vars\ 2236}#
+ (map (lambda (#{x\ 2239}#)
+ (#{chi\ 1333}#
+ #{x\ 2239}#
+ #{r\ 2227}#
+ #{w\ 2228}#
+ #{mod\ 2230}#))
+ #{vals\ 2233}#)
+ (#{chi-body\ 1337}#
+ #{exps\ 2234}#
+ (#{source-wrap\ 1326}#
+ #{e\ 2226}#
+ #{nw\ 2237}#
+ #{s\ 2229}#
+ #{mod\ 2230}#)
+ #{nr\ 2238}#
+ #{nw\ 2237}#
+ #{mod\ 2230}#))))))))
+ (lambda (#{e\ 2240}#
+ #{r\ 2241}#
+ #{w\ 2242}#
+ #{s\ 2243}#
+ #{mod\ 2244}#)
+ ((lambda (#{tmp\ 2245}#)
+ ((lambda (#{tmp\ 2246}#)
+ (if (if #{tmp\ 2246}#
+ (apply (lambda (#{_\ 2247}#
+ #{id\ 2248}#
+ #{val\ 2249}#
+ #{e1\ 2250}#
+ #{e2\ 2251}#)
+ (and-map #{id?\ 1297}# #{id\ 2248}#))
+ #{tmp\ 2246}#)
#f)
- (apply (lambda (_1070 id1071 val1072 e11073 e21074)
- (chi-let1042
- e1057
- r1058
- w1059
- s1060
- mod1061
- build-let95
- id1071
- val1072
- (cons e11073 e21074)))
- tmp1063)
- ((lambda (tmp1078)
- (if (if tmp1078
- (apply (lambda (_1079
- f1080
- id1081
- val1082
- e11083
- e21084)
- (if (id?115 f1080)
- (and-map id?115 id1081)
+ (apply (lambda (#{_\ 2253}#
+ #{id\ 2254}#
+ #{val\ 2255}#
+ #{e1\ 2256}#
+ #{e2\ 2257}#)
+ (#{chi-let\ 2225}#
+ #{e\ 2240}#
+ #{r\ 2241}#
+ #{w\ 2242}#
+ #{s\ 2243}#
+ #{mod\ 2244}#
+ #{build-let\ 1277}#
+ #{id\ 2254}#
+ #{val\ 2255}#
+ (cons #{e1\ 2256}# #{e2\ 2257}#)))
+ #{tmp\ 2246}#)
+ ((lambda (#{tmp\ 2261}#)
+ (if (if #{tmp\ 2261}#
+ (apply (lambda (#{_\ 2262}#
+ #{f\ 2263}#
+ #{id\ 2264}#
+ #{val\ 2265}#
+ #{e1\ 2266}#
+ #{e2\ 2267}#)
+ (if (#{id?\ 1297}# #{f\ 2263}#)
+ (and-map #{id?\ 1297}# #{id\ 2264}#)
#f))
- tmp1078)
+ #{tmp\ 2261}#)
#f)
- (apply (lambda (_1086
- f1087
- id1088
- val1089
- e11090
- e21091)
- (chi-let1042
- e1057
- r1058
- w1059
- s1060
- mod1061
- build-named-let96
- (cons f1087 id1088)
- val1089
- (cons e11090 e21091)))
- tmp1078)
- ((lambda (_1095)
+ (apply (lambda (#{_\ 2269}#
+ #{f\ 2270}#
+ #{id\ 2271}#
+ #{val\ 2272}#
+ #{e1\ 2273}#
+ #{e2\ 2274}#)
+ (#{chi-let\ 2225}#
+ #{e\ 2240}#
+ #{r\ 2241}#
+ #{w\ 2242}#
+ #{s\ 2243}#
+ #{mod\ 2244}#
+ #{build-named-let\ 1278}#
+ (cons #{f\ 2270}# #{id\ 2271}#)
+ #{val\ 2272}#
+ (cons #{e1\ 2273}# #{e2\ 2274}#)))
+ #{tmp\ 2261}#)
+ ((lambda (#{_\ 2278}#)
(syntax-violation
'let
"bad let"
- (source-wrap144 e1057 w1059 s1060 mod1061)))
- tmp1062)))
+ (#{source-wrap\ 1326}#
+ #{e\ 2240}#
+ #{w\ 2242}#
+ #{s\ 2243}#
+ #{mod\ 2244}#)))
+ #{tmp\ 2245}#)))
($sc-dispatch
- tmp1062
+ #{tmp\ 2245}#
'(any any #(each (any any)) any . each-any)))))
($sc-dispatch
- tmp1062
+ #{tmp\ 2245}#
'(any #(each (any any)) any . each-any))))
- e1057))))
- (global-extend113
+ #{e\ 2240}#))))
+ (#{global-extend\ 1295}#
'core
'letrec
- (lambda (e1096 r1097 w1098 s1099 mod1100)
- ((lambda (tmp1101)
- ((lambda (tmp1102)
- (if (if tmp1102
- (apply (lambda (_1103 id1104 val1105 e11106 e21107)
- (and-map id?115 id1104))
- tmp1102)
+ (lambda (#{e\ 2279}#
+ #{r\ 2280}#
+ #{w\ 2281}#
+ #{s\ 2282}#
+ #{mod\ 2283}#)
+ ((lambda (#{tmp\ 2284}#)
+ ((lambda (#{tmp\ 2285}#)
+ (if (if #{tmp\ 2285}#
+ (apply (lambda (#{_\ 2286}#
+ #{id\ 2287}#
+ #{val\ 2288}#
+ #{e1\ 2289}#
+ #{e2\ 2290}#)
+ (and-map #{id?\ 1297}# #{id\ 2287}#))
+ #{tmp\ 2285}#)
#f)
- (apply (lambda (_1109 id1110 val1111 e11112 e21113)
- (let ((ids1114 id1110))
- (if (not (valid-bound-ids?140 ids1114))
+ (apply (lambda (#{_\ 2292}#
+ #{id\ 2293}#
+ #{val\ 2294}#
+ #{e1\ 2295}#
+ #{e2\ 2296}#)
+ (let ((#{ids\ 2297}# #{id\ 2293}#))
+ (if (not (#{valid-bound-ids?\ 1322}#
+ #{ids\ 2297}#))
(syntax-violation
'letrec
"duplicate bound variable"
- e1096)
- (let ((labels1116 (gen-labels121 ids1114))
- (new-vars1117 (map gen-var162 ids1114)))
- (let ((w1118 (make-binding-wrap132
- ids1114
- labels1116
- w1098))
- (r1119 (extend-var-env110
- labels1116
- new-vars1117
- r1097)))
- (build-letrec97
- s1099
- (map syntax->datum ids1114)
- new-vars1117
- (map (lambda (x1120)
- (chi151 x1120 r1119 w1118 mod1100))
- val1111)
- (chi-body155
- (cons e11112 e21113)
- (source-wrap144
- e1096
- w1118
- s1099
- mod1100)
- r1119
- w1118
- mod1100)))))))
- tmp1102)
- ((lambda (_1123)
+ #{e\ 2279}#)
+ (let ((#{labels\ 2299}#
+ (#{gen-labels\ 1303}# #{ids\ 2297}#))
+ (#{new-vars\ 2300}#
+ (map #{gen-var\ 1344}# #{ids\ 2297}#)))
+ (let ((#{w\ 2301}#
+ (#{make-binding-wrap\ 1314}#
+ #{ids\ 2297}#
+ #{labels\ 2299}#
+ #{w\ 2281}#))
+ (#{r\ 2302}#
+ (#{extend-var-env\ 1292}#
+ #{labels\ 2299}#
+ #{new-vars\ 2300}#
+ #{r\ 2280}#)))
+ (#{build-letrec\ 1279}#
+ #{s\ 2282}#
+ (map syntax->datum #{ids\ 2297}#)
+ #{new-vars\ 2300}#
+ (map (lambda (#{x\ 2303}#)
+ (#{chi\ 1333}#
+ #{x\ 2303}#
+ #{r\ 2302}#
+ #{w\ 2301}#
+ #{mod\ 2283}#))
+ #{val\ 2294}#)
+ (#{chi-body\ 1337}#
+ (cons #{e1\ 2295}# #{e2\ 2296}#)
+ (#{source-wrap\ 1326}#
+ #{e\ 2279}#
+ #{w\ 2301}#
+ #{s\ 2282}#
+ #{mod\ 2283}#)
+ #{r\ 2302}#
+ #{w\ 2301}#
+ #{mod\ 2283}#)))))))
+ #{tmp\ 2285}#)
+ ((lambda (#{_\ 2306}#)
(syntax-violation
'letrec
"bad letrec"
- (source-wrap144 e1096 w1098 s1099 mod1100)))
- tmp1101)))
+ (#{source-wrap\ 1326}#
+ #{e\ 2279}#
+ #{w\ 2281}#
+ #{s\ 2282}#
+ #{mod\ 2283}#)))
+ #{tmp\ 2284}#)))
($sc-dispatch
- tmp1101
+ #{tmp\ 2284}#
'(any #(each (any any)) any . each-any))))
- e1096)))
- (global-extend113
+ #{e\ 2279}#)))
+ (#{global-extend\ 1295}#
'core
'set!
- (lambda (e1124 r1125 w1126 s1127 mod1128)
- ((lambda (tmp1129)
- ((lambda (tmp1130)
- (if (if tmp1130
- (apply (lambda (_1131 id1132 val1133) (id?115 id1132))
- tmp1130)
+ (lambda (#{e\ 2307}#
+ #{r\ 2308}#
+ #{w\ 2309}#
+ #{s\ 2310}#
+ #{mod\ 2311}#)
+ ((lambda (#{tmp\ 2312}#)
+ ((lambda (#{tmp\ 2313}#)
+ (if (if #{tmp\ 2313}#
+ (apply (lambda (#{_\ 2314}# #{id\ 2315}# #{val\ 2316}#)
+ (#{id?\ 1297}# #{id\ 2315}#))
+ #{tmp\ 2313}#)
#f)
- (apply (lambda (_1134 id1135 val1136)
- (let ((val1137 (chi151 val1136 r1125 w1126 mod1128))
- (n1138 (id-var-name137 id1135 w1126)))
- (let ((b1139 (lookup112 n1138 r1125 mod1128)))
- (let ((atom-key1140 (binding-type107 b1139)))
- (if (memv atom-key1140 (quote (lexical)))
- (build-lexical-assignment85
- s1127
- (syntax->datum id1135)
- (binding-value108 b1139)
- val1137)
- (if (memv atom-key1140 (quote (global)))
- (build-global-assignment88
- s1127
- n1138
- val1137
- mod1128)
- (if (memv atom-key1140
+ (apply (lambda (#{_\ 2317}# #{id\ 2318}# #{val\ 2319}#)
+ (let ((#{val\ 2320}#
+ (#{chi\ 1333}#
+ #{val\ 2319}#
+ #{r\ 2308}#
+ #{w\ 2309}#
+ #{mod\ 2311}#))
+ (#{n\ 2321}#
+ (#{id-var-name\ 1319}#
+ #{id\ 2318}#
+ #{w\ 2309}#)))
+ (let ((#{b\ 2322}#
+ (#{lookup\ 1294}#
+ #{n\ 2321}#
+ #{r\ 2308}#
+ #{mod\ 2311}#)))
+ (let ((#{atom-key\ 2323}#
+ (#{binding-type\ 1289}# #{b\ 2322}#)))
+ (if (memv #{atom-key\ 2323}#
+ '(lexical))
+ (#{build-lexical-assignment\ 1267}#
+ #{s\ 2310}#
+ (syntax->datum #{id\ 2318}#)
+ (#{binding-value\ 1290}# #{b\ 2322}#)
+ #{val\ 2320}#)
+ (if (memv #{atom-key\ 2323}#
+ '(global))
+ (#{build-global-assignment\ 1270}#
+ #{s\ 2310}#
+ #{n\ 2321}#
+ #{val\ 2320}#
+ #{mod\ 2311}#)
+ (if (memv #{atom-key\ 2323}#
'(displaced-lexical))
(syntax-violation
'set!
"identifier out of context"
- (wrap143 id1135 w1126 mod1128))
+ (#{wrap\ 1325}#
+ #{id\ 2318}#
+ #{w\ 2309}#
+ #{mod\ 2311}#))
(syntax-violation
'set!
"bad set!"
- (source-wrap144
- e1124
- w1126
- s1127
- mod1128)))))))))
- tmp1130)
- ((lambda (tmp1141)
- (if tmp1141
- (apply (lambda (_1142 head1143 tail1144 val1145)
+ (#{source-wrap\ 1326}#
+ #{e\ 2307}#
+ #{w\ 2309}#
+ #{s\ 2310}#
+ #{mod\ 2311}#)))))))))
+ #{tmp\ 2313}#)
+ ((lambda (#{tmp\ 2324}#)
+ (if #{tmp\ 2324}#
+ (apply (lambda (#{_\ 2325}#
+ #{head\ 2326}#
+ #{tail\ 2327}#
+ #{val\ 2328}#)
(call-with-values
(lambda ()
- (syntax-type149
- head1143
- r1125
+ (#{syntax-type\ 1331}#
+ #{head\ 2326}#
+ #{r\ 2308}#
'(())
#f
#f
- mod1128
+ #{mod\ 2311}#
#t))
- (lambda (type1146
- value1147
- ee1148
- ww1149
- ss1150
- modmod1151)
- (if (memv type1146 (quote (module-ref)))
- (let ((val1152
- (chi151
- val1145
- r1125
- w1126
- mod1128)))
+ (lambda (#{type\ 2329}#
+ #{value\ 2330}#
+ #{ee\ 2331}#
+ #{ww\ 2332}#
+ #{ss\ 2333}#
+ #{modmod\ 2334}#)
+ (if (memv #{type\ 2329}#
+ '(module-ref))
+ (let ((#{val\ 2335}#
+ (#{chi\ 1333}#
+ #{val\ 2328}#
+ #{r\ 2308}#
+ #{w\ 2309}#
+ #{mod\ 2311}#)))
(call-with-values
(lambda ()
- (value1147
- (cons head1143 tail1144)))
- (lambda (id1154 mod1155)
- (build-global-assignment88
- s1127
- id1154
- val1152
- mod1155))))
- (build-application82
- s1127
- (chi151
+ (#{value\ 2330}#
+ (cons #{head\ 2326}#
+ #{tail\ 2327}#)))
+ (lambda (#{id\ 2337}# #{mod\ 2338}#)
+ (#{build-global-assignment\ 1270}#
+ #{s\ 2310}#
+ #{id\ 2337}#
+ #{val\ 2335}#
+ #{mod\ 2338}#))))
+ (#{build-application\ 1264}#
+ #{s\ 2310}#
+ (#{chi\ 1333}#
(list '#(syntax-object
setter
((top)
@@ -6492,47 +7154,53 @@
((top) (top))
("i" "i")))
(hygiene guile))
- head1143)
- r1125
- w1126
- mod1128)
- (map (lambda (e1156)
- (chi151
- e1156
- r1125
- w1126
- mod1128))
+ #{head\ 2326}#)
+ #{r\ 2308}#
+ #{w\ 2309}#
+ #{mod\ 2311}#)
+ (map (lambda (#{e\ 2339}#)
+ (#{chi\ 1333}#
+ #{e\ 2339}#
+ #{r\ 2308}#
+ #{w\ 2309}#
+ #{mod\ 2311}#))
(append
- tail1144
- (list val1145))))))))
- tmp1141)
- ((lambda (_1158)
+ #{tail\ 2327}#
+ (list #{val\ 2328}#))))))))
+ #{tmp\ 2324}#)
+ ((lambda (#{_\ 2341}#)
(syntax-violation
'set!
"bad set!"
- (source-wrap144 e1124 w1126 s1127 mod1128)))
- tmp1129)))
+ (#{source-wrap\ 1326}#
+ #{e\ 2307}#
+ #{w\ 2309}#
+ #{s\ 2310}#
+ #{mod\ 2311}#)))
+ #{tmp\ 2312}#)))
($sc-dispatch
- tmp1129
+ #{tmp\ 2312}#
'(any (any . each-any) any)))))
- ($sc-dispatch tmp1129 (quote (any any any)))))
- e1124)))
- (global-extend113
+ ($sc-dispatch
+ #{tmp\ 2312}#
+ '(any any any))))
+ #{e\ 2307}#)))
+ (#{global-extend\ 1295}#
'module-ref
'@
- (lambda (e1159)
- ((lambda (tmp1160)
- ((lambda (tmp1161)
- (if (if tmp1161
- (apply (lambda (_1162 mod1163 id1164)
- (if (and-map id?115 mod1163)
- (id?115 id1164)
+ (lambda (#{e\ 2342}#)
+ ((lambda (#{tmp\ 2343}#)
+ ((lambda (#{tmp\ 2344}#)
+ (if (if #{tmp\ 2344}#
+ (apply (lambda (#{_\ 2345}# #{mod\ 2346}# #{id\ 2347}#)
+ (if (and-map #{id?\ 1297}# #{mod\ 2346}#)
+ (#{id?\ 1297}# #{id\ 2347}#)
#f))
- tmp1161)
+ #{tmp\ 2344}#)
#f)
- (apply (lambda (_1166 mod1167 id1168)
+ (apply (lambda (#{_\ 2349}# #{mod\ 2350}# #{id\ 2351}#)
(values
- (syntax->datum id1168)
+ (syntax->datum #{id\ 2351}#)
(syntax->datum
(cons '#(syntax-object
public
@@ -6885,30 +7553,32 @@
((top) (top))
("i" "i")))
(hygiene guile))
- mod1167))))
- tmp1161)
+ #{mod\ 2350}#))))
+ #{tmp\ 2344}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1160)))
- ($sc-dispatch tmp1160 (quote (any each-any any)))))
- e1159)))
- (global-extend113
+ #{tmp\ 2343}#)))
+ ($sc-dispatch
+ #{tmp\ 2343}#
+ '(any each-any any))))
+ #{e\ 2342}#)))
+ (#{global-extend\ 1295}#
'module-ref
'@@
- (lambda (e1170)
- ((lambda (tmp1171)
- ((lambda (tmp1172)
- (if (if tmp1172
- (apply (lambda (_1173 mod1174 id1175)
- (if (and-map id?115 mod1174)
- (id?115 id1175)
+ (lambda (#{e\ 2353}#)
+ ((lambda (#{tmp\ 2354}#)
+ ((lambda (#{tmp\ 2355}#)
+ (if (if #{tmp\ 2355}#
+ (apply (lambda (#{_\ 2356}# #{mod\ 2357}# #{id\ 2358}#)
+ (if (and-map #{id?\ 1297}# #{mod\ 2357}#)
+ (#{id?\ 1297}# #{id\ 2358}#)
#f))
- tmp1172)
+ #{tmp\ 2355}#)
#f)
- (apply (lambda (_1177 mod1178 id1179)
+ (apply (lambda (#{_\ 2360}# #{mod\ 2361}# #{id\ 2362}#)
(values
- (syntax->datum id1179)
+ (syntax->datum #{id\ 2362}#)
(syntax->datum
(cons '#(syntax-object
private
@@ -7261,84 +7931,123 @@
((top) (top))
("i" "i")))
(hygiene guile))
- mod1178))))
- tmp1172)
+ #{mod\ 2361}#))))
+ #{tmp\ 2355}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1171)))
- ($sc-dispatch tmp1171 (quote (any each-any any)))))
- e1170)))
- (global-extend113
+ #{tmp\ 2354}#)))
+ ($sc-dispatch
+ #{tmp\ 2354}#
+ '(any each-any any))))
+ #{e\ 2353}#)))
+ (#{global-extend\ 1295}#
'core
'if
- (lambda (e1181 r1182 w1183 s1184 mod1185)
- ((lambda (tmp1186)
- ((lambda (tmp1187)
- (if tmp1187
- (apply (lambda (_1188 test1189 then1190)
- (build-conditional83
- s1184
- (chi151 test1189 r1182 w1183 mod1185)
- (chi151 then1190 r1182 w1183 mod1185)
- (build-void81 #f)))
- tmp1187)
- ((lambda (tmp1191)
- (if tmp1191
- (apply (lambda (_1192 test1193 then1194 else1195)
- (build-conditional83
- s1184
- (chi151 test1193 r1182 w1183 mod1185)
- (chi151 then1194 r1182 w1183 mod1185)
- (chi151 else1195 r1182 w1183 mod1185)))
- tmp1191)
+ (lambda (#{e\ 2364}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{s\ 2367}#
+ #{mod\ 2368}#)
+ ((lambda (#{tmp\ 2369}#)
+ ((lambda (#{tmp\ 2370}#)
+ (if #{tmp\ 2370}#
+ (apply (lambda (#{_\ 2371}# #{test\ 2372}# #{then\ 2373}#)
+ (#{build-conditional\ 1265}#
+ #{s\ 2367}#
+ (#{chi\ 1333}#
+ #{test\ 2372}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{mod\ 2368}#)
+ (#{chi\ 1333}#
+ #{then\ 2373}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{mod\ 2368}#)
+ (#{build-void\ 1263}# #f)))
+ #{tmp\ 2370}#)
+ ((lambda (#{tmp\ 2374}#)
+ (if #{tmp\ 2374}#
+ (apply (lambda (#{_\ 2375}#
+ #{test\ 2376}#
+ #{then\ 2377}#
+ #{else\ 2378}#)
+ (#{build-conditional\ 1265}#
+ #{s\ 2367}#
+ (#{chi\ 1333}#
+ #{test\ 2376}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{mod\ 2368}#)
+ (#{chi\ 1333}#
+ #{then\ 2377}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{mod\ 2368}#)
+ (#{chi\ 1333}#
+ #{else\ 2378}#
+ #{r\ 2365}#
+ #{w\ 2366}#
+ #{mod\ 2368}#)))
+ #{tmp\ 2374}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1186)))
- ($sc-dispatch tmp1186 (quote (any any any any))))))
- ($sc-dispatch tmp1186 (quote (any any any)))))
- e1181)))
- (global-extend113
+ #{tmp\ 2369}#)))
+ ($sc-dispatch
+ #{tmp\ 2369}#
+ '(any any any any)))))
+ ($sc-dispatch
+ #{tmp\ 2369}#
+ '(any any any))))
+ #{e\ 2364}#)))
+ (#{global-extend\ 1295}#
'begin
'begin
'())
- (global-extend113
+ (#{global-extend\ 1295}#
'define
'define
'())
- (global-extend113
+ (#{global-extend\ 1295}#
'define-syntax
'define-syntax
'())
- (global-extend113
+ (#{global-extend\ 1295}#
'eval-when
'eval-when
'())
- (global-extend113
+ (#{global-extend\ 1295}#
'core
'syntax-case
- (letrec ((gen-syntax-case1199
- (lambda (x1200 keys1201 clauses1202 r1203 mod1204)
- (if (null? clauses1202)
- (build-application82
+ (letrec ((#{gen-syntax-case\ 2382}#
+ (lambda (#{x\ 2383}#
+ #{keys\ 2384}#
+ #{clauses\ 2385}#
+ #{r\ 2386}#
+ #{mod\ 2387}#)
+ (if (null? #{clauses\ 2385}#)
+ (#{build-application\ 1264}#
#f
- (build-primref92 #f (quote syntax-violation))
- (list (build-data93 #f #f)
- (build-data93
+ (#{build-primref\ 1274}#
+ #f
+ 'syntax-violation)
+ (list (#{build-data\ 1275}# #f #f)
+ (#{build-data\ 1275}#
#f
"source expression failed to match any pattern")
- x1200))
- ((lambda (tmp1205)
- ((lambda (tmp1206)
- (if tmp1206
- (apply (lambda (pat1207 exp1208)
- (if (if (id?115 pat1207)
+ #{x\ 2383}#))
+ ((lambda (#{tmp\ 2388}#)
+ ((lambda (#{tmp\ 2389}#)
+ (if #{tmp\ 2389}#
+ (apply (lambda (#{pat\ 2390}# #{exp\ 2391}#)
+ (if (if (#{id?\ 1297}# #{pat\ 2390}#)
(and-map
- (lambda (x1209)
- (not (free-id=?138
- pat1207
- x1209)))
+ (lambda (#{x\ 2392}#)
+ (not (#{free-id=?\ 1320}#
+ #{pat\ 2390}#
+ #{x\ 2392}#)))
(cons '#(syntax-object
...
((top)
@@ -7716,620 +8425,731 @@
((top) (top))
("i" "i")))
(hygiene guile))
- keys1201))
+ #{keys\ 2384}#))
#f)
- (let ((labels1210
- (list (gen-label120)))
- (var1211 (gen-var162 pat1207)))
- (build-application82
+ (let ((#{labels\ 2393}#
+ (list (#{gen-label\ 1302}#)))
+ (#{var\ 2394}#
+ (#{gen-var\ 1344}#
+ #{pat\ 2390}#)))
+ (#{build-application\ 1264}#
#f
- (build-lambda91
+ (#{build-lambda\ 1273}#
#f
- (list (syntax->datum pat1207))
- (list var1211)
+ (list (syntax->datum
+ #{pat\ 2390}#))
+ (list #{var\ 2394}#)
#f
- (chi151
- exp1208
- (extend-env109
- labels1210
+ (#{chi\ 1333}#
+ #{exp\ 2391}#
+ (#{extend-env\ 1291}#
+ #{labels\ 2393}#
(list (cons 'syntax
- (cons var1211
+ (cons #{var\ 2394}#
0)))
- r1203)
- (make-binding-wrap132
- (list pat1207)
- labels1210
+ #{r\ 2386}#)
+ (#{make-binding-wrap\ 1314}#
+ (list #{pat\ 2390}#)
+ #{labels\ 2393}#
'(()))
- mod1204))
- (list x1200)))
- (gen-clause1198
- x1200
- keys1201
- (cdr clauses1202)
- r1203
- pat1207
+ #{mod\ 2387}#))
+ (list #{x\ 2383}#)))
+ (#{gen-clause\ 2381}#
+ #{x\ 2383}#
+ #{keys\ 2384}#
+ (cdr #{clauses\ 2385}#)
+ #{r\ 2386}#
+ #{pat\ 2390}#
#t
- exp1208
- mod1204)))
- tmp1206)
- ((lambda (tmp1212)
- (if tmp1212
- (apply (lambda (pat1213 fender1214 exp1215)
- (gen-clause1198
- x1200
- keys1201
- (cdr clauses1202)
- r1203
- pat1213
- fender1214
- exp1215
- mod1204))
- tmp1212)
- ((lambda (_1216)
+ #{exp\ 2391}#
+ #{mod\ 2387}#)))
+ #{tmp\ 2389}#)
+ ((lambda (#{tmp\ 2395}#)
+ (if #{tmp\ 2395}#
+ (apply (lambda (#{pat\ 2396}#
+ #{fender\ 2397}#
+ #{exp\ 2398}#)
+ (#{gen-clause\ 2381}#
+ #{x\ 2383}#
+ #{keys\ 2384}#
+ (cdr #{clauses\ 2385}#)
+ #{r\ 2386}#
+ #{pat\ 2396}#
+ #{fender\ 2397}#
+ #{exp\ 2398}#
+ #{mod\ 2387}#))
+ #{tmp\ 2395}#)
+ ((lambda (#{_\ 2399}#)
(syntax-violation
'syntax-case
"invalid clause"
- (car clauses1202)))
- tmp1205)))
- ($sc-dispatch tmp1205 (quote (any any any))))))
- ($sc-dispatch tmp1205 (quote (any any)))))
- (car clauses1202)))))
- (gen-clause1198
- (lambda (x1217
- keys1218
- clauses1219
- r1220
- pat1221
- fender1222
- exp1223
- mod1224)
+ (car #{clauses\ 2385}#)))
+ #{tmp\ 2388}#)))
+ ($sc-dispatch
+ #{tmp\ 2388}#
+ '(any any any)))))
+ ($sc-dispatch #{tmp\ 2388}# (quote (any any)))))
+ (car #{clauses\ 2385}#)))))
+ (#{gen-clause\ 2381}#
+ (lambda (#{x\ 2400}#
+ #{keys\ 2401}#
+ #{clauses\ 2402}#
+ #{r\ 2403}#
+ #{pat\ 2404}#
+ #{fender\ 2405}#
+ #{exp\ 2406}#
+ #{mod\ 2407}#)
(call-with-values
(lambda ()
- (convert-pattern1196 pat1221 keys1218))
- (lambda (p1225 pvars1226)
- (if (not (distinct-bound-ids?141 (map car pvars1226)))
+ (#{convert-pattern\ 2379}#
+ #{pat\ 2404}#
+ #{keys\ 2401}#))
+ (lambda (#{p\ 2408}# #{pvars\ 2409}#)
+ (if (not (#{distinct-bound-ids?\ 1323}#
+ (map car #{pvars\ 2409}#)))
(syntax-violation
'syntax-case
"duplicate pattern variable"
- pat1221)
+ #{pat\ 2404}#)
(if (not (and-map
- (lambda (x1227)
- (not (ellipsis?160 (car x1227))))
- pvars1226))
+ (lambda (#{x\ 2410}#)
+ (not (#{ellipsis?\ 1342}#
+ (car #{x\ 2410}#))))
+ #{pvars\ 2409}#))
(syntax-violation
'syntax-case
"misplaced ellipsis"
- pat1221)
- (let ((y1228 (gen-var162 (quote tmp))))
- (build-application82
+ #{pat\ 2404}#)
+ (let ((#{y\ 2411}#
+ (#{gen-var\ 1344}# (quote tmp))))
+ (#{build-application\ 1264}#
#f
- (build-lambda91
+ (#{build-lambda\ 1273}#
#f
(list (quote tmp))
- (list y1228)
+ (list #{y\ 2411}#)
#f
- (let ((y1229 (build-lexical-reference84
- 'value
- #f
- 'tmp
- y1228)))
- (build-conditional83
+ (let ((#{y\ 2412}#
+ (#{build-lexical-reference\ 1266}#
+ 'value
+ #f
+ 'tmp
+ #{y\ 2411}#)))
+ (#{build-conditional\ 1265}#
#f
- ((lambda (tmp1230)
- ((lambda (tmp1231)
- (if tmp1231
- (apply (lambda () y1229)
- tmp1231)
- ((lambda (_1232)
- (build-conditional83
+ ((lambda (#{tmp\ 2413}#)
+ ((lambda (#{tmp\ 2414}#)
+ (if #{tmp\ 2414}#
+ (apply (lambda () #{y\ 2412}#)
+ #{tmp\ 2414}#)
+ ((lambda (#{_\ 2415}#)
+ (#{build-conditional\ 1265}#
#f
- y1229
- (build-dispatch-call1197
- pvars1226
- fender1222
- y1229
- r1220
- mod1224)
- (build-data93 #f #f)))
- tmp1230)))
+ #{y\ 2412}#
+ (#{build-dispatch-call\ 2380}#
+ #{pvars\ 2409}#
+ #{fender\ 2405}#
+ #{y\ 2412}#
+ #{r\ 2403}#
+ #{mod\ 2407}#)
+ (#{build-data\ 1275}#
+ #f
+ #f)))
+ #{tmp\ 2413}#)))
($sc-dispatch
- tmp1230
+ #{tmp\ 2413}#
'#(atom #t))))
- fender1222)
- (build-dispatch-call1197
- pvars1226
- exp1223
- y1229
- r1220
- mod1224)
- (gen-syntax-case1199
- x1217
- keys1218
- clauses1219
- r1220
- mod1224))))
- (list (if (eq? p1225 (quote any))
- (build-application82
+ #{fender\ 2405}#)
+ (#{build-dispatch-call\ 2380}#
+ #{pvars\ 2409}#
+ #{exp\ 2406}#
+ #{y\ 2412}#
+ #{r\ 2403}#
+ #{mod\ 2407}#)
+ (#{gen-syntax-case\ 2382}#
+ #{x\ 2400}#
+ #{keys\ 2401}#
+ #{clauses\ 2402}#
+ #{r\ 2403}#
+ #{mod\ 2407}#))))
+ (list (if (eq? #{p\ 2408}# (quote any))
+ (#{build-application\ 1264}#
#f
- (build-primref92 #f (quote list))
- (list x1217))
- (build-application82
+ (#{build-primref\ 1274}#
+ #f
+ 'list)
+ (list #{x\ 2400}#))
+ (#{build-application\ 1264}#
#f
- (build-primref92
+ (#{build-primref\ 1274}#
#f
'$sc-dispatch)
- (list x1217
- (build-data93
+ (list #{x\ 2400}#
+ (#{build-data\ 1275}#
#f
- p1225)))))))))))))
- (build-dispatch-call1197
- (lambda (pvars1233 exp1234 y1235 r1236 mod1237)
- (let ((ids1238 (map car pvars1233))
- (levels1239 (map cdr pvars1233)))
- (let ((labels1240 (gen-labels121 ids1238))
- (new-vars1241 (map gen-var162 ids1238)))
- (build-application82
+ #{p\ 2408}#)))))))))))))
+ (#{build-dispatch-call\ 2380}#
+ (lambda (#{pvars\ 2416}#
+ #{exp\ 2417}#
+ #{y\ 2418}#
+ #{r\ 2419}#
+ #{mod\ 2420}#)
+ (let ((#{ids\ 2421}# (map car #{pvars\ 2416}#))
+ (#{levels\ 2422}# (map cdr #{pvars\ 2416}#)))
+ (let ((#{labels\ 2423}#
+ (#{gen-labels\ 1303}# #{ids\ 2421}#))
+ (#{new-vars\ 2424}#
+ (map #{gen-var\ 1344}# #{ids\ 2421}#)))
+ (#{build-application\ 1264}#
#f
- (build-primref92 #f (quote apply))
- (list (build-lambda91
+ (#{build-primref\ 1274}# #f (quote apply))
+ (list (#{build-lambda\ 1273}#
#f
- (map syntax->datum ids1238)
- new-vars1241
+ (map syntax->datum #{ids\ 2421}#)
+ #{new-vars\ 2424}#
#f
- (chi151
- exp1234
- (extend-env109
- labels1240
- (map (lambda (var1242 level1243)
+ (#{chi\ 1333}#
+ #{exp\ 2417}#
+ (#{extend-env\ 1291}#
+ #{labels\ 2423}#
+ (map (lambda (#{var\ 2425}#
+ #{level\ 2426}#)
(cons 'syntax
- (cons var1242 level1243)))
- new-vars1241
- (map cdr pvars1233))
- r1236)
- (make-binding-wrap132
- ids1238
- labels1240
+ (cons #{var\ 2425}#
+ #{level\ 2426}#)))
+ #{new-vars\ 2424}#
+ (map cdr #{pvars\ 2416}#))
+ #{r\ 2419}#)
+ (#{make-binding-wrap\ 1314}#
+ #{ids\ 2421}#
+ #{labels\ 2423}#
'(()))
- mod1237))
- y1235))))))
- (convert-pattern1196
- (lambda (pattern1244 keys1245)
- (letrec ((cvt1246
- (lambda (p1247 n1248 ids1249)
- (if (id?115 p1247)
- (if (bound-id-member?142 p1247 keys1245)
+ #{mod\ 2420}#))
+ #{y\ 2418}#))))))
+ (#{convert-pattern\ 2379}#
+ (lambda (#{pattern\ 2427}# #{keys\ 2428}#)
+ (letrec ((#{cvt\ 2429}#
+ (lambda (#{p\ 2430}# #{n\ 2431}# #{ids\ 2432}#)
+ (if (#{id?\ 1297}# #{p\ 2430}#)
+ (if (#{bound-id-member?\ 1324}#
+ #{p\ 2430}#
+ #{keys\ 2428}#)
(values
- (vector (quote free-id) p1247)
- ids1249)
+ (vector (quote free-id) #{p\ 2430}#)
+ #{ids\ 2432}#)
(values
'any
- (cons (cons p1247 n1248) ids1249)))
- ((lambda (tmp1250)
- ((lambda (tmp1251)
- (if (if tmp1251
- (apply (lambda (x1252 dots1253)
- (ellipsis?160
- dots1253))
- tmp1251)
+ (cons (cons #{p\ 2430}# #{n\ 2431}#)
+ #{ids\ 2432}#)))
+ ((lambda (#{tmp\ 2433}#)
+ ((lambda (#{tmp\ 2434}#)
+ (if (if #{tmp\ 2434}#
+ (apply (lambda (#{x\ 2435}#
+ #{dots\ 2436}#)
+ (#{ellipsis?\ 1342}#
+ #{dots\ 2436}#))
+ #{tmp\ 2434}#)
#f)
- (apply (lambda (x1254 dots1255)
+ (apply (lambda (#{x\ 2437}#
+ #{dots\ 2438}#)
(call-with-values
(lambda ()
- (cvt1246
- x1254
- (fx+72 n1248 1)
- ids1249))
- (lambda (p1256 ids1257)
+ (#{cvt\ 2429}#
+ #{x\ 2437}#
+ (#{fx+\ 1254}#
+ #{n\ 2431}#
+ 1)
+ #{ids\ 2432}#))
+ (lambda (#{p\ 2439}#
+ #{ids\ 2440}#)
(values
- (if (eq? p1256
+ (if (eq? #{p\ 2439}#
'any)
'each-any
(vector
'each
- p1256))
- ids1257))))
- tmp1251)
- ((lambda (tmp1258)
- (if tmp1258
- (apply (lambda (x1259 y1260)
+ #{p\ 2439}#))
+ #{ids\ 2440}#))))
+ #{tmp\ 2434}#)
+ ((lambda (#{tmp\ 2441}#)
+ (if #{tmp\ 2441}#
+ (apply (lambda (#{x\ 2442}#
+ #{y\ 2443}#)
(call-with-values
(lambda ()
- (cvt1246
- y1260
- n1248
- ids1249))
- (lambda (y1261
- ids1262)
+ (#{cvt\ 2429}#
+ #{y\ 2443}#
+ #{n\ 2431}#
+ #{ids\ 2432}#))
+ (lambda (#{y\ 2444}#
+ #{ids\ 2445}#)
(call-with-values
(lambda ()
- (cvt1246
- x1259
- n1248
- ids1262))
- (lambda (x1263
- ids1264)
+ (#{cvt\ 2429}#
+ #{x\ 2442}#
+ #{n\ 2431}#
+ #{ids\ 2445}#))
+ (lambda (#{x\ 2446}#
+ #{ids\ 2447}#)
(values
- (cons x1263
- y1261)
- ids1264))))))
- tmp1258)
- ((lambda (tmp1265)
- (if tmp1265
+ (cons #{x\ 2446}#
+ #{y\ 2444}#)
+ #{ids\ 2447}#))))))
+ #{tmp\ 2441}#)
+ ((lambda (#{tmp\ 2448}#)
+ (if #{tmp\ 2448}#
(apply (lambda ()
(values
'()
- ids1249))
- tmp1265)
- ((lambda (tmp1266)
- (if tmp1266
- (apply (lambda (x1267)
+ #{ids\ 2432}#))
+ #{tmp\ 2448}#)
+ ((lambda (#{tmp\ 2449}#)
+ (if #{tmp\ 2449}#
+ (apply (lambda (#{x\ 2450}#)
(call-with-values
(lambda ()
- (cvt1246
- x1267
- n1248
- ids1249))
- (lambda (p1269
- ids1270)
+ (#{cvt\ 2429}#
+ #{x\ 2450}#
+ #{n\ 2431}#
+ #{ids\ 2432}#))
+ (lambda (#{p\ 2452}#
+ #{ids\ 2453}#)
(values
(vector
'vector
- p1269)
- ids1270))))
- tmp1266)
- ((lambda (x1271)
+ #{p\ 2452}#)
+ #{ids\ 2453}#))))
+ #{tmp\ 2449}#)
+ ((lambda (#{x\ 2454}#)
(values
(vector
'atom
- (strip161
- p1247
+ (#{strip\ 1343}#
+ #{p\ 2430}#
'(())))
- ids1249))
- tmp1250)))
+ #{ids\ 2432}#))
+ #{tmp\ 2433}#)))
($sc-dispatch
- tmp1250
+ #{tmp\ 2433}#
'#(vector
each-any)))))
($sc-dispatch
- tmp1250
+ #{tmp\ 2433}#
'()))))
($sc-dispatch
- tmp1250
+ #{tmp\ 2433}#
'(any . any)))))
($sc-dispatch
- tmp1250
+ #{tmp\ 2433}#
'(any any))))
- p1247)))))
- (cvt1246 pattern1244 0 (quote ()))))))
- (lambda (e1272 r1273 w1274 s1275 mod1276)
- (let ((e1277 (source-wrap144 e1272 w1274 s1275 mod1276)))
- ((lambda (tmp1278)
- ((lambda (tmp1279)
- (if tmp1279
- (apply (lambda (_1280 val1281 key1282 m1283)
+ #{p\ 2430}#)))))
+ (#{cvt\ 2429}# #{pattern\ 2427}# 0 (quote ()))))))
+ (lambda (#{e\ 2455}#
+ #{r\ 2456}#
+ #{w\ 2457}#
+ #{s\ 2458}#
+ #{mod\ 2459}#)
+ (let ((#{e\ 2460}#
+ (#{source-wrap\ 1326}#
+ #{e\ 2455}#
+ #{w\ 2457}#
+ #{s\ 2458}#
+ #{mod\ 2459}#)))
+ ((lambda (#{tmp\ 2461}#)
+ ((lambda (#{tmp\ 2462}#)
+ (if #{tmp\ 2462}#
+ (apply (lambda (#{_\ 2463}#
+ #{val\ 2464}#
+ #{key\ 2465}#
+ #{m\ 2466}#)
(if (and-map
- (lambda (x1284)
- (if (id?115 x1284)
- (not (ellipsis?160 x1284))
+ (lambda (#{x\ 2467}#)
+ (if (#{id?\ 1297}# #{x\ 2467}#)
+ (not (#{ellipsis?\ 1342}#
+ #{x\ 2467}#))
#f))
- key1282)
- (let ((x1286 (gen-var162 (quote tmp))))
- (build-application82
- s1275
- (build-lambda91
+ #{key\ 2465}#)
+ (let ((#{x\ 2469}#
+ (#{gen-var\ 1344}# (quote tmp))))
+ (#{build-application\ 1264}#
+ #{s\ 2458}#
+ (#{build-lambda\ 1273}#
#f
(list (quote tmp))
- (list x1286)
+ (list #{x\ 2469}#)
#f
- (gen-syntax-case1199
- (build-lexical-reference84
+ (#{gen-syntax-case\ 2382}#
+ (#{build-lexical-reference\ 1266}#
'value
#f
'tmp
- x1286)
- key1282
- m1283
- r1273
- mod1276))
- (list (chi151
- val1281
- r1273
+ #{x\ 2469}#)
+ #{key\ 2465}#
+ #{m\ 2466}#
+ #{r\ 2456}#
+ #{mod\ 2459}#))
+ (list (#{chi\ 1333}#
+ #{val\ 2464}#
+ #{r\ 2456}#
'(())
- mod1276))))
+ #{mod\ 2459}#))))
(syntax-violation
'syntax-case
"invalid literals list"
- e1277)))
- tmp1279)
+ #{e\ 2460}#)))
+ #{tmp\ 2462}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1278)))
+ #{tmp\ 2461}#)))
($sc-dispatch
- tmp1278
+ #{tmp\ 2461}#
'(any any each-any . each-any))))
- e1277)))))
+ #{e\ 2460}#)))))
(set! sc-expand
- (lambda (x1290 . rest1289)
- (if (if (pair? x1290)
- (equal? (car x1290) noexpand70)
+ (lambda (#{x\ 2473}# . #{rest\ 2472}#)
+ (if (if (pair? #{x\ 2473}#)
+ (equal? (car #{x\ 2473}#) #{noexpand\ 1252}#)
#f)
- (cadr x1290)
- (let ((m1291 (if (null? rest1289) (quote e) (car rest1289)))
- (esew1292
- (if (let ((t1293 (null? rest1289)))
- (if t1293 t1293 (null? (cdr rest1289))))
+ (cadr #{x\ 2473}#)
+ (let ((#{m\ 2474}#
+ (if (null? #{rest\ 2472}#)
+ 'e
+ (car #{rest\ 2472}#)))
+ (#{esew\ 2475}#
+ (if (let ((#{t\ 2476}# (null? #{rest\ 2472}#)))
+ (if #{t\ 2476}#
+ #{t\ 2476}#
+ (null? (cdr #{rest\ 2472}#))))
'(eval)
- (cadr rest1289))))
+ (cadr #{rest\ 2472}#))))
(with-fluid*
- *mode*71
- m1291
+ #{*mode*\ 1253}#
+ #{m\ 2474}#
(lambda ()
- (chi-top150
- x1290
+ (#{chi-top\ 1332}#
+ #{x\ 2473}#
'()
'((top))
- m1291
- esew1292
+ #{m\ 2474}#
+ #{esew\ 2475}#
(cons 'hygiene
(module-name (current-module))))))))))
(set! identifier?
- (lambda (x1294) (nonsymbol-id?114 x1294)))
+ (lambda (#{x\ 2477}#)
+ (#{nonsymbol-id?\ 1296}# #{x\ 2477}#)))
(set! datum->syntax
- (lambda (id1295 datum1296)
- (make-syntax-object98
- datum1296
- (syntax-object-wrap101 id1295)
+ (lambda (#{id\ 2478}# #{datum\ 2479}#)
+ (#{make-syntax-object\ 1280}#
+ #{datum\ 2479}#
+ (#{syntax-object-wrap\ 1283}# #{id\ 2478}#)
#f)))
(set! syntax->datum
- (lambda (x1297) (strip161 x1297 (quote (())))))
+ (lambda (#{x\ 2480}#)
+ (#{strip\ 1343}# #{x\ 2480}# (quote (())))))
(set! generate-temporaries
- (lambda (ls1298)
+ (lambda (#{ls\ 2481}#)
(begin
- (let ((x1299 ls1298))
- (if (not (list? x1299))
+ (let ((#{x\ 2482}# #{ls\ 2481}#))
+ (if (not (list? #{x\ 2482}#))
(syntax-violation
'generate-temporaries
"invalid argument"
- x1299)))
- (map (lambda (x1300)
- (wrap143 (gensym) (quote ((top))) #f))
- ls1298))))
+ #{x\ 2482}#)))
+ (map (lambda (#{x\ 2483}#)
+ (#{wrap\ 1325}# (gensym) (quote ((top))) #f))
+ #{ls\ 2481}#))))
(set! free-identifier=?
- (lambda (x1301 y1302)
+ (lambda (#{x\ 2484}# #{y\ 2485}#)
(begin
- (let ((x1303 x1301))
- (if (not (nonsymbol-id?114 x1303))
+ (let ((#{x\ 2486}# #{x\ 2484}#))
+ (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2486}#))
(syntax-violation
'free-identifier=?
"invalid argument"
- x1303)))
- (let ((x1304 y1302))
- (if (not (nonsymbol-id?114 x1304))
+ #{x\ 2486}#)))
+ (let ((#{x\ 2487}# #{y\ 2485}#))
+ (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2487}#))
(syntax-violation
'free-identifier=?
"invalid argument"
- x1304)))
- (free-id=?138 x1301 y1302))))
+ #{x\ 2487}#)))
+ (#{free-id=?\ 1320}# #{x\ 2484}# #{y\ 2485}#))))
(set! bound-identifier=?
- (lambda (x1305 y1306)
+ (lambda (#{x\ 2488}# #{y\ 2489}#)
(begin
- (let ((x1307 x1305))
- (if (not (nonsymbol-id?114 x1307))
+ (let ((#{x\ 2490}# #{x\ 2488}#))
+ (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2490}#))
(syntax-violation
'bound-identifier=?
"invalid argument"
- x1307)))
- (let ((x1308 y1306))
- (if (not (nonsymbol-id?114 x1308))
+ #{x\ 2490}#)))
+ (let ((#{x\ 2491}# #{y\ 2489}#))
+ (if (not (#{nonsymbol-id?\ 1296}# #{x\ 2491}#))
(syntax-violation
'bound-identifier=?
"invalid argument"
- x1308)))
- (bound-id=?139 x1305 y1306))))
+ #{x\ 2491}#)))
+ (#{bound-id=?\ 1321}# #{x\ 2488}# #{y\ 2489}#))))
(set! syntax-violation
- (lambda (who1312 message1311 form1310 . subform1309)
+ (lambda (#{who\ 2495}#
+ #{message\ 2494}#
+ #{form\ 2493}#
+ .
+ #{subform\ 2492}#)
(begin
- (let ((x1313 who1312))
- (if (not ((lambda (x1314)
- (let ((t1315 (not x1314)))
- (if t1315
- t1315
- (let ((t1316 (string? x1314)))
- (if t1316 t1316 (symbol? x1314))))))
- x1313))
+ (let ((#{x\ 2496}# #{who\ 2495}#))
+ (if (not ((lambda (#{x\ 2497}#)
+ (let ((#{t\ 2498}# (not #{x\ 2497}#)))
+ (if #{t\ 2498}#
+ #{t\ 2498}#
+ (let ((#{t\ 2499}# (string? #{x\ 2497}#)))
+ (if #{t\ 2499}#
+ #{t\ 2499}#
+ (symbol? #{x\ 2497}#))))))
+ #{x\ 2496}#))
(syntax-violation
'syntax-violation
"invalid argument"
- x1313)))
- (let ((x1317 message1311))
- (if (not (string? x1317))
+ #{x\ 2496}#)))
+ (let ((#{x\ 2500}# #{message\ 2494}#))
+ (if (not (string? #{x\ 2500}#))
(syntax-violation
'syntax-violation
"invalid argument"
- x1317)))
+ #{x\ 2500}#)))
(scm-error
'syntax-error
'sc-expand
(string-append
- (if who1312 "~a: " "")
+ (if #{who\ 2495}# "~a: " "")
"~a "
- (if (null? subform1309)
+ (if (null? #{subform\ 2492}#)
"in ~a"
"in subform `~s' of `~s'"))
- (let ((tail1318
- (cons message1311
- (map (lambda (x1319) (strip161 x1319 (quote (()))))
- (append subform1309 (list form1310))))))
- (if who1312 (cons who1312 tail1318) tail1318))
+ (let ((#{tail\ 2501}#
+ (cons #{message\ 2494}#
+ (map (lambda (#{x\ 2502}#)
+ (#{strip\ 1343}# #{x\ 2502}# (quote (()))))
+ (append
+ #{subform\ 2492}#
+ (list #{form\ 2493}#))))))
+ (if #{who\ 2495}#
+ (cons #{who\ 2495}# #{tail\ 2501}#)
+ #{tail\ 2501}#))
#f))))
- (letrec ((match1324
- (lambda (e1325 p1326 w1327 r1328 mod1329)
- (if (not r1328)
+ (letrec ((#{match\ 2507}#
+ (lambda (#{e\ 2508}#
+ #{p\ 2509}#
+ #{w\ 2510}#
+ #{r\ 2511}#
+ #{mod\ 2512}#)
+ (if (not #{r\ 2511}#)
#f
- (if (eq? p1326 (quote any))
- (cons (wrap143 e1325 w1327 mod1329) r1328)
- (if (syntax-object?99 e1325)
- (match*1323
- (syntax-object-expression100 e1325)
- p1326
- (join-wraps134
- w1327
- (syntax-object-wrap101 e1325))
- r1328
- (syntax-object-module102 e1325))
- (match*1323 e1325 p1326 w1327 r1328 mod1329))))))
- (match*1323
- (lambda (e1330 p1331 w1332 r1333 mod1334)
- (if (null? p1331)
- (if (null? e1330) r1333 #f)
- (if (pair? p1331)
- (if (pair? e1330)
- (match1324
- (car e1330)
- (car p1331)
- w1332
- (match1324
- (cdr e1330)
- (cdr p1331)
- w1332
- r1333
- mod1334)
- mod1334)
+ (if (eq? #{p\ 2509}# (quote any))
+ (cons (#{wrap\ 1325}#
+ #{e\ 2508}#
+ #{w\ 2510}#
+ #{mod\ 2512}#)
+ #{r\ 2511}#)
+ (if (#{syntax-object?\ 1281}# #{e\ 2508}#)
+ (#{match*\ 2506}#
+ (#{syntax-object-expression\ 1282}# #{e\ 2508}#)
+ #{p\ 2509}#
+ (#{join-wraps\ 1316}#
+ #{w\ 2510}#
+ (#{syntax-object-wrap\ 1283}# #{e\ 2508}#))
+ #{r\ 2511}#
+ (#{syntax-object-module\ 1284}# #{e\ 2508}#))
+ (#{match*\ 2506}#
+ #{e\ 2508}#
+ #{p\ 2509}#
+ #{w\ 2510}#
+ #{r\ 2511}#
+ #{mod\ 2512}#))))))
+ (#{match*\ 2506}#
+ (lambda (#{e\ 2513}#
+ #{p\ 2514}#
+ #{w\ 2515}#
+ #{r\ 2516}#
+ #{mod\ 2517}#)
+ (if (null? #{p\ 2514}#)
+ (if (null? #{e\ 2513}#) #{r\ 2516}# #f)
+ (if (pair? #{p\ 2514}#)
+ (if (pair? #{e\ 2513}#)
+ (#{match\ 2507}#
+ (car #{e\ 2513}#)
+ (car #{p\ 2514}#)
+ #{w\ 2515}#
+ (#{match\ 2507}#
+ (cdr #{e\ 2513}#)
+ (cdr #{p\ 2514}#)
+ #{w\ 2515}#
+ #{r\ 2516}#
+ #{mod\ 2517}#)
+ #{mod\ 2517}#)
#f)
- (if (eq? p1331 (quote each-any))
- (let ((l1335 (match-each-any1321
- e1330
- w1332
- mod1334)))
- (if l1335 (cons l1335 r1333) #f))
- (let ((atom-key1336 (vector-ref p1331 0)))
- (if (memv atom-key1336 (quote (each)))
- (if (null? e1330)
- (match-empty1322 (vector-ref p1331 1) r1333)
- (let ((l1337 (match-each1320
- e1330
- (vector-ref p1331 1)
- w1332
- mod1334)))
- (if l1337
- (letrec ((collect1338
- (lambda (l1339)
- (if (null? (car l1339))
- r1333
- (cons (map car l1339)
- (collect1338
- (map cdr l1339)))))))
- (collect1338 l1337))
+ (if (eq? #{p\ 2514}# (quote each-any))
+ (let ((#{l\ 2518}#
+ (#{match-each-any\ 2504}#
+ #{e\ 2513}#
+ #{w\ 2515}#
+ #{mod\ 2517}#)))
+ (if #{l\ 2518}#
+ (cons #{l\ 2518}# #{r\ 2516}#)
+ #f))
+ (let ((#{atom-key\ 2519}# (vector-ref #{p\ 2514}# 0)))
+ (if (memv #{atom-key\ 2519}# (quote (each)))
+ (if (null? #{e\ 2513}#)
+ (#{match-empty\ 2505}#
+ (vector-ref #{p\ 2514}# 1)
+ #{r\ 2516}#)
+ (let ((#{l\ 2520}#
+ (#{match-each\ 2503}#
+ #{e\ 2513}#
+ (vector-ref #{p\ 2514}# 1)
+ #{w\ 2515}#
+ #{mod\ 2517}#)))
+ (if #{l\ 2520}#
+ (letrec ((#{collect\ 2521}#
+ (lambda (#{l\ 2522}#)
+ (if (null? (car #{l\ 2522}#))
+ #{r\ 2516}#
+ (cons (map car #{l\ 2522}#)
+ (#{collect\ 2521}#
+ (map cdr
+ #{l\ 2522}#)))))))
+ (#{collect\ 2521}# #{l\ 2520}#))
#f)))
- (if (memv atom-key1336 (quote (free-id)))
- (if (id?115 e1330)
- (if (free-id=?138
- (wrap143 e1330 w1332 mod1334)
- (vector-ref p1331 1))
- r1333
+ (if (memv #{atom-key\ 2519}# (quote (free-id)))
+ (if (#{id?\ 1297}# #{e\ 2513}#)
+ (if (#{free-id=?\ 1320}#
+ (#{wrap\ 1325}#
+ #{e\ 2513}#
+ #{w\ 2515}#
+ #{mod\ 2517}#)
+ (vector-ref #{p\ 2514}# 1))
+ #{r\ 2516}#
#f)
#f)
- (if (memv atom-key1336 (quote (atom)))
+ (if (memv #{atom-key\ 2519}# (quote (atom)))
(if (equal?
- (vector-ref p1331 1)
- (strip161 e1330 w1332))
- r1333
+ (vector-ref #{p\ 2514}# 1)
+ (#{strip\ 1343}#
+ #{e\ 2513}#
+ #{w\ 2515}#))
+ #{r\ 2516}#
#f)
- (if (memv atom-key1336 (quote (vector)))
- (if (vector? e1330)
- (match1324
- (vector->list e1330)
- (vector-ref p1331 1)
- w1332
- r1333
- mod1334)
+ (if (memv #{atom-key\ 2519}# (quote (vector)))
+ (if (vector? #{e\ 2513}#)
+ (#{match\ 2507}#
+ (vector->list #{e\ 2513}#)
+ (vector-ref #{p\ 2514}# 1)
+ #{w\ 2515}#
+ #{r\ 2516}#
+ #{mod\ 2517}#)
#f)))))))))))
- (match-empty1322
- (lambda (p1340 r1341)
- (if (null? p1340)
- r1341
- (if (eq? p1340 (quote any))
- (cons (quote ()) r1341)
- (if (pair? p1340)
- (match-empty1322
- (car p1340)
- (match-empty1322 (cdr p1340) r1341))
- (if (eq? p1340 (quote each-any))
- (cons (quote ()) r1341)
- (let ((atom-key1342 (vector-ref p1340 0)))
- (if (memv atom-key1342 (quote (each)))
- (match-empty1322 (vector-ref p1340 1) r1341)
- (if (memv atom-key1342 (quote (free-id atom)))
- r1341
- (if (memv atom-key1342 (quote (vector)))
- (match-empty1322
- (vector-ref p1340 1)
- r1341)))))))))))
- (match-each-any1321
- (lambda (e1343 w1344 mod1345)
- (if (pair? e1343)
- (let ((l1346 (match-each-any1321
- (cdr e1343)
- w1344
- mod1345)))
- (if l1346
- (cons (wrap143 (car e1343) w1344 mod1345) l1346)
+ (#{match-empty\ 2505}#
+ (lambda (#{p\ 2523}# #{r\ 2524}#)
+ (if (null? #{p\ 2523}#)
+ #{r\ 2524}#
+ (if (eq? #{p\ 2523}# (quote any))
+ (cons (quote ()) #{r\ 2524}#)
+ (if (pair? #{p\ 2523}#)
+ (#{match-empty\ 2505}#
+ (car #{p\ 2523}#)
+ (#{match-empty\ 2505}#
+ (cdr #{p\ 2523}#)
+ #{r\ 2524}#))
+ (if (eq? #{p\ 2523}# (quote each-any))
+ (cons (quote ()) #{r\ 2524}#)
+ (let ((#{atom-key\ 2525}#
+ (vector-ref #{p\ 2523}# 0)))
+ (if (memv #{atom-key\ 2525}# (quote (each)))
+ (#{match-empty\ 2505}#
+ (vector-ref #{p\ 2523}# 1)
+ #{r\ 2524}#)
+ (if (memv #{atom-key\ 2525}#
+ '(free-id atom))
+ #{r\ 2524}#
+ (if (memv #{atom-key\ 2525}# (quote (vector)))
+ (#{match-empty\ 2505}#
+ (vector-ref #{p\ 2523}# 1)
+ #{r\ 2524}#)))))))))))
+ (#{match-each-any\ 2504}#
+ (lambda (#{e\ 2526}# #{w\ 2527}# #{mod\ 2528}#)
+ (if (pair? #{e\ 2526}#)
+ (let ((#{l\ 2529}#
+ (#{match-each-any\ 2504}#
+ (cdr #{e\ 2526}#)
+ #{w\ 2527}#
+ #{mod\ 2528}#)))
+ (if #{l\ 2529}#
+ (cons (#{wrap\ 1325}#
+ (car #{e\ 2526}#)
+ #{w\ 2527}#
+ #{mod\ 2528}#)
+ #{l\ 2529}#)
#f))
- (if (null? e1343)
+ (if (null? #{e\ 2526}#)
'()
- (if (syntax-object?99 e1343)
- (match-each-any1321
- (syntax-object-expression100 e1343)
- (join-wraps134
- w1344
- (syntax-object-wrap101 e1343))
- mod1345)
+ (if (#{syntax-object?\ 1281}# #{e\ 2526}#)
+ (#{match-each-any\ 2504}#
+ (#{syntax-object-expression\ 1282}# #{e\ 2526}#)
+ (#{join-wraps\ 1316}#
+ #{w\ 2527}#
+ (#{syntax-object-wrap\ 1283}# #{e\ 2526}#))
+ #{mod\ 2528}#)
#f)))))
- (match-each1320
- (lambda (e1347 p1348 w1349 mod1350)
- (if (pair? e1347)
- (let ((first1351
- (match1324
- (car e1347)
- p1348
- w1349
+ (#{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}#
'()
- mod1350)))
- (if first1351
- (let ((rest1352
- (match-each1320
- (cdr e1347)
- p1348
- w1349
- mod1350)))
- (if rest1352 (cons first1351 rest1352) #f))
+ #{mod\ 2533}#)))
+ (if #{first\ 2534}#
+ (let ((#{rest\ 2535}#
+ (#{match-each\ 2503}#
+ (cdr #{e\ 2530}#)
+ #{p\ 2531}#
+ #{w\ 2532}#
+ #{mod\ 2533}#)))
+ (if #{rest\ 2535}#
+ (cons #{first\ 2534}# #{rest\ 2535}#)
+ #f))
#f))
- (if (null? e1347)
+ (if (null? #{e\ 2530}#)
'()
- (if (syntax-object?99 e1347)
- (match-each1320
- (syntax-object-expression100 e1347)
- p1348
- (join-wraps134
- w1349
- (syntax-object-wrap101 e1347))
- (syntax-object-module102 e1347))
+ (if (#{syntax-object?\ 1281}# #{e\ 2530}#)
+ (#{match-each\ 2503}#
+ (#{syntax-object-expression\ 1282}# #{e\ 2530}#)
+ #{p\ 2531}#
+ (#{join-wraps\ 1316}#
+ #{w\ 2532}#
+ (#{syntax-object-wrap\ 1283}# #{e\ 2530}#))
+ (#{syntax-object-module\ 1284}# #{e\ 2530}#))
#f))))))
(set! $sc-dispatch
- (lambda (e1353 p1354)
- (if (eq? p1354 (quote any))
- (list e1353)
- (if (syntax-object?99 e1353)
- (match*1323
- (syntax-object-expression100 e1353)
- p1354
- (syntax-object-wrap101 e1353)
+ (lambda (#{e\ 2536}# #{p\ 2537}#)
+ (if (eq? #{p\ 2537}# (quote any))
+ (list #{e\ 2536}#)
+ (if (#{syntax-object?\ 1281}# #{e\ 2536}#)
+ (#{match*\ 2506}#
+ (#{syntax-object-expression\ 1282}# #{e\ 2536}#)
+ #{p\ 2537}#
+ (#{syntax-object-wrap\ 1283}# #{e\ 2536}#)
'()
- (syntax-object-module102 e1353))
- (match*1323
- e1353
- p1354
+ (#{syntax-object-module\ 1284}# #{e\ 2536}#))
+ (#{match*\ 2506}#
+ #{e\ 2536}#
+ #{p\ 2537}#
'(())
'()
#f)))))))))
@@ -8337,11 +9157,11 @@
(define with-syntax
(make-syncase-macro
'macro
- (lambda (x1355)
- ((lambda (tmp1356)
- ((lambda (tmp1357)
- (if tmp1357
- (apply (lambda (_1358 e11359 e21360)
+ (lambda (#{x\ 2538}#)
+ ((lambda (#{tmp\ 2539}#)
+ ((lambda (#{tmp\ 2540}#)
+ (if #{tmp\ 2540}#
+ (apply (lambda (#{_\ 2541}# #{e1\ 2542}# #{e2\ 2543}#)
(cons '#(syntax-object
begin
((top)
@@ -8352,11 +9172,15 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- (cons e11359 e21360)))
- tmp1357)
- ((lambda (tmp1362)
- (if tmp1362
- (apply (lambda (_1363 out1364 in1365 e11366 e21367)
+ (cons #{e1\ 2542}# #{e2\ 2543}#)))
+ #{tmp\ 2540}#)
+ ((lambda (#{tmp\ 2545}#)
+ (if #{tmp\ 2545}#
+ (apply (lambda (#{_\ 2546}#
+ #{out\ 2547}#
+ #{in\ 2548}#
+ #{e1\ 2549}#
+ #{e2\ 2550}#)
(list '#(syntax-object
syntax-case
((top)
@@ -8367,9 +9191,9 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- in1365
+ #{in\ 2548}#
'()
- (list out1364
+ (list #{out\ 2547}#
(cons '#(syntax-object
begin
((top)
@@ -8387,11 +9211,16 @@
#((top))
#("i")))
(hygiene guile))
- (cons e11366 e21367)))))
- tmp1362)
- ((lambda (tmp1369)
- (if tmp1369
- (apply (lambda (_1370 out1371 in1372 e11373 e21374)
+ (cons #{e1\ 2549}#
+ #{e2\ 2550}#)))))
+ #{tmp\ 2545}#)
+ ((lambda (#{tmp\ 2552}#)
+ (if #{tmp\ 2552}#
+ (apply (lambda (#{_\ 2553}#
+ #{out\ 2554}#
+ #{in\ 2555}#
+ #{e1\ 2556}#
+ #{e2\ 2557}#)
(list '#(syntax-object
syntax-case
((top)
@@ -8419,9 +9248,9 @@
#((top))
#("i")))
(hygiene guile))
- in1372)
+ #{in\ 2555}#)
'()
- (list out1371
+ (list #{out\ 2554}#
(cons '#(syntax-object
begin
((top)
@@ -8443,35 +9272,36 @@
#((top))
#("i")))
(hygiene guile))
- (cons e11373 e21374)))))
- tmp1369)
+ (cons #{e1\ 2556}#
+ #{e2\ 2557}#)))))
+ #{tmp\ 2552}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1356)))
+ #{tmp\ 2539}#)))
($sc-dispatch
- tmp1356
+ #{tmp\ 2539}#
'(any #(each (any any)) any . each-any)))))
($sc-dispatch
- tmp1356
+ #{tmp\ 2539}#
'(any ((any any)) any . each-any)))))
($sc-dispatch
- tmp1356
+ #{tmp\ 2539}#
'(any () any . each-any))))
- x1355))))
+ #{x\ 2538}#))))
(define syntax-rules
(make-syncase-macro
'macro
- (lambda (x1378)
- ((lambda (tmp1379)
- ((lambda (tmp1380)
- (if tmp1380
- (apply (lambda (_1381
- k1382
- keyword1383
- pattern1384
- template1385)
+ (lambda (#{x\ 2561}#)
+ ((lambda (#{tmp\ 2562}#)
+ ((lambda (#{tmp\ 2563}#)
+ (if #{tmp\ 2563}#
+ (apply (lambda (#{_\ 2564}#
+ #{k\ 2565}#
+ #{keyword\ 2566}#
+ #{pattern\ 2567}#
+ #{template\ 2568}#)
(list '#(syntax-object
lambda
((top)
@@ -8512,8 +9342,9 @@
#(ribcage () () ())
#(ribcage #(x) #((top)) #("i")))
(hygiene guile))
- (cons k1382
- (map (lambda (tmp1388 tmp1387)
+ (cons #{k\ 2565}#
+ (map (lambda (#{tmp\ 2571}#
+ #{tmp\ 2570}#)
(list (cons '#(syntax-object
dummy
((top)
@@ -8543,7 +9374,7 @@
#("i")))
(hygiene
guile))
- tmp1387)
+ #{tmp\ 2570}#)
(list '#(syntax-object
syntax
((top)
@@ -8573,155 +9404,164 @@
#("i")))
(hygiene
guile))
- tmp1388)))
- template1385
- pattern1384))))))
- tmp1380)
+ #{tmp\ 2571}#)))
+ #{template\ 2568}#
+ #{pattern\ 2567}#))))))
+ #{tmp\ 2563}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1379)))
+ #{tmp\ 2562}#)))
($sc-dispatch
- tmp1379
+ #{tmp\ 2562}#
'(any each-any . #(each ((any . any) any))))))
- x1378))))
+ #{x\ 2561}#))))
(define let*
(make-extended-syncase-macro
(module-ref (current-module) (quote let*))
'macro
- (lambda (x1389)
- ((lambda (tmp1390)
- ((lambda (tmp1391)
- (if (if tmp1391
- (apply (lambda (let*1392 x1393 v1394 e11395 e21396)
- (and-map identifier? x1393))
- tmp1391)
+ (lambda (#{x\ 2572}#)
+ ((lambda (#{tmp\ 2573}#)
+ ((lambda (#{tmp\ 2574}#)
+ (if (if #{tmp\ 2574}#
+ (apply (lambda (#{let*\ 2575}#
+ #{x\ 2576}#
+ #{v\ 2577}#
+ #{e1\ 2578}#
+ #{e2\ 2579}#)
+ (and-map identifier? #{x\ 2576}#))
+ #{tmp\ 2574}#)
#f)
- (apply (lambda (let*1398 x1399 v1400 e11401 e21402)
- (letrec ((f1403 (lambda (bindings1404)
- (if (null? bindings1404)
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(f bindings)
- #((top) (top))
- #("i" "i"))
- #(ribcage
- #(let* x v e1 e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene guile))
- (cons '()
- (cons e11401 e21402)))
- ((lambda (tmp1408)
- ((lambda (tmp1409)
- (if tmp1409
- (apply (lambda (body1410
- binding1411)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(body
- binding)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- bindings)
- #((top)
- (top))
- #("i"
- "i"))
- #(ribcage
- #(let*
- x
- v
- e1
- e2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (list binding1411)
- body1410))
- tmp1409)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp1408)))
- ($sc-dispatch
- tmp1408
- '(any any))))
- (list (f1403 (cdr bindings1404))
- (car bindings1404)))))))
- (f1403 (map list x1399 v1400))))
- tmp1391)
+ (apply (lambda (#{let*\ 2581}#
+ #{x\ 2582}#
+ #{v\ 2583}#
+ #{e1\ 2584}#
+ #{e2\ 2585}#)
+ (letrec ((#{f\ 2586}#
+ (lambda (#{bindings\ 2587}#)
+ (if (null? #{bindings\ 2587}#)
+ (cons '#(syntax-object
+ let
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(f bindings)
+ #((top) (top))
+ #("i" "i"))
+ #(ribcage
+ #(let* x v e1 e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile))
+ (cons '()
+ (cons #{e1\ 2584}#
+ #{e2\ 2585}#)))
+ ((lambda (#{tmp\ 2591}#)
+ ((lambda (#{tmp\ 2592}#)
+ (if #{tmp\ 2592}#
+ (apply (lambda (#{body\ 2593}#
+ #{binding\ 2594}#)
+ (list '#(syntax-object
+ let
+ ((top)
+ #(ribcage
+ #(body
+ binding)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ bindings)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ #(let*
+ x
+ v
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (list #{binding\ 2594}#)
+ #{body\ 2593}#))
+ #{tmp\ 2592}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp\ 2591}#)))
+ ($sc-dispatch
+ #{tmp\ 2591}#
+ '(any any))))
+ (list (#{f\ 2586}#
+ (cdr #{bindings\ 2587}#))
+ (car #{bindings\ 2587}#)))))))
+ (#{f\ 2586}# (map list #{x\ 2582}# #{v\ 2583}#))))
+ #{tmp\ 2574}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1390)))
+ #{tmp\ 2573}#)))
($sc-dispatch
- tmp1390
+ #{tmp\ 2573}#
'(any #(each (any any)) any . each-any))))
- x1389))))
+ #{x\ 2572}#))))
(define do
(make-extended-syncase-macro
(module-ref (current-module) (quote do))
'macro
- (lambda (orig-x1412)
- ((lambda (tmp1413)
- ((lambda (tmp1414)
- (if tmp1414
- (apply (lambda (_1415
- var1416
- init1417
- step1418
- e01419
- e11420
- c1421)
- ((lambda (tmp1422)
- ((lambda (tmp1423)
- (if tmp1423
- (apply (lambda (step1424)
- ((lambda (tmp1425)
- ((lambda (tmp1426)
- (if tmp1426
+ (lambda (#{orig-x\ 2595}#)
+ ((lambda (#{tmp\ 2596}#)
+ ((lambda (#{tmp\ 2597}#)
+ (if #{tmp\ 2597}#
+ (apply (lambda (#{_\ 2598}#
+ #{var\ 2599}#
+ #{init\ 2600}#
+ #{step\ 2601}#
+ #{e0\ 2602}#
+ #{e1\ 2603}#
+ #{c\ 2604}#)
+ ((lambda (#{tmp\ 2605}#)
+ ((lambda (#{tmp\ 2606}#)
+ (if #{tmp\ 2606}#
+ (apply (lambda (#{step\ 2607}#)
+ ((lambda (#{tmp\ 2608}#)
+ ((lambda (#{tmp\ 2609}#)
+ (if #{tmp\ 2609}#
(apply (lambda ()
(list '#(syntax-object
let
@@ -8802,8 +9642,8 @@
(hygiene
guile))
(map list
- var1416
- init1417)
+ #{var\ 2599}#
+ #{init\ 2600}#)
(list '#(syntax-object
if
((top)
@@ -8882,7 +9722,7 @@
#("i")))
(hygiene
guile))
- e01419)
+ #{e0\ 2602}#)
(cons '#(syntax-object
begin
((top)
@@ -8923,7 +9763,7 @@
(hygiene
guile))
(append
- c1421
+ #{c\ 2604}#
(list (cons '#(syntax-object
doloop
((top)
@@ -8963,12 +9803,12 @@
#("i")))
(hygiene
guile))
- step1424)))))))
- tmp1426)
- ((lambda (tmp1431)
- (if tmp1431
- (apply (lambda (e11432
- e21433)
+ #{step\ 2607}#)))))))
+ #{tmp\ 2609}#)
+ ((lambda (#{tmp\ 2614}#)
+ (if #{tmp\ 2614}#
+ (apply (lambda (#{e1\ 2615}#
+ #{e2\ 2616}#)
(list '#(syntax-object
let
((top)
@@ -9062,8 +9902,8 @@
(hygiene
guile))
(map list
- var1416
- init1417)
+ #{var\ 2599}#
+ #{init\ 2600}#)
(list '#(syntax-object
if
((top)
@@ -9110,7 +9950,7 @@
#("i")))
(hygiene
guile))
- e01419
+ #{e0\ 2602}#
(cons '#(syntax-object
begin
((top)
@@ -9157,8 +9997,8 @@
#("i")))
(hygiene
guile))
- (cons e11432
- e21433))
+ (cons #{e1\ 2615}#
+ #{e2\ 2616}#))
(cons '#(syntax-object
begin
((top)
@@ -9206,7 +10046,7 @@
(hygiene
guile))
(append
- c1421
+ #{c\ 2604}#
(list (cons '#(syntax-object
doloop
((top)
@@ -9253,75 +10093,81 @@
#("i")))
(hygiene
guile))
- step1424)))))))
- tmp1431)
+ #{step\ 2607}#)))))))
+ #{tmp\ 2614}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1425)))
+ #{tmp\ 2608}#)))
($sc-dispatch
- tmp1425
+ #{tmp\ 2608}#
'(any . each-any)))))
- ($sc-dispatch tmp1425 (quote ()))))
- e11420))
- tmp1423)
+ ($sc-dispatch
+ #{tmp\ 2608}#
+ '())))
+ #{e1\ 2603}#))
+ #{tmp\ 2606}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1422)))
- ($sc-dispatch tmp1422 (quote each-any))))
- (map (lambda (v1440 s1441)
- ((lambda (tmp1442)
- ((lambda (tmp1443)
- (if tmp1443
- (apply (lambda () v1440) tmp1443)
- ((lambda (tmp1444)
- (if tmp1444
- (apply (lambda (e1445) e1445)
- tmp1444)
- ((lambda (_1446)
+ #{tmp\ 2605}#)))
+ ($sc-dispatch #{tmp\ 2605}# (quote each-any))))
+ (map (lambda (#{v\ 2623}# #{s\ 2624}#)
+ ((lambda (#{tmp\ 2625}#)
+ ((lambda (#{tmp\ 2626}#)
+ (if #{tmp\ 2626}#
+ (apply (lambda () #{v\ 2623}#)
+ #{tmp\ 2626}#)
+ ((lambda (#{tmp\ 2627}#)
+ (if #{tmp\ 2627}#
+ (apply (lambda (#{e\ 2628}#)
+ #{e\ 2628}#)
+ #{tmp\ 2627}#)
+ ((lambda (#{_\ 2629}#)
(syntax-violation
'do
"bad step expression"
- orig-x1412
- s1441))
- tmp1442)))
- ($sc-dispatch tmp1442 (quote (any))))))
- ($sc-dispatch tmp1442 (quote ()))))
- s1441))
- var1416
- step1418)))
- tmp1414)
+ #{orig-x\ 2595}#
+ #{s\ 2624}#))
+ #{tmp\ 2625}#)))
+ ($sc-dispatch
+ #{tmp\ 2625}#
+ '(any)))))
+ ($sc-dispatch #{tmp\ 2625}# (quote ()))))
+ #{s\ 2624}#))
+ #{var\ 2599}#
+ #{step\ 2601}#)))
+ #{tmp\ 2597}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1413)))
+ #{tmp\ 2596}#)))
($sc-dispatch
- tmp1413
+ #{tmp\ 2596}#
'(any #(each (any any . any))
(any . each-any)
.
each-any))))
- orig-x1412))))
+ #{orig-x\ 2595}#))))
(define quasiquote
(make-extended-syncase-macro
(module-ref (current-module) (quote quasiquote))
'macro
- (letrec ((quasicons1449
- (lambda (x1453 y1454)
- ((lambda (tmp1455)
- ((lambda (tmp1456)
- (if tmp1456
- (apply (lambda (x1457 y1458)
- ((lambda (tmp1459)
- ((lambda (tmp1460)
- (if tmp1460
- (apply (lambda (dy1461)
- ((lambda (tmp1462)
- ((lambda (tmp1463)
- (if tmp1463
- (apply (lambda (dx1464)
+ (letrec ((#{quasicons\ 2632}#
+ (lambda (#{x\ 2636}# #{y\ 2637}#)
+ ((lambda (#{tmp\ 2638}#)
+ ((lambda (#{tmp\ 2639}#)
+ (if #{tmp\ 2639}#
+ (apply (lambda (#{x\ 2640}# #{y\ 2641}#)
+ ((lambda (#{tmp\ 2642}#)
+ ((lambda (#{tmp\ 2643}#)
+ (if #{tmp\ 2643}#
+ (apply (lambda (#{dy\ 2644}#)
+ ((lambda (#{tmp\ 2645}#)
+ ((lambda (#{tmp\ 2646}#)
+ (if #{tmp\ 2646}#
+ (apply (lambda (#{dx\ 2647}#)
(list '#(syntax-object
quote
((top)
@@ -9370,11 +10216,11 @@
"i")))
(hygiene
guile))
- (cons dx1464
- dy1461)))
- tmp1463)
- ((lambda (_1465)
- (if (null? dy1461)
+ (cons #{dx\ 2647}#
+ #{dy\ 2644}#)))
+ #{tmp\ 2646}#)
+ ((lambda (#{_\ 2648}#)
+ (if (null? #{dy\ 2644}#)
(list '#(syntax-object
list
((top)
@@ -9423,7 +10269,7 @@
"i")))
(hygiene
guile))
- x1457)
+ #{x\ 2640}#)
(list '#(syntax-object
cons
((top)
@@ -9472,11 +10318,11 @@
"i")))
(hygiene
guile))
- x1457
- y1458)))
- tmp1462)))
+ #{x\ 2640}#
+ #{y\ 2641}#)))
+ #{tmp\ 2645}#)))
($sc-dispatch
- tmp1462
+ #{tmp\ 2645}#
'(#(free-id
#(syntax-object
quote
@@ -9519,11 +10365,11 @@
(hygiene
guile)))
any))))
- x1457))
- tmp1460)
- ((lambda (tmp1466)
- (if tmp1466
- (apply (lambda (stuff1467)
+ #{x\ 2640}#))
+ #{tmp\ 2643}#)
+ ((lambda (#{tmp\ 2649}#)
+ (if #{tmp\ 2649}#
+ (apply (lambda (#{stuff\ 2650}#)
(cons '#(syntax-object
list
((top)
@@ -9564,10 +10410,10 @@
"i")))
(hygiene
guile))
- (cons x1457
- stuff1467)))
- tmp1466)
- ((lambda (else1468)
+ (cons #{x\ 2640}#
+ #{stuff\ 2650}#)))
+ #{tmp\ 2649}#)
+ ((lambda (#{else\ 2651}#)
(list '#(syntax-object
cons
((top)
@@ -9599,11 +10445,11 @@
"i"
"i")))
(hygiene guile))
- x1457
- y1458))
- tmp1459)))
+ #{x\ 2640}#
+ #{y\ 2641}#))
+ #{tmp\ 2642}#)))
($sc-dispatch
- tmp1459
+ #{tmp\ 2642}#
'(#(free-id
#(syntax-object
list
@@ -9632,7 +10478,7 @@
.
any)))))
($sc-dispatch
- tmp1459
+ #{tmp\ 2642}#
'(#(free-id
#(syntax-object
quote
@@ -9656,25 +10502,26 @@
#("i" "i" "i" "i")))
(hygiene guile)))
any))))
- y1458))
- tmp1456)
+ #{y\ 2641}#))
+ #{tmp\ 2639}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1455)))
- ($sc-dispatch tmp1455 (quote (any any)))))
- (list x1453 y1454))))
- (quasiappend1450
- (lambda (x1469 y1470)
- ((lambda (tmp1471)
- ((lambda (tmp1472)
- (if tmp1472
- (apply (lambda (x1473 y1474)
- ((lambda (tmp1475)
- ((lambda (tmp1476)
- (if tmp1476
- (apply (lambda () x1473) tmp1476)
- ((lambda (_1477)
+ #{tmp\ 2638}#)))
+ ($sc-dispatch #{tmp\ 2638}# (quote (any any)))))
+ (list #{x\ 2636}# #{y\ 2637}#))))
+ (#{quasiappend\ 2633}#
+ (lambda (#{x\ 2652}# #{y\ 2653}#)
+ ((lambda (#{tmp\ 2654}#)
+ ((lambda (#{tmp\ 2655}#)
+ (if #{tmp\ 2655}#
+ (apply (lambda (#{x\ 2656}# #{y\ 2657}#)
+ ((lambda (#{tmp\ 2658}#)
+ ((lambda (#{tmp\ 2659}#)
+ (if #{tmp\ 2659}#
+ (apply (lambda () #{x\ 2656}#)
+ #{tmp\ 2659}#)
+ ((lambda (#{_\ 2660}#)
(list '#(syntax-object
append
((top)
@@ -9703,11 +10550,11 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile))
- x1473
- y1474))
- tmp1475)))
+ #{x\ 2656}#
+ #{y\ 2657}#))
+ #{tmp\ 2658}#)))
($sc-dispatch
- tmp1475
+ #{tmp\ 2658}#
'(#(free-id
#(syntax-object
quote
@@ -9731,22 +10578,22 @@
#("i" "i" "i" "i")))
(hygiene guile)))
()))))
- y1474))
- tmp1472)
+ #{y\ 2657}#))
+ #{tmp\ 2655}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1471)))
- ($sc-dispatch tmp1471 (quote (any any)))))
- (list x1469 y1470))))
- (quasivector1451
- (lambda (x1478)
- ((lambda (tmp1479)
- ((lambda (x1480)
- ((lambda (tmp1481)
- ((lambda (tmp1482)
- (if tmp1482
- (apply (lambda (x1483)
+ #{tmp\ 2654}#)))
+ ($sc-dispatch #{tmp\ 2654}# (quote (any any)))))
+ (list #{x\ 2652}# #{y\ 2653}#))))
+ (#{quasivector\ 2634}#
+ (lambda (#{x\ 2661}#)
+ ((lambda (#{tmp\ 2662}#)
+ ((lambda (#{x\ 2663}#)
+ ((lambda (#{tmp\ 2664}#)
+ ((lambda (#{tmp\ 2665}#)
+ (if #{tmp\ 2665}#
+ (apply (lambda (#{x\ 2666}#)
(list '#(syntax-object
quote
((top)
@@ -9772,11 +10619,11 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile))
- (list->vector x1483)))
- tmp1482)
- ((lambda (tmp1485)
- (if tmp1485
- (apply (lambda (x1486)
+ (list->vector #{x\ 2666}#)))
+ #{tmp\ 2665}#)
+ ((lambda (#{tmp\ 2668}#)
+ (if #{tmp\ 2668}#
+ (apply (lambda (#{x\ 2669}#)
(cons '#(syntax-object
vector
((top)
@@ -9805,9 +10652,9 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile))
- x1486))
- tmp1485)
- ((lambda (_1488)
+ #{x\ 2669}#))
+ #{tmp\ 2668}#)
+ ((lambda (#{_\ 2671}#)
(list '#(syntax-object
list->vector
((top)
@@ -9833,10 +10680,10 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile))
- x1480))
- tmp1481)))
+ #{x\ 2663}#))
+ #{tmp\ 2664}#)))
($sc-dispatch
- tmp1481
+ #{tmp\ 2664}#
'(#(free-id
#(syntax-object
list
@@ -9856,7 +10703,7 @@
.
each-any)))))
($sc-dispatch
- tmp1481
+ #{tmp\ 2664}#
'(#(free-id
#(syntax-object
quote
@@ -9874,18 +10721,18 @@
#("i" "i" "i" "i")))
(hygiene guile)))
each-any))))
- x1480))
- tmp1479))
- x1478)))
- (quasi1452
- (lambda (p1489 lev1490)
- ((lambda (tmp1491)
- ((lambda (tmp1492)
- (if tmp1492
- (apply (lambda (p1493)
- (if (= lev1490 0)
- p1493
- (quasicons1449
+ #{x\ 2663}#))
+ #{tmp\ 2662}#))
+ #{x\ 2661}#)))
+ (#{quasi\ 2635}#
+ (lambda (#{p\ 2672}# #{lev\ 2673}#)
+ ((lambda (#{tmp\ 2674}#)
+ ((lambda (#{tmp\ 2675}#)
+ (if #{tmp\ 2675}#
+ (apply (lambda (#{p\ 2676}#)
+ (if (= #{lev\ 2673}# 0)
+ #{p\ 2676}#
+ (#{quasicons\ 2632}#
'(#(syntax-object
quote
((top)
@@ -9920,18 +10767,21 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile)))
- (quasi1452 (list p1493) (- lev1490 1)))))
- tmp1492)
- ((lambda (tmp1494)
- (if (if tmp1494
- (apply (lambda (args1495) (= lev1490 0))
- tmp1494)
+ (#{quasi\ 2635}#
+ (list #{p\ 2676}#)
+ (- #{lev\ 2673}# 1)))))
+ #{tmp\ 2675}#)
+ ((lambda (#{tmp\ 2677}#)
+ (if (if #{tmp\ 2677}#
+ (apply (lambda (#{args\ 2678}#)
+ (= #{lev\ 2673}# 0))
+ #{tmp\ 2677}#)
#f)
- (apply (lambda (args1496)
+ (apply (lambda (#{args\ 2679}#)
(syntax-violation
'unquote
"unquote takes exactly one argument"
- p1489
+ #{p\ 2672}#
(cons '#(syntax-object
unquote
((top)
@@ -9952,17 +10802,19 @@
#((top) (top) (top) (top))
#("i" "i" "i" "i")))
(hygiene guile))
- args1496)))
- tmp1494)
- ((lambda (tmp1497)
- (if tmp1497
- (apply (lambda (p1498 q1499)
- (if (= lev1490 0)
- (quasiappend1450
- p1498
- (quasi1452 q1499 lev1490))
- (quasicons1449
- (quasicons1449
+ #{args\ 2679}#)))
+ #{tmp\ 2677}#)
+ ((lambda (#{tmp\ 2680}#)
+ (if #{tmp\ 2680}#
+ (apply (lambda (#{p\ 2681}# #{q\ 2682}#)
+ (if (= #{lev\ 2673}# 0)
+ (#{quasiappend\ 2633}#
+ #{p\ 2681}#
+ (#{quasi\ 2635}#
+ #{q\ 2682}#
+ #{lev\ 2673}#))
+ (#{quasicons\ 2632}#
+ (#{quasicons\ 2632}#
'(#(syntax-object
quote
((top)
@@ -10009,22 +10861,26 @@
(top))
#("i" "i" "i" "i")))
(hygiene guile)))
- (quasi1452
- (list p1498)
- (- lev1490 1)))
- (quasi1452 q1499 lev1490))))
- tmp1497)
- ((lambda (tmp1500)
- (if (if tmp1500
- (apply (lambda (args1501 q1502)
- (= lev1490 0))
- tmp1500)
+ (#{quasi\ 2635}#
+ (list #{p\ 2681}#)
+ (- #{lev\ 2673}# 1)))
+ (#{quasi\ 2635}#
+ #{q\ 2682}#
+ #{lev\ 2673}#))))
+ #{tmp\ 2680}#)
+ ((lambda (#{tmp\ 2683}#)
+ (if (if #{tmp\ 2683}#
+ (apply (lambda (#{args\ 2684}#
+ #{q\ 2685}#)
+ (= #{lev\ 2673}# 0))
+ #{tmp\ 2683}#)
#f)
- (apply (lambda (args1503 q1504)
+ (apply (lambda (#{args\ 2686}#
+ #{q\ 2687}#)
(syntax-violation
'unquote-splicing
"unquote-splicing takes exactly one argument"
- p1489
+ #{p\ 2672}#
(cons '#(syntax-object
unquote-splicing
((top)
@@ -10054,12 +10910,12 @@
"i"
"i")))
(hygiene guile))
- args1503)))
- tmp1500)
- ((lambda (tmp1505)
- (if tmp1505
- (apply (lambda (p1506)
- (quasicons1449
+ #{args\ 2686}#)))
+ #{tmp\ 2683}#)
+ ((lambda (#{tmp\ 2688}#)
+ (if #{tmp\ 2688}#
+ (apply (lambda (#{p\ 2689}#)
+ (#{quasicons\ 2632}#
'(#(syntax-object
quote
((top)
@@ -10118,30 +10974,32 @@
"i"
"i")))
(hygiene guile)))
- (quasi1452
- (list p1506)
- (+ lev1490 1))))
- tmp1505)
- ((lambda (tmp1507)
- (if tmp1507
- (apply (lambda (p1508 q1509)
- (quasicons1449
- (quasi1452
- p1508
- lev1490)
- (quasi1452
- q1509
- lev1490)))
- tmp1507)
- ((lambda (tmp1510)
- (if tmp1510
- (apply (lambda (x1511)
- (quasivector1451
- (quasi1452
- x1511
- lev1490)))
- tmp1510)
- ((lambda (p1513)
+ (#{quasi\ 2635}#
+ (list #{p\ 2689}#)
+ (+ #{lev\ 2673}#
+ 1))))
+ #{tmp\ 2688}#)
+ ((lambda (#{tmp\ 2690}#)
+ (if #{tmp\ 2690}#
+ (apply (lambda (#{p\ 2691}#
+ #{q\ 2692}#)
+ (#{quasicons\ 2632}#
+ (#{quasi\ 2635}#
+ #{p\ 2691}#
+ #{lev\ 2673}#)
+ (#{quasi\ 2635}#
+ #{q\ 2692}#
+ #{lev\ 2673}#)))
+ #{tmp\ 2690}#)
+ ((lambda (#{tmp\ 2693}#)
+ (if #{tmp\ 2693}#
+ (apply (lambda (#{x\ 2694}#)
+ (#{quasivector\ 2634}#
+ (#{quasi\ 2635}#
+ #{x\ 2694}#
+ #{lev\ 2673}#)))
+ #{tmp\ 2693}#)
+ ((lambda (#{p\ 2696}#)
(list '#(syntax-object
quote
((top)
@@ -10174,16 +11032,16 @@
"i")))
(hygiene
guile))
- p1513))
- tmp1491)))
+ #{p\ 2696}#))
+ #{tmp\ 2674}#)))
($sc-dispatch
- tmp1491
+ #{tmp\ 2674}#
'#(vector each-any)))))
($sc-dispatch
- tmp1491
+ #{tmp\ 2674}#
'(any . any)))))
($sc-dispatch
- tmp1491
+ #{tmp\ 2674}#
'(#(free-id
#(syntax-object
quasiquote
@@ -10203,7 +11061,7 @@
(hygiene guile)))
any)))))
($sc-dispatch
- tmp1491
+ #{tmp\ 2674}#
'((#(free-id
#(syntax-object
unquote-splicing
@@ -10226,7 +11084,7 @@
.
any)))))
($sc-dispatch
- tmp1491
+ #{tmp\ 2674}#
'((#(free-id
#(syntax-object
unquote-splicing
@@ -10248,7 +11106,7 @@
.
any)))))
($sc-dispatch
- tmp1491
+ #{tmp\ 2674}#
'(#(free-id
#(syntax-object
unquote
@@ -10266,7 +11124,7 @@
.
any)))))
($sc-dispatch
- tmp1491
+ #{tmp\ 2674}#
'(#(free-id
#(syntax-object
unquote
@@ -10279,44 +11137,49 @@
#("i" "i" "i" "i")))
(hygiene guile)))
any))))
- p1489))))
- (lambda (x1514)
- ((lambda (tmp1515)
- ((lambda (tmp1516)
- (if tmp1516
- (apply (lambda (_1517 e1518) (quasi1452 e1518 0))
- tmp1516)
+ #{p\ 2672}#))))
+ (lambda (#{x\ 2697}#)
+ ((lambda (#{tmp\ 2698}#)
+ ((lambda (#{tmp\ 2699}#)
+ (if #{tmp\ 2699}#
+ (apply (lambda (#{_\ 2700}# #{e\ 2701}#)
+ (#{quasi\ 2635}# #{e\ 2701}# 0))
+ #{tmp\ 2699}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1515)))
- ($sc-dispatch tmp1515 (quote (any any)))))
- x1514)))))
+ #{tmp\ 2698}#)))
+ ($sc-dispatch #{tmp\ 2698}# (quote (any any)))))
+ #{x\ 2697}#)))))
(define include
(make-syncase-macro
'macro
- (lambda (x1519)
- (letrec ((read-file1520
- (lambda (fn1521 k1522)
- (let ((p1523 (open-input-file fn1521)))
- (letrec ((f1524 (lambda (x1525)
- (if (eof-object? x1525)
- (begin
- (close-input-port p1523)
- '())
- (cons (datum->syntax k1522 x1525)
- (f1524 (read p1523)))))))
- (f1524 (read p1523)))))))
- ((lambda (tmp1526)
- ((lambda (tmp1527)
- (if tmp1527
- (apply (lambda (k1528 filename1529)
- (let ((fn1530 (syntax->datum filename1529)))
- ((lambda (tmp1531)
- ((lambda (tmp1532)
- (if tmp1532
- (apply (lambda (exp1533)
+ (lambda (#{x\ 2702}#)
+ (letrec ((#{read-file\ 2703}#
+ (lambda (#{fn\ 2704}# #{k\ 2705}#)
+ (let ((#{p\ 2706}# (open-input-file #{fn\ 2704}#)))
+ (letrec ((#{f\ 2707}#
+ (lambda (#{x\ 2708}#)
+ (if (eof-object? #{x\ 2708}#)
+ (begin
+ (close-input-port #{p\ 2706}#)
+ '())
+ (cons (datum->syntax
+ #{k\ 2705}#
+ #{x\ 2708}#)
+ (#{f\ 2707}# (read #{p\ 2706}#)))))))
+ (#{f\ 2707}# (read #{p\ 2706}#)))))))
+ ((lambda (#{tmp\ 2709}#)
+ ((lambda (#{tmp\ 2710}#)
+ (if #{tmp\ 2710}#
+ (apply (lambda (#{k\ 2711}# #{filename\ 2712}#)
+ (let ((#{fn\ 2713}#
+ (syntax->datum #{filename\ 2712}#)))
+ ((lambda (#{tmp\ 2714}#)
+ ((lambda (#{tmp\ 2715}#)
+ (if #{tmp\ 2715}#
+ (apply (lambda (#{exp\ 2716}#)
(cons '#(syntax-object
begin
((top)
@@ -10343,73 +11206,76 @@
#((top))
#("i")))
(hygiene guile))
- exp1533))
- tmp1532)
+ #{exp\ 2716}#))
+ #{tmp\ 2715}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1531)))
- ($sc-dispatch tmp1531 (quote each-any))))
- (read-file1520 fn1530 k1528))))
- tmp1527)
+ #{tmp\ 2714}#)))
+ ($sc-dispatch #{tmp\ 2714}# (quote each-any))))
+ (#{read-file\ 2703}# #{fn\ 2713}# #{k\ 2711}#))))
+ #{tmp\ 2710}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1526)))
- ($sc-dispatch tmp1526 (quote (any any)))))
- x1519)))))
+ #{tmp\ 2709}#)))
+ ($sc-dispatch #{tmp\ 2709}# (quote (any any)))))
+ #{x\ 2702}#)))))
(define unquote
(make-syncase-macro
'macro
- (lambda (x1535)
- ((lambda (tmp1536)
- ((lambda (tmp1537)
- (if tmp1537
- (apply (lambda (_1538 e1539)
+ (lambda (#{x\ 2718}#)
+ ((lambda (#{tmp\ 2719}#)
+ ((lambda (#{tmp\ 2720}#)
+ (if #{tmp\ 2720}#
+ (apply (lambda (#{_\ 2721}# #{e\ 2722}#)
(syntax-violation
'unquote
"expression not valid outside of quasiquote"
- x1535))
- tmp1537)
+ #{x\ 2718}#))
+ #{tmp\ 2720}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1536)))
- ($sc-dispatch tmp1536 (quote (any any)))))
- x1535))))
+ #{tmp\ 2719}#)))
+ ($sc-dispatch #{tmp\ 2719}# (quote (any any)))))
+ #{x\ 2718}#))))
(define unquote-splicing
(make-syncase-macro
'macro
- (lambda (x1540)
- ((lambda (tmp1541)
- ((lambda (tmp1542)
- (if tmp1542
- (apply (lambda (_1543 e1544)
+ (lambda (#{x\ 2723}#)
+ ((lambda (#{tmp\ 2724}#)
+ ((lambda (#{tmp\ 2725}#)
+ (if #{tmp\ 2725}#
+ (apply (lambda (#{_\ 2726}# #{e\ 2727}#)
(syntax-violation
'unquote-splicing
"expression not valid outside of quasiquote"
- x1540))
- tmp1542)
+ #{x\ 2723}#))
+ #{tmp\ 2725}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1541)))
- ($sc-dispatch tmp1541 (quote (any any)))))
- x1540))))
+ #{tmp\ 2724}#)))
+ ($sc-dispatch #{tmp\ 2724}# (quote (any any)))))
+ #{x\ 2723}#))))
(define case
(make-extended-syncase-macro
(module-ref (current-module) (quote case))
'macro
- (lambda (x1545)
- ((lambda (tmp1546)
- ((lambda (tmp1547)
- (if tmp1547
- (apply (lambda (_1548 e1549 m11550 m21551)
- ((lambda (tmp1552)
- ((lambda (body1553)
+ (lambda (#{x\ 2728}#)
+ ((lambda (#{tmp\ 2729}#)
+ ((lambda (#{tmp\ 2730}#)
+ (if #{tmp\ 2730}#
+ (apply (lambda (#{_\ 2731}#
+ #{e\ 2732}#
+ #{m1\ 2733}#
+ #{m2\ 2734}#)
+ ((lambda (#{tmp\ 2735}#)
+ ((lambda (#{body\ 2736}#)
(list '#(syntax-object
let
((top)
@@ -10438,25 +11304,82 @@
#((top))
#("i")))
(hygiene guile))
- e1549))
- body1553))
- tmp1552))
- (letrec ((f1554 (lambda (clause1555 clauses1556)
- (if (null? clauses1556)
- ((lambda (tmp1558)
- ((lambda (tmp1559)
- (if tmp1559
- (apply (lambda (e11560
- e21561)
- (cons '#(syntax-object
- begin
+ #{e\ 2732}#))
+ #{body\ 2736}#))
+ #{tmp\ 2735}#))
+ (letrec ((#{f\ 2737}#
+ (lambda (#{clause\ 2738}# #{clauses\ 2739}#)
+ (if (null? #{clauses\ 2739}#)
+ ((lambda (#{tmp\ 2741}#)
+ ((lambda (#{tmp\ 2742}#)
+ (if #{tmp\ 2742}#
+ (apply (lambda (#{e1\ 2743}#
+ #{e2\ 2744}#)
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(e1 e2)
+ #((top)
+ (top))
+ #("i" "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (cons #{e1\ 2743}#
+ #{e2\ 2744}#)))
+ #{tmp\ 2742}#)
+ ((lambda (#{tmp\ 2746}#)
+ (if #{tmp\ 2746}#
+ (apply (lambda (#{k\ 2747}#
+ #{e1\ 2748}#
+ #{e2\ 2749}#)
+ (list '#(syntax-object
+ if
((top)
#(ribcage
- #(e1
+ #(k
+ e1
e2)
#((top)
+ (top)
(top))
#("i"
+ "i"
"i"))
#(ribcage
()
@@ -10495,319 +11418,8 @@
#("i")))
(hygiene
guile))
- (cons e11560
- e21561)))
- tmp1559)
- ((lambda (tmp1563)
- (if tmp1563
- (apply (lambda (k1564
- e11565
- e21566)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- k1564))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (cons e11565
- e21566))))
- tmp1563)
- ((lambda (_1569)
- (syntax-violation
- 'case
- "bad clause"
- x1545
- clause1555))
- tmp1558)))
- ($sc-dispatch
- tmp1558
- '(each-any
- any
- .
- each-any)))))
- ($sc-dispatch
- tmp1558
- '(#(free-id
- #(syntax-object
- else
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("i" "i" "i"))
- #(ribcage
- #(_ e m1 m2)
- #((top)
- (top)
- (top)
- (top))
- #("i" "i" "i" "i"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene guile)))
- any
- .
- each-any))))
- clause1555)
- ((lambda (tmp1570)
- ((lambda (rest1571)
- ((lambda (tmp1572)
- ((lambda (tmp1573)
- (if tmp1573
- (apply (lambda (k1574
- e11575
- e21576)
(list '#(syntax-object
- if
+ memv
((top)
#(ribcage
#(k
@@ -10820,9 +11432,55 @@
"i"
"i"))
#(ribcage
- #(rest)
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
#((top))
- #("i"))
+ #("i")))
+ (hygiene
+ guile))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
#(ribcage
()
()
@@ -10861,170 +11519,7 @@
(hygiene
guile))
(list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(k
- e1
- e2)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("i"
- "i"
- "i"))
- #(ribcage
- #(_
- e
- m1
- m2)
- #((top)
- (top)
- (top)
- (top))
- #("i"
- "i"
- "i"
- "i"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i")))
- (hygiene
- guile))
- k1574))
- (cons '#(syntax-object
- begin
+ quote
((top)
#(ribcage
#(k
@@ -11037,10 +11532,6 @@
"i"
"i"))
#(ribcage
- #(rest)
- #((top))
- #("i"))
- #(ribcage
()
()
())
@@ -11077,46 +11568,421 @@
#("i")))
(hygiene
guile))
- (cons e11575
- e21576))
- rest1571))
- tmp1573)
- ((lambda (_1579)
- (syntax-violation
- 'case
- "bad clause"
- x1545
- clause1555))
- tmp1572)))
- ($sc-dispatch
- tmp1572
- '(each-any
- any
- .
- each-any))))
- clause1555))
- tmp1570))
- (f1554 (car clauses1556)
- (cdr clauses1556)))))))
- (f1554 m11550 m21551))))
- tmp1547)
+ #{k\ 2747}#))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (cons #{e1\ 2748}#
+ #{e2\ 2749}#))))
+ #{tmp\ 2746}#)
+ ((lambda (#{_\ 2752}#)
+ (syntax-violation
+ 'case
+ "bad clause"
+ #{x\ 2728}#
+ #{clause\ 2738}#))
+ #{tmp\ 2741}#)))
+ ($sc-dispatch
+ #{tmp\ 2741}#
+ '(each-any
+ any
+ .
+ each-any)))))
+ ($sc-dispatch
+ #{tmp\ 2741}#
+ '(#(free-id
+ #(syntax-object
+ else
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(f clause clauses)
+ #((top) (top) (top))
+ #("i" "i" "i"))
+ #(ribcage
+ #(_ e m1 m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i" "i" "i" "i"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene guile)))
+ any
+ .
+ each-any))))
+ #{clause\ 2738}#)
+ ((lambda (#{tmp\ 2753}#)
+ ((lambda (#{rest\ 2754}#)
+ ((lambda (#{tmp\ 2755}#)
+ ((lambda (#{tmp\ 2756}#)
+ (if #{tmp\ 2756}#
+ (apply (lambda (#{k\ 2757}#
+ #{e1\ 2758}#
+ #{e2\ 2759}#)
+ (list '#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (list '#(syntax-object
+ memv
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ '#(syntax-object
+ t
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (list '#(syntax-object
+ quote
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ #{k\ 2757}#))
+ (cons '#(syntax-object
+ begin
+ ((top)
+ #(ribcage
+ #(k
+ e1
+ e2)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(rest)
+ #((top))
+ #("i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(f
+ clause
+ clauses)
+ #((top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"))
+ #(ribcage
+ #(_
+ e
+ m1
+ m2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i"
+ "i"
+ "i"
+ "i"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i")))
+ (hygiene
+ guile))
+ (cons #{e1\ 2758}#
+ #{e2\ 2759}#))
+ #{rest\ 2754}#))
+ #{tmp\ 2756}#)
+ ((lambda (#{_\ 2762}#)
+ (syntax-violation
+ 'case
+ "bad clause"
+ #{x\ 2728}#
+ #{clause\ 2738}#))
+ #{tmp\ 2755}#)))
+ ($sc-dispatch
+ #{tmp\ 2755}#
+ '(each-any
+ any
+ .
+ each-any))))
+ #{clause\ 2738}#))
+ #{tmp\ 2753}#))
+ (#{f\ 2737}#
+ (car #{clauses\ 2739}#)
+ (cdr #{clauses\ 2739}#)))))))
+ (#{f\ 2737}# #{m1\ 2733}# #{m2\ 2734}#))))
+ #{tmp\ 2730}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1546)))
+ #{tmp\ 2729}#)))
($sc-dispatch
- tmp1546
+ #{tmp\ 2729}#
'(any any any . each-any))))
- x1545))))
+ #{x\ 2728}#))))
(define identifier-syntax
(make-syncase-macro
'macro
- (lambda (x1580)
- ((lambda (tmp1581)
- ((lambda (tmp1582)
- (if tmp1582
- (apply (lambda (_1583 e1584)
+ (lambda (#{x\ 2763}#)
+ ((lambda (#{tmp\ 2764}#)
+ ((lambda (#{tmp\ 2765}#)
+ (if #{tmp\ 2765}#
+ (apply (lambda (#{_\ 2766}# #{e\ 2767}#)
(list '#(syntax-object
lambda
((top)
@@ -11205,8 +12071,8 @@
#((top))
#("i")))
(hygiene guile))
- e1584))
- (list (cons _1583
+ #{e\ 2767}#))
+ (list (cons #{_\ 2766}#
'(#(syntax-object
x
((top)
@@ -11246,7 +12112,7 @@
#((top))
#("i")))
(hygiene guile))
- (cons e1584
+ (cons #{e\ 2767}#
'(#(syntax-object
x
((top)
@@ -11274,11 +12140,11 @@
#("i")))
(hygiene
guile)))))))))
- tmp1582)
+ #{tmp\ 2765}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp1581)))
- ($sc-dispatch tmp1581 (quote (any any)))))
- x1580))))
+ #{tmp\ 2764}#)))
+ ($sc-dispatch #{tmp\ 2764}# (quote (any any)))))
+ #{x\ 2763}#))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 6ecf24ee6..cb90fcc17 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1198,7 +1198,13 @@
;; affect compile-time environment (once we have booted)
(if (and (not (module-local-variable (current-module) n))
(current-module))
- (module-define! (current-module) n #f))
+ (let ((old (module-variable (current-module) n)))
+ ;; use value of the same-named imported variable, if
+ ;; any
+ (module-define! (current-module) n
+ (if (variable? old)
+ (variable-ref old)
+ #f))))
(eval-if-c&e m
(build-global-definition s n (chi e r w mod))
mod))
diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 2427c4247..c90947204 100644
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -34,26 +34,21 @@
;; lengths are encoded in 3 bytes
(define *len-len* 3)
+
(define (byte-length assembly)
(pmatch assembly
(,label (guard (not (pair? label)))
0)
- ((load-unsigned-integer ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-integer ,str)
- (+ 1 *len-len* (string-length str)))
((load-number ,str)
(+ 1 *len-len* (string-length str)))
((load-string ,str)
(+ 1 *len-len* (string-length str)))
+ ((load-wide-string ,str)
+ (+ 1 *len-len* (* 4 (string-length str))))
((load-symbol ,str)
(+ 1 *len-len* (string-length str)))
- ((load-keyword ,str)
- (+ 1 *len-len* (string-length str)))
((load-array ,bv)
(+ 1 *len-len* (bytevector-length bv)))
- ((define ,str)
- (+ 1 *len-len* (string-length str)))
((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
@@ -169,5 +164,4 @@
n4)))
((load-string ,s) s)
((load-symbol ,s) (string->symbol s))
- ((load-keyword ,s) (symbol->keyword (string->symbol s)))
(else #f)))
diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index bed0fb2dc..688cb6b31 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -65,6 +65,14 @@
(write-byte (logand (ash x -8) 255))
(write-byte (logand (ash x -16) 255))
(write-byte (logand (ash x -24) 255)))
+ (define (write-uint32 x)
+ (case byte-order
+ ((1234) (write-uint32-le x))
+ ((4321) (write-uint32-be x))
+ (else (error "unknown endianness" byte-order))))
+ (define (write-wide-string s)
+ (write-loader-len (* 4 (string-length s)))
+ (string-for-each (lambda (c) (write-uint32 (char->integer c))) s))
(define (write-loader-len len)
(write-byte (ash len -16))
(write-byte (logand (ash len -8) 255))
@@ -72,6 +80,14 @@
(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!
@@ -89,10 +105,6 @@
(write-uint16 (case byte-order
((1234) write-uint16-le)
((4321) write-uint16-be)
- (else (error "unknown endianness" byte-order))))
- (write-uint32 (case byte-order
- ((1234) write-uint32-le)
- ((4321) write-uint32-be)
(else (error "unknown endianness" byte-order)))))
(let ((opcode (instruction->opcode inst))
(len (instruction-length inst)))
@@ -118,19 +130,16 @@
(set! i (1+ i))
(if (> i 0) (write-byte x))))
(get-addr (lambda () i)))
- ;; FIXME: We should add padding here so that META's bytecode
- ;; meets the alignment requirements of `scm_objcode'. See
- ;; `scm_c_make_objcode_slice ()'.
+ ;; META's bytecode meets the alignment requirements of
+ ;; `scm_objcode', thanks to the alignment computed in
+ ;; `(language assembly)'.
(write-bytecode meta write get-addr '()))))
((make-char32 ,x) (write-uint32-be x))
- ((load-unsigned-integer ,str) (write-loader str))
- ((load-integer ,str) (write-loader str))
((load-number ,str) (write-loader str))
((load-string ,str) (write-loader str))
+ ((load-wide-string ,str) (write-wide-string str))
((load-symbol ,str) (write-loader str))
- ((load-keyword ,str) (write-loader str))
((load-array ,bv) (write-bytevector bv))
- ((define ,str) (write-loader str))
((br ,l) (write-break l))
((br-if ,l) (write-break l))
((br-if-not ,l) (write-break l))
diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm
index 0e34ab4a2..8cdebcfd0 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -24,6 +24,7 @@
#:use-module (srfi srfi-4)
#:use-module (rnrs bytevector)
#:use-module (language assembly)
+ #:use-module ((system vm objcode) #:select (byte-order))
#:export (decompile-bytecode))
(define (decompile-bytecode x env opts)
@@ -101,23 +102,27 @@
(cond
((eq? inst 'load-program)
(decode-load-program pop))
+
((< (instruction-length inst) 0)
+ ;; the negative length indicates a variable length
+ ;; instruction
(let* ((make-sequence
- (if (eq? inst 'load-array)
+ (if (or (memq inst '(load-array load-wide-string)))
make-bytevector
make-string))
(sequence-set!
- (if (eq? inst 'load-array)
+ (if (or (memq inst '(load-array load-wide-string)))
bytevector-u8-set!
(lambda (str pos value)
(string-set! str pos (integer->char value)))))
-
(len (let* ((a (pop)) (b (pop)) (c (pop)))
(+ (ash a 16) (ash b 8) c)))
(seq (make-sequence len)))
(let lp ((i 0))
(if (= i len)
- `(,inst ,seq)
+ `(,inst ,(if (eq? inst 'load-wide-string)
+ (utf32->string seq)
+ seq))
(begin
(sequence-set! seq i (pop))
(lp (1+ i)))))))
diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index d41c8161d..492acb7e5 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -60,6 +60,8 @@
(print-info pos `(load-program ,sym) #f #f)
(lp (+ pos (byte-length asm)) (cdr code)
(acons sym asm programs))))
+ ((nop)
+ (lp (+ pos (byte-length asm)) (cdr code) programs))
(else
(print-info pos asm
(code-annotation end asm objs nargs blocs
diff --git a/module/language/ecmascript/compile-ghil.scm b/module/language/ecmascript/compile-ghil.scm
deleted file mode 100644
index ab04ba80c..000000000
--- a/module/language/ecmascript/compile-ghil.scm
+++ /dev/null
@@ -1,561 +0,0 @@
-;;; ECMAScript for Guile
-
-;; Copyright (C) 2009 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Code:
-
-(define-module (language ecmascript compile-ghil)
- #:use-module (language ghil)
- #:use-module (ice-9 receive)
- #:use-module (system base pmatch)
- #:export (compile-ghil))
-
-(define-macro (-> form)
- `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form)))
-
-(define-macro (@implv sym)
- `(-> (ref (ghil-var-at-module! e '(language ecmascript impl) ',sym #t))))
-(define-macro (@impl sym args)
- `(-> (call (@implv ,sym) ,args)))
-
-(define (compile-ghil exp env opts)
- (values
- (call-with-ghil-environment (make-ghil-toplevel-env) '()
- (lambda (e vars)
- (let ((l #f))
- (-> (lambda vars #f '()
- (-> (begin (list (@impl js-init '())
- (comp exp e)))))))))
- env
- env))
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- props))))
-
-(define (comp x e)
- (let ((l (location x)))
- (define (let1 what proc)
- (call-with-ghil-bindings e '(%tmp)
- (lambda (vars)
- (-> (bind vars (list what)
- (proc (car vars)))))))
- (define (begin1 what proc)
- (call-with-ghil-bindings e '(%tmp)
- (lambda (vars)
- (-> (bind vars (list what)
- (-> (begin (list (proc (car vars))
- (-> (ref (car vars)))))))))))
- (pmatch x
- (null
- ;; FIXME, null doesn't have much relation to EOL...
- (-> (quote '())))
- (true
- (-> (quote #t)))
- (false
- (-> (quote #f)))
- ((number ,num)
- (-> (quote num)))
- ((string ,str)
- (-> (quote str)))
- (this
- (@impl get-this '()))
- ((+ ,a)
- (-> (inline 'add
- (list (@impl ->number (list (comp a e)))
- (-> (quote 0))))))
- ((- ,a)
- (-> (inline 'sub (list (-> (quote 0)) (comp a e)))))
- ((~ ,a)
- (@impl bitwise-not (list (comp a e))))
- ((! ,a)
- (@impl logical-not (list (comp a e))))
- ((+ ,a ,b)
- (-> (inline 'add (list (comp a e) (comp b e)))))
- ((- ,a ,b)
- (-> (inline 'sub (list (comp a e) (comp b e)))))
- ((/ ,a ,b)
- (-> (inline 'div (list (comp a e) (comp b e)))))
- ((* ,a ,b)
- (-> (inline 'mul (list (comp a e) (comp b e)))))
- ((% ,a ,b)
- (@impl mod (list (comp a e) (comp b e))))
- ((<< ,a ,b)
- (@impl shift (list (comp a e) (comp b e))))
- ((>> ,a ,b)
- (@impl shift (list (comp a e) (comp `(- ,b) e))))
- ((< ,a ,b)
- (-> (inline 'lt? (list (comp a e) (comp b e)))))
- ((<= ,a ,b)
- (-> (inline 'le? (list (comp a e) (comp b e)))))
- ((> ,a ,b)
- (-> (inline 'gt? (list (comp a e) (comp b e)))))
- ((>= ,a ,b)
- (-> (inline 'ge? (list (comp a e) (comp b e)))))
- ((in ,a ,b)
- (@impl has-property? (list (comp a e) (comp b e))))
- ((== ,a ,b)
- (-> (inline 'equal? (list (comp a e) (comp b e)))))
- ((!= ,a ,b)
- (-> (inline 'not
- (list (-> (inline 'equal?
- (list (comp a e) (comp b e))))))))
- ((=== ,a ,b)
- (-> (inline 'eqv? (list (comp a e) (comp b e)))))
- ((!== ,a ,b)
- (-> (inline 'not
- (list (-> (inline 'eqv?
- (list (comp a e) (comp b e))))))))
- ((& ,a ,b)
- (@impl band (list (comp a e) (comp b e))))
- ((^ ,a ,b)
- (@impl bxor (list (comp a e) (comp b e))))
- ((bor ,a ,b)
- (@impl bior (list (comp a e) (comp b e))))
- ((and ,a ,b)
- (-> (and (list (comp a e) (comp b e)))))
- ((or ,a ,b)
- (-> (or (list (comp a e) (comp b e)))))
- ((if ,test ,then ,else)
- (-> (if (@impl ->boolean (list (comp test e)))
- (comp then e)
- (comp else e))))
- ((if ,test ,then ,else)
- (-> (if (@impl ->boolean (list (comp test e)))
- (comp then e)
- (@implv *undefined*))))
- ((postinc (ref ,foo))
- (begin1 (comp `(ref ,foo) e)
- (lambda (var)
- (-> (set (ghil-var-for-set! e foo)
- (-> (inline 'add
- (list (-> (ref var))
- (-> (quote 1))))))))))
- ((postinc (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (@impl pget
- (list (-> (ref objvar))
- (-> (quote prop))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (quote prop))
- (-> (inline 'add
- (list (-> (ref tmpvar))
- (-> (quote 1))))))))))))
- ((postinc (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (@impl pget
- (list (-> (ref objvar))
- (-> (ref propvar))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (ref propvar))
- (-> (inline 'add
- (list (-> (ref tmpvar))
- (-> (quote 1))))))))))))))
- ((postdec (ref ,foo))
- (begin1 (comp `(ref ,foo) e)
- (lambda (var)
- (-> (set (ghil-var-for-set! e foo)
- (-> (inline 'sub
- (list (-> (ref var))
- (-> (quote 1))))))))))
- ((postdec (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (@impl pget
- (list (-> (ref objvar))
- (-> (quote prop))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (quote prop))
- (-> (inline 'sub
- (list (-> (ref tmpvar))
- (-> (quote 1))))))))))))
- ((postdec (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (@impl pget
- (list (-> (ref objvar))
- (-> (ref propvar))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (ref propvar))
- (-> (inline
- 'sub (list (-> (ref tmpvar))
- (-> (quote 1))))))))))))))
- ((preinc (ref ,foo))
- (let ((v (ghil-var-for-set! e foo)))
- (-> (begin
- (list
- (-> (set v
- (-> (inline 'add
- (list (-> (ref v))
- (-> (quote 1)))))))
- (-> (ref v)))))))
- ((preinc (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (-> (inline 'add
- (list (@impl pget
- (list (-> (ref objvar))
- (-> (quote prop))))
- (-> (quote 1)))))
- (lambda (tmpvar)
- (@impl pput (list (-> (ref objvar))
- (-> (quote prop))
- (-> (ref tmpvar)))))))))
- ((preinc (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (-> (inline 'add
- (list (@impl pget
- (list (-> (ref objvar))
- (-> (ref propvar))))
- (-> (quote 1)))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (ref propvar))
- (-> (ref tmpvar)))))))))))
- ((predec (ref ,foo))
- (let ((v (ghil-var-for-set! e foo)))
- (-> (begin
- (list
- (-> (set v
- (-> (inline 'sub
- (list (-> (ref v))
- (-> (quote 1)))))))
- (-> (ref v)))))))
- ((predec (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (-> (inline 'sub
- (list (@impl pget
- (list (-> (ref objvar))
- (-> (quote prop))))
- (-> (quote 1)))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (quote prop))
- (-> (ref tmpvar)))))))))
- ((predec (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (-> (inline 'sub
- (list (@impl pget
- (list (-> (ref objvar))
- (-> (ref propvar))))
- (-> (quote 1)))))
- (lambda (tmpvar)
- (@impl pput
- (list (-> (ref objvar))
- (-> (ref propvar))
- (-> (ref tmpvar)))))))))))
- ((ref ,id)
- (-> (ref (ghil-var-for-ref! e id))))
- ((var . ,forms)
- (-> (begin
- (map (lambda (form)
- (pmatch form
- ((,x ,y)
- (-> (define (ghil-var-define! (ghil-env-parent e) x)
- (comp y e))))
- ((,x)
- (-> (define (ghil-var-define! (ghil-env-parent e) x)
- (@implv *undefined*))))
- (else (error "bad var form" form))))
- forms))))
- ((begin . ,forms)
- (-> (begin
- (map (lambda (x) (comp x e)) forms))))
- ((lambda ,formals ,body)
- (call-with-ghil-environment e '(%args)
- (lambda (e vars)
- (-> (lambda vars #t '()
- (comp-body env l body formals '%args))))))
- ((call/this ,obj ,prop ,args)
- (@impl call/this*
- (list obj
- (-> (lambda '() #f '()
- (-> (call (@impl pget (list obj prop))
- args)))))))
- ((call (pref ,obj ,prop) ,args)
- (comp `(call/this ,(comp obj e)
- ,(-> (quote prop))
- ,(map (lambda (x) (comp x e)) args))
- e))
- ((call (aref ,obj ,prop) ,args)
- (comp `(call/this ,(comp obj e)
- ,(comp prop e)
- ,(map (lambda (x) (comp x e)) args))
- e))
- ((call ,proc ,args)
- (-> (call (comp proc e)
- (map (lambda (x) (comp x e)) args))))
- ((return ,expr)
- (-> (inline 'return
- (list (comp expr e)))))
- ((array . ,args)
- (@impl new-array
- (map (lambda (x) (comp x e)) args)))
- ((object . ,args)
- (@impl new-object
- (map (lambda (x)
- (pmatch x
- ((,prop ,val)
- (-> (inline 'cons
- (list (-> (quote prop))
- (comp val e)))))
- (else
- (error "bad prop-val pair" x))))
- args)))
- ((pref ,obj ,prop)
- (@impl pget
- (list (comp obj e)
- (-> (quote prop)))))
- ((aref ,obj ,index)
- (@impl pget
- (list (comp obj e)
- (comp index e))))
- ((= (ref ,name) ,val)
- (let ((v (ghil-var-for-set! e name)))
- (-> (begin
- (list (-> (set v (comp val e)))
- (-> (ref v)))))))
- ((= (pref ,obj ,prop) ,val)
- (@impl pput
- (list (comp obj e)
- (-> (quote prop))
- (comp val e))))
- ((= (aref ,obj ,prop) ,val)
- (@impl pput
- (list (comp obj e)
- (comp prop e)
- (comp val e))))
- ((+= ,what ,val)
- (comp `(= ,what (+ ,what ,val)) e))
- ((-= ,what ,val)
- (comp `(= ,what (- ,what ,val)) e))
- ((/= ,what ,val)
- (comp `(= ,what (/ ,what ,val)) e))
- ((*= ,what ,val)
- (comp `(= ,what (* ,what ,val)) e))
- ((%= ,what ,val)
- (comp `(= ,what (% ,what ,val)) e))
- ((>>= ,what ,val)
- (comp `(= ,what (>> ,what ,val)) e))
- ((<<= ,what ,val)
- (comp `(= ,what (<< ,what ,val)) e))
- ((>>>= ,what ,val)
- (comp `(= ,what (>>> ,what ,val)) e))
- ((&= ,what ,val)
- (comp `(= ,what (& ,what ,val)) e))
- ((bor= ,what ,val)
- (comp `(= ,what (bor ,what ,val)) e))
- ((^= ,what ,val)
- (comp `(= ,what (^ ,what ,val)) e))
- ((new ,what ,args)
- (@impl new
- (map (lambda (x) (comp x e))
- (cons what args))))
- ((delete (pref ,obj ,prop))
- (@impl pdel
- (list (comp obj e)
- (-> (quote prop)))))
- ((delete (aref ,obj ,prop))
- (@impl pdel
- (list (comp obj e)
- (comp prop e))))
- ((void ,expr)
- (-> (begin
- (list (comp expr e)
- (@implv *undefined*)))))
- ((typeof ,expr)
- (@impl typeof
- (list (comp expr e))))
- ((do ,statement ,test)
- (call-with-ghil-bindings e '(%loop %continue)
- (lambda (vars)
- (-> (bind vars
- (list (call-with-ghil-environment e '()
- (lambda (e _)
- (-> (lambda '() #f '()
- (-> (begin
- (list (comp statement e)
- (-> (call
- (-> (ref (ghil-var-for-ref! e '%continue)))
- '())))))))))
- (call-with-ghil-environment e '()
- (lambda (e _)
- (-> (lambda '() #f '()
- (-> (if (@impl ->boolean (list (comp test e)))
- (-> (call
- (-> (ref (ghil-var-for-ref! e '%loop)))
- '()))
- (@implv *undefined*))))))))
- (-> (call (-> (ref (car vars))) '())))))))
- ((while ,test ,statement)
- (call-with-ghil-bindings e '(%continue)
- (lambda (vars)
- (-> (begin
- (list
- (-> (set (car vars)
- (call-with-ghil-environment e '()
- (lambda (e _)
- (-> (lambda '() #f '()
- (-> (if (@impl ->boolean (list (comp test e)))
- (-> (begin
- (list (comp statement e)
- (-> (call
- (-> (ref (ghil-var-for-ref! e '%continue)))
- '())))))
- (@implv *undefined*)))))))))
- (-> (call (-> (ref (car vars))) '()))))))))
- ((for ,init ,test ,inc ,statement)
- (call-with-ghil-bindings e '(%continue)
- (lambda (vars)
- (-> (begin
- (list
- (comp (or init '(begin)) e)
- (-> (set (car vars)
- (call-with-ghil-environment e '()
- (lambda (e _)
- (-> (lambda '() #f '()
- (-> (if (if test
- (@impl ->boolean (list (comp test e)))
- (comp 'true e))
- (-> (begin
- (list (comp statement e)
- (comp (or inc '(begin)) e)
- (-> (call
- (-> (ref (ghil-var-for-ref! e '%continue)))
- '())))))
- (@implv *undefined*)))))))))
- (-> (call (-> (ref (car vars))) '()))))))))
- ((for-in ,var ,object ,statement)
- (call-with-ghil-bindings e '(%continue %enum)
- (lambda (vars)
- (-> (begin
- (list
- (-> (set (car vars)
- (call-with-ghil-environment e '()
- (lambda (e _)
- (-> (lambda '() #f '()
- (-> (if (@impl ->boolean
- (list (@impl pget
- (list (-> (ref (ghil-var-for-ref! e '%enum)))
- (-> (quote 'length))))))
- (-> (begin
- (list
- (comp `(= ,var (call/this ,(-> (ref (ghil-var-for-ref! e '%enum)))
- ,(-> (quote 'pop))
- ()))
- e)
- (comp statement e)
- (-> (call (-> (ref (ghil-var-for-ref! e '%continue)))
- '())))))
- (@implv *undefined*)))))))))
- (-> (set (cadr vars)
- (@impl make-enumerator (list (comp object e)))))
- (-> (call (-> (ref (car vars))) '()))))))))
- ((break)
- (let ((var (ghil-var-for-ref! e '%continue)))
- (if (and (ghil-env? (ghil-var-env var))
- (eq? (ghil-var-env var) (ghil-env-parent e)))
- (-> (inline 'return (@implv *undefined*)))
- (error "bad break, yo"))))
- ((continue)
- (let ((var (ghil-var-for-ref! e '%continue)))
- (if (and (ghil-env? (ghil-var-env var))
- (eq? (ghil-var-env var) (ghil-env-parent e)))
- (-> (inline 'goto/args (list (-> (ref var)))))
- (error "bad continue, yo"))))
- ((block ,x)
- (comp x e))
- (else
- (error "compilation not yet implemented:" x)))))
-
-(define (comp-body e l body formals %args)
- (define (process)
- (let lp ((in body) (out '()) (rvars (reverse formals)))
- (pmatch in
- (((var (,x) . ,morevars) . ,rest)
- (lp `((var . ,morevars) . ,rest)
- out
- (if (memq x rvars) rvars (cons x rvars))))
- (((var (,x ,y) . ,morevars) . ,rest)
- (lp `((var . ,morevars) . ,rest)
- `((= (ref ,x) ,y) . ,out)
- (if (memq x rvars) rvars (cons x rvars))))
- (((var) . ,rest)
- (lp rest out rvars))
- ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
- (lp rest
- (cons x out)
- rvars))
- ((,x . ,rest) (guard (pair? x))
- (receive (sub-out rvars)
- (lp x '() rvars)
- (lp rest
- (cons sub-out out)
- rvars)))
- ((,x . ,rest)
- (lp rest
- (cons x out)
- rvars))
- (()
- (values (reverse! out)
- rvars)))))
- (receive (out rvars)
- (process)
- (call-with-ghil-bindings e (reverse rvars)
- (lambda (vars)
- (let ((%argv (assq-ref (ghil-env-table e) %args)))
- (-> (begin
- `(,@(map
- (lambda (f)
- (-> (if (-> (inline 'null?
- (list (-> (ref %argv)))))
- (-> (begin '()))
- (-> (begin
- (list (-> (set (ghil-var-for-ref! e f)
- (-> (inline 'car
- (list (-> (ref %argv)))))))
- (-> (set %argv
- (-> (inline 'cdr
- (list (-> (ref %argv)))))))))))))
- formals)
- ;; fixme: here check for too many args
- ,(comp out e)))))))))
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
new file mode 100644
index 000000000..88f3db76f
--- /dev/null
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -0,0 +1,549 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language ecmascript compile-tree-il)
+ #:use-module (language tree-il)
+ #:use-module (ice-9 receive)
+ #:use-module (system base pmatch)
+ #:use-module (srfi srfi-1)
+ #:export (compile-tree-il))
+
+(define-syntax ->
+ (syntax-rules ()
+ ((_ (type arg ...))
+ `(type ,arg ...))))
+
+(define-syntax @implv
+ (syntax-rules ()
+ ((_ sym)
+ (-> (module-ref '(language ecmascript impl) 'sym #t)))))
+
+(define-syntax @impl
+ (syntax-rules ()
+ ((_ sym arg ...)
+ (-> (apply (@implv sym) arg ...)))))
+
+(define (empty-lexical-environment)
+ '())
+
+(define (econs name gensym env)
+ (acons name gensym env))
+
+(define (lookup name env)
+ (or (assq-ref env name)
+ (-> (toplevel name))))
+
+(define (compile-tree-il exp env opts)
+ (values
+ (parse-tree-il (comp exp (empty-lexical-environment)))
+ env
+ env))
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ props))))
+
+;; for emacs:
+;; (put 'pmatch/source 'scheme-indent-function 1)
+
+(define-syntax pmatch/source
+ (syntax-rules ()
+ ((_ x clause ...)
+ (let ((x x))
+ (let ((res (pmatch x
+ clause ...)))
+ (let ((loc (location x)))
+ (if loc
+ (set-source-properties! res (location x))))
+ res)))))
+
+(define (comp x e)
+ (let ((l (location x)))
+ (define (let1 what proc)
+ (let ((sym (gensym)))
+ (-> (let (list sym) (list sym) (list what)
+ (proc sym)))))
+ (define (begin1 what proc)
+ (let1 what (lambda (v)
+ (-> (begin (proc v)
+ (-> (lexical v v)))))))
+ (pmatch/source x
+ (null
+ ;; FIXME, null doesn't have much relation to EOL...
+ (-> (const '())))
+ (true
+ (-> (const #t)))
+ (false
+ (-> (const #f)))
+ ((number ,num)
+ (-> (const num)))
+ ((string ,str)
+ (-> (const str)))
+ (this
+ (@impl get-this '()))
+ ((+ ,a)
+ (-> (apply (-> (primitive '+))
+ (@impl ->number (comp a e))
+ (-> (const 0)))))
+ ((- ,a)
+ (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
+ ((~ ,a)
+ (@impl bitwise-not (comp a e)))
+ ((! ,a)
+ (@impl logical-not (comp a e)))
+ ((+ ,a ,b)
+ (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
+ ((- ,a ,b)
+ (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
+ ((/ ,a ,b)
+ (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
+ ((* ,a ,b)
+ (-> (apply (-> (primitive '*)) (comp a e) (comp b e))))
+ ((% ,a ,b)
+ (@impl mod (comp a e) (comp b e)))
+ ((<< ,a ,b)
+ (@impl shift (comp a e) (comp b e)))
+ ((>> ,a ,b)
+ (@impl shift (comp a e) (comp `(- ,b) e)))
+ ((< ,a ,b)
+ (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
+ ((<= ,a ,b)
+ (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
+ ((> ,a ,b)
+ (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
+ ((>= ,a ,b)
+ (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
+ ((in ,a ,b)
+ (@impl has-property? (comp a e) (comp b e)))
+ ((== ,a ,b)
+ (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
+ ((!= ,a ,b)
+ (-> (apply (-> (primitive 'not))
+ (-> (apply (-> (primitive 'equal?))
+ (comp a e) (comp b e))))))
+ ((=== ,a ,b)
+ (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+ ((!== ,a ,b)
+ (-> (apply (-> (primitive 'not))
+ (-> (apply (-> (primitive 'eqv?))
+ (comp a e) (comp b e))))))
+ ((& ,a ,b)
+ (@impl band (comp a e) (comp b e)))
+ ((^ ,a ,b)
+ (@impl bxor (comp a e) (comp b e)))
+ ((bor ,a ,b)
+ (@impl bior (comp a e) (comp b e)))
+ ((and ,a ,b)
+ (-> (if (@impl ->boolean (comp a e))
+ (comp b e)
+ (-> (const #f)))))
+ ((or ,a ,b)
+ (let1 (comp a e)
+ (lambda (v)
+ (-> (if (@impl ->boolean (-> (lexical v v)))
+ (-> (lexical v v))
+ (comp b e))))))
+ ((if ,test ,then ,else)
+ (-> (if (@impl ->boolean (comp test e))
+ (comp then e)
+ (comp else e))))
+ ((if ,test ,then ,else)
+ (-> (if (@impl ->boolean (comp test e))
+ (comp then e)
+ (@implv *undefined*))))
+ ((postinc (ref ,foo))
+ (begin1 (comp `(ref ,foo) e)
+ (lambda (var)
+ (-> (set! (lookup foo e)
+ (-> (apply (-> (primitive '+))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
+ ((postinc (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (apply (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
+ ((postinc (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (apply (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
+ ((postdec (ref ,foo))
+ (begin1 (comp `(ref ,foo) e)
+ (lambda (var)
+ (-> (set (lookup foo e)
+ (-> (apply (-> (primitive '-))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
+ ((postdec (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (apply (-> (primitive '-))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
+ ((postdec (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (inline
+ '- (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
+ ((preinc (ref ,foo))
+ (let ((v (lookup foo e)))
+ (-> (begin
+ (-> (set! v
+ (-> (apply (-> (primitive '+))
+ v
+ (-> (const 1))))))
+ v))))
+ ((preinc (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (-> (apply (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (lexical tmpvar tmpvar))))))))
+ ((preinc (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (-> (apply (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (lexical tmpvar tmpvar))))))))))
+ ((predec (ref ,foo))
+ (let ((v (lookup foo e)))
+ (-> (begin
+ (-> (set! v
+ (-> (apply (-> (primitive '-))
+ v
+ (-> (const 1))))))
+ v))))
+ ((predec (pref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (begin1 (-> (apply (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (const prop))
+ (-> (lexical tmpvar tmpvar))))))))
+ ((predec (aref ,obj ,prop))
+ (let1 (comp obj e)
+ (lambda (objvar)
+ (let1 (comp prop e)
+ (lambda (propvar)
+ (begin1 (-> (apply (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
+ (lambda (tmpvar)
+ (@impl pput
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar))
+ (-> (lexical tmpvar tmpvar))))))))))
+ ((ref ,id)
+ (lookup id e))
+ ((var . ,forms)
+ (-> (begin
+ (map (lambda (form)
+ (pmatch form
+ ((,x ,y)
+ (-> (define x (comp y e))))
+ ((,x)
+ (-> (define x (@implv *undefined*))))
+ (else (error "bad var form" form))))
+ forms))))
+ ((begin . ,forms)
+ `(begin ,@(map (lambda (x) (comp x e)) forms)))
+ ((lambda ,formals ,body)
+ (let ((%args (gensym "%args ")))
+ (-> (lambda '%args %args '()
+ (comp-body (econs '%args %args e) body formals '%args)))))
+ ((call/this ,obj ,prop . ,args)
+ (@impl call/this*
+ obj
+ (-> (lambda '() '() '()
+ `(apply ,(@impl pget obj prop) ,@args)))))
+ ((call (pref ,obj ,prop) ,args)
+ (comp `(call/this ,(comp obj e)
+ ,(-> (const prop))
+ ,@(map (lambda (x) (comp x e)) args))
+ e))
+ ((call (aref ,obj ,prop) ,args)
+ (comp `(call/this ,(comp obj e)
+ ,(comp prop e)
+ ,@(map (lambda (x) (comp x e)) args))
+ e))
+ ((call ,proc ,args)
+ `(apply ,(comp proc e)
+ ,@(map (lambda (x) (comp x e)) args)))
+ ((return ,expr)
+ (-> (apply (-> (primitive 'return))
+ (comp expr e))))
+ ((array . ,args)
+ `(apply ,(@implv new-array)
+ ,@(map (lambda (x) (comp x e)) args)))
+ ((object . ,args)
+ (@impl new-object
+ (map (lambda (x)
+ (pmatch x
+ ((,prop ,val)
+ (-> (apply (-> (primitive 'cons))
+ (-> (const prop))
+ (comp val e))))
+ (else
+ (error "bad prop-val pair" x))))
+ args)))
+ ((pref ,obj ,prop)
+ (@impl pget
+ (comp obj e)
+ (-> (const prop))))
+ ((aref ,obj ,index)
+ (@impl pget
+ (comp obj e)
+ (comp index e)))
+ ((= (ref ,name) ,val)
+ (let ((v (lookup name e)))
+ (-> (begin
+ (-> (set! v (comp val e)))
+ v))))
+ ((= (pref ,obj ,prop) ,val)
+ (@impl pput
+ (comp obj e)
+ (-> (const prop))
+ (comp val e)))
+ ((= (aref ,obj ,prop) ,val)
+ (@impl pput
+ (comp obj e)
+ (comp prop e)
+ (comp val e)))
+ ((+= ,what ,val)
+ (comp `(= ,what (+ ,what ,val)) e))
+ ((-= ,what ,val)
+ (comp `(= ,what (- ,what ,val)) e))
+ ((/= ,what ,val)
+ (comp `(= ,what (/ ,what ,val)) e))
+ ((*= ,what ,val)
+ (comp `(= ,what (* ,what ,val)) e))
+ ((%= ,what ,val)
+ (comp `(= ,what (% ,what ,val)) e))
+ ((>>= ,what ,val)
+ (comp `(= ,what (>> ,what ,val)) e))
+ ((<<= ,what ,val)
+ (comp `(= ,what (<< ,what ,val)) e))
+ ((>>>= ,what ,val)
+ (comp `(= ,what (>>> ,what ,val)) e))
+ ((&= ,what ,val)
+ (comp `(= ,what (& ,what ,val)) e))
+ ((bor= ,what ,val)
+ (comp `(= ,what (bor ,what ,val)) e))
+ ((^= ,what ,val)
+ (comp `(= ,what (^ ,what ,val)) e))
+ ((new ,what ,args)
+ (@impl new
+ (map (lambda (x) (comp x e))
+ (cons what args))))
+ ((delete (pref ,obj ,prop))
+ (@impl pdel
+ (comp obj e)
+ (-> (const prop))))
+ ((delete (aref ,obj ,prop))
+ (@impl pdel
+ (comp obj e)
+ (comp prop e)))
+ ((void ,expr)
+ (-> (begin
+ (comp expr e)
+ (@implv *undefined*))))
+ ((typeof ,expr)
+ (@impl typeof
+ (comp expr e)))
+ ((do ,statement ,test)
+ (let ((%loop (gensym "%loop "))
+ (%continue (gensym "%continue ")))
+ (let ((e (econs '%loop %loop (econs '%continue %continue e))))
+ (-> (letrec '(%loop %continue) (list %loop %continue)
+ (list (-> (lambda '() '() '()
+ (-> (begin
+ (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue)))
+ )))))
+
+ (-> (lambda '() '() '()
+ (-> (if (@impl ->boolean (comp test e))
+ (-> (apply (-> (lexical '%loop %loop))))
+ (@implv *undefined*))))))
+ (-> (apply (-> (lexical '%loop %loop)))))))))
+ ((while ,test ,statement)
+ (let ((%continue (gensym "%continue ")))
+ (let ((e (econs '%continue %continue e)))
+ (-> (letrec '(%continue) (list %continue)
+ (list (-> (lambda '() '() '()
+ (-> (if (@impl ->boolean (comp test e))
+ (-> (begin (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*))))))
+ (-> (apply (-> (lexical '%continue %continue)))))))))
+
+ ((for ,init ,test ,inc ,statement)
+ (let ((%continue (gensym "%continue ")))
+ (let ((e (econs '%continue %continue e)))
+ (-> (letrec '(%continue) (list %continue)
+ (list (-> (lambda '() '() '()
+ (-> (if (if test
+ (@impl ->boolean (comp test e))
+ (comp 'true e))
+ (-> (begin (comp statement e)
+ (comp (or inc '(begin)) e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*))))))
+ (-> (begin (comp (or init '(begin)) e)
+ (-> (apply (-> (lexical '%continue %continue)))))))))))
+
+ ((for-in ,var ,object ,statement)
+ (let ((%enum (gensym "%enum "))
+ (%continue (gensym "%continue ")))
+ (let ((e (econs '%enum %enum (econs '%continue %continue e))))
+ (-> (letrec '(%enum %continue) (list %enum %continue)
+ (list (@impl make-enumerator (comp object e))
+ (-> (lambda '() '() '()
+ (-> (if (@impl ->boolean
+ (@impl pget
+ (-> (lexical '%enum %enum))
+ (-> (const 'length))))
+ (-> (begin
+ (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
+ ,(-> (const 'pop))))
+ e)
+ (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*))))))
+ (-> (apply (-> (lexical '%continue %continue)))))))))
+
+ ((block ,x)
+ (comp x e))
+ (else
+ (error "compilation not yet implemented:" x)))))
+
+(define (comp-body e body formals %args)
+ (define (process)
+ (let lp ((in body) (out '()) (rvars (reverse formals)))
+ (pmatch in
+ (((var (,x) . ,morevars) . ,rest)
+ (lp `((var . ,morevars) . ,rest)
+ out
+ (if (memq x rvars) rvars (cons x rvars))))
+ (((var (,x ,y) . ,morevars) . ,rest)
+ (lp `((var . ,morevars) . ,rest)
+ `((= (ref ,x) ,y) . ,out)
+ (if (memq x rvars) rvars (cons x rvars))))
+ (((var) . ,rest)
+ (lp rest out rvars))
+ ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
+ (lp rest
+ (cons x out)
+ rvars))
+ ((,x . ,rest) (guard (pair? x))
+ (receive (sub-out rvars)
+ (lp x '() rvars)
+ (lp rest
+ (cons sub-out out)
+ rvars)))
+ ((,x . ,rest)
+ (lp rest
+ (cons x out)
+ rvars))
+ (()
+ (values (reverse! out)
+ rvars)))))
+ (receive (out rvars)
+ (process)
+ (let* ((names (reverse rvars))
+ (syms (map (lambda (x)
+ (gensym (string-append (symbol->string x) " ")))
+ names))
+ (e (fold acons e names syms)))
+ (let ((%argv (lookup %args e)))
+ (let lp ((names names) (syms syms))
+ (if (null? names)
+ ;; fixme: here check for too many args
+ (comp out e)
+ (-> (let (list (car names)) (list (car syms))
+ (list (-> (if (-> (apply (-> (primitive 'null?)) %argv))
+ (-> (@implv *undefined*))
+ (-> (let1 (-> (apply (-> (primitive 'car)) %argv))
+ (lambda (v)
+ (-> (set! %argv
+ (-> (apply (-> (primitive 'cdr)) %argv))))
+ (-> (lexical v v))))))))
+ (lp (cdr names) (cdr syms))))))))))
diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm
index 6e9470f38..7a1ea465c 100644
--- a/module/language/ecmascript/spec.scm
+++ b/module/language/ecmascript/spec.scm
@@ -21,7 +21,7 @@
(define-module (language ecmascript spec)
#:use-module (system base language)
#:use-module (language ecmascript parse)
- #:use-module (language ecmascript compile-ghil)
+ #:use-module (language ecmascript compile-tree-il)
#:export (ecmascript))
;;;
@@ -32,7 +32,7 @@
#:title "Guile ECMAScript"
#:version "3.0"
#:reader (lambda () (read-ecmascript/1 (current-input-port)))
- #:compilers `((ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il))
;; a pretty-printer would be interesting.
#:printer write
)
diff --git a/module/language/ecmascript/tokenize.scm b/module/language/ecmascript/tokenize.scm
index 63f180b14..1b6a7eeaf 100644
--- a/module/language/ecmascript/tokenize.scm
+++ b/module/language/ecmascript/tokenize.scm
@@ -365,7 +365,7 @@
. ,(cdar puncs))))))
(lp nodes (cdr puncs))))
(else
- (lp (cons `(,(string-ref (caar puncs) 0) #f) nodes)
+ (lp (cons (list (string-ref (caar puncs) 0) #f) nodes)
puncs))))))
(lambda (port)
(let lp ((c (peek-char port)) (tree punc-tree) (candidate #f))
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index fa5805757..121d9db9f 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -251,35 +251,41 @@
(emit-code
(if local?
(if (< index 256)
- `((,(case op
- ((ref) (if boxed? 'local-boxed-ref 'local-ref))
- ((set) (if boxed? 'local-boxed-set 'local-set))
- ((box) 'box)
- ((empty-box) 'empty-box)
- (else (error "what" op)))
- ,index))
+ (case op
+ ((ref) (if boxed?
+ `((local-boxed-ref ,index))
+ `((local-ref ,index))))
+ ((set) (if boxed?
+ `((local-boxed-set ,index))
+ `((local-set ,index))))
+ ((box) `((box ,index)))
+ ((empty-box) `((empty-box ,index)))
+ ((fix) `((fix-closure 0 ,index)))
+ (else (error "what" op)))
(let ((a (quotient i 256))
(b (modulo i 256)))
- `((,(case op
- ((ref)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-ref))
- `((long-local-ref ,a ,b))))
- ((set)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-set))
- `((long-local-set ,a ,b))))
- ((box)
- `((make-variable)
- (variable-set)
- (long-local-set ,a ,b)))
- ((empty-box)
- `((make-variable)
- (long-local-set ,a ,b)))
- (else (error "what" op)))
- ,index))))
+ `((,(case op
+ ((ref)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-ref))
+ `((long-local-ref ,a ,b))))
+ ((set)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-set))
+ `((long-local-set ,a ,b))))
+ ((box)
+ `((make-variable)
+ (variable-set)
+ (long-local-set ,a ,b)))
+ ((empty-box)
+ `((make-variable)
+ (long-local-set ,a ,b)))
+ ((fix)
+ `((fix-closure ,a ,b)))
+ (else (error "what" op)))
+ ,index))))
`((,(case op
((ref) (if boxed? 'free-boxed-ref 'free-ref))
((set) (if boxed? 'free-boxed-set (error "what." glil)))
@@ -312,8 +318,8 @@
,(modulo i 256))))
object-alist)))))
((define)
- (emit-code `((define ,(symbol->string name))
- (variable-set))))
+ (emit-code `(,@(dump-object name addr)
+ (define))))
(else
(error "unknown toplevel var kind" op name))))
@@ -385,11 +391,20 @@
((number? x)
`((load-number ,(number->string x))))
((string? x)
- `((load-string ,x)))
+ (case (string-bytes-per-char x)
+ ((1) `((load-string ,x)))
+ ((4) (align-code `(load-wide-string ,x) addr 4 4))
+ (else (error "bad string bytes per char" x))))
((symbol? x)
- `((load-symbol ,(symbol->string x))))
+ (let ((str (symbol->string x)))
+ (case (string-bytes-per-char str)
+ ((1) `((load-symbol ,str)))
+ ((4) `(,@(dump-object str addr)
+ (make-symbol)))
+ (else (error "bad string bytes per char" str)))))
((keyword? x)
- `((load-keyword ,(symbol->string (keyword->symbol x)))))
+ `(,@(dump-object (keyword->symbol x) addr)
+ (make-keyword)))
((list? x)
(let ((tail (let ((len (length x)))
(if (>= len 65536) (too-long "list"))
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 21aa023a5..df618581f 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.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
@@ -20,7 +20,6 @@
(define-module (language scheme spec)
#:use-module (system base language)
- #:use-module (language scheme compile-ghil)
#:use-module (language scheme compile-tree-il)
#:use-module (language scheme decompile-tree-il)
#:export (scheme))
@@ -39,8 +38,7 @@
#:title "Guile Scheme"
#:version "0.5"
#:reader read
- #:compilers `((tree-il . ,compile-tree-il)
- (ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il))
#:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index aec4eedb9..ad8b73176 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -18,6 +18,7 @@
(define-module (language tree-il)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
@@ -38,6 +39,7 @@
<lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
<let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
+ <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
parse-tree-il
@@ -45,6 +47,7 @@
tree-il->scheme
tree-il-fold
+ make-tree-il-folder
post-order!
pre-order!))
@@ -65,6 +68,7 @@
(<lambda> names vars meta body)
(<let> names vars vals body)
(<letrec> names vars vals body)
+ (<fix> names vars vals body)
(<let-values> names vars exp body))
@@ -141,6 +145,9 @@
((letrec ,names ,vars ,vals ,body)
(make-letrec loc names vars (map retrans vals) (retrans body)))
+ ((fix ,names ,vars ,vals ,body)
+ (make-fix loc names vars (map retrans vals) (retrans body)))
+
((let-values ,names ,vars ,exp ,body)
(make-let-values loc names vars (retrans exp) (retrans body)))
@@ -197,6 +204,9 @@
((<letrec> names vars vals body)
`(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+ ((<fix> names vars vals body)
+ `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+
((<let-values> names vars exp body)
`(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il body)))))
@@ -256,6 +266,10 @@
((<letrec> vars vals body)
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+ ((<fix> vars vals body)
+ ;; not a typo, we really do translate back to letrec
+ `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+
((<let-values> vars exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body))))))
@@ -300,11 +314,65 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop body
(loop vals
(down tree result)))))
- ((<let-values> body)
- (up tree (loop body (down tree result))))
+ ((<fix> vals body)
+ (up tree (loop body
+ (loop vals
+ (down tree result)))))
+ ((<let-values> exp body)
+ (up tree (loop body (loop exp (down tree result)))))
(else
(leaf tree result))))))
+
+(define-syntax make-tree-il-folder
+ (syntax-rules ()
+ ((_ seed ...)
+ (lambda (tree down up seed ...)
+ (define (fold-values proc exps seed ...)
+ (if (null? exps)
+ (values seed ...)
+ (let-values (((seed ...) (proc (car exps) seed ...)))
+ (fold-values proc (cdr exps) seed ...))))
+ (let foldts ((tree tree) (seed seed) ...)
+ (let*-values
+ (((seed ...) (down tree seed ...))
+ ((seed ...)
+ (record-case tree
+ ((<lexical-set> exp)
+ (foldts exp seed ...))
+ ((<module-set> exp)
+ (foldts exp seed ...))
+ ((<toplevel-set> exp)
+ (foldts exp seed ...))
+ ((<toplevel-define> exp)
+ (foldts exp seed ...))
+ ((<conditional> test then else)
+ (let*-values (((seed ...) (foldts test seed ...))
+ ((seed ...) (foldts then seed ...)))
+ (foldts else seed ...)))
+ ((<application> proc args)
+ (let-values (((seed ...) (foldts proc seed ...)))
+ (fold-values foldts args seed ...)))
+ ((<sequence> exps)
+ (fold-values foldts exps seed ...))
+ ((<lambda> body)
+ (foldts body seed ...))
+ ((<let> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<letrec> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<fix> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed ...)))
+ (foldts body seed ...)))
+ ((<let-values> exp body)
+ (let*-values (((seed ...) (foldts exp seed ...)))
+ (foldts body seed ...)))
+ (else
+ (values seed ...)))))
+ (up tree seed ...)))))))
+
(define (post-order! f x)
(let lp ((x x))
(record-case x
@@ -343,6 +411,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
+ ((<fix> vars vals body)
+ (set! (fix-vals x) (map lp vals))
+ (set! (fix-body x) (lp body)))
+
((<let-values> vars exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
@@ -390,6 +462,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
+ ((<fix> vars vals body)
+ (set! (fix-vals x) (map lp vals))
+ (set! (fix-body x) (lp body)))
+
((<let-values> vars exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 1b39b2dd4..b93a0bd7e 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -78,6 +78,25 @@
;; in a vector. Each closure variable has a unique index into that
;; vector.
;;
+;; There is one more complication. Procedures bound by <fix> may, in
+;; some cases, be rendered inline to their parent procedure. That is to
+;; say,
+;;
+;; (letrec ((lp (lambda () (lp)))) (lp))
+;; => (fix ((lp (lambda () (lp)))) (lp))
+;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
+;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop
+;;
+;; The upshot is that we don't have to allocate any space for the `lp'
+;; closure at all, as it can be rendered inline as a loop. So there is
+;; another kind of allocation, "label allocation", in which the
+;; procedure is simply a label, placed at the start of the lambda body.
+;; The label is the gensym under which the lambda expression is bound.
+;;
+;; The analyzer checks to see that the label is called with the correct
+;; number of arguments. Calls to labels compile to rename + goto.
+;; Lambda, the ultimate goto!
+;;
;;
;; The return value of `analyze-lexicals' is a hash table, the
;; "allocation".
@@ -88,15 +107,17 @@
;; in many procedures, it is a two-level map.
;;
;; The allocation also stored information on how many local variables
-;; need to be allocated for each procedure, and information on what free
-;; variables to capture from its lexical parent procedure.
+;; need to be allocated for each procedure, lexicals that have been
+;; translated into labels, and information on what free variables to
+;; capture from its lexical parent procedure.
;;
;; That is:
;;
;; sym -> {lambda -> address}
-;; lambda -> (nlocs . free-locs)
+;; lambda -> (nlocs labels . free-locs)
;;
-;; address := (local? boxed? . index)
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda-vars) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
@@ -108,32 +129,52 @@
(define (analyze-lexicals x)
;; bound-vars: lambda -> (sym ...)
;; all identifiers bound within a lambda
+ (define bound-vars (make-hash-table))
;; free-vars: lambda -> (sym ...)
;; all identifiers referenced in a lambda, but not bound
;; NB, this includes identifiers referenced by contained lambdas
+ (define free-vars (make-hash-table))
;; assigned: sym -> #t
;; variables that are assigned
+ (define assigned (make-hash-table))
;; refcounts: sym -> count
;; allows us to detect the or-expansion in O(1) time
-
+ (define refcounts (make-hash-table))
+ ;; labels: sym -> lambda-vars
+ ;; for determining if fixed-point procedures can be rendered as
+ ;; labels. lambda-vars may be an improper list.
+ (define labels (make-hash-table))
+
;; returns variables referenced in expr
- (define (analyze! x proc)
- (define (step y) (analyze! y proc))
- (define (recur x new-proc) (analyze! x new-proc))
+ (define (analyze! x proc labels-in-proc tail? tail-call-args)
+ (define (step y) (analyze! y proc labels-in-proc #f #f))
+ (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
+ (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
+ (and tail? args)))
+ (define (recur/labels x new-proc labels)
+ (analyze! x new-proc (append labels labels-in-proc) #t #f))
+ (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
(record-case x
((<application> proc args)
- (apply lset-union eq? (step proc) (map step args)))
+ (apply lset-union eq? (step-tail-call proc args)
+ (map step args)))
((<conditional> test then else)
- (lset-union eq? (step test) (step then) (step else)))
+ (lset-union eq? (step test) (step-tail then) (step-tail else)))
((<lexical-ref> name gensym)
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+ (if (not (and tail-call-args
+ (memq gensym labels-in-proc)
+ (let ((args (hashq-ref labels gensym)))
+ (and (list? args)
+ (= (length args) (length tail-call-args))))))
+ (hashq-set! labels gensym #f))
(list gensym))
((<lexical-set> name gensym exp)
- (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(hashq-set! assigned gensym #t)
+ (hashq-set! labels gensym #f)
(lset-adjoin eq? (step exp) gensym))
((<module-set> mod name public? exp)
@@ -146,7 +187,12 @@
(step exp))
((<sequence> exps)
- (apply lset-union eq? (map step exps)))
+ (let lp ((exps exps) (ret '()))
+ (cond ((null? exps) '())
+ ((null? (cdr exps))
+ (lset-union eq? ret (step-tail (car exps))))
+ (else
+ (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
((<lambda> vars meta body)
(let ((locally-bound (let rev* ((vars vars) (out '()))
@@ -166,7 +212,7 @@
(hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc)))
(lset-difference eq?
- (apply lset-union eq? (step body) (map step vals))
+ (apply lset-union eq? (step-tail body) (map step vals))
vars))
((<letrec> vars vals body)
@@ -174,21 +220,103 @@
(append (reverse vars) (hashq-ref bound-vars proc)))
(for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
(lset-difference eq?
- (apply lset-union eq? (step body) (map step vals))
+ (apply lset-union eq? (step-tail body) (map step vals))
vars))
- ((<let-values> vars exp body)
+ ((<fix> vars vals body)
+ ;; Try to allocate these procedures as labels.
+ (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val)))
+ vars vals)
(hashq-set! bound-vars proc
- (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)))))
- (lset-difference eq?
- (lset-union eq? (step exp) (step body))
- vars))
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ ;; Step into subexpressions.
+ (let* ((var-refs
+ (map
+ ;; Since we're trying to label-allocate the lambda,
+ ;; pretend it's not a closure, and just recurse into its
+ ;; body directly. (Otherwise, recursing on a closure
+ ;; that references one of the fix's bound vars would
+ ;; prevent label allocation.)
+ (lambda (x)
+ (record-case x
+ ((<lambda> (lvars vars) body)
+ (let ((locally-bound
+ (let rev* ((lvars lvars) (out '()))
+ (cond ((null? lvars) out)
+ ((pair? lvars) (rev* (cdr lvars)
+ (cons (car lvars) out)))
+ (else (cons lvars out))))))
+ (hashq-set! bound-vars x locally-bound)
+ ;; recur/labels, the difference from the closure case
+ (let* ((referenced (recur/labels body x vars))
+ (free (lset-difference eq? referenced locally-bound))
+ (all-bound (reverse! (hashq-ref bound-vars x))))
+ (hashq-set! bound-vars x all-bound)
+ (hashq-set! free-vars x free)
+ free)))))
+ vals))
+ (vars-with-refs (map cons vars var-refs))
+ (body-refs (recur/labels body proc vars)))
+ (define (delabel-dependents! sym)
+ (let ((refs (assq-ref vars-with-refs sym)))
+ (if refs
+ (for-each (lambda (sym)
+ (if (hashq-ref labels sym)
+ (begin
+ (hashq-set! labels sym #f)
+ (delabel-dependents! sym))))
+ refs))))
+ ;; Stepping into the lambdas and the body might have made some
+ ;; procedures not label-allocatable -- which might have
+ ;; knock-on effects. For example:
+ ;; (fix ((a (lambda () (b)))
+ ;; (b (lambda () a)))
+ ;; (a))
+ ;; As far as `a' is concerned, both `a' and `b' are
+ ;; label-allocatable. But `b' references `a' not in a proc-tail
+ ;; position, which makes `a' not label-allocatable. The
+ ;; knock-on effect is that, when back-propagating this
+ ;; information to `a', `b' will also become not
+ ;; label-allocatable, as it is referenced within `a', which is
+ ;; allocated as a closure. This is a transitive relationship.
+ (for-each (lambda (sym)
+ (if (not (hashq-ref labels sym))
+ (delabel-dependents! sym)))
+ vars)
+ ;; Now lift bound variables with label-allocated lambdas to the
+ ;; parent procedure.
+ (for-each
+ (lambda (sym val)
+ (if (hashq-ref labels sym)
+ ;; Remove traces of the label-bound lambda. The free
+ ;; vars will propagate up via the return val.
+ (begin
+ (hashq-set! bound-vars proc
+ (append (hashq-ref bound-vars val)
+ (hashq-ref bound-vars proc)))
+ (hashq-remove! bound-vars val)
+ (hashq-remove! free-vars val))))
+ vars vals)
+ (lset-difference eq?
+ (apply lset-union eq? body-refs var-refs)
+ vars)))
+
+ ((<let-values> vars exp body)
+ (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
+ (if (pair? in)
+ (lp (cons (car in) out) (cdr in))
+ (if (null? in) out (cons in out))))))
+ (hashq-set! bound-vars proc bound)
+ (lset-difference eq?
+ (lset-union eq? (step exp) (step-tail body))
+ bound)))
(else '())))
+ ;; allocation: sym -> {lambda -> address}
+ ;; lambda -> (nlocs labels . free-locs)
+ (define allocation (make-hash-table))
+
(define (allocate! x proc n)
(define (recur y) (allocate! y proc n))
(record-case x
@@ -237,9 +365,13 @@
(free-addresses
(map (lambda (v)
(hashq-ref (hashq-ref allocation v) proc))
- (hashq-ref free-vars x))))
+ (hashq-ref free-vars x)))
+ (labels (filter cdr
+ (map (lambda (sym)
+ (cons sym (hashq-ref labels sym)))
+ (hashq-ref bound-vars x)))))
;; set procedure allocations
- (hashq-set! allocation x (cons nlocs free-addresses)))
+ (hashq-set! allocation x (cons* nlocs labels free-addresses)))
n)
((<let> vars vals body)
@@ -285,29 +417,71 @@
`(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n))))))
+ ((<fix> vars vals body)
+ (let lp ((in vars) (n n))
+ (if (null? in)
+ (let lp ((vars vars) (vals vals) (nmax n))
+ (cond
+ ((null? vars)
+ (max nmax (allocate! body proc n)))
+ ((hashq-ref labels (car vars))
+ ;; allocate label bindings & body inline to proc
+ (lp (cdr vars)
+ (cdr vals)
+ (record-case (car vals)
+ ((<lambda> vars body)
+ (let lp ((vars vars) (n n))
+ (if (not (null? vars))
+ ;; allocate bindings
+ (let ((v (if (pair? vars) (car vars) vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq
+ proc `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
+ ;; allocate body
+ (max nmax (allocate! body proc n))))))))
+ (else
+ ;; allocate closure
+ (lp (cdr vars)
+ (cdr vals)
+ (max nmax (allocate! (car vals) proc n))))))
+
+ (let ((v (car in)))
+ (cond
+ ((hashq-ref assigned v)
+ (error "fixpoint procedures may not be assigned" x))
+ ((hashq-ref labels v)
+ ;; no binding, it's a label
+ (lp (cdr in) n))
+ (else
+ ;; allocate closure binding
+ (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
+ (lp (cdr in) (1+ n))))))))
+
((<let-values> vars exp body)
(let ((nmax (recur exp)))
(let lp ((vars vars) (n n))
- (if (null? vars)
- (max nmax (allocate! body proc n))
- (let ((v (if (pair? vars) (car vars) vars)))
- (let ((v (car vars)))
- (hashq-set!
- allocation v
- (make-hashq proc
- `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (cdr vars) (1+ n))))))))
+ (cond
+ ((null? vars)
+ (max nmax (allocate! body proc n)))
+ ((not (pair? vars))
+ (hashq-set! allocation vars
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned vars) . ,n)))
+ ;; the 1+ for this var
+ (max nmax (allocate! body proc (1+ n))))
+ (else
+ (let ((v (car vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (cdr vars) (1+ n))))))))
(else n)))
- (define bound-vars (make-hash-table))
- (define free-vars (make-hash-table))
- (define assigned (make-hash-table))
- (define refcounts (make-hash-table))
-
- (define allocation (make-hash-table))
-
- (analyze! x #f)
+ (analyze! x #f '() #t #f)
(allocate! x #f 0)
allocation)
@@ -381,6 +555,9 @@
((<letrec> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
+ ((<fix> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
((<let-values> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
@@ -428,6 +605,9 @@
((<letrec> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
+ ((<fix> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
((<let-values> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index bf4699797..86b610f94 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -37,7 +37,7 @@
;; allocation:
;; sym -> {lambda -> address}
-;; lambda -> (nlocs . closure-vars)
+;; lambda -> (nlocs labels . free-locs)
;;
;; address := (local? boxed? . index)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
@@ -53,20 +53,20 @@
(or (and=> (memq #:warnings opts) cadr)
'()))
- (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
- (x (optimize! x e opts))
- (allocation (analyze-lexicals x)))
-
- ;; Go throught the warning passes.
- (for-each (lambda (kind)
+ ;; Go throught the warning passes.
+ (for-each (lambda (kind)
(let ((warn (assoc-ref %warning-passes kind)))
(and (procedure? warn)
(warn x))))
- warnings)
+ warnings)
+
+ (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+ (x (optimize! x e opts))
+ (allocation (analyze-lexicals x)))
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda ()
- (values (flatten-lambda x allocation)
+ (values (flatten-lambda x #f allocation)
(and e (cons (car e) (cddr e)))
e)))))
@@ -85,6 +85,8 @@
((>= . 2) . ge?)
((+ . 2) . add)
((- . 2) . sub)
+ ((1+ . 1) . add1)
+ ((1- . 1) . sub1)
((* . 2) . mul)
((/ . 2) . div)
((quotient . 2) . quo)
@@ -161,10 +163,10 @@
ids
vars))
+;; FIXME: always emit? otherwise it's hard to pair bind with unbind
(define (emit-bindings src ids vars allocation proc emit-code)
- (if (pair? vars)
- (emit-code src (make-glil-bind
- (vars->bind-list ids vars allocation proc)))))
+ (emit-code src (make-glil-bind
+ (vars->bind-list ids vars allocation proc))))
(define (with-output-to-code proc)
(let ((out '()))
@@ -175,7 +177,7 @@
(proc emit-code)
(reverse out)))
-(define (flatten-lambda x allocation)
+(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))
@@ -186,53 +188,67 @@
(else (values (reverse (cons ids oids))
(reverse (cons vars ovars))
(1+ n) 1))))
- (let ((nlocs (car (hashq-ref allocation x))))
+ (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
- (emit-bindings #f ids vars allocation x emit-code)
+ (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)))))
+ ((#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 emit-code)))))))
+ (flatten (lambda-body x) allocation x self-label
+ labels emit-code)))))))
-(define (flatten x allocation proc emit-code)
+(define (flatten x allocation self self-label fix-labels emit-code)
(define (emit-label label)
(emit-code #f (make-glil-label label)))
(define (emit-branch src inst label)
(emit-code src (make-glil-branch inst label)))
- ;; LMVRA == "let-values MV return address"
- (let comp ((x x) (context 'tail) (LMVRA #f))
- (define (comp-tail tree) (comp tree context LMVRA))
- (define (comp-push tree) (comp tree 'push #f))
- (define (comp-drop tree) (comp tree 'drop #f))
- (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA))
-
+ ;; RA: "return address"; #f unless we're in a non-tail fix with labels
+ ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
+ (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
+ (define (comp-tail tree) (comp tree context RA MVRA))
+ (define (comp-push tree) (comp tree 'push #f #f))
+ (define (comp-drop tree) (comp tree 'drop #f #f))
+ (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
+ (define (comp-fix tree RA) (comp tree context RA MVRA))
+
+ ;; A couple of helpers. Note that if we are in tail context, we
+ ;; won't have an RA.
+ (define (maybe-emit-return)
+ (if RA
+ (emit-branch #f 'br RA)
+ (if (eq? context 'tail)
+ (emit-code #f (make-glil-call 'return 1)))))
+
(record-case x
((<void>)
(case context
- ((push vals) (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((push vals tail)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<const> src exp)
(case context
- ((push vals) (emit-code src (make-glil-const exp)))
- ((tail)
- (emit-code src (make-glil-const exp))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((push vals tail)
+ (emit-code src (make-glil-const exp))))
+ (maybe-emit-return))
;; FIXME: should represent sequence as exps tail
((<sequence> src exps)
@@ -258,7 +274,7 @@
;; drop: (lambda () (apply values '(1 2)) 3)
;; push: (lambda () (list (apply values '(10 12)) 1))
(case context
- ((drop) (for-each comp-drop args))
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
((tail)
(for-each comp-push args)
(emit-code src (make-glil-call 'return/values* (length args))))))
@@ -270,14 +286,17 @@
(for-each comp-push args)
(emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
((push)
+ (emit-code src (make-glil-call 'new-frame 0))
(comp-push proc)
(for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args)))))
+ (emit-code src (make-glil-call 'apply (1+ (length args))))
+ (maybe-emit-return))
((vals)
(comp-vals
(make-application src (make-primitive-ref #f 'apply)
(cons proc args))
- LMVRA))
+ MVRA)
+ (maybe-emit-return))
((drop)
;; Well, shit. The proc might return any number of
;; values (including 0), since it's in a drop context,
@@ -285,8 +304,9 @@
;; mv-call out to our trampoline instead.
(comp-drop
(make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))))))))
-
+ (cons proc args)))
+ (maybe-emit-return)))))))
+
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
(not (eq? context 'push)))
;; tail: (lambda () (values '(1 2)))
@@ -294,11 +314,11 @@
;; push: (lambda () (list (values '(10 12)) 1))
;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
(case context
- ((drop) (for-each comp-drop args))
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
((vals)
(for-each comp-push args)
(emit-code #f (make-glil-const (length args)))
- (emit-branch src 'br LMVRA))
+ (emit-branch src 'br MVRA))
((tail)
(for-each comp-push args)
(emit-code src (make-glil-call 'return/values (length args))))))
@@ -319,11 +339,15 @@
(comp-vals
(make-application src (make-primitive-ref #f 'call-with-values)
args)
- LMVRA))
+ MVRA)
+ (maybe-emit-return))
(else
(let ((MV (make-label)) (POST (make-label))
(producer (car args)) (consumer (cadr args)))
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
(comp-push consumer)
+ (emit-code src (make-glil-call 'new-frame 0))
(comp-push producer)
(emit-code src (make-glil-mv-call 0 MV))
(case context
@@ -336,7 +360,8 @@
(else (emit-code src (make-glil-call 'call/nargs 0))
(emit-label POST)
(if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))))))))
+ (emit-code #f (make-glil-call 'drop 1)))
+ (maybe-emit-return)))))))
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-current-continuation)
@@ -350,16 +375,19 @@
(make-application
src (make-primitive-ref #f 'call-with-current-continuation)
args)
- LMVRA))
+ MVRA)
+ (maybe-emit-return))
((push)
(comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1)))
+ (emit-code src (make-glil-call 'call/cc 1))
+ (maybe-emit-return))
((drop)
;; Crap. Just like `apply' in drop context.
(comp-drop
(make-application
src (make-primitive-ref #f 'call-with-current-continuation)
- args)))))
+ args))
+ (maybe-emit-return))))
((and (primitive-ref? proc)
(or (hash-ref *primcall-ops*
@@ -371,34 +399,76 @@
(case (instruction-pushes op)
((0)
(case context
- ((tail) (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))
- ((push vals) (emit-code #f (make-glil-void)))))
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((1)
(case context
- ((tail) (emit-code #f (make-glil-call 'return 1)))
- ((drop) (emit-code #f (make-glil-call 'drop 1)))))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
(else
(error "bad primitive op: too many pushes"
op (instruction-pushes op))))))
+ ;; da capo al fine
+ ((and (lexical-ref? proc)
+ self-label (eq? (lexical-ref-gensym proc) self-label)
+ ;; self-call in tail position is a goto
+ (eq? context 'tail)
+ ;; make sure the arity is right
+ (list? (lambda-vars self))
+ (= (length args) (length (lambda-vars self))))
+ ;; evaluate new values
+ (for-each comp-push args)
+ ;; rename & goto
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t ,boxed? . ,index)
+ ;; set unboxed, as the proc prelude will box if needed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ (,x (error "what" x))))
+ (reverse (lambda-vars self)))
+ (emit-branch src 'br self-label))
+
+ ;; lambda, the ultimate goto
+ ((and (lexical-ref? proc)
+ (assq (lexical-ref-gensym proc) fix-labels))
+ ;; evaluate new values, assuming that analyze-lexicals did its
+ ;; job, and that the arity was right
+ (for-each comp-push args)
+ ;; rename
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index)
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index)
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "what" x))))
+ (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
+ ;; goto!
+ (emit-branch src 'br (lexical-ref-gensym proc)))
+
(else
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
(comp-push proc)
(for-each comp-push args)
(let ((len (length args)))
(case context
((tail) (emit-code src (make-glil-call 'goto/args len)))
- ((push) (emit-code src (make-glil-call 'call len)))
- ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA)))
- ((drop)
- (let ((MV (make-label)) (POST (make-label)))
- (emit-code src (make-glil-mv-call len MV))
- (emit-code #f (make-glil-call 'drop 1))
- (emit-branch #f 'br POST)
- (emit-label MV)
- (emit-code #f (make-glil-mv-bind '() #f))
- (emit-code #f (make-glil-unbind))
- (emit-label POST))))))))
+ ((push) (emit-code src (make-glil-call 'call len))
+ (maybe-emit-return))
+ ((vals) (emit-code src (make-glil-mv-call len MVRA))
+ (maybe-emit-return))
+ ((drop) (let ((MV (make-label)) (POST (make-label)))
+ (emit-code src (make-glil-mv-call len MV))
+ (emit-code #f (make-glil-call 'drop 1))
+ (emit-branch #f 'br (or RA POST))
+ (emit-label MV)
+ (emit-code #f (make-glil-mv-bind '() #f))
+ (emit-code #f (make-glil-unbind))
+ (if RA
+ (emit-branch #f 'br RA)
+ (emit-label POST)))))))))
((<conditional> src test then else)
;; TEST
@@ -411,104 +481,98 @@
(comp-push test)
(emit-branch src 'br-if-not L1)
(comp-tail then)
- (if (not (eq? context 'tail))
+ ;; if there is an RA, comp-tail will cause a jump to it -- just
+ ;; have to clean up here if there is no RA.
+ (if (and (not RA) (not (eq? context 'tail)))
(emit-branch #f 'br L2))
(emit-label L1)
(comp-tail else)
- (if (not (eq? context 'tail))
+ (if (and (not RA) (not (eq? context 'tail)))
(emit-label L2))))
-
+
((<primitive-ref> src name)
(cond
((eq? (module-variable (fluid-ref *comp-module*) name)
(module-variable the-root-module name))
(case context
- ((push vals)
- (emit-code src (make-glil-toplevel 'ref name)))
- ((tail)
- (emit-code src (make-glil-toplevel 'ref name))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code src (make-glil-toplevel 'ref name))))
+ (maybe-emit-return))
+ ((module-variable the-root-module name)
+ (case context
+ ((tail push vals)
+ (emit-code src (make-glil-module 'ref '(guile) name #f))))
+ (maybe-emit-return))
(else
- (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
(case context
- ((push vals)
- (emit-code src (make-glil-module 'ref '(guile) name #f)))
- ((tail)
- (emit-code src (make-glil-module 'ref '(guile) name #f))
- (emit-code #f (make-glil-call 'return 1)))))))
+ ((tail push vals)
+ (emit-code src (make-glil-module
+ 'ref (module-name (fluid-ref *comp-module*)) name #f))))
+ (maybe-emit-return))))
((<lexical-ref> src name gensym)
(case context
((push vals tail)
- (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+ (pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'ref index)))
(,loc
(error "badness" x loc)))))
- (case context
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
+ (maybe-emit-return))
((<lexical-set> src name gensym exp)
(comp-push exp)
- (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+ (pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'set index)))
(,loc
(error "badness" x loc)))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<module-ref> src mod name public?)
(emit-code src (make-glil-module 'ref mod name public?))
(case context
- ((drop) (emit-code #f (make-glil-call 'drop 1)))
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
((<module-set> src mod name public? exp)
(comp-push exp)
(emit-code src (make-glil-module 'set mod name public?))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<toplevel-ref> src name)
(emit-code src (make-glil-toplevel 'ref name))
(case context
- ((drop) (emit-code #f (make-glil-call 'drop 1)))
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
((<toplevel-set> src name exp)
(comp-push exp)
(emit-code src (make-glil-toplevel 'set name))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<toplevel-define> src name exp)
(comp-push exp)
(emit-code src (make-glil-toplevel 'define name))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<lambda>)
- (let ((free-locs (cdr (hashq-ref allocation x))))
+ (let ((free-locs (cddr (hashq-ref allocation x))))
(case context
((push vals tail)
- (emit-code #f (flatten-lambda x allocation))
+ (emit-code #f (flatten-lambda x #f allocation))
(if (not (null? free-locs))
(begin
(for-each
@@ -519,15 +583,14 @@
(else (error "what" x loc))))
free-locs)
(emit-code #f (make-glil-call 'vector (length free-locs)))
- (emit-code #f (make-glil-call 'make-closure 2))))
- (if (eq? context 'tail)
- (emit-code #f (make-glil-call 'return 1)))))))
+ (emit-code #f (make-glil-call 'make-closure 2)))))))
+ (maybe-emit-return))
((<let> src names vars vals body)
(for-each comp-push vals)
- (emit-bindings src names vars allocation proc emit-code)
+ (emit-bindings src names vars allocation self emit-code)
(for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
@@ -539,15 +602,15 @@
((<letrec> src names vars vals body)
(for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n)))
(,loc (error "badness" x loc))))
vars)
(for-each comp-push vals)
- (emit-bindings src names vars allocation proc emit-code)
+ (emit-bindings src names vars allocation self emit-code)
(for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc))))
@@ -555,6 +618,87 @@
(comp-tail body)
(emit-code #f (make-glil-unbind)))
+ ((<fix> src names vars vals body)
+ ;; The ideal here is to just render the lambda bodies inline, and
+ ;; wire the code together with gotos. We can do that if
+ ;; analyze-lexicals has determined that a given var has "label"
+ ;; allocation -- which is the case if it is in `fix-labels'.
+ ;;
+ ;; But even for closures that we can't inline, we can do some
+ ;; tricks to avoid heap-allocation for the binding itself. Since
+ ;; we know the vals are lambdas, we can set them to their local
+ ;; var slots first, then capture their bindings, mutating them in
+ ;; place.
+ (let ((RA (if (eq? context 'tail) #f (make-label))))
+ (for-each
+ (lambda (x v)
+ (cond
+ ((hashq-ref allocation x)
+ ;; allocating a closure
+ (emit-code #f (flatten-lambda x v allocation))
+ (if (not (null? (cddr (hashq-ref allocation x))))
+ ;; Need to make-closure first, but with a temporary #f
+ ;; free-variables vector, so we are mutating fresh
+ ;; closures on the heap.
+ (begin
+ (emit-code #f (make-glil-const #f))
+ (emit-code #f (make-glil-call 'make-closure 2))))
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ (,loc (error "badness" x loc))))
+ (else
+ ;; labels allocation: emit label & body, but jump over it
+ (let ((POST (make-label)))
+ (emit-branch #f 'br POST)
+ (emit-label v)
+ ;; we know the lambda vars are a list
+ (emit-bindings #f (lambda-names x) (lambda-vars x)
+ allocation self emit-code)
+ (if (lambda-src x)
+ (emit-code #f (make-glil-source (lambda-src x))))
+ (comp-fix (lambda-body x) RA)
+ (emit-code #f (make-glil-unbind))
+ (emit-label POST)))))
+ vals
+ vars)
+ ;; Emit bindings metadata for closures
+ (let ((binds (let lp ((out '()) (vars vars) (names names))
+ (cond ((null? vars) (reverse! out))
+ ((assq (car vars) fix-labels)
+ (lp out (cdr vars) (cdr names)))
+ (else
+ (lp (acons (car vars) (car names) out)
+ (cdr vars) (cdr names)))))))
+ (emit-bindings src (map cdr binds) (map car binds)
+ allocation self emit-code))
+ ;; Now go back and fix up the bindings for closures.
+ (for-each
+ (lambda (x v)
+ (let ((free-locs (if (hashq-ref allocation x)
+ (cddr (hashq-ref allocation x))
+ ;; can hit this latter case for labels allocation
+ '())))
+ (if (not (null? free-locs))
+ (begin
+ (for-each
+ (lambda (loc)
+ (pmatch loc
+ ((,local? ,boxed? . ,n)
+ (emit-code #f (make-glil-lexical local? #f 'ref n)))
+ (else (error "what" x loc))))
+ free-locs)
+ (emit-code #f (make-glil-call 'vector (length free-locs)))
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'fix n)))
+ (,loc (error "badness" x loc)))))))
+ vals
+ vars)
+ (comp-tail body)
+ (emit-label RA)
+ (emit-code #f (make-glil-unbind))))
+
((<let-values> src names vars exp body)
(let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
(cond
@@ -571,10 +715,10 @@
(emit-code #f (make-glil-const 1))
(emit-label MV)
(emit-code src (make-glil-mv-bind
- (vars->bind-list names vars allocation proc)
+ (vars->bind-list names vars allocation self)
rest?))
(for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
new file mode 100644
index 000000000..9b66d9ed5
--- /dev/null
+++ b/module/language/tree-il/fix-letrec.scm
@@ -0,0 +1,240 @@
+;;; transformation of letrec into simpler forms
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (language tree-il fix-letrec)
+ #:use-module (system base syntax)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:export (fix-letrec!))
+
+;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
+;; Efficient Implementation of Scheme’s Recursive Binding Construct", by
+;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
+
+(define fix-fold
+ (make-tree-il-folder unref ref set simple lambda complex))
+
+(define (simple-expression? x bound-vars)
+ (record-case x
+ ((<void>) #t)
+ ((<const>) #t)
+ ((<lexical-ref> gensym)
+ (not (memq gensym bound-vars)))
+ ((<conditional> test then else)
+ (and (simple-expression? test bound-vars)
+ (simple-expression? then bound-vars)
+ (simple-expression? else bound-vars)))
+ ((<sequence> exps)
+ (and-map (lambda (x) (simple-expression? x bound-vars))
+ exps))
+ ((<application> proc args)
+ (and (primitive-ref? proc)
+ (effect-free-primitive? (primitive-ref-name proc))
+ (and-map (lambda (x) (simple-expression? x bound-vars))
+ args)))
+ (else #f)))
+
+(define (partition-vars x)
+ (let-values
+ (((unref ref set simple lambda* complex)
+ (fix-fold x
+ (lambda (x unref ref set simple lambda* complex)
+ (record-case x
+ ((<lexical-ref> gensym)
+ (values (delq gensym unref)
+ (lset-adjoin eq? ref gensym)
+ set
+ simple
+ lambda*
+ complex))
+ ((<lexical-set> gensym)
+ (values unref
+ ref
+ (lset-adjoin eq? set gensym)
+ simple
+ lambda*
+ complex))
+ ((<letrec> vars)
+ (values (append vars unref)
+ ref
+ set
+ simple
+ lambda*
+ complex))
+ ((<let> vars)
+ (values (append vars unref)
+ ref
+ set
+ simple
+ lambda*
+ complex))
+ (else
+ (values unref ref set simple lambda* complex))))
+ (lambda (x unref ref set simple lambda* complex)
+ (record-case x
+ ((<letrec> (orig-vars vars) vals)
+ (let lp ((vars orig-vars) (vals vals)
+ (s '()) (l '()) (c '()))
+ (cond
+ ((null? vars)
+ (values unref
+ ref
+ set
+ (append s simple)
+ (append l lambda*)
+ (append c complex)))
+ ((memq (car vars) unref)
+ (lp (cdr vars) (cdr vals)
+ s l c))
+ ((memq (car vars) set)
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c)))
+ ((lambda? (car vals))
+ (lp (cdr vars) (cdr vals)
+ s (cons (car vars) l) c))
+ ((simple-expression? (car vals) orig-vars)
+ (lp (cdr vars) (cdr vals)
+ (cons (car vars) s) l c))
+ (else
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c))))))
+ ((<let> (orig-vars vars) vals)
+ ;; The point is to compile let-bound lambdas as
+ ;; efficiently as we do letrec-bound lambdas, so
+ ;; we use the same algorithm for analyzing the
+ ;; vars. There is no problem recursing into the
+ ;; bindings after the let, because all variables
+ ;; have been renamed.
+ (let lp ((vars orig-vars) (vals vals)
+ (s '()) (l '()) (c '()))
+ (cond
+ ((null? vars)
+ (values unref
+ ref
+ set
+ (append s simple)
+ (append l lambda*)
+ (append c complex)))
+ ((memq (car vars) unref)
+ (lp (cdr vars) (cdr vals)
+ s l c))
+ ((memq (car vars) set)
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c)))
+ ((and (lambda? (car vals))
+ (not (memq (car vars) set)))
+ (lp (cdr vars) (cdr vals)
+ s (cons (car vars) l) c))
+ ;; There is no difference between simple and
+ ;; complex, for the purposes of let. Just lump
+ ;; them all into complex.
+ (else
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c))))))
+ (else
+ (values unref ref set simple lambda* complex))))
+ '()
+ '()
+ '()
+ '()
+ '()
+ '())))
+ (values unref simple lambda* complex)))
+
+(define (fix-letrec! x)
+ (let-values (((unref simple lambda* complex) (partition-vars x)))
+ (post-order!
+ (lambda (x)
+ (record-case x
+
+ ;; Sets to unreferenced variables may be replaced by their
+ ;; expression, called for effect.
+ ((<lexical-set> gensym exp)
+ (if (memq gensym unref)
+ (make-sequence #f (list exp (make-void #f)))
+ x))
+
+ ((<letrec> src names vars vals body)
+ (let ((binds (map list vars names vals)))
+ (define (lookup set)
+ (map (lambda (v) (assq v binds))
+ (lset-intersection eq? vars set)))
+ (let ((u (lookup unref))
+ (s (lookup simple))
+ (l (lookup lambda*))
+ (c (lookup complex)))
+ ;; Bind "simple" bindings, and locations for complex
+ ;; bindings.
+ (make-let
+ src
+ (append (map cadr s) (map cadr c))
+ (append (map car s) (map car c))
+ (append (map caddr s) (map (lambda (x) (make-void #f)) c))
+ ;; Bind lambdas using the fixpoint operator.
+ (make-fix
+ src (map cadr l) (map car l) (map caddr l)
+ (make-sequence
+ src
+ (append
+ ;; The right-hand-sides of the unreferenced
+ ;; bindings, for effect.
+ (map caddr u)
+ (if (null? c)
+ ;; No complex bindings, just emit the body.
+ (list body)
+ (list
+ ;; Evaluate the the "complex" bindings, in a `let' to
+ ;; indicate that order doesn't matter, and bind to
+ ;; their variables.
+ (let ((tmps (map (lambda (x) (gensym)) c)))
+ (make-let
+ #f (map cadr c) tmps (map caddr c)
+ (make-sequence
+ #f
+ (map (lambda (x tmp)
+ (make-lexical-set
+ #f (cadr x) (car x)
+ (make-lexical-ref #f (cadr x) tmp)))
+ c tmps))))
+ ;; Finally, the body.
+ body)))))))))
+
+ ((<let> src names vars vals body)
+ (let ((binds (map list vars names vals)))
+ (define (lookup set)
+ (map (lambda (v) (assq v binds))
+ (lset-intersection eq? vars set)))
+ (let ((u (lookup unref))
+ (l (lookup lambda*))
+ (c (lookup complex)))
+ (make-sequence
+ src
+ (append
+ ;; unreferenced bindings, called for effect.
+ (map caddr u)
+ (list
+ ;; unassigned lambdas use fix.
+ (make-fix src (map cadr l) (map car l) (map caddr l)
+ ;; and the "complex" bindings.
+ (make-let src (map cadr c) (map car c) (map caddr c)
+ body))))))))
+
+ (else x)))
+ x)))
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
new file mode 100644
index 000000000..adc3f18bd
--- /dev/null
+++ b/module/language/tree-il/inline.scm
@@ -0,0 +1,81 @@
+;;; a simple inliner
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (language tree-il inline)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:export (inline!))
+
+;; Possible optimizations:
+;; * constant folding, propagation
+;; * procedure inlining
+;; * always when single call site
+;; * always for "trivial" procs
+;; * otherwise who knows
+;; * dead code elimination
+;; * degenerate case optimizations
+;; * "fixing letrec"
+
+;; This is a completely brain-dead optimization pass whose sole claim to
+;; fame is ((lambda () x)) => x.
+(define (inline! x)
+ (post-order!
+ (lambda (x)
+ (record-case x
+ ((<application> src proc args)
+ (cond
+
+ ;; ((lambda () x)) => x
+ ((and (lambda? proc) (null? (lambda-vars proc))
+ (null? args))
+ (lambda-body proc))
+
+ ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
+ ;; => (let-values (((a b . c) foo)) bar)
+ ;;
+ ;; Note that this is a singly-binding form of let-values. Also
+ ;; note that Scheme's let-values expands into call-with-values,
+ ;; then here we reduce it to tree-il's let-values.
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@call-with-values)
+ (= (length args) 2)
+ (lambda? (cadr args)))
+ (let ((producer (car args))
+ (consumer (cadr args)))
+ (make-let-values src
+ (lambda-names consumer)
+ (lambda-vars consumer)
+ (if (and (lambda? producer)
+ (null? (lambda-names producer)))
+ (lambda-body producer)
+ (make-application src producer '()))
+ (lambda-body consumer))))
+
+ (else #f)))
+
+ ((<let> vars body)
+ (if (null? vars) body x))
+
+ ((<letrec> vars body)
+ (if (null? vars) body x))
+
+ ((<fix> vars body)
+ (if (null? vars) body x))
+
+ (else #f)))
+ x))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index ac16a9e39..0e490a636 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -21,21 +21,15 @@
(define-module (language tree-il optimize)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
+ #:use-module (language tree-il inline)
+ #:use-module (language tree-il fix-letrec)
#:export (optimize!))
(define (env-module e)
(if e (car e) (current-module)))
(define (optimize! x env opts)
- (expand-primitives! (resolve-primitives! x (env-module env))))
-
-;; Possible optimizations:
-;; * constant folding, propagation
-;; * procedure inlining
-;; * always when single call site
-;; * always for "trivial" procs
-;; * otherwise who knows
-;; * dead code elimination
-;; * degenerate case optimizations
-;; * "fixing letrec"
-
+ (inline!
+ (fix-letrec!
+ (expand-primitives!
+ (resolve-primitives! x (env-module env))))))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 9ccd2720d..955c7bf25 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -19,12 +19,13 @@
;;; Code:
(define-module (language tree-il primitives)
+ #:use-module (system base pmatch)
#:use-module (rnrs bytevector)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
- expand-primitives!))
+ expand-primitives! effect-free-primitive?))
(define *interesting-primitive-names*
'(apply @apply
@@ -84,6 +85,39 @@
(for-each add-interesting-primitive! *interesting-primitive-names*)
+(define *effect-free-primitives*
+ '(values
+ eq? eqv? equal?
+ = < > <= >= zero?
+ + * - / 1- 1+ quotient remainder modulo
+ not
+ pair? null? list? acons cons cons*
+ list vector
+ car cdr
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ vector-ref
+ bytevector-u8-ref bytevector-s8-ref
+ bytevector-u16-ref bytevector-u16-native-ref
+ bytevector-s16-ref bytevector-s16-native-ref
+ bytevector-u32-ref bytevector-u32-native-ref
+ bytevector-s32-ref bytevector-s32-native-ref
+ bytevector-u64-ref bytevector-u64-native-ref
+ bytevector-s64-ref bytevector-s64-native-ref
+ bytevector-ieee-single-ref bytevector-ieee-single-native-ref
+ bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+
+
+(define *effect-free-primitive-table* (make-hash-table))
+
+(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t))
+ *effect-free-primitives*)
+
+(define (effect-free-primitive? prim)
+ (hashq-ref *effect-free-primitive-table* prim))
+
(define (resolve-primitives! x mod)
(post-order!
(lambda (x)
@@ -142,8 +176,14 @@
(define (consequent exp)
(cond
((pair? exp)
- `(make-application src (make-primitive-ref src ',(car exp))
- ,(inline-args (cdr exp))))
+ (pmatch exp
+ ((if ,test ,then ,else)
+ `(if ,test
+ ,(consequent then)
+ ,(consequent else)))
+ (else
+ `(make-application src (make-primitive-ref src ',(car exp))
+ ,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
exp)
@@ -160,9 +200,21 @@
(cons `((src . ,(car in))
,(consequent (cadr in))) out)))))))
+(define-primitive-expander zero? (x)
+ (= x 0))
+
(define-primitive-expander +
() 0
(x) x
+ (x y) (if (and (const? y)
+ (let ((y (const-exp y)))
+ (and (exact? y) (= y 1))))
+ (1+ x)
+ (if (and (const? x)
+ (let ((x (const-exp x)))
+ (and (exact? x) (= x 1))))
+ (1+ y)
+ (+ x y)))
(x y z . rest) (+ x (+ y z . rest)))
(define-primitive-expander *
@@ -172,11 +224,13 @@
(define-primitive-expander -
(x) (- 0 x)
+ (x y) (if (and (const? y)
+ (let ((y (const-exp y)))
+ (and (exact? y) (= y 1))))
+ (1- x)
+ (- x y))
(x y z . rest) (- x (+ y z . rest)))
-(define-primitive-expander 1-
- (x) (- x 1))
-
(define-primitive-expander /
(x) (/ 1 x)
(x y z . rest) (/ x (* y z . rest)))
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 89d35bcb5..9b14f2fca 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -48,6 +48,10 @@
(list (option '(#\h "help") #f #f
(lambda (opt name arg result)
(alist-cons 'help? #t result)))
+ (option '("version") #f #f
+ (lambda (opt name arg result)
+ (show-version)
+ (exit 0)))
(option '(#\L "load-path") #t #f
(lambda (opt name arg result)
@@ -90,7 +94,7 @@
options."
(args-fold args %options
(lambda (opt name arg result)
- (format (current-error-port) "~A: unrecognized option" opt)
+ (format (current-error-port) "~A: unrecognized option" name)
(exit 1))
(lambda (file result)
(let ((input-files (assoc-ref result 'input-files)))
@@ -102,6 +106,13 @@ options."
(load-path)
(warnings unsupported-warning))))
+(define (show-version)
+ (format #t "compile (GNU Guile) ~A~%" (version))
+ (format #t "Copyright (C) 2009 Free Software Foundation, Inc.
+License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.~%"))
+
(define (show-warning-help)
(format #t "The available warning types are:~%~%")
(for-each (lambda (wt)
@@ -143,7 +154,8 @@ Compile each Guile source file FILE into a Guile object.
Note that autocompilation will be turned off.
-Report bugs to <guile-user@gnu.org>.~%")
+Report bugs to <~A>.~%"
+ %guile-bug-report-address)
(exit 0)))
(set! %load-path (append load-path %load-path))
diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm
index c8422eeaf..22bda21a2 100644
--- a/module/srfi/srfi-11.scm
+++ b/module/srfi/srfi-11.scm
@@ -1,6 +1,6 @@
;;; srfi-11.scm --- let-values and let*-values
-;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -63,148 +63,58 @@
;; (q <tmp-q>))
;; (baz x y z p q))))))
-;; I originally wrote this as a define-macro, but then I found out
-;; that guile's gensym/gentemp was broken, so I tried rewriting it as
-;; a syntax-rules statement.
-;; [make-symbol now fixes gensym/gentemp problems.]
-;;
-;; Since syntax-rules didn't seem powerful enough to implement
-;; let-values in one definition without exposing illegal syntax (or
-;; perhaps my brain's just not powerful enough :>). I tried writing
-;; it using a private helper, but that didn't work because the
-;; let-values expands outside the scope of this module. I wonder why
-;; syntax-rules wasn't designed to allow "private" patterns or
-;; similar...
-;;
-;; So in the end, I dumped the syntax-rules implementation, reproduced
-;; here for posterity, and went with the define-macro one below --
-;; gensym/gentemp's got to be fixed anyhow...
-;
-; (define-syntax let-values-helper
-; (syntax-rules ()
-; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
-; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
-; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
-; ;; temps you create so you can use them later...
-; ;;
-; ;; I really don't fully understand why the (var-1 var-1) trick
-; ;; works below, but basically, when all those (x x) bindings show
-; ;; up in the final "let", syntax-rules forces a renaming.
-
-; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
-; body ...)
-; (lambda lambda-tmps
-; (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
-
-; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
-; body ...)
-; (let-values-helper "consumer"
-; (var-2 ...)
-; (lambda-tmp ... var-1)
-; ((var-1 var-1) . final-let-bindings)
-; lv-bindings
-; body ...))
-
-; ((_ "cwv" () final-let-bindings body ...)
-; (let final-let-bindings
-; body ...))
-
-; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
-; body ...)
-; (call-with-values (lambda () binding-1)
-; (let-values-helper "consumer"
-; vars-1
-; ()
-; final-let-bindings
-; (other-bindings ...)
-; body ...)))))
-;
-; (define-syntax let-values
-; (syntax-rules ()
-; ((let-values () body ...)
-; (begin body ...))
-; ((let-values (binding ...) body ...)
-; (let-values-helper "cwv" (binding ...) () body ...))))
-;
-;
-; (define-syntax let-values
-; (letrec-syntax ((build-consumer
-; ;; Take the vars from one let binding (i.e. the (x
-; ;; y z) from ((x y z) (values 1 2 3)) and turn it
-; ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
-; ;; <tmp-z>) ...) from above.
-; (syntax-rules ()
-; ((_ () new-tmps tmp-vars () body ...)
-; (lambda new-tmps
-; body ...))
-; ((_ () new-tmps tmp-vars vars body ...)
-; (lambda new-tmps
-; (lv-builder vars tmp-vars body ...)))
-; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
-; (build-consumer (var-2 ...)
-; (tmp-1 . new-tmps)
-; ((var-1 tmp-1) . tmp-vars)
-; bindings
-; body ...))))
-; (lv-builder
-; (syntax-rules ()
-; ((_ () tmp-vars body ...)
-; (let tmp-vars
-; body ...))
-; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
-; tmp-vars
-; body ...)
-; (call-with-values (lambda () binding-1)
-; (build-consumer vars-1
-; ()
-; tmp-vars
-; ((vars-2 binding-2) ...)
-; body ...))))))
-;
-; (syntax-rules ()
-; ((_ () body ...)
-; (begin body ...))
-; ((_ ((vars binding) ...) body ...)
-; (lv-builder ((vars binding) ...) () body ...)))))
-
-(define-macro (let-values vars . body)
-
- (define (map-1-dot proc elts)
- ;; map over one optionally dotted (a b c . d) list, producing an
- ;; optionally dotted result.
- (cond
- ((null? elts) '())
- ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
- (else (proc elts))))
-
- (define (undot-list lst)
- ;; produce a non-dotted list from a possibly dotted list.
- (cond
- ((null? lst) '())
- ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
- (else (list lst))))
-
- (define (let-values-helper vars body prev-let-vars)
- (let* ((var-binding (car vars))
- (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var"))
- (car var-binding)))
- (let-vars (map (lambda (sym tmp) (list sym tmp))
- (undot-list (car var-binding))
- (undot-list new-tmps))))
-
- (if (null? (cdr vars))
- `(call-with-values (lambda () ,(cadr var-binding))
- (lambda ,new-tmps
- (let ,(apply append let-vars prev-let-vars)
- ,@body)))
- `(call-with-values (lambda () ,(cadr var-binding))
- (lambda ,new-tmps
- ,(let-values-helper (cdr vars) body
- (cons let-vars prev-let-vars)))))))
-
- (if (null? vars)
- `(begin ,@body)
- (let-values-helper vars body '())))
+;; We could really use quasisyntax here...
+(define-syntax let-values
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((binds exp)) b0 b1 ...)
+ (syntax (call-with-values (lambda () exp)
+ (lambda binds b0 b1 ...))))
+ ((_ (clause ...) b0 b1 ...)
+ (let lp ((clauses (syntax (clause ...)))
+ (ids '())
+ (tmps '()))
+ (if (null? clauses)
+ (with-syntax (((id ...) ids)
+ ((tmp ...) tmps))
+ (syntax (let ((id tmp) ...)
+ b0 b1 ...)))
+ (syntax-case (car clauses) ()
+ (((var ...) exp)
+ (with-syntax (((new-tmp ...) (generate-temporaries
+ (syntax (var ...))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (var ... id ...))
+ (syntax (new-tmp ... tmp ...)))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda (new-tmp ...) inner))))))
+ ((vars exp)
+ (with-syntax ((((new-tmp . new-var) ...)
+ (let lp ((vars (syntax vars)))
+ (syntax-case vars ()
+ ((id . rest)
+ (acons (syntax id)
+ (car
+ (generate-temporaries (syntax (id))))
+ (lp (syntax rest))))
+ (id (acons (syntax id)
+ (car
+ (generate-temporaries (syntax (id))))
+ '())))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (new-var ... id ...))
+ (syntax (new-tmp ... tmp ...))))
+ (args (let lp ((tmps (syntax (new-tmp ...))))
+ (syntax-case tmps ()
+ ((id) (syntax id))
+ ((id . rest) (cons (syntax id)
+ (lp (syntax rest))))))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda args inner)))))))))))))
;;;;;;;;;;;;;;
;; let*-values
@@ -226,28 +136,11 @@
(define-syntax let*-values
(syntax-rules ()
((let*-values () body ...)
- (begin body ...))
+ (let () body ...))
((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
(call-with-values (lambda () binding-1)
(lambda vars-1
(let*-values ((vars-2 binding-2) ...)
body ...))))))
-; Alternate define-macro implementation...
-;
-; (define-macro (let*-values vars . body)
-; (define (let-values-helper vars body)
-; (let ((var-binding (car vars)))
-; (if (null? (cdr vars))
-; `(call-with-values (lambda () ,(cadr var-binding))
-; (lambda ,(car var-binding)
-; ,@body))
-; `(call-with-values (lambda () ,(cadr var-binding))
-; (lambda ,(car var-binding)
-; ,(let-values-helper (cdr vars) body))))))
-
-; (if (null? vars)
-; `(begin ,@body)
-; (let-values-helper vars body)))
-
;;; srfi-11.scm ends here
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
new file mode 100644
index 000000000..d3f73b3e9
--- /dev/null
+++ b/module/srfi/srfi-4/gnu.scm
@@ -0,0 +1,52 @@
+;;; Extensions to SRFI-4
+
+;; Copyright (C) 2001, 2002, 2004, 2006, 2009 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Extensions to SRFI-4. Fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-4 gnu)
+ #:use-module (srfi srfi-4)
+ #:export (;; Somewhat polymorphic conversions.
+ any->u8vector any->s8vector any->u16vector any->s16vector
+ any->u32vector any->s32vector any->u64vector any->s64vector
+ any->f32vector any->f64vector any->c32vector any->c64vector))
+
+
+(define-macro (define-any->vector . tags)
+ `(begin
+ ,@(map (lambda (tag)
+ `(define (,(symbol-append 'any-> tag 'vector) obj)
+ (cond ((,(symbol-append tag 'vector?) obj) obj)
+ ((pair? obj) (,(symbol-append 'list-> tag 'vector) obj))
+ ((generalized-vector? obj)
+ (let* ((len (generalized-vector-length obj))
+ (v (,(symbol-append 'make- tag 'vector) len)))
+ (let lp ((i 0))
+ (if (< i len)
+ (begin
+ (,(symbol-append tag 'vector-set!)
+ v i (generalized-vector-ref obj i))
+ (lp (1+ i)))
+ v))))
+ (else (scm-error 'wrong-type-arg #f "" '() (list obj))))))
+ tags)))
+
+(define-any->vector u8 s8 u16 s16 u32 s32 u64 s64 f32 f64 c32 c64)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 8470f39e2..26dd29e20 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -145,8 +145,11 @@
(from (current-language))
(to 'objcode)
(opts '()))
- (let ((comp (or output-file (compiled-file-name file)))
- (in (open-input-file file)))
+ (let* ((comp (or output-file (compiled-file-name file)))
+ (in (open-input-file file))
+ (enc (file-encoding in)))
+ (if enc
+ (set-port-encoding! in enc))
(ensure-writable-dir (dirname comp))
(call-with-output-file/atomic comp
(lambda (port)
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index cc73f38d1..249961d79 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -1,6 +1,6 @@
;;; Guile VM specific syntaxes and utilities
-;; 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
@@ -174,29 +174,70 @@
;; 5.88 0.01 0.01 list-index
-(define-macro (record-case record . clauses)
- (let ((r (gensym))
- (rtd (gensym)))
- (define (process-clause clause)
- (if (eq? (car clause) 'else)
- clause
- (let ((record-type (caar clause))
- (slots (cdar clause))
- (body (cdr clause)))
- (let ((stem (trim-brackets record-type)))
- `((eq? ,rtd ,record-type)
- (let ,(map (lambda (slot)
- (if (pair? slot)
- `(,(car slot) (,(symbol-append stem '- (cadr slot)) ,r))
- `(,slot (,(symbol-append stem '- slot) ,r))))
- slots)
- ,@(if (pair? body) body '((if #f #f)))))))))
- `(let* ((,r ,record)
- (,rtd (struct-vtable ,r)))
- (cond ,@(let ((clauses (map process-clause clauses)))
- (if (assq 'else clauses)
- clauses
- (append clauses `((else (error "unhandled record" ,r))))))))))
+;;; So ugly... but I am too ignorant to know how to make it better.
+(define-syntax record-case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ record clause ...)
+ (let ((r (syntax r))
+ (rtd (syntax rtd)))
+ (define (process-clause tag fields exprs)
+ (let ((infix (trim-brackets (syntax->datum tag))))
+ (with-syntax ((tag tag)
+ (((f . accessor) ...)
+ (let lp ((fields fields))
+ (syntax-case fields ()
+ (() (syntax ()))
+ (((v0 f0) f1 ...)
+ (acons (syntax v0)
+ (datum->syntax x
+ (symbol-append infix '- (syntax->datum
+ (syntax f0))))
+ (lp (syntax (f1 ...)))))
+ ((f0 f1 ...)
+ (acons (syntax f0)
+ (datum->syntax x
+ (symbol-append infix '- (syntax->datum
+ (syntax f0))))
+ (lp (syntax (f1 ...))))))))
+ ((e0 e1 ...)
+ (syntax-case exprs ()
+ (() (syntax (#t)))
+ ((e0 e1 ...) (syntax (e0 e1 ...))))))
+ (syntax
+ ((eq? rtd tag)
+ (let ((f (accessor r))
+ ...)
+ e0 e1 ...))))))
+ (with-syntax
+ ((r r)
+ (rtd rtd)
+ ((processed ...)
+ (let lp ((clauses (syntax (clause ...)))
+ (out '()))
+ (syntax-case clauses (else)
+ (()
+ (reverse! (cons (syntax
+ (else (error "unhandled record" r)))
+ out)))
+ (((else e0 e1 ...))
+ (reverse! (cons (syntax (else e0 e1 ...)) out)))
+ (((else e0 e1 ...) . rest)
+ (syntax-violation 'record-case
+ "bad else clause placement"
+ (syntax x)
+ (syntax (else e0 e1 ...))))
+ ((((<foo> f0 ...) e0 ...) . rest)
+ (lp (syntax rest)
+ (cons (process-clause (syntax <foo>)
+ (syntax (f0 ...))
+ (syntax (e0 ...)))
+ out)))))))
+ (syntax
+ (let* ((r record)
+ (rtd (struct-vtable r)))
+ (cond processed ...)))))))))
+
;; Here we take the terrorism to another level. Nasty, but the client
;; code looks good.
diff --git a/module/system/xref.scm b/module/system/xref.scm
index 0613754ab..906ec8e4a 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 ,next ,labels ,len . ,body)
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,len . ,body)
(for-each
(lambda (x)
(pmatch x
diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am
index 37b9cb5e6..488eb1453 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -28,19 +28,23 @@ check_SCRIPTS =
BUILT_SOURCES =
EXTRA_DIST =
-TESTS_ENVIRONMENT = "${top_builddir}/meta/uninstalled-env"
+TESTS_ENVIRONMENT = \
+ GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"
+
+## Check for headers in $(srcdir) and bulid dir before $(CPPFLAGS), which
+## may point us to an old, installed version of guile.
+AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \
+ -I$(top_srcdir)/lib -I$(top_builddir)/lib
test_cflags = \
- -I$(top_srcdir)/test-suite/standalone \
- -I$(top_srcdir) -I$(top_builddir) \
- -I$(top_srcdir)/lib -I$(top_builddir)/lib \
+ -I$(top_srcdir)/test-suite/standalone -I. \
$(EXTRA_DEFS) $(GUILE_CFLAGS) $(GCC_CFLAGS)
AM_LDFLAGS = $(GUILE_CFLAGS)
-snarfcppopts = \
- $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS) -I$(top_srcdir) \
- -I$(top_srcdir)/lib -I$(top_builddir)/lib -I$(top_builddir)
+snarfcppopts = \
+ -I$(top_srcdir) -I$(top_srcdir)/lib -I$(top_builddir)/lib -I$(top_builddir) \
+ -I. $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS)
SUFFIXES = .x
.c.x:
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index 33a2a45f0..a8e251b83 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -65,15 +65,6 @@
(comp-test '(make-int8 3)
#(make-int8 3))
- (comp-test `(load-integer ,(string (integer->char 0)))
- #(load-integer 0 0 1 0))
-
- (comp-test `(load-integer ,(string (integer->char 255)))
- #(load-integer 0 0 1 255))
-
- (comp-test `(load-integer ,(string (integer->char 1) (integer->char 0)))
- #(load-integer 0 0 2 1 0))
-
(comp-test '(load-number "3.14")
(vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.)
(char->integer #\1) (char->integer #\4)))
@@ -86,10 +77,6 @@
(vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o)
(char->integer #\o)))
- (comp-test '(load-keyword "qux")
- (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u)
- (char->integer #\x)))
-
(comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
#(load-program
3 2 (uint16 1) ;; nargs, nrest, nlocs
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 1252c2881..f9fabd7bc 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006 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
@@ -19,9 +19,37 @@
:use-module (test-suite lib)
:use-module (test-suite guile-test)
:use-module (system base compile))
-
+
+
(with-test-prefix "basic"
(pass-if "compile to value"
(equal? (compile 1) 1)))
+
+
+(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.
+ (begin
+ (compile '(define round round))
+ (compile '(eq? round (@@ (guile) round)))))
+
+ (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)
+ (eq? o 'ok))))
+
+ (pass-if "compile in fresh module"
+ (let* ((m (let ((m (make-module)))
+ (beautify-user-module! m)
+ m))
+ (o (begin
+ (compile '(define-macro (foo) 'bar) #:env m)
+ (compile '(let ((bar 'ok)) (foo)) #:env m))))
+ (and (module-ref m 'foo)
+ (eq? o 'ok)))))
diff --git a/test-suite/tests/dynamic-scope.test b/test-suite/tests/dynamic-scope.test
index 77be3b480..08cf1c4e1 100644
--- a/test-suite/tests/dynamic-scope.test
+++ b/test-suite/tests/dynamic-scope.test
@@ -1,7 +1,7 @@
;;;; -*- scheme -*-
;;;; dynamic-scop.test --- test suite for dynamic scoping constructs
;;;;
-;;;; 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
@@ -21,12 +21,10 @@
:use-module (test-suite lib))
-(define exception:missing-expr
- (cons 'syntax-error "Missing expression"))
-(define exception:bad-binding
- (cons 'syntax-error "Bad binding"))
+(define exception:syntax-error
+ (cons 'syntax-error "failed to match"))
(define exception:duplicate-binding
- (cons 'syntax-error "Duplicate binding"))
+ (cons 'syntax-error "duplicate"))
(define global-a 0)
(define (fetch-global-a) global-a)
@@ -48,17 +46,17 @@
(interaction-environment)))
(pass-if-exception "@bind missing expression"
- exception:missing-expr
+ exception:syntax-error
(eval '(@bind ((global-a 1)))
(interaction-environment)))
(pass-if-exception "@bind bad bindings"
- exception:bad-binding
+ exception:syntax-error
(eval '(@bind (a) #f)
(interaction-environment)))
(pass-if-exception "@bind bad bindings"
- exception:bad-binding
+ exception:syntax-error
(eval '(@bind ((a)) #f)
(interaction-environment)))
diff --git a/test-suite/tests/encoding-escapes.test b/test-suite/tests/encoding-escapes.test
new file mode 100644
index 000000000..8859d2e83
--- /dev/null
+++ b/test-suite/tests/encoding-escapes.test
@@ -0,0 +1,139 @@
+;;;; 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,
+;;;; 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
+
+(define-module (test-strings)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1))
+
+(define exception:conversion
+ (cons 'misc-error "^cannot convert to output locale"))
+
+;; Create a string from integer char values, eg. (string-ints 65) => "A"
+(define (string-ints . args)
+ (apply string (map integer->char args)))
+
+(define s1 "última")
+(define s2 "cédula")
+(define s3 "años")
+(define s4 "羅生門")
+
+(with-test-prefix "internal encoding"
+
+ (pass-if "ultima"
+ (string=? s1 (string-ints #xfa #x6c #x74 #x69 #x6d #x61)))
+
+ (pass-if "cedula"
+ (string=? s2 (string-ints #x63 #xe9 #x64 #x75 #x6c #x61)))
+
+ (pass-if "anos"
+ (string=? s3 (string-ints #x61 #xf1 #x6f #x73)))
+
+ (pass-if "Rashomon"
+ (string=? s4 (string-ints #x7f85 #x751f #x9580))))
+
+(with-test-prefix "chars"
+
+ (pass-if "ultima"
+ (list= eqv? (string->list s1)
+ (list #\372 #\l #\t #\i #\m #\a)))
+
+ (pass-if "cedula"
+ (list= eqv? (string->list s2)
+ (list #\c #\351 #\d #\u #\l #\a)))
+
+ (pass-if "anos"
+ (list= eqv? (string->list s3)
+ (list #\a #\361 #\o #\s)))
+
+ (pass-if "Rashomon"
+ (list= eqv? (string->list s4)
+ (list #\77605 #\72437 #\112600))))
+
+
+;; Check that an error is flagged on display output when the output
+;; error strategy is 'error
+
+(with-test-prefix "display output errors"
+
+ (pass-if-exception "ultima"
+ exception:conversion
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ASCII")
+ (set-port-conversion-strategy! pt 'error)
+ (display s1 pt)))
+
+ (pass-if-exception "Rashomon"
+ exception:conversion
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ASCII")
+ (set-port-conversion-strategy! pt 'error)
+ (display s4 pt))))
+
+;; Check that questions marks or substitutions appear when the conversion
+;; mode is substitute
+(with-test-prefix "display output substitutions"
+
+ (pass-if "ultima"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ASCII")
+ (set-port-conversion-strategy! pt 'substitute)
+ (display s1 pt)
+ (string=? "?ltima"
+ (get-output-string pt))))
+
+ (pass-if "Rashomon"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ASCII")
+ (set-port-conversion-strategy! pt 'substitute)
+ (display s4 pt)
+ (string=? "???"
+ (get-output-string pt)))))
+
+
+;; Check that hex escapes appear in the write output and that no error
+;; is thrown. The output error strategy should be irrelevant here.
+(with-test-prefix "display output escapes"
+
+ (pass-if "ultima"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ASCII")
+ (set-port-conversion-strategy! pt 'escape)
+ (display s1 pt)
+ (string=? "\\xfaltima"
+ (get-output-string pt))))
+ (pass-if "Rashomon"
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ASCII")
+ (set-port-conversion-strategy! pt 'escape)
+ (display s4 pt)
+ (string=? "\\u7F85\\u751F\\u9580"
+ (get-output-string pt)))))
+
+(setlocale LC_ALL "en_US.utf8")
+
+(with-test-prefix "input escapes"
+
+ (pass-if "última"
+ (string=? "última"
+ (with-input-from-string "\"\\xfaltima\"" read)))
+
+ (pass-if "羅生門"
+ (string=? "羅生門"
+ (with-input-from-string "\"\\u7F85\\u751F\\u9580\"" read))))
+
diff --git a/test-suite/tests/encoding-iso88591.test b/test-suite/tests/encoding-iso88591.test
new file mode 100644
index 000000000..edd573432
--- /dev/null
+++ b/test-suite/tests/encoding-iso88591.test
@@ -0,0 +1,135 @@
+;;;; strings.test --- test suite for Guile's string functions -*- 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,
+;;;; 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
+
+(define-module (test-strings)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1))
+
+(define exception:conversion
+ (cons 'misc-error "^cannot convert to output locale"))
+
+;; Create a string from integer char values, eg. (string-ints 65) => "A"
+(define (string-ints . args)
+ (apply string (map integer->char args)))
+
+(setlocale LC_ALL "")
+
+(define s1 "última")
+(define s2 "cédula")
+(define s3 "años")
+(define s4 "¿Cómo?")
+
+(with-test-prefix "string length"
+
+ (pass-if "última"
+ (eq? (string-length s1) 6))
+
+ (pass-if "cédula"
+ (eq? (string-length s2) 6))
+
+ (pass-if "años"
+ (eq? (string-length s3) 4))
+
+ (pass-if "¿Cómo?"
+ (eq? (string-length s4) 6)))
+
+(with-test-prefix "internal encoding"
+
+ (pass-if "última"
+ (string=? s1 (string-ints #xfa #x6c #x74 #x69 #x6d #x61)))
+
+ (pass-if "cédula"
+ (string=? s2 (string-ints #x63 #xe9 #x64 #x75 #x6c #x61)))
+
+ (pass-if "años"
+ (string=? s3 (string-ints #x61 #xf1 #x6f #x73)))
+
+ (pass-if "¿Cómo?"
+ (string=? s4 (string-ints #xbf #x43 #xf3 #x6d #x6f #x3f))))
+
+(with-test-prefix "chars"
+
+ (pass-if "última"
+ (list= eqv? (string->list s1)
+ (list #\ú #\l #\t #\i #\m #\a)))
+
+ (pass-if "cédula"
+ (list= eqv? (string->list s2)
+ (list #\c #\é #\d #\u #\l #\a)))
+
+ (pass-if "años"
+ (list= eqv? (string->list s3)
+ (list #\a #\ñ #\o #\s)))
+
+ (pass-if "¿Cómo?"
+ (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"
+ (eq? (string->symbol s1) 'última))
+
+ (pass-if "cédula"
+ (eq? (string->symbol s2) 'cédula))
+
+ (pass-if "años"
+ (eq? (string->symbol s3) 'años))
+
+ (pass-if "¿Cómo?"
+ (eq? (string->symbol s4) '¿Cómo?)))
+
+(with-test-prefix "non-ascii variable names"
+
+ (pass-if "1"
+ (let ((á 1)
+ (ñ 2))
+ (eq? (+ á ñ) 3))))
+
+(with-test-prefix "output errors"
+
+ (pass-if-exception "char 256" exception:conversion
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-1")
+ (set-port-conversion-strategy! pt 'error)
+ (display (string-ints 256) pt))))
+
+;; Reset locales
+(setlocale LC_ALL "C") \ No newline at end of file
diff --git a/test-suite/tests/encoding-iso88597.test b/test-suite/tests/encoding-iso88597.test
new file mode 100644
index 000000000..8985042f4
--- /dev/null
+++ b/test-suite/tests/encoding-iso88597.test
@@ -0,0 +1,136 @@
+;;;; strings.test --- test suite for Guile's string functions -*- 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,
+;;;; 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
+
+(define-module (test-strings)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1))
+
+(define exception:conversion
+ (cons 'misc-error "^cannot convert to output locale"))
+
+;; Create a string from integer char values, eg. (string-ints 65) => "A"
+(define (string-ints . args)
+ (apply string (map integer->char args)))
+
+(setlocale LC_ALL "")
+
+(define s1 "Ðåñß")
+(define s2 "ôçò")
+(define s3 "êñéôéêÞò")
+(define s4 "êáé")
+
+(with-test-prefix "string length"
+
+ (pass-if "s1"
+ (eq? (string-length s1) 4))
+
+ (pass-if "s2"
+ (eq? (string-length s2) 3))
+
+ (pass-if "s3"
+ (eq? (string-length s3) 8))
+
+ (pass-if "s4"
+ (eq? (string-length s4) 3)))
+
+(with-test-prefix "internal encoding"
+
+ (pass-if "s1"
+ (string=? s1 (string-ints #x03a0 #x03b5 #x03c1 #x03af)))
+
+ (pass-if "s2"
+ (string=? s2 (string-ints #x03c4 #x03b7 #x03c2)))
+
+ (pass-if "s3"
+ (string=? s3 (string-ints #x03ba #x03c1 #x03b9 #x03c4 #x03b9 #x03ba #x03ae #x03c2)))
+
+ (pass-if "s4"
+ (string=? s4 (string-ints #x03ba #x03b1 #x03b9))))
+
+(with-test-prefix "chars"
+
+ (pass-if "s1"
+ (list= eqv? (string->list s1)
+ (list #\Ð #\å #\ñ #\ß)))
+
+ (pass-if "s2"
+ (list= eqv? (string->list s2)
+ (list #\ô #\ç #\ò)))
+
+ (pass-if "s3"
+ (list= eqv? (string->list s3)
+ (list #\ê #\ñ #\é #\ô #\é #\ê #\Þ #\ò)))
+
+ (pass-if "s4"
+ (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 "Ðåñß"
+ (eq? (string->symbol s1) 'Ðåñß))
+
+ (pass-if "ôçò"
+ (eq? (string->symbol s2) 'ôçò))
+
+ (pass-if "êñéôéêÞò"
+ (eq? (string->symbol s3) 'êñéôéêÞò))
+
+ (pass-if "êáé"
+ (eq? (string->symbol s4) 'êáé)))
+
+(with-test-prefix "non-ascii variable names"
+
+ (pass-if "1"
+ (let ((á 1)
+ (ñ 2))
+ (eq? (+ á ñ) 3))))
+
+(with-test-prefix "output errors"
+
+ (pass-if-exception "char #x0400"
+ exception:conversion
+ (let ((pt (open-output-string)))
+ (set-port-encoding! pt "ISO-8859-7")
+ (set-port-conversion-strategy! pt 'error)
+ (display (string-ints #x0400) pt))))
+
+;; Reset locale
+(setlocale LC_ALL "C") \ No newline at end of file
diff --git a/test-suite/tests/encoding-utf8.test b/test-suite/tests/encoding-utf8.test
new file mode 100644
index 000000000..83e7540f3
--- /dev/null
+++ b/test-suite/tests/encoding-utf8.test
@@ -0,0 +1,105 @@
+;;;; strings.test --- test suite for Guile's string functions -*- 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,
+;;;; 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
+
+(define-module (test-strings)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1))
+
+(define exception:conversion
+ (cons 'misc-error "^cannot convert to output locale"))
+
+;; Create a string from integer char values, eg. (string-ints 65) => "A"
+(define (string-ints . args)
+ (apply string (map integer->char args)))
+
+(setlocale LC_ALL "")
+
+(define s1 "última")
+(define s2 "cédula")
+(define s3 "años")
+(define s4 "羅生門")
+
+(with-test-prefix "string length"
+
+ (pass-if "última"
+ (eq? (string-length s1) 6))
+
+ (pass-if "cédula"
+ (eq? (string-length s2) 6))
+
+ (pass-if "años"
+ (eq? (string-length s3) 4))
+
+ (pass-if "羅生門"
+ (eq? (string-length s4) 3)))
+
+(with-test-prefix "internal encoding"
+
+ (pass-if "última"
+ (string=? s1 (string-ints #xfa #x6c #x74 #x69 #x6d #x61)))
+
+ (pass-if "cédula"
+ (string=? s2 (string-ints #x63 #xe9 #x64 #x75 #x6c #x61)))
+
+ (pass-if "años"
+ (string=? s3 (string-ints #x61 #xf1 #x6f #x73)))
+
+ (pass-if "羅生門"
+ (string=? s4 (string-ints #x7f85 #x751f #x9580))))
+
+(with-test-prefix "chars"
+
+ (pass-if "última"
+ (list= eqv? (string->list s1)
+ (list #\ú #\l #\t #\i #\m #\a)))
+
+ (pass-if "cédula"
+ (list= eqv? (string->list s2)
+ (list #\c #\é #\d #\u #\l #\a)))
+
+ (pass-if "años"
+ (list= eqv? (string->list s3)
+ (list #\a #\ñ #\o #\s)))
+
+ (pass-if "羅生門"
+ (list= eqv? (string->list s4)
+ (list #\羅 #\生 #\門))))
+
+(with-test-prefix "symbols == strings"
+
+ (pass-if "última"
+ (eq? (string->symbol s1) 'última))
+
+ (pass-if "cédula"
+ (eq? (string->symbol s2) 'cédula))
+
+ (pass-if "años"
+ (eq? (string->symbol s3) 'años))
+
+ (pass-if "羅生門"
+ (eq? (string->symbol s4) '羅生門)))
+
+(with-test-prefix "non-ascii variable names"
+
+ (pass-if "1"
+ (let ((芥å·é¾ä¹‹ä»‹ 1)
+ (ñ 2))
+ (eq? (+ 芥å·é¾ä¹‹ä»‹ ñ) 3))))
+
+
diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
index 696c35ca2..f22cfe9c1 100644
--- a/test-suite/tests/modules.test
+++ b/test-suite/tests/modules.test
@@ -1,6 +1,6 @@
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
-;;;; 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
@@ -34,6 +34,13 @@
(with-test-prefix "foundations"
+ (pass-if "modules don't remain anonymous"
+ ;; This is a requirement for `psyntax': it stores module names and relies
+ ;; on being able to `resolve-module' them.
+ (let ((m (make-module)))
+ (and (module-name m)
+ (eq? m (resolve-module (module-name m))))))
+
(pass-if "module-add!"
(let ((m (make-module))
(value (cons 'x 'y)))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 4a9476a52..774e228a7 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -22,6 +22,7 @@
;;;
;;; miscellaneous
;;;
+(setbinary)
(define exception:numerical-overflow
(cons 'numerical-overflow "^Numerical overflow"))
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 67df5b979..76b3e5656 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -33,6 +33,9 @@
;;;; Some general utilities for testing ports.
+;;; Make sure we are set up for 8-bit data
+(setbinary)
+
;;; Read from PORT until EOF, and return the result as a string.
(define (read-all port)
(let loop ((chars '()))
diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test
index 5768e1a64..6af73f6bb 100644
--- a/test-suite/tests/procprop.test
+++ b/test-suite/tests/procprop.test
@@ -43,9 +43,7 @@
'(1 0 #f)))
(pass-if "apply"
- (equal? (if ((@ (system vm program) program?) apply)
- (throw 'unresolved)
- (procedure-property apply 'arity))
+ (equal? (procedure-property apply 'arity)
'(1 0 #t)))
(pass-if "cons*"
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index df12e5cbc..c2b0755f8 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -27,6 +27,9 @@
;;; All these tests assume Guile 1.8's port system, where characters are
;;; treated as octets.
+;;; Set the default encoding of future ports to be binary
+(setbinary)
+
(with-test-prefix "7.2.5 End-of-File Object"
diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test
index 8ec298960..17d8ae2d9 100644
--- a/test-suite/tests/srcprop.test
+++ b/test-suite/tests/srcprop.test
@@ -36,11 +36,51 @@
(not (null? (source-properties s))))))
;;;
+;;; set-source-property!
+;;;
+
+(with-test-prefix "set-source-property!"
+ (read-enable 'positions)
+
+ (pass-if "setting the breakpoint property works"
+ (let ((s (read (open-input-string "(+ 3 4)"))))
+ (set-source-property! s 'breakpoint #t)
+ (let ((current-trap-opts (evaluator-traps-interface))
+ (current-debug-opts (debug-options-interface))
+ (trap-called #f))
+ (trap-set! enter-frame-handler (lambda _ (set! trap-called #t)))
+ (trap-enable 'traps)
+ (debug-enable 'debug)
+ (debug-enable 'breakpoints)
+ (with-traps (lambda ()
+ (primitive-eval s)))
+ (evaluator-traps-interface current-trap-opts)
+ (debug-options-interface current-debug-opts)
+ trap-called))))
+
+;;;
;;; set-source-properties!
;;;
(with-test-prefix "set-source-properties!"
(read-enable 'positions)
+
+ (pass-if "setting the breakpoint property works"
+ (let ((s (read (open-input-string "(+ 3 4)"))))
+ (set-source-properties! s '((breakpoint #t)))
+ (let ((current-trap-opts (evaluator-traps-interface))
+ (current-debug-opts (debug-options-interface))
+ (trap-called #f))
+ (trap-set! enter-frame-handler (lambda _ (set! trap-called #t)))
+ (trap-enable 'traps)
+ (debug-enable 'debug)
+ (debug-enable 'breakpoints)
+ (with-traps (lambda ()
+ (primitive-eval s)))
+ (evaluator-traps-interface current-trap-opts)
+ (debug-options-interface current-debug-opts)
+ trap-called)))
+
(let ((s (read (open-input-string "(1 . 2)"))))
(with-test-prefix "copied props"
@@ -48,7 +88,7 @@
(let ((t (cons 3 4)))
(set-source-properties! t (source-properties s))
(number? (source-property t 'line))))
-
+
(pass-if "visible to source-properties"
(let ((t (cons 3 4)))
(set-source-properties! t (source-properties s))
diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test
index 9dbf5bf40..d8e379959 100644
--- a/test-suite/tests/srfi-13.test
+++ b/test-suite/tests/srfi-13.test
@@ -30,6 +30,9 @@
(define (string-ints . args)
(apply string (map integer->char args)))
+;; Some abbreviations
+;; BMP - Basic Multilingual Plane (codepoints below U+FFFF)
+;; SMP - Suplementary Multilingual Plane (codebpoints from U+10000 to U+1FFFF)
;;;
;;; string-any
@@ -53,6 +56,12 @@
(pass-if "one match"
(string-any #\C "abCde"))
+ (pass-if "one match: BMP"
+ (string-any (integer->char #x0100) "ab\u0100de"))
+
+ (pass-if "one match: SMP"
+ (string-any (integer->char #x010300) "ab\U010300de"))
+
(pass-if "more than one match"
(string-any #\X "abXXX"))
@@ -151,7 +160,9 @@
(pass-if (string=? "" (string-append/shared "" "")))
(pass-if (string=? "xyz" (string-append/shared "xyz" "")))
(pass-if (string=? "xyz" (string-append/shared "" "xyz")))
- (pass-if (string=? "abcxyz" (string-append/shared "abc" "xyz"))))
+ (pass-if (string=? "abcxyz" (string-append/shared "abc" "xyz")))
+ (pass-if (string=? "abc\u0100\u0101"
+ (string-append/shared "abc" "\u0100\u0101"))))
(with-test-prefix "three args"
(pass-if (string=? "" (string-append/shared "" "" "")))
@@ -191,7 +202,10 @@
(pass-if-exception "improper 1" exception:wrong-type-arg
(string-concatenate '("a" . "b")))
- (pass-if (equal? "abc" (string-concatenate '("a" "b" "c")))))
+ (pass-if (equal? "abc" (string-concatenate '("a" "b" "c"))))
+
+ (pass-if "concatenate BMP"
+ (equal? "a\u0100" (string-concatenate '("a" "\u0100")))))
;;
;; string-compare
@@ -234,7 +248,10 @@
(pass-if-exception "improper 1" exception:wrong-type-arg
(string-concatenate/shared '("a" . "b")))
- (pass-if (equal? "abc" (string-concatenate/shared '("a" "b" "c")))))
+ (pass-if (equal? "abc" (string-concatenate/shared '("a" "b" "c"))))
+
+ (pass-if "BMP"
+ (equal? "a\u0100c" (string-concatenate/shared '("a" "\u0100" "c")))))
;;;
;;; string-every
@@ -267,6 +284,9 @@
(pass-if "all match"
(string-every #\X "XXXXX"))
+ (pass-if "all match BMP"
+ (string-every #\200000 "\U010000\U010000"))
+
(pass-if "no match at all, start index"
(not (string-every #\X "Xbcde" 1)))
@@ -386,6 +406,9 @@
(pass-if "nonempty, start index"
(= (length (string->list "foo" 1 3)) 2))
+
+ (pass-if "nonempty, start index, BMP"
+ (= (length (string->list "\xff\u0100\u0300" 1 3)) 2))
)
(with-test-prefix "reverse-list->string"
@@ -394,8 +417,10 @@
(string-null? (reverse-list->string '())))
(pass-if "nonempty"
- (string=? "foo" (reverse-list->string '(#\o #\o #\f)))))
+ (string=? "foo" (reverse-list->string '(#\o #\o #\f))))
+ (pass-if "nonempty, BMP"
+ (string=? "\u0100\u0101\u0102" (reverse-list->string '(#\402 #\401 #\400)))))
(with-test-prefix "string-join"
@@ -436,6 +461,11 @@
(string=? "bla|delim|fasel" (string-join '("bla" "fasel") "|delim|"
'infix)))
+ (pass-if "two strings, explicit infix, BMP"
+ (string=? "\u0100\u0101::\u0102\u0103"
+ (string-join '("\u0100\u0101" "\u0102\u0103") "::"
+ 'infix)))
+
(pass-if-exception "empty list, strict infix"
exception:strict-infix-grammar
(string-join '() "|delim|" 'strict-infix))
@@ -484,9 +514,15 @@
(pass-if "full string"
(string=? "foo-bar" (string-copy "foo-bar")))
+ (pass-if "full string, BMP"
+ (string=? "foo-\u0100\u0101" (string-copy "foo-\u0100\u0101")))
+
(pass-if "start index"
(string=? "o-bar" (string-copy "foo-bar" 2)))
+ (pass-if "start index"
+ (string=? "o-bar" (string-copy "\u0100\u0101o-bar" 2)))
+
(pass-if "start and end index"
(string=? "o-ba" (string-copy "foo-bar" 2 6)))
)
@@ -519,6 +555,9 @@
(pass-if "non-empty string"
(string=? "foo " (string-take "foo bar braz" 4)))
+ (pass-if "non-empty string BMP"
+ (string=? "\u0100oo " (string-take "\u0100oo \u0101ar braz" 4)))
+
(pass-if "full string"
(string=? "foo bar braz" (string-take "foo bar braz" 12))))
@@ -530,6 +569,9 @@
(pass-if "non-empty string"
(string=? "braz" (string-take-right "foo bar braz" 4)))
+ (pass-if "non-empty string"
+ (string=? "braz" (string-take-right "foo ba\u0100 braz" 4)))
+
(pass-if "full string"
(string=? "foo bar braz" (string-take-right "foo bar braz" 12))))
@@ -541,6 +583,9 @@
(pass-if "non-empty string"
(string=? "braz" (string-drop "foo bar braz" 8)))
+ (pass-if "non-empty string BMP"
+ (string=? "braz" (string-drop "foo \u0100\u0101\u0102 braz" 8)))
+
(pass-if "full string"
(string=? "foo bar braz" (string-drop "foo bar braz" 0))))
@@ -552,6 +597,9 @@
(pass-if "non-empty string"
(string=? "foo " (string-drop-right "foo bar braz" 8)))
+ (pass-if "non-empty string BMP"
+ (string=? "foo " (string-drop-right "foo \u0100\u0101\u0102 braz" 8)))
+
(pass-if "full string"
(string=? "foo bar braz" (string-drop-right "foo bar braz" 0))))
diff --git a/test-suite/tests/srfi-14.test b/test-suite/tests/srfi-14.test
index 8c678cdd5..2bb934aac 100644
--- a/test-suite/tests/srfi-14.test
+++ b/test-suite/tests/srfi-14.test
@@ -1,4 +1,5 @@
-;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions.
+;;;; srfi-14.test -*- mode:scheme; coding: iso-8859-1 -*-
+;;;; --- Test suite for Guile's SRFI-14 functions.
;;;; Martin Grabmueller, 2001-07-16
;;;;
;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
@@ -29,6 +30,30 @@
(define exception:non-char-return
(cons 'misc-error "returned non-char"))
+
+(with-test-prefix "char set contents"
+
+ (pass-if "empty set"
+ (list= eqv?
+ (char-set->list (char-set))
+ '()))
+
+ (pass-if "single char"
+ (list= eqv?
+ (char-set->list (char-set #\a))
+ (list #\a)))
+
+ (pass-if "contiguous chars"
+ (list= eqv?
+ (char-set->list (char-set #\a #\b #\c))
+ (list #\a #\b #\c)))
+
+ (pass-if "discontiguous chars"
+ (list= eqv?
+ (char-set->list (char-set #\a #\c #\e))
+ (list #\a #\c #\e))))
+
+
(with-test-prefix "char-set?"
(pass-if "success on empty set"
@@ -113,7 +138,7 @@
(with-test-prefix "char-set cursor"
(pass-if-exception "invalid character cursor"
- exception:invalid-char-set-cursor
+ exception:wrong-type-arg
(let* ((cs (char-set #\B #\r #\a #\z))
(cc (char-set-cursor cs)))
(char-set-ref cs 1000)))
@@ -148,30 +173,33 @@
(= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c))
(char-set) (char-set #\a #\b))) 2)))
+(define char-set:256
+ (string->char-set (apply string (map integer->char (iota 256)))))
+
(with-test-prefix "char-set-unfold"
(pass-if "create char set"
- (char-set= char-set:full
+ (char-set= char-set:256
(char-set-unfold (lambda (s) (= s 256)) integer->char
(lambda (s) (+ s 1)) 0)))
(pass-if "create char set (base set)"
- (char-set= char-set:full
+ (char-set= char-set:256
(char-set-unfold (lambda (s) (= s 256)) integer->char
(lambda (s) (+ s 1)) 0 char-set:empty))))
(with-test-prefix "char-set-unfold!"
(pass-if "create char set"
- (char-set= char-set:full
+ (char-set= char-set:256
(char-set-unfold! (lambda (s) (= s 256)) integer->char
(lambda (s) (+ s 1)) 0
(char-set-copy char-set:empty))))
(pass-if "create char set"
- (char-set= char-set:full
+ (char-set= char-set:256
(char-set-unfold! (lambda (s) (= s 32)) integer->char
(lambda (s) (+ s 1)) 0
- (char-set-copy char-set:full)))))
+ (char-set-copy char-set:256)))))
(with-test-prefix "char-set-for-each"
@@ -186,9 +214,15 @@
(with-test-prefix "char-set-map"
- (pass-if "upper case char set"
- (char-set= (char-set-map char-upcase char-set:lower-case)
- char-set:upper-case)))
+ (pass-if "upper case char set 1"
+ (char-set= (char-set-map char-upcase
+ (string->char-set "abcdefghijklmnopqrstuvwxyz"))
+ (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")))
+
+ (pass-if "upper case char set 2"
+ (char-set= (char-set-map char-upcase
+ (string->char-set "àáâãäåæçèéêëìíîïñòóôõöøùúûüýþ"))
+ (string->char-set "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÑÒÓÔÕÖØÙÚÛÜÝÞ"))))
(with-test-prefix "string->char-set"
@@ -197,42 +231,107 @@
(char-set= (list->char-set chars)
(string->char-set (apply string chars))))))
+(with-test-prefix "char-set->string"
+
+ (pass-if "some char set"
+ (let ((cs (char-set #\g #\u #\i #\l #\e)))
+ (string=? (char-set->string cs)
+ "egilu"))))
+
;; Make sure we get an ASCII charset and character classification.
(if (defined? 'setlocale) (setlocale LC_CTYPE "C"))
(with-test-prefix "standard char sets (ASCII)"
+ (pass-if "char-set:lower-case"
+ (char-set<= (string->char-set "abcdefghijklmnopqrstuvwxyz")
+ char-set:lower-case))
+
+ (pass-if "char-set:upper-case"
+ (char-set<= (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ char-set:upper-case))
+
+ (pass-if "char-set:title-case"
+ (char-set<= (string->char-set "")
+ char-set:title-case))
+
(pass-if "char-set:letter"
- (char-set= (string->char-set
- (string-append "abcdefghijklmnopqrstuvwxyz"
- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
- char-set:letter))
+ (char-set<= (char-set-union
+ (string->char-set "abcdefghijklmnopqrstuvwxyz")
+ (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
+ char-set:letter))
- (pass-if "char-set:punctuation"
- (char-set= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
- char-set:punctuation))
+ (pass-if "char-set:digit"
+ (char-set<= (string->char-set "0123456789")
+ char-set:digit))
- (pass-if "char-set:symbol"
- (char-set= (string->char-set "$+<=>^`|~")
- char-set:symbol))
+ (pass-if "char-set:hex-digit"
+ (char-set<= (string->char-set "0123456789abcdefABCDEF")
+ char-set:hex-digit))
(pass-if "char-set:letter+digit"
- (char-set= char-set:letter+digit
- (char-set-union char-set:letter char-set:digit)))
+ (char-set<= (char-set-union
+ (string->char-set "abcdefghijklmnopqrstuvwxyz")
+ (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ (string->char-set "0123456789"))
+ char-set:letter+digit))
- (pass-if "char-set:graphic"
- (char-set= char-set:graphic
- (char-set-union char-set:letter char-set:digit
- char-set:punctuation char-set:symbol)))
+ (pass-if "char-set:punctuation"
+ (char-set<= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
+ char-set:punctuation))
- (pass-if "char-set:printing"
- (char-set= char-set:printing
- (char-set-union char-set:whitespace char-set:graphic))))
+ (pass-if "char-set:symbol"
+ (char-set<= (string->char-set "$+<=>^`|~")
+ char-set:symbol))
+ (pass-if "char-set:graphic"
+ (char-set<= (char-set-union
+ (string->char-set "abcdefghijklmnopqrstuvwxyz")
+ (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ (string->char-set "0123456789")
+ (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
+ (string->char-set "$+<=>^`|~"))
+ char-set:graphic))
+
+ (pass-if "char-set:whitespace"
+ (char-set<= (string->char-set
+ (string
+ (integer->char #x09)
+ (integer->char #x0a)
+ (integer->char #x0b)
+ (integer->char #x0c)
+ (integer->char #x0d)
+ (integer->char #x20)))
+ char-set:whitespace))
+
+ (pass-if "char-set:printing"
+ (char-set<= (char-set-union
+ (string->char-set "abcdefghijklmnopqrstuvwxyz")
+ (string->char-set "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ (string->char-set "0123456789")
+ (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
+ (string->char-set "$+<=>^`|~")
+ (string->char-set (string
+ (integer->char #x09)
+ (integer->char #x0a)
+ (integer->char #x0b)
+ (integer->char #x0c)
+ (integer->char #x0d)
+ (integer->char #x20))))
+ char-set:printing))
+
+ (pass-if "char-set:iso-control"
+ (char-set<= (string->char-set
+ (apply string
+ (map integer->char (append
+ ;; U+0000 to U+001F
+ (iota #x20)
+ (list #x7f)))))
+ char-set:iso-control)))
;;;
-;;; 8-bit charsets.
+;;; Non-ASCII codepoints
;;;
;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of
;;; SRFI-14 for implementations supporting this charset is well-defined.
@@ -260,57 +359,123 @@
(with-test-prefix "Latin-1 (8-bit charset)"
- ;; Note: the membership tests below are not exhaustive.
-
- (pass-if "char-set:letter (membership)"
+ (pass-if "char-set:lower-case"
(if (not %latin1)
(throw 'unresolved)
- (let ((letters (char-set->list char-set:letter)))
- (every? (lambda (8-bit-char)
- (memq 8-bit-char letters))
- (append '(#\a #\b #\c) ;; ASCII
- (string->list "çéèâùÉÀÈÊ") ;; French
- (string->list "øñÑíßåæðþ"))))))
-
- (pass-if "char-set:letter (size)"
+ (char-set<= (string->char-set
+ (string-append "abcdefghijklmnopqrstuvwxyz"
+ "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ")
+ char-set:lower-case))))
+
+ (pass-if "char-set:upper-case"
(if (not %latin1)
- (throw 'unresolved)
- (= (char-set-size char-set:letter) 117)))
+ (throw 'unresolved)
+ (char-set<= (string->char-set
+ (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ")
+ char-set:lower-case))))
- (pass-if "char-set:lower-case (size)"
+ (pass-if "char-set:title-case"
(if (not %latin1)
(throw 'unresolved)
- (= (char-set-size char-set:lower-case) (+ 26 33))))
+ (char-set<= (string->char-set "")
+ char-set:title-case)))
- (pass-if "char-set:upper-case (size)"
+ (pass-if "char-set:letter"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (char-set<= (string->char-set
+ (string-append
+ ;; Lowercase
+ "abcdefghijklmnopqrstuvwxyz"
+ "µßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ"
+ ;; Uppercase
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞ"
+ ;; Uncased
+ "ªº"))
+ char-set:letter)))
+
+ (pass-if "char-set:digit"
(if (not %latin1)
(throw 'unresolved)
- (= (char-set-size char-set:upper-case) (+ 26 30))))
+ (char-set<= (string->char-set "0123456789")
+ char-set:digit)))
- (pass-if "char-set:punctuation (membership)"
+ (pass-if "char-set:hex-digit"
(if (not %latin1)
(throw 'unresolved)
- (let ((punctuation (char-set->list char-set:punctuation)))
- (every? (lambda (8-bit-char)
- (memq 8-bit-char punctuation))
- (append '(#\! #\. #\?) ;; ASCII
- (string->list "¡¿") ;; Castellano
- (string->list "«»")))))) ;; French
+ (char-set<= (string->char-set "0123456789abcdefABCDEF")
+ char-set:hex-digit)))
(pass-if "char-set:letter+digit"
- (char-set= char-set:letter+digit
- (char-set-union char-set:letter char-set:digit)))
+ (if (not %latin1)
+ (throw 'unresolved)
+ (char-set<= (char-set-union
+ char-set:letter
+ char-set:digit)
+ char-set:letter+digit)))
- (pass-if "char-set:graphic"
- (char-set= char-set:graphic
- (char-set-union char-set:letter char-set:digit
- char-set:punctuation char-set:symbol)))
+ (pass-if "char-set:punctuation"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (char-set<= (string->char-set
+ (string-append "!\"#%&'()*,-./:;?@[\\]_{}"
+ "¡«·»¿"))
+ char-set:punctuation)))
+ (pass-if "char-set:symbol"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (char-set<= (string->char-set
+ (string-append "$+<=>^`|~"
+ "¢£¤¥¦§¨©¬®¯°±´¶¸×÷"))
+ char-set:symbol)))
+
+ ;; Note that SRFI-14 itself is inconsistent here. Characters that
+ ;; are non-digit numbers (such as category No) are clearly 'graphic'
+ ;; but don't occur in the letter, digit, punct, or symbol charsets.
+ (pass-if "char-set:graphic"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (char-set<= (char-set-union
+ char-set:letter
+ char-set:digit
+ char-set:punctuation
+ char-set:symbol)
+ char-set:graphic)))
+
+ (pass-if "char-set:whitespace"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (char-set<= (string->char-set
+ (string
+ (integer->char #x09)
+ (integer->char #x0a)
+ (integer->char #x0b)
+ (integer->char #x0c)
+ (integer->char #x0d)
+ (integer->char #x20)
+ (integer->char #xa0)))
+ char-set:whitespace)))
+
(pass-if "char-set:printing"
- (char-set= char-set:printing
- (char-set-union char-set:whitespace char-set:graphic))))
+ (if (not %latin1)
+ (throw 'unresolved)
+ (char-set<= (char-set-union char-set:graphic char-set:whitespace)
+ char-set:printing)))
+
+ (pass-if "char-set:iso-control"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (char-set<= (string->char-set
+ (apply string
+ (map integer->char (append
+ ;; U+0000 to U+001F
+ (iota #x20)
+ (list #x7f)
+ ;; U+007F to U+009F
+ (map (lambda (x) (+ #x80 x))
+ (iota #x20))))))
+ char-set:iso-control))))
-;; Local Variables:
-;; mode: scheme
-;; coding: latin-1
-;; End:
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index ffc6955ca..3f245371d 100644
--- a/test-suite/tests/strings.test
+++ b/test-suite/tests/strings.test
@@ -1,7 +1,7 @@
;;;; strings.test --- test suite for Guile's string functions -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
;;;;
-;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 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
@@ -20,14 +20,223 @@
(define-module (test-strings)
#:use-module (test-suite lib))
-
(define exception:read-only-string
(cons 'misc-error "^string is read-only"))
+(define exception:illegal-escape
+ (cons 'read-error "illegal character in escape sequence"))
+;; Wrong types may have either the 'wrong-type-arg key when
+;; interpreted or 'vm-error when compiled. This matches both.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
(apply string (map integer->char args)))
+;;
+;; string internals
+;;
+
+;; Some abbreviations
+;; BMP - Basic Multilingual Plane (codepoints below U+FFFF)
+;; SMP - Suplementary Multilingual Plane (codebpoints from U+10000 to U+1FFFF)
+
+(with-test-prefix "string internals"
+
+ (pass-if "new string starts at 1st char in stringbuf"
+ (let ((s "abc"))
+ (= 0 (assq-ref (%string-dump s) 'start))))
+
+ (pass-if "length of new string same as stringbuf"
+ (let ((s "def"))
+ (= (string-length s) (assq-ref (%string-dump s) 'stringbuf-length))))
+
+ (pass-if "contents of new string same as stringbuf"
+ (let ((s "ghi"))
+ (string=? s (assq-ref (%string-dump s) 'stringbuf-chars))))
+
+ (pass-if "writable strings are not read-only"
+ (let ((s "zyx"))
+ (not (assq-ref (%string-dump s) 'read-only))))
+
+ (pass-if "read-only strings are read-only"
+ (let ((s (substring/read-only "zyx" 0)))
+ (assq-ref (%string-dump s) 'read-only)))
+
+ (pass-if "null strings are inlined"
+ (let ((s ""))
+ (assq-ref (%string-dump s) 'stringbuf-inline)))
+
+ (pass-if "short Latin-1 encoded strings are inlined"
+ (let ((s "m"))
+ (assq-ref (%string-dump s) 'stringbuf-inline)))
+
+ (pass-if "long Latin-1 encoded strings are not inlined"
+ (let ((s "0123456789012345678901234567890123456789"))
+ (not (assq-ref (%string-dump s) 'stringbuf-inline))))
+
+ (pass-if "short UCS-4 encoded strings are not inlined"
+ (let ((s "\u0100"))
+ (not (assq-ref (%string-dump s) 'stringbuf-inline))))
+
+ (pass-if "long UCS-4 encoded strings are not inlined"
+ (let ((s "\u010012345678901234567890123456789"))
+ (not (assq-ref (%string-dump s) 'stringbuf-inline))))
+
+ (pass-if "new Latin-1 encoded strings are not shared"
+ (let ((s "abc"))
+ (not (assq-ref (%string-dump s) 'stringbuf-shared))))
+
+ (pass-if "new UCS-4 encoded strings are not shared"
+ (let ((s "\u0100bc"))
+ (not (assq-ref (%string-dump s) 'stringbuf-shared))))
+
+ ;; Should this be true? It isn't currently true.
+ (pass-if "null shared substrings are shared"
+ (let* ((s1 "")
+ (s2 (substring/shared s1 0 0)))
+ (throw 'untested)
+ (eq? (assq-ref (%string-dump s2) 'shared)
+ s1)))
+
+ (pass-if "ASCII shared substrings are shared"
+ (let* ((s1 "foobar")
+ (s2 (substring/shared s1 0 3)))
+ (eq? (assq-ref (%string-dump s2) 'shared)
+ s1)))
+
+ (pass-if "BMP shared substrings are shared"
+ (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
+ (s2 (substring/shared s1 0 3)))
+ (eq? (assq-ref (%string-dump s2) 'shared)
+ s1)))
+
+ (pass-if "null substrings are not shared"
+ (let* ((s1 "")
+ (s2 (substring s1 0 0)))
+ (not (eq? (assq-ref (%string-dump s2) 'shared)
+ s1))))
+
+ (pass-if "ASCII substrings are not shared"
+ (let* ((s1 "foobar")
+ (s2 (substring s1 0 3)))
+ (not (eq? (assq-ref (%string-dump s2) 'shared)
+ s1))))
+
+ (pass-if "BMP substrings are not shared"
+ (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
+ (s2 (substring s1 0 3)))
+ (not (eq? (assq-ref (%string-dump s2) 'shared)
+ s1))))
+
+ (pass-if "ASCII substrings share stringbufs before copy-on-write"
+ (let* ((s1 "foobar")
+ (s2 (substring s1 0 3)))
+ (assq-ref (%string-dump s1) 'stringbuf-shared)))
+
+ (pass-if "BMP substrings share stringbufs before copy-on-write"
+ (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
+ (s2 (substring s1 0 3)))
+ (assq-ref (%string-dump s1) 'stringbuf-shared)))
+
+ (pass-if "ASCII substrings don't share stringbufs after copy-on-write"
+ (let* ((s1 "foobar")
+ (s2 (substring s1 0 3)))
+ (string-set! s2 0 #\F)
+ (not (assq-ref (%string-dump s2) 'stringbuf-shared))))
+
+ (pass-if "BMP substrings don't share stringbufs after copy-on-write"
+ (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105")
+ (s2 (substring s1 0 3)))
+ (string-set! s2 0 #\F)
+ (not (assq-ref (%string-dump s2) 'stringbuf-shared))))
+
+ (with-test-prefix "encodings"
+
+ (pass-if "null strings are Latin-1 encoded"
+ (let ((s ""))
+ (not (assq-ref (%string-dump s) 'stringbuf-wide))))
+
+ (pass-if "ASCII strings are Latin-1 encoded"
+ (let ((s "jkl"))
+ (not (assq-ref (%string-dump s) 'stringbuf-wide))))
+
+ (pass-if "Latin-1 strings are Latin-1 encoded"
+ (let ((s "\xC0\xC1\xC2"))
+ (not (assq-ref (%string-dump s) 'stringbuf-wide))))
+
+ (pass-if "BMP strings are UCS-4 encoded"
+ (let ((s "\u0100\u0101\x0102"))
+ (assq-ref (%string-dump s) 'stringbuf-wide)))
+
+ (pass-if "SMP strings are UCS-4 encoded"
+ (let ((s "\U010300\u010301\x010302"))
+ (assq-ref (%string-dump s) 'stringbuf-wide)))
+
+ (pass-if "null list->string is Latin-1 encoded"
+ (let ((s (string-ints)))
+ (not (assq-ref (%string-dump s) 'stringbuf-wide))))
+
+ (pass-if "ASCII list->string is Latin-1 encoded"
+ (let ((s (string-ints 65 66 67)))
+ (not (assq-ref (%string-dump s) 'stringbuf-wide))))
+
+ (pass-if "Latin-1 list->string is Latin-1 encoded"
+ (let ((s (string-ints #xc0 #xc1 #xc2)))
+ (not (assq-ref (%string-dump s) 'stringbuf-wide))))
+
+ (pass-if "BMP list->string is UCS-4 encoded"
+ (let ((s (string-ints #x0100 #x0101 #x0102)))
+ (assq-ref (%string-dump s) 'stringbuf-wide)))
+
+ (pass-if "SMP list->string is UCS-4 encoded"
+ (let ((s (string-ints #x010300 #x010301 #x010302)))
+ (assq-ref (%string-dump s) 'stringbuf-wide)))
+
+ (pass-if "encoding of string not based on escape style"
+ (let ((s "\U000040"))
+ (not (assq-ref (%string-dump s) 'stringbuf-wide))))))
+
+(with-test-prefix "hex escapes"
+
+ (pass-if-exception "non-hex char in two-digit hex-escape"
+ exception:illegal-escape
+ (with-input-from-string "\"\\x0g\"" read))
+
+ (pass-if-exception "non-hex char in four-digit hex-escape"
+ exception:illegal-escape
+ (with-input-from-string "\"\\u000g\"" read))
+
+ (pass-if-exception "non-hex char in six-digit hex-escape"
+ exception:illegal-escape
+ (with-input-from-string "\"\\U00000g\"" read))
+
+ (pass-if-exception "premature termination of two-digit hex-escape"
+ exception:illegal-escape
+ (with-input-from-string "\"\\x0\"" read))
+
+ (pass-if-exception "premature termination of four-digit hex-escape"
+ exception:illegal-escape
+ (with-input-from-string "\"\\u000\"" read))
+
+ (pass-if-exception "premature termination of six-digit hex-escape"
+ exception:illegal-escape
+ (with-input-from-string "\"\\U00000\"" read))
+
+ (pass-if "extra hex digits ignored for two-digit hex escape"
+ (eqv? (string-ref "--\xfff--" 2)
+ (integer->char #xff)))
+
+ (pass-if "extra hex digits ignored for four-digit hex escape"
+ (eqv? (string-ref "--\u0100f--" 2)
+ (integer->char #x0100)))
+
+ (pass-if "extra hex digits ignored for six-digit hex escape"
+ (eqv? (string-ref "--\U010300f--" 2)
+ (integer->char #x010300)))
+
+ (pass-if "escaped characters match non-escaped ASCII characters"
+ (string=? "ABC" "\x41\u0042\U000043")))
;;
;; string=?
@@ -181,8 +390,20 @@
exception:out-of-range
(string-ref "hello" -1))
- (pass-if "regular string"
- (char=? (string-ref "GNU Guile" 4) #\G)))
+ (pass-if "regular string, ASCII char"
+ (char=? (string-ref "GNU Guile" 4) #\G))
+
+ (pass-if "regular string, hex escaped Latin-1 char"
+ (char=? (string-ref "--\xff--" 2)
+ (integer->char #xff)))
+
+ (pass-if "regular string, hex escaped BMP char"
+ (char=? (string-ref "--\u0100--" 2)
+ (integer->char #x0100)))
+
+ (pass-if "regular string, hex escaped SMP char"
+ (char=? (string-ref "--\U010300--" 2)
+ (integer->char #x010300))))
;;
;; string-set!
@@ -210,12 +431,37 @@
exception:read-only-string
(string-set! (substring/read-only "abc" 0) 1 #\space))
- (pass-if "regular string"
+ (pass-if "regular string, ASCII char"
(let ((s (string-copy "GNU guile")))
(string-set! s 4 #\G)
- (char=? (string-ref s 4) #\G))))
+ (char=? (string-ref s 4) #\G)))
+ (pass-if "regular string, Latin-1 char"
+ (let ((s (string-copy "GNU guile")))
+ (string-set! s 4 (integer->char #xfe))
+ (char=? (string-ref s 4) (integer->char #xfe))))
+
+ (pass-if "regular string, BMP char"
+ (let ((s (string-copy "GNU guile")))
+ (string-set! s 4 (integer->char #x0100))
+ (char=? (string-ref s 4) (integer->char #x0100))))
+ (pass-if "regular string, SMP char"
+ (let ((s (string-copy "GNU guile")))
+ (string-set! s 4 (integer->char #x010300))
+ (char=? (string-ref s 4) (integer->char #x010300)))))
+
+;;
+;; list->string
+;;
+(with-test-prefix "string"
+
+ (pass-if-exception "convert circular list to string"
+ exception:wrong-type-arg
+ (let ((foo (list #\a #\b #\c)))
+ (set-cdr! (cddr foo) (cdr foo))
+ (apply string foo))))
+
(with-test-prefix "string-split"
;; in guile 1.6.7 and earlier, character >=128 wasn't matched in the string
diff --git a/test-suite/tests/symbols.test b/test-suite/tests/symbols.test
index 5be2743b2..b6dbb9d59 100644
--- a/test-suite/tests/symbols.test
+++ b/test-suite/tests/symbols.test
@@ -1,6 +1,6 @@
;;;; symbols.test --- test suite for Guile's symbols -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 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
@@ -31,6 +31,79 @@
(define (documented? object)
(not (not (object-documentation object))))
+(define (symbol-length s)
+ (string-length (symbol->string s)))
+
+;;
+;; symbol internals
+;;
+
+(with-test-prefix "symbol internals"
+
+ (pass-if "length of new symbol same as stringbuf"
+ (let ((s 'def))
+ (= (symbol-length s) (assq-ref (%symbol-dump s) 'stringbuf-length))))
+
+ (pass-if "contents of new symbol same as stringbuf"
+ (let ((s 'ghi))
+ (string=? (symbol->string s)
+ (assq-ref (%symbol-dump s) 'stringbuf-chars))))
+
+ (pass-if "the null symbol is inlined"
+ (let ((s '#{}#))
+ (assq-ref (%symbol-dump s) 'stringbuf-inline)))
+
+ (pass-if "short Latin-1-encoded symbols are inlined"
+ (let ((s 'm))
+ (assq-ref (%symbol-dump s) 'stringbuf-inline)))
+
+ (pass-if "long Latin-1-encoded symbols are not inlined"
+ (let ((s 'x0123456789012345678901234567890123456789))
+ (not (assq-ref (%symbol-dump s) 'stringbuf-inline))))
+
+ (pass-if "short UCS-4-encoded symbols are not inlined"
+ (let ((s (string->symbol "\u0100")))
+ (not (assq-ref (%symbol-dump s) 'stringbuf-inline))))
+
+ (pass-if "long UCS-4-encoded symbols are not inlined"
+ (let ((s (string->symbol "\u010012345678901234567890123456789")))
+ (not (assq-ref (%symbol-dump s) 'stringbuf-inline))))
+
+ (with-test-prefix "hashes"
+
+ (pass-if "equal symbols have equal hashes"
+ (let ((s1 'mux)
+ (s2 'mux))
+ (= (assq-ref (%symbol-dump s1) 'hash)
+ (assq-ref (%symbol-dump s2) 'hash))))
+
+ (pass-if "different symbols have different hashes"
+ (let ((s1 'mux)
+ (s2 'muy))
+ (not (= (assq-ref (%symbol-dump s1) 'hash)
+ (assq-ref (%symbol-dump s2) 'hash))))))
+
+ (with-test-prefix "encodings"
+
+ (pass-if "the null symbol is Latin-1 encoded"
+ (let ((s '#{}#))
+ (not (assq-ref (%symbol-dump s) 'stringbuf-wide))))
+
+ (pass-if "ASCII symbols are Latin-1 encoded"
+ (let ((s 'jkl))
+ (not (assq-ref (%symbol-dump s) 'stringbuf-wide))))
+
+ (pass-if "Latin-1 symbols are Latin-1 encoded"
+ (let ((s (string->symbol "\xC0\xC1\xC2")))
+ (not (assq-ref (%symbol-dump s) 'stringbuf-wide))))
+
+ (pass-if "BMP symbols are UCS-4 encoded"
+ (let ((s (string->symbol "\u0100\u0101\x0102")))
+ (assq-ref (%symbol-dump s) 'stringbuf-wide)))
+
+ (pass-if "SMP symbols are UCS-4 encoded"
+ (let ((s (string->symbol "\U010300\u010301\x010302")))
+ (assq-ref (%symbol-dump s) 'stringbuf-wide)))))
;;;
;;; symbol?
@@ -47,6 +120,16 @@
(pass-if "symbol"
(symbol? 'foo)))
+;;;
+;;; wide symbols
+;;;
+
+(with-test-prefix "BMP symbols"
+
+ (pass-if "BMP symbol's string"
+ (and (= 4 (string-length "abc\u0100"))
+ (string=? "abc\u0100"
+ (symbol->string (string->symbol "abc\u0100"))))))
;;;
;;; symbol->string
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 0593ea6a6..282072b5b 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -1,6 +1,6 @@
;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001,2003,2004, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2005, 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
@@ -807,21 +807,20 @@
(with-test-prefix "unmemoization"
(pass-if "definition unmemoized without prior execution"
- (eval '(begin
- (define (blub) (cons ('(1 . 2)) 2))
- (equal?
- (procedure-source blub)
- '(lambda () (cons ('(1 . 2)) 2))))
- (interaction-environment)))
+ (primitive-eval '(begin
+ (define (blub) (cons ('(1 . 2)) 2))
+ (equal?
+ (procedure-source blub)
+ '(lambda () (cons ('(1 . 2)) 2))))))
+
(pass-if "definition with documentation unmemoized without prior execution"
- (eval '(begin
- (define (blub) "Comment" (cons ('(1 . 2)) 2))
- (equal?
- (procedure-source blub)
- '(lambda () "Comment" (cons ('(1 . 2)) 2))))
- (interaction-environment))))
-
+ (primitive-eval '(begin
+ (define (blub) "Comment" (cons ('(1 . 2)) 2))
+ (equal?
+ (procedure-source blub)
+ '(lambda () "Comment" (cons ('(1 . 2)) 2)))))))
+
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(define)"
@@ -896,16 +895,15 @@
(interaction-environment)))
(pass-if "unmemoization"
- (eval '(begin
- (define (foo)
- (define (bar)
- 'ok)
- (bar))
- (foo)
- (matches?
- (procedure-source foo)
- (lambda () (letrec ((_ (lambda () (quote ok)))) (_)))))
- (current-module))))
+ (primitive-eval '(begin
+ (define (foo)
+ (define (bar)
+ 'ok)
+ (bar))
+ (foo)
+ (matches?
+ (procedure-source foo)
+ (lambda () (letrec ((_ (lambda () (quote ok)))) (_))))))))
(with-test-prefix "set!"
diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test
index 38a49d384..da7a48c04 100644
--- a/test-suite/tests/time.test
+++ b/test-suite/tests/time.test
@@ -202,6 +202,11 @@
(string=? (strftime "%Z" t)
"ZOW")))
+ (pass-if "strftime passes wide characters"
+ (let ((t (localtime (current-time))))
+ (string=? (substring (strftime "\u0100%Z" t) 0 1)
+ "\u0100")))
+
(with-test-prefix "C99 %z format"
;; %z here is quite possibly affected by the same tm:gmtoff vs current
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 896206b1f..ee5e4d352 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -72,7 +72,7 @@
(program 0 0 0 () (const 1) (call return 1)))
(assert-tree-il->glil
(apply (primitive +) (void) (const 1))
- (program 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
+ (program 0 0 0 () (void) (call add1 1) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
@@ -80,7 +80,7 @@
(program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
(assert-tree-il->glil/pmatch
(begin (apply (toplevel foo) (const 1)) (void))
- (program 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+ (program 0 0 0 () (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,7 +88,7 @@
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar)))
- (program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
+ (program 0 0 0 () (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
(call goto/args 1))))
(with-test-prefix "conditional"
@@ -151,25 +151,33 @@
(with-test-prefix "lexical sets"
(assert-tree-il->glil
- (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
+ ;; 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 ()
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
- (const 2) (lexical #t #t set 0) (void) (call return 1)
+ (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
+ (void) (call return 1)
(unbind)))
(assert-tree-il->glil
- (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
+ (let (x) (y) ((const 1))
+ (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
+ (lexical x y)))
(program 0 0 1 ()
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
- (const 2) (lexical #t #t set 0) (const #f) (call return 1)
+ (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
+ (lexical #t #t ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil
(let (x) (y) ((const 1))
- (apply (primitive null?) (set! (lexical x y) (const 2))))
+ (apply (primitive null?)
+ (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
(program 0 0 1 ()
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
- (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
+ (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
+ (call null? 1) (call return 1)
(unbind))))
(with-test-prefix "module refs"
@@ -413,20 +421,19 @@
(unbind))
(eq? l1 l2))
+ ;; second bound var is unreferenced
(assert-tree-il->glil/pmatch
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
(let (a) (b) ((const 2))
(lexical x y))))
- (program 0 0 2 ()
+ (program 0 0 1 ()
(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)
(label ,l2)
- (const 2) (bind (a #f 1)) (lexical #t #f set 1)
(lexical #t #f ref 0) (call return 1)
- (unbind)
(unbind))
(eq? l1 l2)))
@@ -437,7 +444,7 @@
(assert-tree-il->glil/pmatch
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
(program 0 0 0 ()
- (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
+ (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)
(void) (call return 1))
@@ -446,7 +453,7 @@
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
(program 0 0 0 ()
(toplevel ref foo)
- (toplevel ref bar) (toplevel ref baz) (call apply 2)
+ (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
(call goto/args 1))))
(with-test-prefix "call/cc"
@@ -456,7 +463,7 @@
(assert-tree-il->glil/pmatch
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
(program 0 0 0 ()
- (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
+ (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)
(void) (call return 1))
diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test
index 61dbeb89e..5d584e86e 100644
--- a/test-suite/tests/unif.test
+++ b/test-suite/tests/unif.test
@@ -1,6 +1,6 @@
;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
;;;;
-;;;; Copyright 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright 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
@@ -17,7 +17,7 @@
;;;; 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 (test-suite lib))
;;;
;;; array?
diff --git a/testsuite/run-vm-tests.scm b/testsuite/run-vm-tests.scm
index f7eba40bb..39e7bf117 100644
--- a/testsuite/run-vm-tests.scm
+++ b/testsuite/run-vm-tests.scm
@@ -72,8 +72,7 @@ equal in the sense of @var{equal?}."
(if (catch #t
(lambda ()
(equal? (compile/run-test-from-file file)
- (eval (fetch-sexp-from-file file)
- (interaction-environment))))
+ (primitive-eval (fetch-sexp-from-file file))))
(lambda (key . args)
(format #t "[~a/~a] " key args)
#f))