[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. 938d46a35d39ec5d7b5fa
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. 938d46a35d39ec5d7b5fa858a8783136ce24d10d |
|
Date: |
Tue, 02 Jun 2009 09:14:13 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=938d46a35d39ec5d7b5fa858a8783136ce24d10d
The branch, master has been updated
via 938d46a35d39ec5d7b5fa858a8783136ce24d10d (commit)
via 1ee2c72eafaae5f91f4c899bc4b4853af5c16f28 (commit)
via 24d56127bb0f07bcb477e2c73ccc3cac0c51ee73 (commit)
via e3c5df539640a36eb1493f581087d54a4714f337 (commit)
via 6ed0c41a2d621c485a0b0e1b39535fd5a1e9bd20 (commit)
via 34f3d47df9311852ba7eab6f8d1c36535c3774dd (commit)
via 21346c4f5e30910e3950c40bc267bb4249973240 (commit)
via 4201062de5e4f2eb7b2207a3c09e02a12b9bda50 (commit)
via 560b9c256d9cd5f80dead6ddb0d747a21c6c003a (commit)
via 1351c2dba5ce54aeeae41cb2322ad39cd29510b0 (commit)
via b579617b2db0e83f620c5b856dcc320cea9d6d1f (commit)
via 442f3f20ddd33b43743ea181d95024c10622df52 (commit)
via d9a9e18205f4da1486a70dbd5690b8fdc593cb10 (commit)
via 9d07bb7276d1be078c5933645897694035ecdcfe (commit)
via 73643339527d27a09d62424428b67417ca627bf5 (commit)
via 81fd3152992c8ef62e1ec036f5a39443c8f8d0aa (commit)
via de784acd87b8d567fb6433d8f531a7f28b91d635 (commit)
via a755136ba8469fdccbcac956b4f5d8c6f4ec2a4e (commit)
via 0e7b72a8fefc27d67623b11659372b7ac37b7a58 (commit)
via b40d023067b54f1085f194c521c2d046fceb9444 (commit)
via 39a2eca2ce7461108ddc595cb74a6bf47c456bd8 (commit)
via 55ae815b62c5d4bf324351d64919bdb8d4070148 (commit)
via e0c90f9084914956d90db73b21ef2ab32d1a477a (commit)
via e6b94431794ad5cffedfbdbe949789d04ef97761 (commit)
via 7902c547130235438fa170d94c43e0c271adb71d (commit)
via 9ecac781bf3b33abca137c242ceaa7c49f604958 (commit)
via dc1eed52f71004bca74028d03ae35bbf569be709 (commit)
via 0260421208267eb202f9c9628cdaf39b531a5129 (commit)
via 40b36cfbbe4676f52bd4d6b45ae1642756642907 (commit)
via 2032f3d1db09aa63de4ec060081a5bf9053f0d3c (commit)
via 0f423f20aae6228431d3695e60ade937858110b8 (commit)
via 30a5e062d022aafdb72cea648f3a4de0e72feb6d (commit)
via a48358b38fed9486cebf7f8338dc05adc770fc0f (commit)
via d63927150aa22bb7e57125ed50e5ecbe11765fba (commit)
via 47c8983f08157865a3937722c06acbbb3cbd7621 (commit)
via 837b0ae0b5d530b0c254ebe331fb5ab1de3e7fe8 (commit)
via 3731192f30158c0c70d243ddeae87693fa37a0e4 (commit)
via f240aacb412172f9c228653674b13d41279bebc8 (commit)
via fc76c08d872f816a075de0a9096006966f00a666 (commit)
via 5d66005209f57878aea994c9109eb32bd9b9feab (commit)
via 5c006c3f5183cda8ddd57c470df03ba0cd7cb492 (commit)
via 13ff47408fcda1fb57df97102bc0fe7730f37a9e (commit)
via 1bcf79939201609e1cee667dd9bcd8c3c519385d (commit)
via e2e85d14065d0ec417570bf398dc19ab87ff366f (commit)
via 66818dbb710c83730310c15088f1784d61158f04 (commit)
via 5f380d71c3b1080d8f0e52610fa0b5efe09232c6 (commit)
via ca329120627a0905c1aac805a52a59439f6c5482 (commit)
via d0f452d16299e8dbf2258fd00fbb7303186e6bdc (commit)
via 5e647d08e95de4245bdd75e94929b29e095b52f2 (commit)
via 452e13f3112f38c67d8652d284c8b96e0851c272 (commit)
via f5851b8942b81ef1ed3eb9e153a4ae274260f176 (commit)
via 88f2f7a12718492d175efdb1230d30256f1c4041 (commit)
via 877f06c33829ac2a5ba263826454f880d5460ee8 (commit)
via 8bb0b3cc9d582c48ed6cb5d123168ffd27ac7cf8 (commit)
via 68623e8e7883077dbb26521fe6d9c185df3138ce (commit)
via 9806a548fe1a9cca0f82ef4f2f08fbcba5eccfaa (commit)
via ad9b8c451b82f74cf88c5a6207ed3ea72c86f93e (commit)
via c11f46afe113f50e34af33ad3055b3da66e4b71f (commit)
via 5af166bda2f1d89525add147a9e3d2d6867d03a5 (commit)
via e32a1792de84c20eaaae6ea7f33048b6eef2c9d8 (commit)
via a1a482e0e9518b5711bc2734aa014254f9207919 (commit)
via ce09ee19892d391f3b2ca13e0616d343929c2c14 (commit)
via dce042f1f74f8ef5ca5089beb50fd7496feae5da (commit)
via 112edbaea3e48e002261c72064d6602d661c3df4 (commit)
via 1eec95f8def91bcb6f9f22c21c6d27ec2a7175ac (commit)
via 2ce77f2d95271887b54d0c56d1e81d7f472ae1ae (commit)
via 696495f4d21fc8bc479b50588c08ea55e7c6e3a7 (commit)
via 547a602d1ef4d3622cf2d476ff311957b447eaba (commit)
via cf10678fe7014a67020c45ee02f2aabb44598adc (commit)
via 073bb617eb7e5f76269ca6dba0fe498baff6f058 (commit)
via cb28c08537790b49f7bc94f2f6b426497152bbe7 (commit)
via 9efc833d65adef11e76410fee7ea548143131417 (commit)
via b81d329e449420b6abaa2b689d7107b862111cbf (commit)
via 06656e06d454f16694d0b550fb339efb0c36123a (commit)
via 982a1c205d2ff1dc61a2ff56ba2e6491974f9303 (commit)
via 811d10f5a2297e2fe6a881d02c67c45bf4311a27 (commit)
via 1aeb082b8281eb12640d7a42c88a566418c64782 (commit)
via f27e9e11cd01eefa9eab3cfd277120ce73e3355a (commit)
via f4a644ee886903df43810f1a0e65ce2ef891999f (commit)
via 71f46dbd5ecf62809c2aa475b6f5742993ada0b9 (commit)
via 123f8abb2da5ed7b2d8ccd67b3bd3532aa9d257e (commit)
via 41af238146428f5841880f26d84b5dc9ddfad2c4 (commit)
via 6a952e0ee9093424cdc8f300406d09ce195ebf5c (commit)
via 4d24854111110b44a28a4d46242bac1285de387a (commit)
via 12eae603c76edc8affc0e8331df7f22a4d8a8b2c (commit)
via 3d5f3091e100550052abc698e980b3e86cc01b65 (commit)
via 5a0132b3375b35c69c6afb735acbaa8619237fb5 (commit)
via 5f1a2fb10f5eb97e302c50f5b62d6df28f73d97a (commit)
via bac0272216e89fa93bc935952befe0e7973625f7 (commit)
via 22225fc113e716ec20712825e71191fedf3eecd8 (commit)
via e4721dde312fb2e00963e826441edcc71ee840be (commit)
via 165a7596ee62a2871de8569e3d41ef7f7c925594 (commit)
via 00bbb89e9694faac612ecf2e234291df086ebd11 (commit)
via f176c584d0513f4dea82329011f81f114f3a8ec9 (commit)
via 39f30ea29df55eda3f92d0cf68f1f89282a1418e (commit)
via 97ce9dbf2158a08980189bcb3c3016ba30246829 (commit)
via b3501b8043d36a3215ec51e321a2aa3733ea54cc (commit)
via 2ce560b944c8af2047415612835fcd23fa3de473 (commit)
via 0ee32d0131b49ee0661669b7a0b595d0a6565de4 (commit)
via 9c35c5796cbffda57d76499048e8b8f82db943eb (commit)
via 34ad4f83ca4310e84226d6bd06feb03006c736cc (commit)
via 6e26b23c5d0df8a69a12aca7be4494a19cdf0600 (commit)
via d6ebfd72268878d64c583998ea9d57c0eb22996e (commit)
via a2716cbe1e9d2b43d1fb1a017cb8b1e97617da3c (commit)
via 384e92b3ae491e2f8495b0d188b384f138a8cc61 (commit)
via 7c72fe0bb5a6ef00c90f6988ce3178a45ed95f26 (commit)
via 01c161ca11b19d56ce994cba477a8fc4aeb8ac43 (commit)
via c5ad45c7b34346f0f7084477479e7367c30a67f6 (commit)
via 85e95b47108a84f0829cf17c5dde40f53814186e (commit)
via 64e5d08d3e7076b554f724efede860883f846b5f (commit)
via 131826039c62bdfd5932272b5d19d4b08cbe4e63 (commit)
via a26934a850fba4ee1caf5d44cdbbe95115c91be0 (commit)
via 757937c290ae64a7a75232793c659d0cca3dea10 (commit)
from 58df2e43937bb86fbf751f48db7bf13934d7c87e (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 938d46a35d39ec5d7b5fa858a8783136ce24d10d
Merge: 1ee2c72eafaae5f91f4c899bc4b4853af5c16f28
e3c5df539640a36eb1493f581087d54a4714f337
Author: Andy Wingo <address@hidden>
Date: Fri May 29 16:01:43 2009 +0200
Merge branch 'syncase-in-boot-9'
Conflicts:
module/Makefile.am
commit 1ee2c72eafaae5f91f4c899bc4b4853af5c16f28
Author: Ludovic Courtès <address@hidden>
Date: Wed May 27 18:18:07 2009 +0200
Import R6RS bytevectors and I/O ports from Guile-R6RS-Libs 0.2.
* README: Document dependency on GNU libunistring.
* benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add
`benchmark/bytevectors.bm'.
* configure.in: Make sure we have libunistring; update $LIBS.
* libguile.h: Include "bytevectors.h" and "r6rs-ports.h".
* libguile/Makefile.am (libguile_la_SOURCES): Add `bytevectors.c' and
`r6rs-ports.c'
(DOT_X_FILES): Add `bytevectors.x' and `r6rs-ports.x'.
(DOT_DOC_FILES): Add `bytevectors.doc' and `r6rs-ports.doc'.
(noinst_HEADERS): Add `ieee-754.h'.
(modinclude_HEADERS): Add `bytevectors.h' and `r6rs-ports.h'
* libguile/validate.h (SCM_VALIDATE_BYTEVECTOR): New macro.
* module/Makefile.am (SOURCES): Add $(RNRS_SOURCES).
(RNRS_SOURCES): New variable.
* test-suite/Makefile.am (SCM_TESTS): Add `bytevectors.test' and
`r6rs-ports.test'.
commit 24d56127bb0f07bcb477e2c73ccc3cac0c51ee73
Author: Ludovic Courtès <address@hidden>
Date: Wed May 27 16:50:40 2009 +0200
Use GNU libunistring and Gnulib modules needed by R6RS bytevectors and
ports.
* m4/gnulib-cache.m4 (gl_MODULES): Add `byteswap', `iconv_open-utf',
`libunistring', `striconveh', and `string'.
commit e3c5df539640a36eb1493f581087d54a4714f337
Author: Andy Wingo <address@hidden>
Date: Thu May 28 15:01:30 2009 +0200
add tests for #' etc
* test-suite/tests/reader.test ("#'"): Add tests for the hash-syntax
reader macros.
commit 6ed0c41a2d621c485a0b0e1b39535fd5a1e9bd20
Author: Andy Wingo <address@hidden>
Date: Thu May 28 14:59:47 2009 +0200
add reader tests for #;
* test-suite/tests/reader.test ("#;"): Add reader tests for #;.
commit 34f3d47df9311852ba7eab6f8d1c36535c3774dd
Author: Andy Wingo <address@hidden>
Date: Thu May 28 14:49:33 2009 +0200
add reader support for #; #` #' #, and #,@. fix bug in compile-and-load.
* libguile/read.c (flush_ws, scm_read_commented_expression)
(scm_read_sharp): Add support for commenting out expressions with #;.
(scm_read_syntax, scm_read_sharp): Add support for #', #`, #, and #,@.
* module/ice-9/boot-9.scm: Remove #' read-hash extension, which actually
didn't do anything at all. It's been there since 1997, but no Guile
code I've ever seen uses it, and it conflicts with #'x => (syntax x)
from modern Scheme.
* module/system/base/compile.scm (compile-and-load): Whoops, fix a number
of bugs here.
commit 21346c4f5e30910e3950c40bc267bb4249973240
Author: Neil Jerram <address@hidden>
Date: Wed May 20 21:55:35 2009 +0100
Remove possible deadlock in scm_join_thread_timed
* libguile/threads.c (scm_join_thread_timed): Recheck t->exited before
looping round to call block_self again, in case thread t has now
exited.
* test-suite/tests/threads.test ("don't hang when joined thread
terminates in SCM_TICK"): New test.
commit 4201062de5e4f2eb7b2207a3c09e02a12b9bda50
Author: Neil Jerram <address@hidden>
Date: Sat May 23 17:55:58 2009 +0100
Fix wait-condition-variable so that it doesn't leave asyncs blocked
* libguile/threads.c (fat_mutex_unlock): Unblock asyncs when breaking
out of loop.
* test-suite/tests/threads.test (asyncs-still-working?): New function,
to test if asyncs are working (i.e. unblocked). Use this throughout
threads.test, in particular before and after the "timed locking
succeeds if mutex unlocked within timeout" test.
commit 560b9c256d9cd5f80dead6ddb0d747a21c6c003a
Author: Andy Wingo <address@hidden>
Date: Tue May 26 22:23:44 2009 +0200
adjust VM copyright notices to LGPL, use SCM_INTERNAL/API properly
* libguile/frames.c:
* libguile/frames.h:
* libguile/instructions.c:
* libguile/instructions.h:
* libguile/objcodes.c:
* libguile/objcodes.h:
* libguile/programs.c:
* libguile/programs.h:
* libguile/vm-bootstrap.h:
* libguile/vm-engine.c:
* libguile/vm-engine.h:
* libguile/vm-expand.h:
* libguile/vm-i-scheme.c:
* libguile/vm.c:
* libguile/vm.h: Update to use SCM_API and SCM_INTERNAL correctly. Adjust
copyright to be the same as the copyright of Guile itself, which should
be fine given that the FSF holds the whole thing.
commit 1351c2dba5ce54aeeae41cb2322ad39cd29510b0
Author: Andy Wingo <address@hidden>
Date: Tue May 26 21:47:45 2009 +0200
fix backtraces with compiled boot-9
* module/ice-9/boot-9.scm (default-pre-unwind-handler): Since we were
tail-called by pre-unwind-handler-dispatch, we can't use
pre-unwind-handler-dispatch as a narrowing argument. Instead just
narrow by one frame.
(pre-unwind-handler-dispatch): Deprecate.
(error-catching-loop): Remove crack comment and code, and just use
default-pre-unwind-handler as our pre-unwind handler.
* module/ice-9/stack-catch.scm (stack-catch):
* module/system/repl/repl.scm (call-with-backtrace): Use
default-pre-unwind-handler directly.
commit b579617b2db0e83f620c5b856dcc320cea9d6d1f
Author: Andy Wingo <address@hidden>
Date: Tue May 26 18:06:21 2009 +0200
gnulib-tool --import environ; rely on gnulib for environ definitions
* libguile/posix.c:
* libguile/stime.c: Remove environ definition, gnulib provides it now.
commit 442f3f20ddd33b43743ea181d95024c10622df52
Author: Andy Wingo <address@hidden>
Date: Tue May 26 17:39:58 2009 +0200
symbols are now hidden unless explicitly exported by SCM_API
* libguile/__scm.h (SCM_API, SCM_INTERNAL): Take the reverse strategy:
symbols will
be hidden by default, and only exported with SCM_API. In addition to
working
on Mac OS, it has the several nice efficiency benefits on Linux, and
unifies
codepaths with Win32.
* libguile/Makefile.am: Define BUILDING_LIBGUILE when building Guile.
commit d9a9e18205f4da1486a70dbd5690b8fdc593cb10
Author: Andy Wingo <address@hidden>
Date: Tue May 26 17:45:48 2009 +0200
gnulib-tool --import lib-symbol-visibility
commit 9d07bb7276d1be078c5933645897694035ecdcfe
Author: Andy Wingo <address@hidden>
Date: Tue May 26 16:03:37 2009 +0200
distcheck fix, fix (ice-9 time)
* lang/Makefile.am (elisp_sources): Add elisp/expand.scm.
* module/ice-9/time.scm (time): Fix for new macro expander. Ew.
commit 73643339527d27a09d62424428b67417ca627bf5
Author: Andy Wingo <address@hidden>
Date: Mon May 25 22:45:42 2009 +0200
update docs -- sections on assembly and objcode
* doc/ref/api-procedures.texi:
* doc/ref/compiler.texi:
* doc/ref/vm.texi: Update the docs some more.
commit 81fd3152992c8ef62e1ec036f5a39443c8f8d0aa
Author: Andy Wingo <address@hidden>
Date: Sun May 24 13:09:01 2009 +0200
update docs, clean up VM vestiges, macro docs, fix (/ a b c)
* doc/ref/api-procedures.texi (Compiled Procedures): Fix for API changes.
* doc/ref/compiler.texi (Compiling to the Virtual Machine): Replace GHIL
docs with Tree-IL docs. Update the bits about the Scheme compiler to
talk about Tree-IL and the expander instead of GHIL. Remove
<glil-argument>. Add placeholder sections for assembly and bytecode.
* doc/ref/vm.texi: Update examples with what currently happens. Reword
some things. Fix a couple errors.
* libguile/vm-i-system.c (externals): Remove this instruction, it's not
used.
* module/ice-9/documentation.scm (object-documentation): If the object is
a macro, try to return documentation on the macro transformer.
* module/language/assembly/disassemble.scm (disassemble-load-program):
Fix problem in which we skipped the first element of the object vector,
because of changes to procedure layouts a few months ago.
* module/language/scheme/spec.scm (read-file): Remove read-file
definition.
* module/language/tree-il.scm: Reorder exports. Remove <lexical>, it was
a compat shim to something that was never released. Fix `location'.
* module/language/tree-il/primitives.scm (/): Fix expander for more than
two args to /.
* module/system/base/compile.scm (read-file-in): Remove unused
definition.
* module/system/base/language.scm (system): Remove language-read-file.
* module/language/ecmascript/spec.scm (ecmascript): Remove read-file
definition.
commit de784acd87b8d567fb6433d8f531a7f28b91d635
Author: Ludovic Courtès <address@hidden>
Date: Fri May 22 23:44:43 2009 +0200
Rewrite SRFI-35 macros using `syntax-rules'.
* module/srfi/srfi-35.scm: Use `(ice-9 syncase)'.
(define-condition-type, condition): Rewritten using `syntax-rules'.
(compound-condition, condition-instantiation): New helper internal
macros. Thanks to Andy Wingo for his help!
commit a755136ba8469fdccbcac956b4f5d8c6f4ec2a4e
Author: Andy Wingo <address@hidden>
Date: Fri May 22 21:14:48 2009 +0200
fix (oop goops) compilation for (language tree-il primitives)
* module/oop/goops.scm (compile): Whoop-dee, fix up (oop goops) for
(language tree-il primitives) change.
commit 0e7b72a8fefc27d67623b11659372b7ac37b7a58
Author: Andy Wingo <address@hidden>
Date: Fri May 22 21:12:42 2009 +0200
source location tracking in psyntax, booya!
* module/ice-9/psyntax.scm (source-annotation): Return #f if
source-properties returns null.
(source-wrap): Rework a bit.
(syntax-type): Don't throw away source info for wrapped expressions.
Can has source location info, fools!
(chi-body): Correctly propagate source info for body subforms.
(syntax): Remove special case for map, it doesn't apply (ahem) for
Guile.
* module/ice-9/psyntax-pp.scm: Regenerate.
commit b40d023067b54f1085f194c521c2d046fceb9444
Author: Andy Wingo <address@hidden>
Date: Fri May 22 19:48:14 2009 +0200
remove annotations in psyntax in favor of guile's source properties
* module/ice-9/psyntax.scm: Remove references to annotation objects,
we're just going to try and use Guile's source properties now. It works
until `syntax' reconstructs output, at which point it seems we lose it.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 39a2eca2ce7461108ddc595cb74a6bf47c456bd8
Author: Andy Wingo <address@hidden>
Date: Fri May 22 19:26:58 2009 +0200
fix problem naming internal definitions
* module/ice-9/psyntax.scm (chi-body): Fix a problem introduced in
dc1eed52f71, that internal syntax definitions were included in the id
lis along with value definitions. Only showed up on a second bootstrap.
Psyntax, how I love thee.
* module/ice-9/psyntax-pp.scm
commit 55ae815b62c5d4bf324351d64919bdb8d4070148
Author: Andy Wingo <address@hidden>
Date: Fri May 22 16:07:41 2009 +0200
move things to (language tree-il primitives)
* module/language/tree-il/optimize.scm:
* module/language/tree-il/primitives.scm: Move primitive-related things
to primitive.scm from inline.scm and optimize.scm.
* module/Makefile.am: Update for inventory changes.
commit e0c90f9084914956d90db73b21ef2ab32d1a477a
Author: Andy Wingo <address@hidden>
Date: Fri May 22 13:00:23 2009 +0200
fix tree-il test to work if source info happens to be present
* module/language/tree-il/compile-glil.scm (flatten-lambda): Fix source
emission.
* test-suite/tests/tree-il.test (strip-source): Strip source info on
tree-il before compiling, so we don't get extraneous source info in the
glil. Make check passes!
commit e6b94431794ad5cffedfbdbe949789d04ef97761
Author: Andy Wingo <address@hidden>
Date: Fri May 22 12:48:45 2009 +0200
fix bad call to make-glil-src
* module/language/tree-il/compile-glil.scm (flatten-lambda): Fix bad call
to make-glil-src, unfortunately not hit during production because
psyntax doesn't yet understand source locations.
commit 7902c547130235438fa170d94c43e0c271adb71d
Author: Andy Wingo <address@hidden>
Date: Fri May 22 12:45:49 2009 +0200
fix expansion of (ice-9 threads)
* module/ice-9/threads.scm: Move syntax definitions before the procedures
that use them, and rewrite as hygienic macros since they are so much
nicer that way. Fixes the thread tests.
commit 9ecac781bf3b33abca137c242ceaa7c49f604958
Author: Andy Wingo <address@hidden>
Date: Fri May 22 12:22:39 2009 +0200
syntax.test is passing, yay
* test-suite/tests/syntax.test ("top-level define"): Remove the test for
currying, as we don't do that any more by default. It should be easy
for the user to add in if she wants it, though.
("do"): Remove unmemoization tests, as sc-expand fully expands `do'.
("while"): Remove while tests in empty environments. They have been
throwing 'unresolved, and the problem they seek to test is fully
handled by hygiene anyway.
And otherwise tweak expected exception strings, and everything passes!
commit dc1eed52f71004bca74028d03ae35bbf569be709
Author: Andy Wingo <address@hidden>
Date: Fri May 22 12:08:50 2009 +0200
residualize names into procedures. re-implement srfi-61. module naming foo.
* module/ice-9/boot-9.scm (cond): Implement srfi-61; most of the code is
from the SRFI itself. Yuk.
(%print-module, make-modules-in, %app, (%app modules))
(module-name): Syncase needs to get at the names of modules, even at
anonymous modules. So lazily assign gensyms as module names. Name %app
as (%app), but since (%app modules) is at the top of the module
hierarchy, name it ().
* module/ice-9/psyntax.scm: When building tree-il, try to name lambdas in
definitions and in lets.
(let, letrec): Give more specific errors in a couple of cases.
* module/ice-9/psyntax-pp.scm: Regenerated.
* test-suite/tests/syntax.test: More work. Many exceptions have different
messages than they used to, many more generic; we can roll this back to
be faithful to the original strings, but it doesn't seem necessary to
me.
commit 0260421208267eb202f9c9628cdaf39b531a5129
Author: Andy Wingo <address@hidden>
Date: Thu May 21 22:43:07 2009 +0200
some work on syntax.test
* module/language/tree-il.scm (tree-il->scheme):
* module/ice-9/psyntax.scm (build-conditional): Attempt to not generate
(if #f #f) as the second arm of an if, but it doesn't seem to be
successful.
* module/ice-9/psyntax-pp.scm (syntax-rules): Regenerate.
* test-suite/tests/syntax.test (exception:unexpected-syntax): Change
capitalization.
("unquote-splicing"): Update test.
("begin"): Add in second arms on these ifs, to avoid the strange though
harmless expansion of `if'.
(matches?): New helper macro.
("lambda"): Match on lexically bound symbols, as they will be
alpha-renamed.
commit 40b36cfbbe4676f52bd4d6b45ae1642756642907
Author: Andy Wingo <address@hidden>
Date: Thu May 21 22:11:48 2009 +0200
catch syntax errors in unquote and unquote-splicing
* module/ice-9/psyntax.scm (quasiquote): Catch syntax errors in unquote
and unquote-splicing.
* module/ice-9/psytax-pp.scm: Regenerated.
commit 2032f3d1db09aa63de4ec060081a5bf9053f0d3c
Author: Andy Wingo <address@hidden>
Date: Thu May 21 21:39:37 2009 +0200
fix multiple values returning from srfi-18's `with-exception-handler'
* module/srfi/srfi-18.scm (with-exception-handler): Hah! Fixed a
scurrilous bug in which we assumed that the thunk returned one or more
values. Hah.
commit 0f423f20aae6228431d3695e60ade937858110b8
Author: Andy Wingo <address@hidden>
Date: Thu May 21 21:13:24 2009 +0200
fix apply and call/cc in drop contexts
* module/language/tree-il/compile-glil.scm (flatten): Actually apply only
needs one arg after the proc. And shit, call/cc and apply in drop
contexts also need to be able to return arbitrary numbers of values;
work it by trampolining through their applicative (non-@) definitions.
Also, simplify the single-valued drop case to avoid the
truncate-values.
* module/language/tree-il/inline.scm (call/cc):
* module/language/tree-il/optimize.scm (*interesting-primitive-names*):
Define call/cc as "interesting". Perhaps we should be hashing on value
and not on variable.
* test-suite/tests/tree-il.test ("application"): Fix up test for new,
sleeker output. (Actually the GLIL is more verbose, but the assembly is
better.)
("apply", "call/cc"): Add some more tests.
commit 30a5e062d022aafdb72cea648f3a4de0e72feb6d
Author: Andy Wingo <address@hidden>
Date: Thu May 21 17:22:58 2009 +0200
procedures in "drop" contexts can return unspecified values
* module/language/tree-il/compile-glil.scm (flatten): For applications in
"drop" context, allow the procedure to return unspecified values
(including 0 values).
* test-suite/tests/tree-il.test ("application"): Adapt test.
* module/srfi/srfi-18.scm (wrap): Clarify.
* test-suite/tests/srfi-18.test: Fix so that the expression importing
srfi-18 is expanded before the tests. However the tests are still
failing, something about 0-valued returns...
commit a48358b38fed9486cebf7f8338dc05adc770fc0f
Author: Andy Wingo <address@hidden>
Date: Thu May 21 16:04:14 2009 +0200
fix srfi-17.test
* test-suite/tests/srfi-17.test (exception:bad-quote): Change the
expected exception for (set! (quote foo) ...) errors.
commit d63927150aa22bb7e57125ed50e5ecbe11765fba
Author: Andy Wingo <address@hidden>
Date: Thu May 21 15:34:29 2009 +0200
just parse method arguments once.
* module/oop/goops.scm (method): Tweak to just run through the arguments
once. Thanks to Eli Barzilay for the tip.
commit 47c8983f08157865a3937722c06acbbb3cbd7621
Author: Andy Wingo <address@hidden>
Date: Thu May 21 13:49:00 2009 +0200
rewrite `method' as a hygienic macro to re-allow lexical specializers
* module/oop/goops.scm (method): Reimplement as a hygienic macro. This
seriously took me like 6 hours to figure out. Allows for lexical
specializers: (let ((<x> ...)) (define-method (foo (arg <x>)) ...)).
* module/oop/goops/compile.scm (next-method?, compile-make-procedure):
Remove these, as `method' does it all now, hygienically.
commit 837b0ae0b5d530b0c254ebe331fb5ab1de3e7fe8
Author: Ludovic Courtès <address@hidden>
Date: Thu May 21 01:24:01 2009 +0200
Make use of Gnulib's `flock' module.
* libguile/posix.c: Always use <sys/file.h>, which is provided by
Gnulib.
(flock)[__MINGW32__]: Remove.
(scm_flock): Compile unconditionally. Always use Gnulib's flock(2).
commit 3731192f30158c0c70d243ddeae87693fa37a0e4
Author: Ludovic Courtès <address@hidden>
Date: Thu May 21 01:17:00 2009 +0200
Make use of Gnulib's `putenv' module.
* libguile/posix.c: Include <stdlib.h> since the putenv(3) declaration
is there (POSIX and Gnulib).
(scm_putenv): Rely on Gnulib's `putenv' module.
commit f240aacb412172f9c228653674b13d41279bebc8
Author: Ludovic Courtès <address@hidden>
Date: Thu May 21 01:00:41 2009 +0200
Add Gnulib portability modules; update Gnulib files.
* m4/gnulib-cache.m4 (gl_MODULES): Add `flock' (provides flock(2)
declaration and implementation), `fpieee' (fixes floating point
behavior on Alpha and SH), `stdlib' (provides an unsetenv(3)
declaration, among others), `putenv' (provides a putenv(3) declaration
and implementation with the semantics we need).
commit fc76c08d872f816a075de0a9096006966f00a666
Author: Ludovic Courtès <address@hidden>
Date: Tue May 12 00:12:18 2009 +0200
Update `NEWS'.
commit 5d66005209f57878aea994c9109eb32bd9b9feab
Author: Michael Gran <address@hidden>
Date: Fri Apr 24 22:23:13 2009 -0700
Symbols longer than 128 chars can cause an exception. Also, the
terminating colon of long postfix keywords are not handled correctly.
* test-suite/tests/reader.test ("read-options"): Add test
for long postfix keywords.
* libguile/read.c (scm_read_mixed_case_symbol): Fix
exception on symbols are greater than 128 chars. Also,
colons are not stripped from long postfix keywords.
commit 5c006c3f5183cda8ddd57c470df03ba0cd7cb492
Author: Ludovic Courtès <address@hidden>
Date: Thu May 21 00:16:47 2009 +0200
Update `NEWS' wrt. `branch_release-1-8'.
commit 13ff47408fcda1fb57df97102bc0fe7730f37a9e
Author: Ludovic Courtès <address@hidden>
Date: Mon May 11 22:13:29 2009 +0200
Fix compilation of `test-round.c' on BSD.
* test-suite/standalone/test-round.c (HAVE_MACHINE_FPU_H): Include
<sys/types.h> when available. This fixes compilation on NetBSD.
Reported by Greg Toxel.
commit 1bcf79939201609e1cee667dd9bcd8c3c519385d
Author: Ludovic Courtès <address@hidden>
Date: Fri Apr 24 00:44:43 2009 +0200
Update `NEWS'.
commit e2e85d14065d0ec417570bf398dc19ab87ff366f
Author: Ludovic Courtès <address@hidden>
Date: Thu Apr 23 23:20:59 2009 +0200
Don't use raw divisions by zero in `test-conversion.c'.
* test-suite/standalone/test-conversion.c (ieee_init): New function.
(guile_Inf, guile_NaN): New variables.
(test_from_double, test_to_double): Use them. Divisions by zero made
`cc' on Tru64 5.1b ("Compaq C V6.5-011") bail out and led to a
floating point exception when compiled with GCC on the same platform.
(main): Call `ieee_init ()'.
commit 66818dbb710c83730310c15088f1784d61158f04
Author: Ludovic Courtès <address@hidden>
Date: Thu Apr 23 22:51:27 2009 +0200
Use <machine/fpu.h> instead of <fenv.h> when needed (e.g., Tru64 5.1b).
* configure.in: Look for <machine/fpu.h>.
* test-suite/standalone/test-round.c: Use <machine/fpu.h> if available.
commit 5f380d71c3b1080d8f0e52610fa0b5efe09232c6
Author: Ludovic Courtès <address@hidden>
Date: Thu Apr 23 22:24:32 2009 +0200
Work around lack of cuserid(3) declaration on Tru64 5.1b.
* configure.in: Check for a cuserid(3) declaration.
* libguile/posix.c [HAVE_CUSERID][!HAVE_DECL_CUSERID]: Provide a
declaration.
commit ca329120627a0905c1aac805a52a59439f6c5482
Author: Ludovic Courtès <address@hidden>
Date: Thu Apr 23 00:28:32 2009 +0200
Work around the lack of hstrerror(3) declaration on Tru64.
* configure.in: Look for the declaration of hstrerror(3).
* libguile/net_db.c: Add hstrerror(3) declaration if
`HAVE_DECL_HSTRERROR' is undefined.
commit d0f452d16299e8dbf2258fd00fbb7303186e6bdc
Author: Ludovic Courtès <address@hidden>
Date: Wed Apr 22 23:53:52 2009 +0200
Remove extraneous semicolons from `test-conversion.c'.
* test-suite/standalone/test-conversion.c: Remove extraneous semicolon
following `DEF[SU]TST' invocations since that made Compaq C
V6.5-011 (`cc' on Tru64 5.1b) bail out.
commit 5e647d08e95de4245bdd75e94929b29e095b52f2
Author: Ludovic Courtès <address@hidden>
Date: Tue Apr 21 22:37:45 2009 +0200
Fix compilation of `numbers.c' on Tru64.
* libguile/numbers.c (scm_c_make_polar): Don't use sincos(3) on non-GNU
platforms. Reported by Didier Godefroy <address@hidden>.
commit 452e13f3112f38c67d8652d284c8b96e0851c272
Author: Ludovic Courtès <address@hidden>
Date: Tue Apr 21 22:34:54 2009 +0200
Fix compilation of `gcc_os_dep.c' on Tru64.
* libguile/gc_os_dep.c [OSF1](_end): Specify the type.
(scm_get_stack_base): Suitably cast RESULT. Reported by Didier
Godefroy <address@hidden>.
commit f5851b8942b81ef1ed3eb9e153a4ae274260f176
Author: Ludovic Courtès <address@hidden>
Date: Tue Apr 21 22:27:38 2009 +0200
Update `NEWS' and `THANKS'.
commit 88f2f7a12718492d175efdb1230d30256f1c4041
Author: Neil Jerram <address@hidden>
Date: Sun Sep 7 16:29:05 2008 +0100
Avoid "no duplicate" popen tests leaving zombie processes
On the one hand we want the child process in these tests to exit. On
the other, we don't want it to exit before the parent Guile code has
tested the relevant condition (EOF in the first test, broken pipe in
the second) - because these conditions would obviously be true if the
child had already exited, and that's not what we're trying to test
here. We're trying to test getting EOF and broken pipe while the
child process is still alive.
* test-suite/tests/popen.test (open-input-pipe:no duplicate): Add
another pipe from parent to child, so that the child can finish by
reading from this. Then the parent controls the child lifetime by
writing to this pipe.
* test-suite/tests/popen.test (open-output-pipe:no duplicate): Add
another pipe from child to parent, and have the child finish by
endlessly writing into this. Then the parent controls the child
lifetime by closing its end of the pipe, causing a broken pipe in
the child.
commit 877f06c33829ac2a5ba263826454f880d5460ee8
Author: Neil Jerram <address@hidden>
Date: Wed May 20 18:50:52 2009 +0100
Fix `explicitely' typos, should be `explicitly'
commit 8bb0b3cc9d582c48ed6cb5d123168ffd27ac7cf8
Author: Andy Wingo <address@hidden>
Date: Wed May 20 18:11:23 2009 +0200
fix failing macro-as-parameter tests in eval.test
* module/ice-9/psyntax.scm (chi-lambda-clause): Strip the docstring
before passing it on to the continuation.
* module/ice-9/psyntax-pp.scm: Regenerated.
* test-suite/tests/eval.test (exception:failed-match): New exception, for
syntax-case failed matches.
("evaluator"): Fix macro-as-parameter tests. They pass now :)
commit 68623e8e7883077dbb26521fe6d9c185df3138ce
Author: Andy Wingo <address@hidden>
Date: Wed May 20 17:41:21 2009 +0200
remove compile-time-environment
* module/ice-9/boot-9.scm (guile-user): Move the `compile' autoload to
the guile-user module. Remove reference to compile-time-environment.
* module/language/scheme/compile-ghil.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/optimize.scm:
* module/system/base/compile.scm:
* test-suite/tests/compiler.test: Remove definition of and references to
compile-time-environment. While I do think that recompilation based on
a lexical environment can be useful, I think it needs to be implemented
differently. So for now we've lost nothing if we take it away, as it
doesn't work with syncase anyway.
commit 9806a548fe1a9cca0f82ef4f2f08fbcba5eccfaa
Author: Andy Wingo <address@hidden>
Date: Wed May 20 17:28:59 2009 +0200
Fix a bug in the (ice-9 match) test
* testsuite/t-match.scm (matches?): Fix match invocation. As far as I can
tell, although (ice-9 match) does advertise a => form of clauses, it
requires that the end of the => be a symbol. For some reason this
works in the interpreter:
((lambda () (begin => #t)))
It's part of the expansion of matches?. It also worked in the old
compiler. Thinking that maybe toplevel references could cause side
effects, I made the new compiler actually ref =>, which brought this to
light.
commit ad9b8c451b82f74cf88c5a6207ed3ea72c86f93e
Author: Andy Wingo <address@hidden>
Date: Wed May 20 13:59:42 2009 +0200
fix @slot-ref / @slot-set! compilation
* module/language/tree-il/compile-glil.scm: Add primcall compilers for
@slot-ref and @slot-set.
* module/language/tree-il/optimize.scm (add-interesting-primitive!): New
export. Creates an association between a variable in the current module
and a primitive name.
* module/oop/goops.scm: Rework compiler hooks to work with tree-il and
not ghil.
commit c11f46afe113f50e34af33ad3055b3da66e4b71f
Author: Andy Wingo <address@hidden>
Date: Wed May 20 13:33:44 2009 +0200
compile `list' and `vector' to their associated opcodes
* module/language/glil/compile-assembly.scm (glil->assembly): Check the
length when emitting calls to variable-argument stack instructions.
Allow two-byte lengths -- allows e.g. calls to `list' with more than
256 arguments.
* module/language/tree-il/compile-glil.scm: Add primcall associations for
`list' and `vector', with any number of arguments. Necessary because
syncase's quasiquote expansions will produce calls to `list' with many
arguments.
* module/language/tree-il/optimize.scm (*interesting-primitive-names*):
Add `list' and `vector' to the set of primitives to resolve.
commit 5af166bda2f1d89525add147a9e3d2d6867d03a5
Author: Andy Wingo <address@hidden>
Date: Wed May 20 12:46:23 2009 +0200
don't allocate too many locals for expansions of `or'
* module/language/tree-il/analyze.scm (analyze-lexicals): Add in a hack
to avoid allocating more locals than necessary for expansions of `or'.
Documented in the source.
* test-suite/tests/tree-il.test: Add a test case.
commit e32a1792de84c20eaaae6ea7f33048b6eef2c9d8
Author: Andy Wingo <address@hidden>
Date: Wed May 20 11:59:41 2009 +0200
a few fixups
* module/ice-9/psyntax.scm (chi-install-global, syntax-case): Fix a
couple of cases in which bare datums were passed to output
constructors.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/scheme/spec.scm (scheme): Clean up the #:compilers
list.
* module/language/tree-il/compile-glil.scm (flatten): Fix call to
`length' in call/cc compiler.
commit a1a482e0e9518b5711bc2734aa014254f9207919
Author: Andy Wingo <address@hidden>
Date: Wed May 20 11:15:22 2009 +0200
and, or, cond etc use syntax-rules, compile scheme through tree-il
* libguile/vm-i-system.c:
* libguile/vm-engine.h (ASSERT_BOUND): New assertion, that a value is
bound. Used by local-ref and external-ref in paranoid mode.
* module/ice-9/boot-9.scm (and, or, cond, case, do): Since we are
switching to use psyntax as the first pass of the compiler, and perhaps
soon of the interpreter too, we need to make sure it expands out all
forms to primitive expressions. So define expanders for these derived
syntax forms, as in the R5RS report.
* module/ice-9/psyntax-pp.scm: Regenerate, with core forms fully
expanded.
* module/ice-9/psyntax.scm (build-void): New constructor, for making
undefined values.
(build-primref): Add in a hack so that primitive refs in the boot
module expand out to toplevel refs, not module refs.
(chi-void): Use build-void.
(if): Define an expander for if that calls build-conditional.
* module/language/scheme/compile-tree-il.scm (compile-tree-il): Use let*
so as not to depend on binding order for the result of
(current-module).
* module/language/scheme/spec.scm (scheme): Switch over to tree-il as the
primary intermediate language. Not yet fully tested, but at least it
can compile psyntax-pp.scm.
* module/language/tree-il/analyze.scm (analyze-lexicals): Arguments don't
count towards a function's nlocs.
* module/language/tree-il/compile-glil.scm (*comp-module*, compile-glil):
Define a "compilation module" fluid.
(flatten-lambda): Fix a call to make-glil-argument. Fix bug in
heapifying arguments.
(flatten): Fix number of arguments passed to apply instruction. Add a
special case for `(values ...)'. If inlining primitive-refs fails,
try expanding into toplevel-refs if the comp-module's variable is the
same as the root variable.
* module/language/tree-il/optimize.scm (resolve-primitives!): Add missing
src variable for <module-ref>.
* test-suite/tests/tree-il.test ("lambda"): Fix nlocs counts. Add a
closure test case.
commit ce09ee19892d391f3b2ca13e0616d343929c2c14
Author: Andy Wingo <address@hidden>
Date: Mon May 18 23:45:35 2009 +0200
add tree-il->glil compilation test suite
* module/language/tree-il.scm (parse-tree-il): Fix a number of bugs.
(unparse-tree-il): Apply takes rest args now.
* module/language/tree-il/analyze.scm (analyze-lexicals)
(analyze-lexicals): Heap vars shouldn't increment the number of locals.
* module/language/tree-il/optimize.scm (resolve-primitives!): Don't
resolve public refs to primitives, not at the moment anyway.
* test-suite/Makefile.am (SCM_TESTS): Add tree-il test.
* test-suite/lib.scm (pass-if, expect-fail, pass-if-exception)
(expect-fail-exception): Rewrite as syntax-rules macros. In a very
amusing turn of events, it turns out that bindings introduced by
hygienic macros are not visible inside expansions produced by
defmacros. This seems to be expected, so go ahead and work around the
problem.
* test-suite/tests/srfi-31.test ("rec special form"): Expand in eval.
* test-suite/tests/syntax.test ("begin"): Do some more expanding in eval,
though all is not yet well.
* test-suite/tests/tree-il.test: New test suite, for tree-il->glil
compilation.
commit dce042f1f74f8ef5ca5089beb50fd7496feae5da
Author: Andy Wingo <address@hidden>
Date: Mon May 18 01:08:34 2009 +0200
special cases for more types of known applications
* module/language/tree-il/compile-glil.scm (flatten): Handle a number of
interesting applications, and fix a bug for calls in `drop' contexts.
* module/language/tree-il/inline.scm: Define expanders for apply,
call-with-values, call-with-current-continuation, and values.
commit 112edbaea3e48e002261c72064d6602d661c3df4
Author: Andy Wingo <address@hidden>
Date: Sun May 17 23:24:26 2009 +0200
inline calls to some primitives
* module/system/base/pmatch.scm: Wrap consequents in (let () ) instead of
(begin ) so that they can have local definitions.
* module/language/tree-il/compile-glil.scm: Inline some calls to
primitives.
commit 1eec95f8def91bcb6f9f22c21c6d27ec2a7175ac
Author: Andy Wingo <address@hidden>
Date: Sun May 17 18:04:36 2009 +0200
define `delay' in terms of make-promise
* module/ice-9/boot-9.scm (delay): Define `delay' in terms of
make-promise.
* module/ice-9/psyntax-pp.scm (compile): Regenerated with a fully
compiled Guile, so that the gensym numbers are the same.
* module/language/tree-il/compile-glil.scm: Add some notes about what
needs doing to catch up to the old compiler.
commit 2ce77f2d95271887b54d0c56d1e81d7f472ae1ae
Author: Andy Wingo <address@hidden>
Date: Sun May 17 16:46:46 2009 +0200
and now, we residualize the original names into the metadata. yay!
* module/language/tree-il/compile-glil.scm (vars->bind-list)
(emit-bindings, flatten-lambda, flatten): Write the original names into
<glil-bind> structures. Yaaaaay!
commit 696495f4d21fc8bc479b50588c08ea55e7c6e3a7
Author: Andy Wingo <address@hidden>
Date: Sun May 17 16:39:55 2009 +0200
actually pass original ids on to tree-il data types
* module/ice-9/psyntax.scm (build-lambda, build-let, build-named-let)
(build-letrec): Actually pass along the original ids to tree-il
constructors.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/tree-il.scm: Add fields in <lambda>, <let>, and
<letrec> for the original variable names.
* module/language/tree-il/compile-glil.scm (compile-glil): Adapt for new
make-lambda arg.
commit 547a602d1ef4d3622cf2d476ff311957b447eaba
Author: Andy Wingo <address@hidden>
Date: Sun May 17 16:27:18 2009 +0200
preserve original var names in lets and lambdas
* module/ice-9/psyntax.scm (build-letrec, build-let, build-lambda)
(build-named-let): Take extra args for the original names of the
gensyms. Not used yet. Callers adapted.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit cf10678fe7014a67020c45ee02f2aabb44598adc
Author: Andy Wingo <address@hidden>
Date: Fri May 15 23:44:14 2009 +0200
tree-il -> glil compiler works now, at least in initial tests
* module/language/tree-il/analyze.scm: Break analyzer out into its own
file.
* module/language/tree-il/compile-glil.scm: Port the GHIL->GLIL compiler
over to work on tree-il. Works, but still misses a number of important
optimizations.
* module/language/tree-il.scm: Add <void>. Not used quite yet.
* module/language/glil.scm: Remove <glil-argument>, as it is the same as
<glil-local> (minus an offset).
* module/language/glil/compile-assembly.scm:
* module/language/glil/decompile-assembly.scm:
* module/language/ghil/compile-glil.scm: Adapt for <glil-argument>
* removal.
* module/Makefile.am (TREE_IL_LANG_SOURCES): Reorder, and add
analyze.scm.
commit 073bb617eb7e5f76269ca6dba0fe498baff6f058
Author: Andy Wingo <address@hidden>
Date: Thu May 14 00:11:25 2009 +0200
add lexical analyzer and allocator
* module/language/tree-il/optimize.scm: Rework to just export the
optimize! procedure.
* module/language/tree-il/compile-glil.scm (analyze-lexicals): New
function, analyzes and allocates lexical variables. Almost ready to
compile now.
(codegen): Dedent.
commit cb28c08537790b49f7bc94f2f6b426497152bbe7
Author: Andy Wingo <address@hidden>
Date: Tue May 12 22:29:34 2009 +0200
add primitive expander for tree-il
* module/Makefile.am: Add inline.scm.
* module/language/tree-il.scm (pre-order!, post-order!): pre-order! is
new. post-order! existed but was not public. They do destructive tree
traversals of tree-il, and need more documentation. Also, add
predicates to tree-il's export list.
* module/language/tree-il/inline.scm: New file, which expands primitives
into more primitive primitives. In the future perhaps it will not be
necessary, as the general inlining infrastructure will handle these
cases, but for now it's useful.
* module/language/tree-il/optimize.scm: Move post-order! out to better
pastures.
commit 9efc833d65adef11e76410fee7ea548143131417
Author: Andy Wingo <address@hidden>
Date: Mon May 11 23:23:34 2009 +0200
add tree-il optimizer
* module/language/tree-il/optimize.scm: New module, for optimizations.
Currently all we have is resolving some toplevel refs to primitive
refs.
* module/Makefile.am: Add new module.
* module/language/tree-il.scm: Fix exports for accessors for `src'.
* module/language/tree-il/compile-glil.scm: Tweaks, things still aren't
working yet.
commit b81d329e449420b6abaa2b689d7107b862111cbf
Author: Andy Wingo <address@hidden>
Date: Fri May 8 12:56:18 2009 +0200
more work on tree-il compilation
* module/language/scheme/amatch.scm: Remove, this approach won't be used.
* module/Makefile.am: Adjust for additions and removals.
* module/language/scheme/compile-ghil.scm: Remove an vestigial debugging
statement.
* module/language/scheme/spec.scm:
* module/language/scheme/compile-tree-il.scm:
* module/language/scheme/decompile-tree-il.scm: Add tree-il compiler and
decompiler.
* module/language/tree-il/compile-glil.scm: Add some notes.
* module/language/tree-il/spec.scm: No need to wrap expressions in
lambdas -- GHIL needs somewhere to put its variables, we don't.
commit 06656e06d454f16694d0b550fb339efb0c36123a
Author: Andy Wingo <address@hidden>
Date: Thu May 7 17:44:51 2009 +0200
go ahead and regenerate psyntax-pp.scm
commit 982a1c205d2ff1dc61a2ff56ba2e6491974f9303
Author: Andy Wingo <address@hidden>
Date: Thu May 7 17:38:40 2009 +0200
remove (ice-9 expand-support)
* module/ice-9/Makefile.am:
* module/ice-9/expand-support.scm: Remove module, no longer used.
* module/ice-9/psyntax.scm: Fix a comment.
commit 811d10f5a2297e2fe6a881d02c67c45bf4311a27
Author: Andy Wingo <address@hidden>
Date: Thu May 7 13:45:03 2009 +0200
new language: tree-il. psyntax generates it when run in compile mode.
* module/Makefile.am: Add tree-il sources.
* module/ice-9/compile-psyntax.scm: Adjust for sc-expand producing
tree-il in compile mode.
* module/ice-9/psyntax.scm: Switch from expand-support to tree-il for
generating output in compile mode. Completely generate tree-il -- the
output wasn't Scheme before, but now it's completely not Scheme.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/scheme/compile-ghil.scm: Strip structures using
tree-il, not expand-support.
* module/language/tree-il.scm:
* module/language/tree-il/spec.scm
* module/language/tree-il/compile-glil.scm: New language. It will compile
to GLIL, though it doesn't yet.
commit 1aeb082b8281eb12640d7a42c88a566418c64782
Author: Andy Wingo <address@hidden>
Date: Thu May 7 11:02:10 2009 +0200
make expand-support structure constructors take a source argument
* module/ice-9/expand-support.scm (make-module-ref, make-lexical): Add
source arguments to these constructors.
* module/ice-9/psyntax.scm:
* module/ice-9/psyntax-pp.scm: Adapt to match, though we don't wire
everything up yet.
commit f27e9e11cd01eefa9eab3cfd277120ce73e3355a
Author: Andy Wingo <address@hidden>
Date: Thu May 7 10:27:53 2009 +0200
fix install-global construction of `define' forms
* module/ice-9/psyntax.scm (build-global-definition): Remove mod
argument, as it does not seem we could ever define something in another
module.
(chi-install-global): Build the define as a definition, not an
application. Doesn't matter now, but it will later.
(chi-top): Fix build-global-definition call.
* module/ice-9/psyntax.scm: Regenerated.
commit f4a644ee886903df43810f1a0e65ce2ef891999f
Author: Andy Wingo <address@hidden>
Date: Mon May 4 12:18:14 2009 +0200
when compiling, use make-lexical to residualize original var names
* module/ice-9/psyntax.scm (build-lexical-reference): Change to be a
function. Take an extra arg, the original name of the variable. If we
are compiling, make a #<lexical>, annotated with the original var name.
All callers changed.
(build-lexical-assignment): Also a function, taking also the original
var name, using build-lexical-reference to build its output.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 71f46dbd5ecf62809c2aa475b6f5742993ada0b9
Author: Andy Wingo <address@hidden>
Date: Mon May 4 11:57:36 2009 +0200
sc-expand in compile mode produces (ice-9 expand-support) structures
* module/ice-9/psyntax.scm (*mode*): New moving part, a fluid.
(sc-expand): Dynamically bind *mode* to the expansion mode.
(build-global-reference): Change to be a procedure instead of local
syntax. Import the logic about when to make a @ or @@ form to here,
from boot-9.scm. If we are compiling, build output using (ice-9
expand-support)'s make-module-ref, otherwise just making the familiar
s-expressions. (This will allow us to correctly expand in modules in
which @ or @@ are not bound, at least when we are compiling.)
(build-global-assignment): Use the result of build-global-reference. A
bit hacky, but hey.
(top-level-eval-hook, local-eval-hook): Strip expansion structures
before evalling.
* module/ice-9/boot-9.scm (make-module-ref): Remove, this logic is now
back in psyntax.scm.
* module/ice-9/compile-psyntax.scm (source): Since we expand in compile
mode, we need to strip expansion structures.
* module/ice-9/expand-support.scm (strip-expansion-structures): Remove
the logic about whether and how to strip @/@@ from here, as it's part
of psyntax now.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/scheme/compile-ghil.scm (compile-ghil): Strip expansion
structures -- for now. In the future, we might translate directly from
these structures into GHIL.
commit 123f8abb2da5ed7b2d8ccd67b3bd3532aa9d257e
Author: Andy Wingo <address@hidden>
Date: Mon May 4 10:47:31 2009 +0200
replace sc-expand with sc-expand3, removing binding for sc-expand3
* module/ice-9/boot-9.scm (sc-expand3):
* module/ice-9/psyntax.scm (sc-expand3): Replace sc-expand with
sc-expand3, as expand3 with one argument is the same as sc-expand.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/ice-9/compile-psyntax.scm:
* module/language/scheme/compile-ghil.scm: Change callers to sc-expand3
to use sc-expand.
commit 41af238146428f5841880f26d84b5dc9ddfad2c4
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 23:57:31 2009 +0200
remove (void) from boot-9 and psyntax
* module/ice-9/psyntax.scm: Tweak comments. Remove references to `void';
just produce (if #f #f) instead of (void).
* module/ice-9/psyntax-pp.scm: Regenerated, twice.
* module/ice-9/boot-9.scm (void): Remove this binding.
commit 6a952e0ee9093424cdc8f300406d09ce195ebf5c
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 23:39:09 2009 +0200
more cleanups to boot-9/psyntax
* module/ice-9/boot-9.scm: Comment some more things.
* module/ice-9/psyntax.scm: Remove error-hook -- callers should just use
syntax-violation. Change all callers.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 4d24854111110b44a28a4d46242bac1285de387a
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 23:12:12 2009 +0200
remove andmap from public API (we still have and-map)
* module/ice-9/boot-9.scm (and-map, or-map): Move these definitions up so
psyntax can use them.
(andmap): Remove, yay.
* module/ice-9/psyntax.scm: Remove notes about andmap, and just use
Guile's and-map -- except in cases that need the multiple list support,
in which case we have a private and-map*.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 12eae603c76edc8affc0e8331df7f22a4d8a8b2c
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 22:50:45 2009 +0200
cleanups to boot-9
* module/ice-9/boot-9.scm: Shuffle around some definitions.
(module-add!): Removed stub definition, no longer used.
(install-global-transformer): Removed, no longer used (yay!).
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/ice-9/psyntax.scm: Remove install-global-transformer.
commit 3d5f3091e100550052abc698e980b3e86cc01b65
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 21:19:23 2009 +0200
first-class macro representation (no bits on variables)
* libguile/macros.c (scm_macro_p): Update docs.
* module/ice-9/boot-9.scm (module-define!, module-ref): Define pre-boot
forms of these functions as well. I suspect module-add! can go soon.
(module-lookup-keyword, module-define-keyword!)
(module-undefine-keyword!) Remove these.
* module/ice-9/psyntax-pp.scm: Regenerate. Notice the difference?
* module/ice-9/psyntax.scm (put-global-definition-hook)
(get-global-definition-hook): Rework to expect first-class macros. Heh
heh.
(remove-global-definition-hook): Pleasantly, this hook can go away.
(chi-install-global): Terrorism to generate the right kind of output --
will clean up.
(chi-top): Unify definition handling for all kinds of values.
commit 5a0132b3375b35c69c6afb735acbaa8619237fb5
Author: Andy Wingo <address@hidden>
Date: Wed Apr 29 00:38:12 2009 +0200
a different tack for syncase macro representation
* libguile/macros.c (macro_print): Show syntax-case bindings, if present.
(macro_mark): Mark the extra two words if they're there.
(scm_make_syncase_macro, scm_make_extended_syncase_macro): OK! A new
take at the "how do we represent syncase macros in Guile" problem.
Whereas we need a disjoint type, but would like it to be compatible
with old predicates (e.g. `macro?'), and need to be able to extend
existing syntax definitions (e.g. `cond'), let's add a bit to macros to
indicate whether they have syncase macro bindings or not, and a fourth
macro type for native syncase macros.
(scm_macro_type): Return 'syntax-case for native syntax-case macros.
Note that other macro types may have syntax-case bindings.
(scm_macro_name): Return #f if the transformer is not a procedure.
(scm_syncase_macro_type, scm_syncase_macro_binding): New accessors for
the syncase macro bindings.
* libguile/macros.h: Add API for syncase macros.
* module/ice-9/boot-9.scm (module-define-keyword!): Adapt to use syncase
macros, though they are not yet used. Reorder other syncase API.
* module/ice-9/psyntax.scm (chi-expr): Fix syntax-violation invocation.
commit 5f1a2fb10f5eb97e302c50f5b62d6df28f73d97a
Author: Andy Wingo <address@hidden>
Date: Sun Apr 26 21:10:24 2009 +0200
syntax-dispatch -> $sc-dispatch
* module/ice-9/boot-9.scm:
* module/ice-9/psyntax-pp.scm:
* module/ice-9/psyntax.scm: Change syntax-dispatch to $sc-dispatch, as it
is in current psyntax. The idea is that this isn't really a public
variable, though it has to be, currently, so just obscure that fact
with an obscure name.
commit bac0272216e89fa93bc935952befe0e7973625f7
Author: Andy Wingo <address@hidden>
Date: Sun Apr 26 20:57:51 2009 +0200
build ecmascript stuff last
* module/Makefile.am: Wait to build ecmascript until the compiler has
bootstrapped.
commit 22225fc113e716ec20712825e71191fedf3eecd8
Author: Andy Wingo <address@hidden>
Date: Sun Apr 26 20:56:24 2009 +0200
syntax-object->datum => syntax->datum, likewise datum->syntax
* module/ice-9/boot-9.scm (datum->syntax, syntax->datum): Rename from
datum->syntax-object and syntax-object->datum, following r6rs. Change
all callers. Reorder some of the other exports from psyntax.
* module/ice-9/psyntax.scm: Change datum->syntax and syntax->datum
definitions and callers.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/oop/goops.scm (define-class-pre-definition): Update for changes.
commit e4721dde312fb2e00963e826441edcc71ee840be
Author: Andy Wingo <address@hidden>
Date: Sun Apr 26 20:36:58 2009 +0200
replace psyntax's syntax-error with r6rs' syntax-violation
* module/ice-9/boot-9.scm (syntax-violation): Well, as long as we have to
have a function for indicating syntax errors, let's let it be a
well-thought-out one -- syntax-violation from r6rs. No more
syntax-error.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/ice-9/psyntax.scm: Replace instances of syntax-error with
syntax-violation. Implement as a scm-error to 'syntax-error, with some
nice arguments.
commit 165a7596ee62a2871de8569e3d41ef7f7c925594
Author: Andy Wingo <address@hidden>
Date: Sun Apr 26 13:10:30 2009 +0200
add module-{define-keyword!,undefine-keyword!,lookup-keyword}
* libguile/modules.c (scm_module_local_variable): Allow this to be called
before modules are booted with #f as the module.
* module/ice-9/boot-9.scm (module-define-keyword!)
(module-lookup-keyword, module-undefine-keyword!): Well, if syncase
forces us to allow the keyword bindings to be partitioned from value
bindings, let's go ahead and do that in boot-9 instead of in
psyntax. A step on the way to removing `install-global-transformer'.
(sc-chi): Remove.
* module/ice-9/psyntax.scm (put-global-definition-hook):
(remove-global-definition-hook, get-global-definition-hook): Use our
new module-* functions.
(sc-chi): Remove, no longer needed.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 00bbb89e9694faac612ecf2e234291df086ebd11
Author: Andy Wingo <address@hidden>
Date: Sun Apr 26 11:48:29 2009 +0200
remove sc-macro definition
* module/ice-9/boot-9.scm (sc-macro): Remove sc-macro definition, yay.
commit f176c584d0513f4dea82329011f81f114f3a8ec9
Author: Andy Wingo <address@hidden>
Date: Sun Apr 26 11:35:23 2009 +0200
fix module-bound?, start compiling srfi-18.scm
* module/Makefile.am (SRFI_SOURCES): Let's finally start compiling
srfi-18.scm, what the hell.
* module/ice-9/boot-9.scm (module-bound?): module-bound? was returning
true if (not (variable-bound? (module-local-variable m v))), but
(variable-bound? (module-variable m v)). Fix to cut out on the first
variable it finds. This bug has been there for a while now.
commit 39f30ea29df55eda3f92d0cf68f1f89282a1418e
Author: Andy Wingo <address@hidden>
Date: Sat Apr 25 19:09:19 2009 +0200
Fix the elisp memoizer code for syncase-in-boot-9
* lang/elisp/interface.scm:
* lang/elisp/internals/lambda.scm:
* lang/elisp/primitives/syntax.scm:
* lang/elisp/transform.scm: Use (lang elisp expand) as the transformer,
because we really are intending this code for the memoizer and not the
compiler.
* lang/elisp/expand.scm: A null expander.
* lang/elisp/interface.scm (use-elisp-file, use-elisp-library):
* lang/elisp/transform.scm (scheme): Turn these defmacros into
procedure->memoizing-macro calls, given that without syncase we have no
defmacro either.
* lang/elisp/primitives/fns.scm (macroexpand): Comment out, as Scheme's
macro expander (temporarily on hiatus) won't work with elisp.
commit 97ce9dbf2158a08980189bcb3c3016ba30246829
Author: Andy Wingo <address@hidden>
Date: Sat Apr 25 16:31:52 2009 +0200
allow defmacros to have docstrings
* module/ice-9/boot-9.scm (define-macro, defmacro): Add the ability to
have a docstring.
* module/ice-9/documentation.scm (object-documentation): Remove
references to defmacro? and macro?. Since we store the transformation
procedure as the binding, we can get docs from the procedure directly.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/psyntax.scm (put-global-definition-hook):
Take the type and the value separately, so we can set the variable to
the procedure, while keeping the *sc-expander* to be the "binding
object".
(global-extend): Pass type and val separately.
commit b3501b8043d36a3215ec51e321a2aa3733ea54cc
Author: Andy Wingo <address@hidden>
Date: Sat Apr 25 14:10:08 2009 +0200
all of guile compiles now, expanded with syncase
* libguile/eval.c (scm_m_eval_when): Whoops, eval-when has an implicit
begin. Fix.
* module/oop/goops.scm: Syncase doesn't like definitions in expression
context, and grudgingly I have decided to go along with that. But that
doesn't mean we can't keep the old semantics, via accessing the module
system directly. So do so. I took the opportunity to rewrite some
macros with syntax-rules and syntax-case -- the former is nicer than
the latter, of course.
* module/oop/goops/save.scm: Don't define within an expression.
* module/oop/goops/simple.scm (define-class): Use define-syntax.
* module/oop/goops/stklos.scm (define-class): Use define-syntax.
commit 2ce560b944c8af2047415612835fcd23fa3de473
Author: Andy Wingo <address@hidden>
Date: Sat Apr 25 12:50:53 2009 +0200
fix bad syntax in define-macro, (ice-9 match), and (oop goops)
* module/ice-9/boot-9.scm (define-macro): Use syntax-case to destructure
macro arguments, so we get good errors.
* module/ice-9/match.scm (defstruct, define-const-structure): Don't
unquote in the `defstruct' macro as a value in expansions.
* module/oop/goops.scm (standard-define-class): Can't define a macro with
`define', use `define-syntax' instead.
(define-accessor): Use syntax-rules. Doesn't give us much in this case.
(toplevel-define!): New helper, to let us keep GOOPS' behavior with the
new expander. Some solution that works lexically and at the toplevel
would be nice, though.
(define-method): Reimplement with syntax-rules -- soooo much nicer.
* module/oop/goops/dispatch.scm (lookup-create-cmethod): Don't define
within an expression.
commit 0ee32d0131b49ee0661669b7a0b595d0a6565de4
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 23:56:40 2009 +0200
allow docstrings with internal definitions
* module/Makefile.am (SCHEME_LANG_SOURCES):
* module/language/scheme/expand.scm: Remove expand.scm, we don't need it
any more.
* module/ice-9/psyntax.scm (build-lambda, chi-lambda-clause): Support
docstrings with internal definitions. What are Scheme people thinking
these days?
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 9c35c5796cbffda57d76499048e8b8f82db943eb
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 23:10:31 2009 +0200
make sure we compile boot code in (guile), not (guile-user)
* libguile/eval.h:
* libguile/eval.c (scm_m_eval_when): Define a cheap eval-when, used
before syncase has booted.
* module/Makefile.am: Reorder to put (system vm) and (system repl)
modules after the compiler, as they are not needed at runtime.
* module/ice-9/boot-9.scm: Move the eval-when earlier, to be the first
thing -- so when we recompile Guile we do so all in the '(guile)
module, not '(guile-user).
* module/ice-9/compile-psyntax.scm: Rewrite to assume that psyntax.scm
will eval-when to set its module, etc. Have everything in a let --
otherwise the `format' call is in (guile), but `target' was defined
in (guile-user). Also, write in an eval-when to the expanded file.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/networking.scm:
* module/ice-9/psyntax.scm:
* module/ice-9/r4rs.scm: Sprinkles of eval-when, for flavor.
commit 34ad4f83ca4310e84226d6bd06feb03006c736cc
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 19:59:42 2009 +0200
handle pre-module macro procedures correctly
* module/ice-9/psyntax.scm (chi-macro): It's possible for a macro
procedure to have no module, if the procedure was made before modules
were booted.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 6e26b23c5d0df8a69a12aca7be4494a19cdf0600
Merge: d6ebfd72268878d64c583998ea9d57c0eb22996e
58df2e43937bb86fbf751f48db7bf13934d7c87e
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 19:45:43 2009 +0200
Merge branch 'master' into syncase-in-boot-9
commit d6ebfd72268878d64c583998ea9d57c0eb22996e
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 13:30:57 2009 +0200
finish transition to bare/hygiene/public/private
* module/ice-9/boot-9.scm (make-module-ref): Remove the transition
support.
* module/ice-9/psyntax.scm (get-global-definition-hook): Remove
transition support. Also remove support for guile-macro.
(build-global-reference, build-global-assignment): Remove transition
support.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit a2716cbe1e9d2b43d1fb1a017cb8b1e97617da3c
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 13:13:29 2009 +0200
only bend hygiene in macro-introduced output, not for explicit @/@@
* module/ice-9/psyntax.scm
* module/ice-9/psyntax-pp.scm
* module/ice-9/boot-9.scm (make-module-ref): We were so almost there
with what we had, sniff. The deal is that
(begin (load "foo.scm") ((@@ (foo) bar)))
would expand to
(begin (load "foo.scm") (bar))
because bar was unbound at expansion time, and make-module-ref assumed
it was like the else in a cond. But it shouldn't have, because we
/explicitly/ asked for the @@ var -- so now if we see a @ or @@, we
never drop it. @@ introduced by hygiene can be dropped if it doesn't
reference a var, though.
Practically speaking, this means tagging all modules in psyntax with
their intent: public or private (corresponding to @ or @@), hygiene
(introduced by a macro), or bare (when we don't have a module). I'm
not sure when we'd see a bare.
The implementation is complicated by the need to support the old
format and the new format at the same time, so that psyntax-pp can be
regenerated.
commit 384e92b3ae491e2f8495b0d188b384f138a8cc61
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 12:12:24 2009 +0200
fix @ and syncase
* module/ice-9/boot-9.scm
(make-module-ref): equal?, not eq?, when matching on module name.
(Module names don't have to come from an invocation of module-name in
this process.)
* module/ice-9/psyntax.scm (build-global-reference)
(build-global-assignment, @): Rework the format of the module in syntax
objects so that a car of #f indicates a public reference. Loading (foo
%module-public-interface) didn't guarantee that (foo) was loaded and
useful.
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/scheme/compile-ghil.scm (lookup-transformer):
primitive-macro? does not exist any more.
commit 7c72fe0bb5a6ef00c90f6988ce3178a45ed95f26
Author: Andy Wingo <address@hidden>
Date: Thu Apr 23 13:34:23 2009 +0200
ice-9 syncase now deprecated, woo
Remove #:use-module (ice-9 syncase) from lots of places, as it's no
longer needed.
commit 01c161ca11b19d56ce994cba477a8fc4aeb8ac43
Author: Andy Wingo <address@hidden>
Date: Thu Apr 23 13:30:23 2009 +0200
it is alive!!!!! + concision + fix to compile-ghil
* module/ice-9/boot-9.scm: Remove lots of debugging prints. Remove some
already-deprecated attempts to load modules from shared libraries.
* module/ice-9/psyntax.scm: If we have to create a variable for a
syntactic binding, initialize its contents to a gensym. I'd like
something more meaningful, but at least this way we can tell different
macros apart. Only warn about missing modules if modules are booted.
Chi the value part of a (set! (@ ...) ) expression -- whoops!
* module/ice-9/psyntax-pp.scm: Regenerated.
* module/language/glil.scm (parse-glil): Fix an unquoting error.
* module/language/scheme/compile-ghil.scm: No need to import syncase, we
gots it. Rework compiler to expand only once, with syncase, instead of
incrementally. Fix define-scheme-transformer to work with syncase, by
not referencing bare keywords. It works!
commit c5ad45c7b34346f0f7084477479e7367c30a67f6
Author: Andy Wingo <address@hidden>
Date: Thu Apr 23 12:41:03 2009 +0200
allow redefinition of global macros to variables
* module/ice-9/psyntax.scm: Allow the redefinition of keywords to
variables. Otherwise we can't do (define let #f), which is totally
useful and stuff.
* module/ice-9/psyntax-pp.scm: Regenerated.
commit 85e95b47108a84f0829cf17c5dde40f53814186e
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 14:08:32 2009 +0200
fix load for syncase-in-boot-9; compile-psyntax works again
* module/ice-9/r4rs.scm:
* module/ice-9/boot-9.scm (%load-verbosely, assert-load-verbosity)
(%load-announce, %load-hook, load): Move these from r4rs.scm to
boot-9.scm.
* module/ice-9/compile-psyntax.scm: Update to work with
syncase-in-boot-9.
* module/ice-9/psyntax-pp.scm: Recompiled with syncase-in-boot-9.
commit 64e5d08d3e7076b554f724efede860883f846b5f
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 14:01:26 2009 +0200
leap of faith: (ice-9 syncase) in psyntax-pp.scm -> (guile)
* module/ice-9/psyntax-pp.scm: Manually switch psyntax-pp over to (guile)
from (ice-9 syncase). Heh heh.
commit 131826039c62bdfd5932272b5d19d4b08cbe4e63
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 13:54:38 2009 +0200
syncase early in boot-9, defmacros in terms of syntax-case -- halfway
working
* module/ice-9/boot-9.scm
(eval-when): Remove, as syncase is going to handle this one for us.
(sc-expand, sc-expand3, sc-chi, install-global-transformer)
(syntax-dispatch, syntax-error, annotation?, bound-identifier=?)
(datum->syntax-object, free-identifier=?, generate-temporaries)
(identifier?, syntax-object->datum, void, andmap): Oh, ugly of uglies:
add these exciting definitions to the main environment. Hopefully we
can pull them back out soon.
(make-module-ref, resolve-module): Stub these out, as a replacement for
expand-support.
(%pre-modules-transformer): Define to sc-expand, so that we are using
syncase from the very start.
(defmacro, define-macro): Define in terms of syntax-case.
(macroexpand, macroexpand-1): Remove, there should be a different way
to get at this -- though perhaps with the same name.
(make-module): Make sc-expand the default module-transformer.
(process-define-module): Issue a deprecation warning when using ice-9
syncase.
(primitive-macro?): Remove, no meaning...
(use-syntax): Deprecate.
(define-private, define-public, defmacro-public): Rework in terms of
syntax-rules.
* module/ice-9/syncase.scm: Gut, as syncase is provided by core now.
commit a26934a850fba4ee1caf5d44cdbbe95115c91be0
Author: Andy Wingo <address@hidden>
Date: Fri Apr 24 13:50:14 2009 +0200
module-name returns '(guile) during boot; psyntax tweak
* module/ice-9/boot-9.scm (module-name): Return '(guile) before the
module system is booted, for syncase's benefit. Defer redefinition
until the module system is booted.
* module/ice-9/psyntax.scm (put-global-definition-hook): Only set a
variable if it's unbound.
* module/ice-9/psyntax.scm: Regenerated.
commit 757937c290ae64a7a75232793c659d0cca3dea10
Author: Andy Wingo <address@hidden>
Date: Wed Apr 22 23:10:35 2009 +0200
more steps on the way to boot-time syncase
* module/ice-9/boot-9.scm: Define a version of module-add! for psyntax,
before modules are booted.
* module/ice-9/psyntax.scm: Remove a warning, and rename a variable.
Initialize a new variable to 'sc-macro, though it will have no effect.
* module/ice-9/psyntax-pp.scm: Regenerated.
-----------------------------------------------------------------------
Summary of changes:
ANNOUNCE | 2 +-
NEWS | 5 +
README | 6 +
THANKS | 1 +
benchmark-suite/Makefile.am | 1 +
benchmark-suite/benchmarks/bytevectors.bm | 99 ++
build-aux/config.rpath | 24 +-
configure.in | 17 +-
doc/maint/guile.texi | 2 +-
doc/ref/api-data.texi | 2 +-
doc/ref/api-init.texi | 2 +-
doc/ref/api-memory.texi | 4 +-
doc/ref/api-procedures.texi | 28 +-
doc/ref/api-undocumented.texi | 2 +-
doc/ref/compiler.texi | 761 ++++++-----
doc/ref/libguile-concepts.texi | 2 +-
doc/ref/vm.texi | 166 +--
guile-readline/ice-9/readline.scm | 32 +-
lang/Makefile.am | 1 +
lang/elisp/expand.scm | 4 +
lang/elisp/interface.scm | 45 +-
lang/elisp/internals/lambda.scm | 1 +
lang/elisp/primitives/fns.scm | 3 +-
lang/elisp/primitives/syntax.scm | 1 +
lang/elisp/transform.scm | 39 +-
lib/Makefile.am | 440 ++++++-
lib/byteswap.in.h | 44 +
lib/c-ctype.c | 396 +++++
lib/c-ctype.h | 295 ++++
lib/c-strcase.h | 55 +
lib/c-strcasecmp.c | 57 +
lib/c-strcaseeq.h | 184 +++
lib/c-strncasecmp.c | 57 +
lib/config.charset | 46 +-
lib/flock.c | 222 +++
lib/iconv.c | 450 ++++++
lib/iconv.in.h | 71 +
lib/iconv_close.c | 47 +
lib/iconv_open-aix.gperf | 44 +
lib/iconv_open-hpux.gperf | 56 +
lib/iconv_open-irix.gperf | 31 +
lib/iconv_open-osf.gperf | 50 +
lib/iconv_open.c | 172 +++
lib/iconveh.h | 41 +
lib/localcharset.c | 41 +-
lib/malloc.c | 57 +
lib/mbrtowc.c | 47 +-
lib/putenv.c | 132 ++
lib/stdint.in.h | 567 ++++++++
lib/stdlib.in.h | 383 +++++
lib/strftime.c | 28 +-
lib/striconveh.c | 1251 ++++++++++++++++
lib/striconveh.h | 120 ++
lib/string.in.h | 605 ++++++++
lib/sys_file.in.h | 60 +
lib/unistd.in.h | 36 +-
lib/unistr.h | 681 +++++++++
lib/unistr/u8-mbtouc-aux.c | 158 ++
lib/unistr/u8-mbtouc-unsafe-aux.c | 168 +++
lib/unistr/u8-mbtouc-unsafe.c | 179 +++
lib/unistr/u8-mbtouc.c | 168 +++
lib/unistr/u8-mbtoucr.c | 285 ++++
lib/unistr/u8-prev.c | 93 ++
lib/unistr/u8-uctomb-aux.c | 69 +
lib/unistr/u8-uctomb.c | 88 ++
lib/unitypes.h | 26 +
lib/wchar.in.h | 26 +-
libguile.h | 4 +-
libguile/Makefile.am | 30 +-
libguile/__scm.h | 26 +-
libguile/async.c | 2 +-
libguile/bytevectors.c | 1978 ++++++++++++++++++++++++++
libguile/bytevectors.h | 133 ++
libguile/eval.c | 19 +
libguile/eval.h | 2 +
libguile/frames.c | 49 +-
libguile/frames.h | 84 +-
libguile/gc_os_dep.c | 4 +-
libguile/ieee-754.h | 90 ++
libguile/instructions.c | 50 +-
libguile/instructions.h | 66 +-
libguile/macros.c | 113 ++-
libguile/macros.h | 13 +-
libguile/modules.c | 4 +-
libguile/net_db.c | 8 +-
libguile/numbers.c | 9 +-
libguile/objcodes.c | 49 +-
libguile/objcodes.h | 66 +-
libguile/posix.c | 186 +---
libguile/programs.c | 49 +-
libguile/programs.h | 86 +-
libguile/r6rs-ports.c | 1118 +++++++++++++++
libguile/r6rs-ports.h | 43 +
libguile/read.c | 98 ++-
libguile/stime.c | 13 -
libguile/strings.c | 2 +-
libguile/threads.c | 11 +
libguile/validate.h | 5 +-
libguile/vm-bootstrap.h | 50 +-
libguile/vm-engine.c | 48 +-
libguile/vm-engine.h | 52 +-
libguile/vm-expand.h | 48 +-
libguile/vm-i-scheme.c | 48 +-
libguile/vm-i-system.c | 8 +-
libguile/vm.c | 49 +-
libguile/vm.h | 110 +-
m4/00gnulib.m4 | 30 +
m4/alloca.m4 | 6 +-
m4/byteswap.m4 | 18 +
m4/codeset.m4 | 6 +-
m4/environ.m4 | 36 +
m4/extensions.m4 | 20 +-
m4/flock.m4 | 26 +
m4/fpieee.m4 | 52 +
m4/gnulib-cache.m4 | 13 +-
m4/gnulib-common.m4 | 31 +-
m4/gnulib-comp.m4 | 88 ++
m4/iconv.m4 | 180 +++
m4/iconv_h.m4 | 34 +
m4/iconv_open.m4 | 237 +++
m4/include_next.m4 | 51 +-
m4/inline.m4 | 6 +-
m4/lib-ld.m4 | 110 ++
m4/lib-link.m4 | 761 ++++++++++
m4/lib-prefix.m4 | 224 +++
m4/libunistring.m4 | 37 +
m4/localcharset.m4 | 6 +-
m4/locale-fr.m4 | 79 +-
m4/locale-ja.m4 | 83 +-
m4/locale-zh.m4 | 67 +-
m4/longlong.m4 | 106 ++
m4/malloc.m4 | 41 +
m4/mbrtowc.m4 | 85 +-
m4/mbstate_t.m4 | 10 +-
m4/multiarch.m4 | 65 +
m4/putenv.m4 | 41 +
m4/stdbool.m4 | 4 +-
m4/stdint.m4 | 472 ++++++
m4/stdlib_h.m4 | 73 +
m4/strcase.m4 | 10 +-
m4/strftime.m4 | 8 +-
m4/string_h.m4 | 92 ++
m4/sys_file_h.m4 | 41 +
m4/tm_gmtoff.m4 | 6 +-
m4/unistd_h.m4 | 6 +-
m4/visibility.m4 | 52 +
m4/wchar.m4 | 51 +-
m4/wint_t.m4 | 6 +-
module/Makefile.am | 51 +-
module/ice-9/boot-9.scm | 550 ++++---
module/ice-9/compile-psyntax.scm | 47 +-
module/ice-9/deprecated.scm | 2 +-
module/ice-9/documentation.scm | 8 +-
module/ice-9/expand-support.scm | 169 ---
module/ice-9/match.scm | 4 +-
module/ice-9/networking.scm | 3 +
module/ice-9/null.scm | 1 -
module/ice-9/occam-channel.scm | 1 -
module/ice-9/posix.scm | 3 +
module/ice-9/psyntax-pp.scm | 24 +-
module/ice-9/psyntax.scm | 1011 +++++++------
module/ice-9/r4rs.scm | 28 +-
module/ice-9/stack-catch.scm | 2 +-
module/ice-9/syncase.scm | 200 +---
module/ice-9/threads.scm | 114 +-
module/ice-9/time.scm | 2 +-
module/language/assembly/disassemble.scm | 2 +-
module/language/ecmascript/spec.scm | 1 -
module/language/ghil/compile-glil.scm | 14 +-
module/language/glil.scm | 9 +-
module/language/glil/compile-assembly.scm | 31 +-
module/language/glil/decompile-assembly.scm | 8 +-
module/language/scheme/amatch.scm | 37 -
module/language/scheme/compile-ghil.scm | 48 +-
module/language/scheme/compile-tree-il.scm | 64 +
module/language/scheme/decompile-tree-il.scm | 27 +
module/language/scheme/expand.scm | 307 ----
module/language/scheme/spec.scm | 13 +-
module/language/tree-il.scm | 359 +++++
module/language/tree-il/analyze.scm | 235 +++
module/language/tree-il/compile-glil.scm | 448 ++++++
module/language/tree-il/optimize.scm | 42 +
module/language/tree-il/primitives.scm | 206 +++
module/language/tree-il/spec.scm | 43 +
module/oop/goops.scm | 400 +++---
module/oop/goops/compile.scm | 32 +-
module/oop/goops/dispatch.scm | 5 +-
module/oop/goops/save.scm | 4 +-
module/oop/goops/simple.scm | 5 +-
module/oop/goops/stklos.scm | 71 +-
module/rnrs/bytevector.scm | 84 ++
module/rnrs/io/ports.scm | 111 ++
module/srfi/srfi-11.scm | 1 -
module/srfi/srfi-18.scm | 10 +-
module/srfi/srfi-35.scm | 67 +-
module/srfi/srfi-39.scm | 1 -
module/system/base/compile.scm | 20 +-
module/system/base/language.scm | 3 +-
module/system/base/pmatch.scm | 7 +-
module/system/repl/repl.scm | 2 +-
test-suite/Makefile.am | 3 +
test-suite/lib.scm | 40 +-
test-suite/standalone/test-conversion.c | 102 +-
test-suite/standalone/test-round.c | 9 +-
test-suite/tests/bytevectors.test | 531 +++++++
test-suite/tests/compiler.test | 43 +-
test-suite/tests/eval.test | 27 +-
test-suite/tests/popen.test | 108 +-
test-suite/tests/r6rs-ports.test | 455 ++++++
test-suite/tests/reader.test | 40 +
test-suite/tests/srfi-17.test | 7 +-
test-suite/tests/srfi-18.test | 9 +-
test-suite/tests/srfi-31.test | 2 +-
test-suite/tests/syntax.test | 414 +++---
test-suite/tests/threads.test | 67 +-
test-suite/tests/tree-il.test | 467 ++++++
testsuite/t-match.scm | 2 +-
217 files changed, 20728 insertions(+), 4004 deletions(-)
create mode 100644 benchmark-suite/benchmarks/bytevectors.bm
create mode 100644 lang/elisp/expand.scm
create mode 100644 lib/byteswap.in.h
create mode 100644 lib/c-ctype.c
create mode 100644 lib/c-ctype.h
create mode 100644 lib/c-strcase.h
create mode 100644 lib/c-strcasecmp.c
create mode 100644 lib/c-strcaseeq.h
create mode 100644 lib/c-strncasecmp.c
create mode 100644 lib/flock.c
create mode 100644 lib/iconv.c
create mode 100644 lib/iconv.in.h
create mode 100644 lib/iconv_close.c
create mode 100644 lib/iconv_open-aix.gperf
create mode 100644 lib/iconv_open-hpux.gperf
create mode 100644 lib/iconv_open-irix.gperf
create mode 100644 lib/iconv_open-osf.gperf
create mode 100644 lib/iconv_open.c
create mode 100644 lib/iconveh.h
create mode 100644 lib/malloc.c
create mode 100644 lib/putenv.c
create mode 100644 lib/stdint.in.h
create mode 100644 lib/stdlib.in.h
create mode 100644 lib/striconveh.c
create mode 100644 lib/striconveh.h
create mode 100644 lib/string.in.h
create mode 100644 lib/sys_file.in.h
create mode 100644 lib/unistr.h
create mode 100644 lib/unistr/u8-mbtouc-aux.c
create mode 100644 lib/unistr/u8-mbtouc-unsafe-aux.c
create mode 100644 lib/unistr/u8-mbtouc-unsafe.c
create mode 100644 lib/unistr/u8-mbtouc.c
create mode 100644 lib/unistr/u8-mbtoucr.c
create mode 100644 lib/unistr/u8-prev.c
create mode 100644 lib/unistr/u8-uctomb-aux.c
create mode 100644 lib/unistr/u8-uctomb.c
create mode 100644 lib/unitypes.h
create mode 100644 libguile/bytevectors.c
create mode 100644 libguile/bytevectors.h
create mode 100644 libguile/ieee-754.h
create mode 100644 libguile/r6rs-ports.c
create mode 100644 libguile/r6rs-ports.h
create mode 100644 m4/00gnulib.m4
create mode 100644 m4/byteswap.m4
create mode 100644 m4/environ.m4
create mode 100644 m4/flock.m4
create mode 100644 m4/fpieee.m4
create mode 100644 m4/iconv.m4
create mode 100644 m4/iconv_h.m4
create mode 100644 m4/iconv_open.m4
create mode 100644 m4/lib-ld.m4
create mode 100644 m4/lib-link.m4
create mode 100644 m4/lib-prefix.m4
create mode 100644 m4/libunistring.m4
create mode 100644 m4/longlong.m4
create mode 100644 m4/malloc.m4
create mode 100644 m4/multiarch.m4
create mode 100644 m4/putenv.m4
create mode 100644 m4/stdint.m4
create mode 100644 m4/stdlib_h.m4
create mode 100644 m4/string_h.m4
create mode 100644 m4/sys_file_h.m4
create mode 100644 m4/visibility.m4
delete mode 100644 module/ice-9/expand-support.scm
delete mode 100644 module/language/scheme/amatch.scm
create mode 100644 module/language/scheme/compile-tree-il.scm
create mode 100644 module/language/scheme/decompile-tree-il.scm
delete mode 100644 module/language/scheme/expand.scm
create mode 100644 module/language/tree-il.scm
create mode 100644 module/language/tree-il/analyze.scm
create mode 100644 module/language/tree-il/compile-glil.scm
create mode 100644 module/language/tree-il/optimize.scm
create mode 100644 module/language/tree-il/primitives.scm
create mode 100644 module/language/tree-il/spec.scm
create mode 100644 module/rnrs/bytevector.scm
create mode 100644 module/rnrs/io/ports.scm
create mode 100644 test-suite/tests/bytevectors.test
create mode 100644 test-suite/tests/r6rs-ports.test
create mode 100644 test-suite/tests/tree-il.test
diff --git a/ANNOUNCE b/ANNOUNCE
index 89d8cbd..bfbda73 100644
--- a/ANNOUNCE
+++ b/ANNOUNCE
@@ -30,7 +30,7 @@ The NEWS file is quite long. Here are the most interesting
entries:
from threads that have not been created by Guile.
* Mutexes and condition variables are now always fair. A recursive
- mutex must be requested explicitely.
+ mutex must be requested explicitly.
* The low-level thread API has been removed.
diff --git a/NEWS b/NEWS
index de8e2c1..1785fe8 100644
--- a/NEWS
+++ b/NEWS
@@ -52,10 +52,15 @@ Changes in 1.8.7 (since 1.8.6)
* Bugs fixed
+** Fix compilation with `--disable-deprecated'
** Fix %fast-slot-ref/set!, to avoid possible segmentation fault
** Fix MinGW build problem caused by HAVE_STRUCT_TIMESPEC confusion
** Fix build problem when scm_t_timespec is different from struct timespec
** Fix build when compiled with -Wundef -Werror
+** More build fixes for `alphaev56-dec-osf5.1b' (Tru64)
+** With GCC, always compile with `-mieee' on `alpha*' and `sh*'
+** Better diagnose broken `(strftime "%z" ...)' in `time.test' (bug #24130)
+** Fix parsing of SRFI-88/postfix keywords longer than 128 characters
** Allow @ macro to work with (ice-9 syncase)
diff --git a/README b/README
index 9993fcf..4950229 100644
--- a/README
+++ b/README
@@ -61,6 +61,12 @@ Guile requires the following external packages:
libltdl is used for loading extensions at run-time. It is
available from http://www.gnu.org/software/libtool/
+ - GNU libunistring
+
+ libunistring is used for Unicode string operations, such as the
+ `utf*->string' procedures. It is available from
+ http://www.gnu.org/software/libunistring/ .
+
Special Instructions For Some Systems =====================================
diff --git a/THANKS b/THANKS
index d93837d..c347abc 100644
--- a/THANKS
+++ b/THANKS
@@ -61,6 +61,7 @@ For fixes or providing information which led to a fix:
René Köcher
Matthias Köppe
Matt Kraai
+ Daniel Kraft
Miroslav Lichvar
Jeff Long
Marco Maggi
diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am
index e65e8bc..dcadd58 100644
--- a/benchmark-suite/Makefile.am
+++ b/benchmark-suite/Makefile.am
@@ -1,4 +1,5 @@
SCM_BENCHMARKS = benchmarks/0-reference.bm \
+ benchmarks/bytevectors.bm \
benchmarks/continuations.bm \
benchmarks/if.bm \
benchmarks/logand.bm \
diff --git a/benchmark-suite/benchmarks/bytevectors.bm
b/benchmark-suite/benchmarks/bytevectors.bm
new file mode 100644
index 0000000..9547a71
--- /dev/null
+++ b/benchmark-suite/benchmarks/bytevectors.bm
@@ -0,0 +1,99 @@
+;;; -*- mode: scheme; coding: latin-1; -*-
+;;; R6RS Byte Vectors.
+;;;
+;;; Copyright 2009 Ludovic Courtès <address@hidden>
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmarks bytevector)
+ :use-module (rnrs bytevector)
+ :use-module (srfi srfi-4)
+ :use-module (benchmark-suite lib))
+
+(define bv (make-bytevector 16384))
+
+(define %native-endianness
+ (native-endianness))
+
+(define %foreign-endianness
+ (if (eq? (native-endianness) (endianness little))
+ (endianness big)
+ (endianness little)))
+
+(define u8v (make-u8vector 16384))
+(define u16v (make-u16vector 8192))
+(define u32v (make-u32vector 4196))
+(define u64v (make-u64vector 2048))
+
+
+(with-benchmark-prefix "ref/set!"
+
+ (benchmark "bytevector-u8-ref" 1000000
+ (bytevector-u8-ref bv 0))
+
+ (benchmark "bytevector-u16-ref (foreign)" 1000000
+ (bytevector-u16-ref bv 0 %foreign-endianness))
+
+ (benchmark "bytevector-u16-ref (native)" 1000000
+ (bytevector-u16-ref bv 0 %native-endianness))
+
+ (benchmark "bytevector-u16-native-ref" 1000000
+ (bytevector-u16-native-ref bv 0))
+
+ (benchmark "bytevector-u32-ref (foreign)" 1000000
+ (bytevector-u32-ref bv 0 %foreign-endianness))
+
+ (benchmark "bytevector-u32-ref (native)" 1000000
+ (bytevector-u32-ref bv 0 %native-endianness))
+
+ (benchmark "bytevector-u32-native-ref" 1000000
+ (bytevector-u32-native-ref bv 0))
+
+ (benchmark "bytevector-u64-ref (foreign)" 1000000
+ (bytevector-u64-ref bv 0 %foreign-endianness))
+
+ (benchmark "bytevector-u64-ref (native)" 1000000
+ (bytevector-u64-ref bv 0 %native-endianness))
+
+ (benchmark "bytevector-u64-native-ref" 1000000
+ (bytevector-u16-native-ref bv 0)))
+
+
+(with-benchmark-prefix "lists"
+
+ (benchmark "bytevector->u8-list" 2000
+ (bytevector->u8-list bv))
+
+ (benchmark "bytevector->uint-list 16-bit" 2000
+ (bytevector->uint-list bv (native-endianness) 2))
+
+ (benchmark "bytevector->uint-list 64-bit" 2000
+ (bytevector->uint-list bv (native-endianness) 8)))
+
+
+(with-benchmark-prefix "SRFI-4" ;; for comparison
+
+ (benchmark "u8vector-ref" 1000000
+ (u8vector-ref u8v 0))
+
+ (benchmark "u16vector-ref" 1000000
+ (u16vector-ref u16v 0))
+
+ (benchmark "u32vector-ref" 1000000
+ (u32vector-ref u32v 0))
+
+ (benchmark "u64vector-ref" 1000000
+ (u64vector-ref u64v 0)))
diff --git a/build-aux/config.rpath b/build-aux/config.rpath
index 35f959b..85c2f20 100755
--- a/build-aux/config.rpath
+++ b/build-aux/config.rpath
@@ -47,7 +47,7 @@ for cc_temp in $CC""; do
done
cc_basename=`echo "$cc_temp" | sed -e 's%^.*/%%'`
-# Code taken from libtool.m4's AC_LIBTOOL_PROG_COMPILER_PIC.
+# Code taken from libtool.m4's _LT_COMPILER_PIC.
wl=
if test "$GCC" = yes; then
@@ -64,7 +64,7 @@ else
;;
esac
;;
- mingw* | cygwin* | pw32* | os2*)
+ mingw* | cygwin* | pw32* | os2* | cegcc*)
;;
hpux9* | hpux10* | hpux11*)
wl='-Wl,'
@@ -76,7 +76,13 @@ else
;;
linux* | k*bsd*-gnu)
case $cc_basename in
- icc* | ecc*)
+ ecc*)
+ wl='-Wl,'
+ ;;
+ icc* | ifort*)
+ wl='-Wl,'
+ ;;
+ lf95*)
wl='-Wl,'
;;
pgcc | pgf77 | pgf90)
@@ -124,7 +130,7 @@ else
esac
fi
-# Code taken from libtool.m4's AC_LIBTOOL_PROG_LD_SHLIBS.
+# Code taken from libtool.m4's _LT_LINKER_SHLIBS.
hardcode_libdir_flag_spec=
hardcode_libdir_separator=
@@ -132,7 +138,7 @@ hardcode_direct=no
hardcode_minus_L=no
case "$host_os" in
- cygwin* | mingw* | pw32*)
+ cygwin* | mingw* | pw32* | cegcc*)
# FIXME: the MSVC++ port hasn't been tested in a loooong time
# When not using gcc, we currently assume that we are using
# Microsoft Visual C++.
@@ -182,7 +188,7 @@ if test "$with_gnu_ld" = yes; then
ld_shlibs=no
fi
;;
- cygwin* | mingw* | pw32*)
+ cygwin* | mingw* | pw32* | cegcc*)
# hardcode_libdir_flag_spec is actually meaningless, as there is
# no search path for DLLs.
hardcode_libdir_flag_spec='-L$libdir'
@@ -326,7 +332,7 @@ else
;;
bsdi[45]*)
;;
- cygwin* | mingw* | pw32*)
+ cygwin* | mingw* | pw32* | cegcc*)
# When not using gcc, we currently assume that we are using
# Microsoft Visual C++.
# hardcode_libdir_flag_spec is actually meaningless, as there is
@@ -494,7 +500,7 @@ else
fi
# Check dynamic linker characteristics
-# Code taken from libtool.m4's AC_LIBTOOL_SYS_DYNAMIC_LINKER.
+# Code taken from libtool.m4's _LT_SYS_DYNAMIC_LINKER.
# Unlike libtool.m4, here we don't care about _all_ names of the library, but
# only about the one the linker finds when passed -lNAME. This is the last
# element of library_names_spec in libtool.m4, or possibly two of them if the
@@ -517,7 +523,7 @@ case "$host_os" in
bsdi[45]*)
library_names_spec='$libname$shrext'
;;
- cygwin* | mingw* | pw32*)
+ cygwin* | mingw* | pw32* | cegcc*)
shrext=.dll
library_names_spec='$libname.dll.a $libname.lib'
;;
diff --git a/configure.in b/configure.in
index 553d688..6568e52 100644
--- a/configure.in
+++ b/configure.in
@@ -621,6 +621,8 @@ AC_SUBST([SCM_I_GSC_HAVE_STRUCT_DIRENT64])
# Reasons for testing:
# complex.h - new in C99
# fenv.h - available in C99, but not older systems
+# machine/fpu.h - on Tru64 5.1b, the declaration of fesetround(3) is in
+# this file instead of <fenv.h>
# process.h - mingw specific
# langinfo.h, nl_types.h - SuS v2
#
@@ -628,7 +630,7 @@ AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h
malloc.h memory.h proces
regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \
sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
-direct.h langinfo.h nl_types.h])
+direct.h langinfo.h nl_types.h machine/fpu.h])
# "complex double" is new in C99, and "complex" is only a keyword if
# <complex.h> is included
@@ -734,10 +736,14 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10
ctermid fesetround ftime
# sethostname - the function itself check because it's not in mingw,
# the DECL is checked because Solaris 10 doens't have in any header
# xlocale.h - needed on Darwin for the `locale_t' API
+# hstrerror - on Tru64 5.1b the symbol is available in libc but the
+# declaration isn't anywhere.
+# cuserid - on Tru64 5.1b the declaration is documented to be available
+# only with `_XOPEN_SOURCE' or some such.
#
AC_CHECK_HEADERS(crypt.h netdb.h pthread.h sys/param.h sys/resource.h
sys/file.h xlocale.h)
AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass
sethostname gethostname)
-AC_CHECK_DECLS([sethostname])
+AC_CHECK_DECLS([sethostname, hstrerror, cuserid])
# crypt() may or may not be available, for instance in some countries there
# are restrictions on cryptography.
@@ -830,6 +836,13 @@ AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <gmp.h>]],
[],
[AC_MSG_ERROR([At least GNU MP 4.1 is required, 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 i18n tests
#AC_CHECK_HEADERS([libintl.h])
#AC_CHECK_FUNCS(gettext)
diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi
index ac08334..4ef4aab 100644
--- a/doc/maint/guile.texi
+++ b/doc/maint/guile.texi
@@ -204,7 +204,7 @@ Execute all thunks from the asyncs of the list
@var{list_of_a}.
@deffn {Scheme Procedure} system-async thunk
@deffnx {C Function} scm_system_async (thunk)
This function is deprecated. You can use @var{thunk} directly
-instead of explicitely creating an async object.
+instead of explicitly creating an async object.
@end deffn
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index e1db2a6..b529199 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -331,7 +331,7 @@ integers.
The motivation for this behavior is that the inexactness of a number
should not be lost silently. If you want to allow inexact integers,
-you can explicitely insert a call to @code{inexact->exact} or to its C
+you can explicitly insert a call to @code{inexact->exact} or to its C
equivalent @code{scm_inexact_to_exact}. (Only inexact integers will
be converted by this call into exact integers; inexact non-integers
will become exact fractions.)
diff --git a/doc/ref/api-init.texi b/doc/ref/api-init.texi
index 0e4e8b8..f9714c3 100644
--- a/doc/ref/api-init.texi
+++ b/doc/ref/api-init.texi
@@ -61,7 +61,7 @@ Arrange things so that all of the code in the current thread
executes as
if from within a call to @code{scm_with_guile}. That is, all functions
called by the current thread can assume that @code{SCM} values on their
stack frames are protected from the garbage collector (except when the
-thread has explicitely left guile mode, of course).
+thread has explicitly left guile mode, of course).
When @code{scm_init_guile} is called from a thread that already has been
in guile mode once, nothing happens. This behavior matters when you
diff --git a/doc/ref/api-memory.texi b/doc/ref/api-memory.texi
index 32d3998..f492203 100644
--- a/doc/ref/api-memory.texi
+++ b/doc/ref/api-memory.texi
@@ -10,7 +10,7 @@
Guile uses a @emph{garbage collector} to manage most of its objects.
While the garbage collector is designed to be mostly invisible, you
-sometimes need to interact with it explicitely.
+sometimes need to interact with it explicitly.
See @ref{Garbage Collection} for a general discussion of how garbage
collection relates to using Guile from C.
@@ -201,7 +201,7 @@ below for a motivation.
@deftypefn {C Function} void scm_gc_free (void address@hidden, size_t
@var{size}, const char address@hidden)
Like @code{free}, but also call @code{scm_gc_unregister_collectable_memory}.
-Note that you need to explicitely pass the @var{size} parameter. This
+Note that you need to explicitly pass the @var{size} parameter. This
is done since it should normally be easy to provide this parameter
(for memory that is associated with GC controlled objects) and this
frees us from tracking this value in the GC itself, which will keep
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index e3cf258..8098b4f 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -162,18 +162,10 @@ appropriate module first, though:
Returns @code{#t} iff @var{obj} is a compiled procedure.
@end deffn
address@hidden {Scheme Procedure} program-bytecode program
address@hidden {C Function} scm_program_bytecode (program)
-Returns the object code associated with this program, as a
address@hidden
address@hidden deffn
-
address@hidden {Scheme Procedure} program-base program
address@hidden {C Function} scm_program_base (program)
-Returns the address in memory corresponding to the start of
address@hidden's object code, as an integer. This is useful mostly when
-you map the value of an instruction pointer from the VM to actual
-instructions.
address@hidden {Scheme Procedure} program-objcode program
address@hidden {C Function} scm_program_objcode (program)
+Returns the object code associated with this program. @xref{Bytecode
+and Objcode}, for more information.
@end deffn
@deffn {Scheme Procedure} program-objects program
@@ -184,9 +176,9 @@ vector. @xref{VM Programs}, for more information.
@deffn {Scheme Procedure} program-module program
@deffnx {C Function} scm_program_module (program)
-Returns the module that was current when this program was created.
-Free variables in this program are looked up with respect to this
-module.
+Returns the module that was current when this program was created. Can
+return @code{#f} if the compiler could determine that this information
+was unnecessary.
@end deffn
@deffn {Scheme Procedure} program-external program
@@ -250,9 +242,9 @@ REPL. The only tricky bit is that @var{extp} is a boolean,
declaring
whether the binding is heap-allocated or not. @xref{VM Concepts}, for
more information.
-Note that bindings information are stored in a program as part of its
-metadata thunk, so including them in the generated object code does
-not impose a runtime performance penalty.
+Note that bindings information is stored in a program as part of its
+metadata thunk, so including it in the generated object code does not
+impose a runtime performance penalty.
@end deffn
@deffn {Scheme Procedure} program-sources program
diff --git a/doc/ref/api-undocumented.texi b/doc/ref/api-undocumented.texi
index 826b4d3..ef1df19 100644
--- a/doc/ref/api-undocumented.texi
+++ b/doc/ref/api-undocumented.texi
@@ -257,7 +257,7 @@ otherwise return the first argument.
@deffn {Scheme Procedure} system-async thunk
@deffnx {C Function} scm_system_async (thunk)
This function is deprecated. You can use @var{thunk} directly
-instead of explicitely creating an async object.
+instead of explicitly creating an async object.
@end deffn
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 27d8f79..0d68abf 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -22,9 +22,10 @@ know how to compile your .scm file.
@menu
* Compiler Tower::
* The Scheme Compiler::
-* GHIL::
+* Tree-IL::
* GLIL::
-* Object Code::
+* Assembly::
+* Bytecode and Objcode::
* Extending the Compiler::
@end menu
@@ -52,7 +53,7 @@ They are registered with the @code{define-language} form.
@deffn {Scheme Syntax} define-language @
name title version reader printer @
-[parser=#f] [read-file=#f] [compilers='()] [evaluator=#f]
+[parser=#f] [compilers='()] [decompilers='()] [evaluator=#f]
Define a language.
This syntax defines a @code{#<language>} object, bound to @var{name}
@@ -62,17 +63,15 @@ for Scheme:
@example
(define-language scheme
- #:title "Guile Scheme"
- #:version "0.5"
- #:reader read
- #:read-file read-file
- #:compilers `((,ghil . ,compile-ghil))
- #:evaluator (lambda (x module) (primitive-eval x))
- #:printer write)
+ #:title "Guile Scheme"
+ #:version "0.5"
+ #:reader read
+ #:compilers `((tree-il . ,compile-tree-il)
+ (ghil . ,compile-ghil))
+ #:decompilers `((tree-il . ,decompile-tree-il))
+ #:evaluator (lambda (x module) (primitive-eval x))
+ #:printer write)
@end example
-
-In this example, from @code{(language scheme spec)}, @code{read-file}
-reads expressions from a port and wraps them in a @code{begin} block.
@end deffn
The interesting thing about having languages defined this way is that
@@ -85,12 +84,12 @@ Guile Scheme interpreter 0.5 on Guile 1.9.0
Copyright (C) 2001-2008 Free Software Foundation, Inc.
Enter `,help' for help.
-scheme@@(guile-user)> ,language ghil
-Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0
+scheme@@(guile-user)> ,language tree-il
+Tree Intermediate Language interpreter 1.0 on Guile 1.9.0
Copyright (C) 2001-2008 Free Software Foundation, Inc.
Enter `,help' for help.
-ghil@@(guile-user)>
+tree-il@@(guile-user)>
@end example
Languages can be looked up by name, as they were above.
@@ -128,17 +127,25 @@ The normal tower of languages when compiling Scheme goes
like this:
@itemize
@item Scheme, which we know and love
address@hidden Guile High Intermediate Language (GHIL)
address@hidden Tree Intermediate Language (Tree-IL)
@item Guile Low Intermediate Language (GLIL)
address@hidden Object code
address@hidden Assembly
address@hidden Bytecode
address@hidden Objcode
@end itemize
Object code may be serialized to disk directly, though it has a cookie
-and version prepended to the front. But when compiling Scheme at
-run time, you want a Scheme value, e.g. a compiled procedure. For this
-reason, so as not to break the abstraction, Guile defines a fake
-language, @code{value}. Compiling to @code{value} loads the object
-code into a procedure, and wakes the sleeping giant.
+and version prepended to the front. But when compiling Scheme at run
+time, you want a Scheme value: for example, a compiled procedure. For
+this reason, so as not to break the abstraction, Guile defines a fake
+language at the bottom of the tower:
+
address@hidden
address@hidden Value
address@hidden itemize
+
+Compiling to @code{value} loads the object code into a procedure, and
+wakes the sleeping giant.
Perhaps this strangeness can be explained by example:
@code{compile-file} defaults to compiling to object code, because it
@@ -156,340 +163,254 @@ different worlds indefinitely, as shown by the
following quine:
@node The Scheme Compiler
@subsection The Scheme Compiler
-The job of the Scheme compiler is to expand all macros and to resolve
-all symbols to lexical variables. Its target language, GHIL, is fairly
-close to Scheme itself, so this process is not very complicated.
-
-The Scheme compiler is driven by a table of @dfn{translators},
-declared with the @code{define-scheme-translator} form, defined in the
-module, @code{(language scheme compile-ghil)}.
-
address@hidden {Scheme Syntax} define-scheme-translator head clause1 clause2...
-The best documentation of this form is probably an example. Here is
-the translator for @code{if}:
-
address@hidden
-(define-scheme-translator if
- ;; (if TEST THEN [ELSE])
- ((,test ,then)
- (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
- ((,test ,then ,else)
- (make-ghil-if e l (retrans test) (retrans then) (retrans else))))
address@hidden example
-
-The match syntax is from the @code{pmatch} macro, defined in
address@hidden(system base pmatch)}. The result of a clause should be a valid
-GHIL value. If no clause matches, a syntax error is signalled.
-
-In the body of the clauses, the following bindings are introduced:
address@hidden
address@hidden @code{e}, the current environment
address@hidden @code{l}, the current source location (or @code{#f})
address@hidden @code{retrans}, a procedure that may be called to compile
-subexpressions
address@hidden itemize
-
-Note that translators are looked up by @emph{value}, not by name. That
-is to say, the translator is keyed under the @emph{value} of
address@hidden, which normally prints as @code{#<primitive-builtin-macro!
-if>}.
address@hidden deffn
-
-Users can extend the compiler by defining new translators.
-Additionally, some forms can be inlined directly to
-instructions -- @xref{Inlined Scheme Instructions}, for a list. The
-actual inliners are defined in @code{(language scheme inline)}:
-
address@hidden {Scheme Syntax} define-inline head arity1 result1 arity2
result2...
-Defines an inliner for @code{head}. As in
address@hidden, inliners are keyed by value and not
-by name.
-
-Expressions are matched on their arities. For example:
-
address@hidden
-(define-inline eq?
- (x y) (eq? x y))
address@hidden example
-
-This inlines calls to the Scheme procedure, @code{eq?}, to the
-instruction @code{eq?}.
-
-A more complicated example would be:
-
address@hidden
-(define-inline +
- () 0
- (x) x
- (x y) (add x y)
- (x y . rest) (add x (+ y . rest)))
address@hidden example
address@hidden deffn
-
-Compilers take two arguments, an expression and an environment, and
-return two values as well: an expression in the target language, and
-an environment suitable for the target language. The format of the
-environment is language-dependent.
-
-For Scheme, an environment may be one of three things:
+The job of the Scheme compiler is to expand all macros and all of
+Scheme to its most primitive expressions. The definition of
+``primitive'' is given by the inventory of constructs provided by
+Tree-IL, the target language of the Scheme compiler: procedure
+applications, conditionals, lexical references, etc. This is described
+more fully in the next section.
+
+The tricky and amusing thing about the Scheme-to-Tree-IL compiler is
+that it is completely implemented by the macro expander. Since the
+macro expander has to run over all of the source code already in order
+to expand macros, it might as well do the analysis at the same time,
+producing Tree-IL expressions directly.
+
+Because this compiler is actually the macro expander, it is
+extensible. Any macro which the user writes becomes part of the
+compiler.
+
+The Scheme-to-Tree-IL expander may be invoked using the generic
address@hidden procedure:
+
address@hidden
+(compile '(+ 1 2) #:from 'scheme #:to 'tree-il)
address@hidden
+ #<<application> src: #f
+ proc: #<<toplevel-ref> src: #f name: +>
+ args: (#<<const> src: #f exp: 1>
+ #<<const> src: #f exp: 2>)>
address@hidden lisp
+
+Or, since Tree-IL is so close to Scheme, it is often useful to expand
+Scheme to Tree-IL, then translate back to Scheme. For that reason the
+expander provides two interfaces. The former is equivalent to calling
address@hidden(sc-expand '(+ 1 2) 'c)}, where the @code{'c} is for
+``compile''. With @code{'e} (the default), the result is translated
+back to Scheme:
+
address@hidden
+(sc-expand '(+ 1 2))
address@hidden (+ 1 2)
+(sc-expand '(let ((x 10)) (* x x)))
address@hidden (let ((x84 10)) (* x84 x84))
address@hidden lisp
+
+The second example shows that as part of its job, the macro expander
+renames lexically-bound variables. The original names are preserved
+when compiling to Tree-IL, but can't be represented in Scheme: a
+lexical binding only has one name. It is for this reason that the
address@hidden output of the expander is @emph{not} Scheme. There's too
+much information we would lose if we translated to Scheme directly:
+lexical variable names, source locations, and module hygiene.
+
+Note however that @code{sc-expand} does not have the same signature as
address@hidden @code{compile-tree-il} is a small wrapper
+around @code{sc-expand}, to make it conform to the general form of
+compiler procedures in Guile's language tower.
+
+Compiler procedures take two arguments, an expression and an
+environment. They return three values: the compiled expression, the
+corresponding environment for the target language, and a
+``continuation environment''. The compiled expression and environment
+will serve as input to the next language's compiler. The
+``continuation environment'' can be used to compile another expression
+from the same source language within the same module.
+
+For example, you might compile the expression, @code{(define-module
+(foo))}. This will result in a Tree-IL expression and environment. But
+if you compiled a second expression, you would want to take into
+account the compile-time effect of compiling the previous expression,
+which puts the user in the @code{(foo)} module. That is purpose of the
+``continuation environment''; you would pass it as the environment
+when compiling the subsequent expression.
+
+For Scheme, an environment may be one of two things:
@itemize
@item @code{#f}, in which case compilation is performed in the context
-of the current module;
address@hidden a module, which specifies the context of the compilation; or
address@hidden a @dfn{compile environment}, which specifies lexical variables
-as well.
+of the current module; or
address@hidden a module, which specifies the context of the compilation.
@end itemize
-The format of a compile environment for scheme is @code{(@var{module}
address@hidden . @var{externals})}, though users are strongly
-discouraged from constructing these environments themselves. Instead,
-if you need this functionality -- as in GOOPS' dynamic method compiler
--- capture an environment with @code{compile-time-environment}, then
-pass that environment to @code{compile}.
-
address@hidden {Scheme Procedure} compile-time-environment
-A special function known to the compiler that, when compiled, will
-return a representation of the lexical environment in place at compile
-time. Useful for supporting some forms of dynamic compilation. Returns
address@hidden if called from the interpreter.
address@hidden deffn
-
address@hidden GHIL
address@hidden GHIL
address@hidden Tree-IL
address@hidden Tree-IL
-Guile High Intermediate Language (GHIL) is a structured intermediate
+Tree Intermediate Language (Tree-IL) is a structured intermediate
language that is close in expressive power to Scheme. It is an
expanded, pre-analyzed Scheme.
-GHIL is ``structured'' in the sense that its representation is based
-on records, not S-expressions. This gives a rigidity to the language
-that ensures that compiling to a lower-level language only requires a
-limited set of transformations. Practically speaking, consider the
-GHIL type, @code{<ghil-quote>}, which has fields named @code{env},
address@hidden, and @code{exp}. Instances of this type are records created
-via @code{make-ghil-quote}, and whose fields are accessed as
address@hidden, @code{ghil-quote-loc}, and
address@hidden There is also a predicate, @code{ghil-quote?}.
address@hidden, for more information on records.
-
-Expressions of GHIL name their environments explicitly, and all
-variables are referenced by identity in addition to by name.
address@hidden(language ghil)} defines a number of routines to deal explicitly
-with variables and environments:
-
address@hidden {Scheme Variable} <ghil-toplevel-env> [table='()]
-A toplevel environment. The @var{table} holds all toplevel variables
-that have been resolved in this environment.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-env> parent [table='()] [variables='()]
-A lexical environment. @var{parent} will be the enclosing lexical
-environment, or a toplevel environment. @var{table} holds an alist
-mapping symbols to variables bound in this environment, while
address@hidden holds a cumulative list of all variables ever defined
-in this environment.
-
-Lexical environments correspond to procedures. Bindings introduced
-e.g. by Scheme's @code{let} add to the bindings in a lexical
-environment. An example of a case in which a variable might be in
address@hidden but not in @var{table} would be a variable that is in
-the same procedure, but is out of scope.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-var> env name kind [index=#f]
-A variable. @var{kind} is one of @code{argument}, @code{local},
address@hidden, @code{toplevel}, @code{public}, or @code{private};
-see the procedures below for more information. @var{index} is used in
-compilation.
address@hidden deftp
-
address@hidden {Scheme Procedure} ghil-var-is-bound? env sym
-Recursively look up a variable named @var{sym} in @var{env}, and
-return it or @code{#f} if none is found.
address@hidden deffn
address@hidden {Scheme Procedure} ghil-var-for-ref! env sym
-Recursively look up a variable named @var{sym} in @var{env}, and
-return it. If the symbol was not bound, return a new toplevel
-variable.
address@hidden deffn
address@hidden {Scheme Procedure} ghil-var-for-set! env sym
-Like @code{ghil-var-for-ref!}, except that the returned variable will
-be marked as @code{external}. @xref{Variables and the VM}.
address@hidden deffn
address@hidden {Scheme Procedure} ghil-var-define! toplevel-env sym
-Return an existing or new toplevel variable named @var{sym}.
address@hidden must be a toplevel environment.
address@hidden deffn
address@hidden {Scheme Procedure} ghil-var-at-module! env modname sym interface?
-Return a variable that will be resolved at run-time with respect to a
-specific module named @var{modname}. If @var{interface?} is true, the
-variable will be of type @code{public}, otherwise @code{private}.
address@hidden deffn
address@hidden {Scheme Procedure} call-with-ghil-environment env syms func
-Bind @var{syms} to fresh variables within a new lexical environment
-whose parent is @var{env}, and call @var{func} as @code{(@var{func}
address@hidden @var{new-vars})}.
address@hidden deffn
address@hidden {Scheme Procedure} call-with-ghil-bindings env syms func
-Like @code{call-with-ghil-environment}, except the existing
-environment @var{env} is re-used. For that reason, @var{func} is
-invoked as @code{(@var{func} @var{new-vars})}
address@hidden deffn
-
-In the aforementioned @code{<ghil-quote>} type, the @var{env} slot
-holds a pointer to the environment in which the expression occurs. The
address@hidden slot holds source location information, so that errors
-corresponding to this expression can be mapped back to the initial
-expression in the higher-level language, e.g. Scheme. @xref{Compiled
-Procedures}, for more information on source location objects.
-
-GHIL also has a declarative serialization format, which makes writing
-and reading it a tractable problem for the human mind. Since all GHIL
-language constructs contain @code{env} and @code{loc} pointers, they
-are left out of the serialization. (Serializing @code{env} structures
-would be difficult, as they are often circular.) What is left is the
-type of expression, and the remaining slots defined in the expression
-type.
-
-For example, an S-expression representation of the @code{<ghil-quote>}
-expression would be:
+Tree-IL is ``structured'' in the sense that its representation is
+based on records, not S-expressions. This gives a rigidity to the
+language that ensures that compiling to a lower-level language only
+requires a limited set of transformations. Practically speaking,
+consider the Tree-IL type, @code{<const>}, which has two fields,
address@hidden and @code{exp}. Instances of this type are records created
+via @code{make-const}, and whose fields are accessed as
address@hidden, and @code{const-exp}. There is also a predicate,
address@hidden @xref{Records}, for more information on records.
+
address@hidden alpha renaming
+
+All Tree-IL types have a @code{src} slot, which holds source location
+information for the expression. This information, if present, will be
+residualized into the compiled object code, allowing backtraces to
+show source information. The format of @code{src} is the same as that
+returned by Guile's @code{source-properties} function. @xref{Source
+Properties}, for more information.
+
+Although Tree-IL objects are represented internally using records,
+there is also an equivalent S-expression external representation for
+each kind of Tree-IL. For example, an the S-expression representation
+of @code{#<const src: #f exp: 3>} expression would be:
@example
-(quote 3)
+(const 3)
@end example
-It's deceptively like Scheme. The general rule is, for a type defined
-as @code{<address@hidden> env loc @var{slot1} @var{slot2}...}, the
-S-expression representation will be @code{(@var{foo} @var{slot1}
address@hidden)}. Users may program with this format directly at the
-REPL:
+Users may program with this format directly at the REPL:
@example
-scheme@@(guile-user)> ,language ghil
-Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0
+scheme@@(guile-user)> ,language tree-il
+Tree Intermediate Language interpreter 1.0 on Guile 1.9.0
Copyright (C) 2001-2008 Free Software Foundation, Inc.
Enter `,help' for help.
-ghil@@(guile-user)> (call (ref +) (quote 32) (quote 10))
+tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10))
@result{} 42
@end example
-For convenience, some slots are serialized as rest arguments; those
-are noted below. The other caveat is that variables are serialized as
-their names only, and not their identities.
-
address@hidden {Scheme Variable} <ghil-void> env loc
-The unspecified value.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-quote> env loc exp
-A quoted expression.
-
-Note that unlike in Scheme, there are no self-quoting expressions; all
-constants must come from @code{quote} expressions.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-quasiquote> env loc exp
-A quasiquoted expression. The expression is treated as a constant,
-except for embedded @code{unquote} and @code{unquote-splicing} forms.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-unquote> env loc exp
-Like Scheme's @code{unquote}; only valid within a quasiquote.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-unquote-splicing> env loc exp
-Like Scheme's @code{unquote-splicing}; only valid within a quasiquote.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-ref> env loc var
-A variable reference. Note that for purposes of serialization,
address@hidden is serialized as its name, as a symbol.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-set> env loc var val
-A variable mutation. @var{var} is serialized as a symbol.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-define> env loc var val
-A toplevel variable definition. See @code{ghil-var-define!}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-if> env loc test then else
+The @code{src} fields are left out of the external representation.
+
address@hidden {Scheme Variable} <void> src
address@hidden {External Representation} (void)
+An empty expression. In practice, equivalent to Scheme's @code{(if #f
+#f)}.
address@hidden deftp
address@hidden {Scheme Variable} <const> src exp
address@hidden {External Representation} (const @var{exp})
+A constant.
address@hidden deftp
address@hidden {Scheme Variable} <primitive-ref> src name
address@hidden {External Representation} (primitive @var{name})
+A reference to a ``primitive''. A primitive is a procedure that, when
+compiled, may be open-coded. For example, @code{cons} is usually
+recognized as a primitive, so that it compiles down to a single
+instruction.
+
+Compilation of Tree-IL usually begins with a pass that resolves some
address@hidden<module-ref>} and @code{<toplevel-ref>} expressions to
address@hidden<primitive-ref>} expressions. The actual compilation pass
+has special cases for applications of certain primitives, like
address@hidden or @code{cons}.
address@hidden deftp
address@hidden {Scheme Variable} <lexical-ref> src name gensym
address@hidden {External Representation} (lexical @var{name} @var{gensym})
+A reference to a lexically-bound variable. The @var{name} is the
+original name of the variable in the source program. @var{gensym} is a
+unique identifier for this variable.
address@hidden deftp
address@hidden {Scheme Variable} <lexical-set> src name gensym exp
address@hidden {External Representation} (set! (lexical @var{name}
@var{gensym}) @var{exp})
+Sets a lexically-bound variable.
address@hidden deftp
address@hidden {Scheme Variable} <module-ref> src mod name public?
address@hidden {External Representation} (@@ @var{mod} @var{name})
address@hidden {External Representation} (@@@@ @var{mod} @var{name})
+A reference to a variable in a specific module. @var{mod} should be
+the name of the module, e.g. @code{(guile-user)}.
+
+If @var{public?} is true, the variable named @var{name} will be looked
+up in @var{mod}'s public interface, and serialized with @code{@@};
+otherwise it will be looked up among the module's private bindings,
+and is serialized with @code{@@@@}.
address@hidden deftp
address@hidden {Scheme Variable} <module-set> src mod name public? exp
address@hidden {External Representation} (set! (@@ @var{mod} @var{name})
@var{exp})
address@hidden {External Representation} (set! (@@@@ @var{mod} @var{name})
@var{exp})
+Sets a variable in a specific module.
address@hidden deftp
address@hidden {Scheme Variable} <toplevel-ref> src name
address@hidden {External Representation} (toplevel @var{name})
+References a variable from the current procedure's module.
address@hidden deftp
address@hidden {Scheme Variable} <toplevel-set> src name exp
address@hidden {External Representation} (set! (toplevel @var{name}) @var{exp})
+Sets a variable in the current procedure's module.
address@hidden deftp
address@hidden {Scheme Variable} <toplevel-define> src name exp
address@hidden {External Representation} (define (toplevel @var{name})
@var{exp})
+Defines a new top-level variable in the current procedure's module.
address@hidden deftp
address@hidden {Scheme Variable} <conditional> src test then else
address@hidden {External Representation} (if @var{test} @var{then} @var{else})
A conditional. Note that @var{else} is not optional.
@end deftp
address@hidden {Scheme Variable} <ghil-and> env loc . exps
-Like Scheme's @code{and}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-or> env loc . exps
-Like Scheme's @code{or}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-begin> env loc . body
-Like Scheme's @code{begin}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-bind> env loc vars exprs . body
-Like a deconstructed @code{let}: each element of @var{vars} will be
-bound to the corresponding GHIL expression in @var{exprs}.
-
-Note that for purposes of the serialization format, @var{exprs} are
-evaluated before the new bindings are added to the environment. For
address@hidden semantics, there also exists a @code{bindrec} parse
-flavor. This is useful for writing GHIL at the REPL, but the
-serializer does not currently have the cleverness needed to determine
-whether a @code{<ghil-bind>} has @code{let} or @code{letrec}
-semantics, and thus only serializes @code{<ghil-bind>} as @code{bind}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-mv-bind> env loc vars rest producer .
body
-Like Scheme's @code{receive} -- binds the values returned by
-applying @code{producer}, which should be a thunk, to the
address@hidden bindings described by @var{vars} and @var{rest}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-lambda> env loc vars rest meta . body
-A closure. @var{vars} is the argument list, serialized as a list of
-symbols. @var{rest} is a boolean, which is @code{#t} iff the last
-argument is a rest argument. @var{meta} is an association list of
-properties. The actual @var{body} should be a list of GHIL
-expressions.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-call> env loc proc . args
address@hidden {Scheme Variable} <application> src proc args
address@hidden {External Representation} (apply @var{proc} . @var{args})
A procedure call.
@end deftp
address@hidden {Scheme Variable} <ghil-mv-call> env loc producer consumer
-Like Scheme's @code{call-with-values}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-inline> env loc op . args
-An inlined VM instruction. @var{op} should be the instruction name as
-a symbol, and @var{args} should be its arguments, as GHIL expressions.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-values> env loc . values
-Like Scheme's @code{values}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-values*> env loc . values
address@hidden are as in the Scheme expression, @code{(apply values .
address@hidden)}.
address@hidden deftp
address@hidden {Scheme Variable} <ghil-reified-env> env loc
-Produces, at run-time, a reification of the environment at compile
-time. Used in the implementation of Scheme's
address@hidden
address@hidden {Scheme Variable} <sequence> src exps
address@hidden {External Representation} (begin . @var{exps})
+Like Scheme's @code{begin}.
@end deftp
-
-GHIL implements a compiler to GLIL that recursively traverses GHIL
-expressions, writing out GLIL expressions into a linear list. The
-compiler also keeps some state as to whether the current expression is
-in tail context, and whether its value will be used in future
-computations. This state allows the compiler not to emit code for
-constant expressions that will not be used (e.g. docstrings), and to
-perform tail calls when in tail position.
-
-Just as the Scheme to GHIL compiler introduced new hidden state---the
-environment---the GHIL to GLIL compiler introduces more state, the
-stack. While not represented explicitly, the stack is present in the
-compilation of each GHIL expression: compiling a GHIL expression
-should leave the run-time value stack in the same state. For example,
-if the intermediate value stack has two elements before evaluating an
address@hidden expression, it should have two elements after that
-expression.
address@hidden {Scheme Variable} <lambda> src names vars meta body
address@hidden {External Representation} (lambda @var{names} @var{vars}
@var{meta} @var{body})
+A closure. @var{names} is original binding form, as given in the
+source code, which may be an improper list. @var{vars} are gensyms
+corresponding to the @var{names}. @var{meta} is an association list of
+properties. The actual @var{body} is a single Tree-IL expression.
address@hidden deftp
address@hidden {Scheme Variable} <let> src names vars vals exp
address@hidden {External Representation} (let @var{names} @var{vars} @var{vals}
@var{exp})
+Lexical binding, like Scheme's @code{let}. @var{names} are the
+original binding names, @var{vars} are gensyms corresponding to the
address@hidden, and @var{vals} are Tree-IL expressions for the values.
address@hidden is a single Tree-IL expression.
address@hidden deftp
address@hidden {Scheme Variable} <letrec> src names vars vals exp
address@hidden {External Representation} (letrec @var{names} @var{vars}
@var{vals} @var{exp})
+A version of @code{<let>} that creates recursive bindings, like
+Scheme's @code{letrec}.
address@hidden deftp
+
address@hidden FIXME -- need to revive this one
address@hidden @deftp {Scheme Variable} <ghil-mv-bind> src vars rest producer .
body
address@hidden Like Scheme's @code{receive} -- binds the values returned by
address@hidden applying @code{producer}, which should be a thunk, to the
address@hidden @code{lambda}-like bindings described by @var{vars} and
@var{rest}.
address@hidden @end deftp
+
+Tree-IL implements a compiler to GLIL that recursively traverses
+Tree-IL expressions, writing out GLIL expressions into a linear list.
+The compiler also keeps some state as to whether the current
+expression is in tail context, and whether its value will be used in
+future computations. This state allows the compiler not to emit code
+for constant expressions that will not be used (e.g. docstrings), and
+to perform tail calls when in tail position.
+
+In the future, there will be a pass at the beginning of the
+Tree-IL->GLIL compilation step to perform inlining, copy propagation,
+dead code elimination, and constant folding.
Interested readers are encouraged to read the implementation in
address@hidden(language ghil compile-glil)} for more details.
address@hidden(language tree-il compile-glil)} for more details.
@node GLIL
@subsection GLIL
Guile Low Intermediate Language (GLIL) is a structured intermediate
-language whose expressions closely mirror the functionality of Guile's
-VM instruction set.
+language whose expressions more closely approximate Guile's VM
+instruction set.
Its expression types are defined in @code{(language glil)}, and as
with GHIL, some of its fields parse as rest arguments.
@@ -499,8 +420,8 @@ A unit of code that at run-time will correspond to a
compiled
procedure. @var{nargs} @var{nrest} @var{nlocs}, and @var{nexts}
collectively define the program's arity; see @ref{Compiled
Procedures}, for more information. @var{meta} should be an alist of
-properties, as in @code{<ghil-lambda>}. @var{body} is a list of GLIL
-expressions.
+properties, as in Tree IL's @code{<lambda>}. @var{body} is a list of
+GLIL expressions.
@end deftp
@deftp {Scheme Variable} <glil-bind> . vars
An advisory expression that notes a liveness extent for a set of
@@ -534,24 +455,23 @@ offset within a VM program.
@end deftp
@deftp {Scheme Variable} <glil-source> loc
Records source information for the preceding expression. @var{loc}
-should be a vector, @code{#(@var{line} @var{column} @var{filename})}.
+should be an association list of containing @code{line} @code{column},
+and @code{filename} keys, e.g. as returned by
address@hidden
@end deftp
@deftp {Scheme Variable} <glil-void>
Pushes the unspecified value on the stack.
@end deftp
@deftp {Scheme Variable} <glil-const> obj
Pushes a constant value onto the stack. @var{obj} must be a number,
-string, symbol, keyword, boolean, character, or a pair or vector or
-list thereof, or the empty list.
address@hidden deftp
address@hidden {Scheme Variable} <glil-argument> op index
-Accesses an argument on the stack. If @var{op} is @code{ref}, the
-argument is pushed onto the stack; if it is @code{set}, the argument
-is set from the top value on the stack, which is popped off.
+string, symbol, keyword, boolean, character, the empty list, or a pair
+or vector of constants.
@end deftp
@deftp {Scheme Variable} <glil-local> op index
-Like @code{<glil-argument>}, but for local variables. @xref{Stack
-Layout}, for more information.
+Accesses a lexically bound variable from the stack. If @var{op} is
address@hidden, the value is pushed onto the stack; if it is @code{set},
+the variable is set from the top value on the stack, which is popped
+off. @xref{Stack Layout}, for more information.
@end deftp
@deftp {Scheme Variable} <glil-external> op depth index
Accesses a heap-allocated variable, addressed by @var{depth}, the nth
@@ -563,8 +483,8 @@ Accesses a toplevel variable. @var{op} may be @code{ref},
@code{set},
or @code{define}.
@end deftp
@deftp {Scheme Variable} <glil-module> op mod name public?
-Accesses a variable within a specific module. See
address@hidden, for more information.
+Accesses a variable within a specific module. See Tree-IL's
address@hidden<module-ref>}, for more information.
@end deftp
@deftp {Scheme Variable} <glil-label> label
Creates a new label. @var{label} can be any Scheme value, and should
@@ -607,23 +527,143 @@ Just as in all of Guile's compilers, an environment is
passed to the
GLIL-to-object code compiler, and one is returned as well, along with
the object code.
address@hidden Object Code
address@hidden Object Code
address@hidden Assembly
address@hidden Assembly
+
+Assembly is an S-expression-based, human-readable representation of
+the actual bytecodes that will be emitted for the VM. As such, it is a
+useful intermediate language both for compilation and for
+decompilation.
-Object code is the serialization of the raw instruction stream of a
-program, ready for interpretation by the VM. Procedures related to
-object code are defined in the @code{(system vm objcode)} module.
+Besides the fact that it is not a record-based language, assembly
+differs from GLIL in four main ways:
+
address@hidden
address@hidden Labels have been resolved to byte offsets in the program.
address@hidden Constants inside procedures have either been expressed as inline
+instructions, and possibly cached in object arrays.
address@hidden Procedures with metadata (source location information, liveness
+extents, procedure names, generic properties, etc) have had their
+metadata serialized out to thunks.
address@hidden All expressions correspond directly to VM instructions -- i.e.,
+there is no @code{<glil-local>} which can be a ref or a set.
address@hidden itemize
+
+Assembly is isomorphic to the bytecode that it compiles to. You can
+compile to bytecode, then decompile back to assembly, and you have the
+same assembly code.
+
+The general form of assembly instructions is the following:
+
address@hidden
+(@var{inst} @var{arg} ...)
address@hidden lisp
+
+The @var{inst} names a VM instruction, and its @var{arg}s will be
+embedded in the instruction stream. The easiest way to see assembly is
+to play around with it at the REPL, as can be seen in this annotated
+example:
+
address@hidden
+scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly)
+(load-program 0 0 0 0
+ () ; Labels
+ 60 ; Length
+ #f ; Metadata
+ (make-false) ; object table for the returned lambda
+ (nop)
+ (nop) ; Alignment. Since assembly has already resolved its labels
+ (nop) ; to offsets, and programs must be 8-byte aligned since their
+ (nop) ; object code is mmap'd directly to structures, assembly
+ (nop) ; has to have the alignment embedded in it.
+ (nop)
+ (load-program 1 0 0 0
+ ()
+ 6
+ ; This is the metadata thunk for the returned procedure.
+ (load-program 0 0 0 0 () 21 #f
+ (load-symbol "x") ; Name and liveness extent for @code{x}.
+ (make-false)
+ (make-int8:0) ; Some instruction+arg combinations
+ (make-int8:0) ; have abbreviations.
+ (make-int8 6)
+ (list 0 5)
+ (list 0 1)
+ (make-eol)
+ (list 0 2)
+ (return))
+ ; And here, the actual code.
+ (local-ref 0)
+ (local-ref 0)
+ (add)
+ (return))
+ ; Return our new procedure.
+ (return))
address@hidden example
+
+Of course you can switch the REPL to assembly and enter in assembly
+S-expressions directly, like with other languages, though it is more
+difficult, given that the length fields have to be correct.
+
address@hidden Bytecode and Objcode
address@hidden Bytecode and Objcode
+
+Finally, the raw bytes. There are actually two different ``languages''
+here, corresponding to two different ways to represent the bytes.
+
+``Bytecode'' represents code as uniform byte vectors, useful for
+structuring and destructuring code on the Scheme level. Bytecode is
+the next step down from assembly:
+
address@hidden
+scheme@@(guile-user)> (compile '(+ 32 10) #:to 'assembly)
address@hidden (load-program 0 0 0 0 () 6 #f
+ (make-int8 32) (make-int8 10) (add) (return))
+scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode)
address@hidden #u8(0 0 0 0 6 0 0 0 0 0 0 0 10 32 10 10 100 48)
address@hidden example
+
+``Objcode'' is bytecode, but mapped directly to a C structure,
address@hidden scm_objcode}:
+
address@hidden
+struct scm_objcode @{
+ scm_t_uint8 nargs;
+ scm_t_uint8 nrest;
+ scm_t_uint8 nlocs;
+ scm_t_uint8 nexts;
+ scm_t_uint32 len;
+ scm_t_uint32 metalen;
+ scm_t_uint8 base[0];
address@hidden;
address@hidden example
+
+As one might imagine, objcode imposes a minimum length on the
+bytecode. Also, the multibyte fields are in native endianness, which
+makes objcode (and bytecode) system-dependent. Indeed, in the short
+example above, all but the last 5 bytes were the program's header.
+
+Objcode also has a couple of important efficiency hacks. First,
+objcode may be mapped directly from disk, allowing compiled code to be
+loaded quickly, often from the system's disk cache, and shared among
+multiple processes. Secondly, objcode may be embedded in other
+objcode, allowing procedures to have the text of other procedures
+inlined into their bodies, without the need for separate allocation of
+the code. Of course, the objcode object itself does need to be
+allocated.
+
+Procedures related to objcode are defined in the @code{(system vm
+objcode)} module.
@deffn {Scheme Procedure} objcode? obj
@deffnx {C Function} scm_objcode_p (obj)
Returns @code{#f} iff @var{obj} is object code, @code{#f} otherwise.
@end deffn
address@hidden {Scheme Procedure} bytecode->objcode bytecode nlocs nexts
address@hidden {C Function} scm_bytecode_to_objcode (bytecode, nlocs, nexts)
address@hidden {Scheme Procedure} bytecode->objcode bytecode
address@hidden {C Function} scm_bytecode_to_objcode (bytecode,)
Makes a bytecode object from @var{bytecode}, which should be a
address@hidden @var{nlocs} and @var{nexts} denote the number of
-stack and heap variables to reserve when this objcode is executed.
address@hidden
@end deffn
@deffn {Scheme Variable} load-objcode file
@@ -631,21 +671,28 @@ stack and heap variables to reserve when this objcode is
executed.
Load object code from a file named @var{file}. The file will be mapped
into memory via @code{mmap}, so this is a very fast operation.
-On disk, object code has an eight-byte cookie prepended to it, so that
-we will not execute arbitrary garbage. In addition, two more bytes are
-reserved for @var{nlocs} and @var{nexts}.
+On disk, object code has an eight-byte cookie prepended to it, to
+prevent accidental loading of arbitrary garbage.
address@hidden deffn
+
address@hidden {Scheme Variable} write-objcode objcode file
address@hidden {C Function} scm_write_objcode (objcode)
+Write object code out to a file, prepending the eight-byte cookie.
@end deffn
@deffn {Scheme Variable} objcode->u8vector objcode
@deffnx {C Function} scm_objcode_to_u8vector (objcode)
-Copy object code out to a @code{u8vector} for analysis by Scheme. The
-ten-byte header is included.
+Copy object code out to a @code{u8vector} for analysis by Scheme.
@end deffn
address@hidden {Scheme Variable} objcode->program objcode [external='()]
address@hidden {C Function} scm_objcode_to_program (objcode, external)
+The following procedure is actually in @code{(system vm program)}, but
+we'll mention it here:
+
address@hidden {Scheme Variable} make-program objcode objtable [external='()]
address@hidden {C Function} scm_make_program (objcode, objtable, external)
Load up object code into a Scheme program. The resulting program will
-be a thunk that captures closure variables from @var{external}.
+have @var{objtable} as its object table, which should be a vector or
address@hidden, and will capture the closure variables from @var{external}.
@end deffn
Object code from a file may be disassembled at the REPL via the
@@ -689,7 +736,7 @@ fruit, running programs of interest under a system-level
profiler and
determining which improvements would give the most bang for the buck.
There are many well-known efficiency hacks in the literature: Dybvig's
letrec optimization, individual boxing of heap-allocated values (and
-then store the boxes on the stack directory), optimized case-lambda
+then store the boxes on the stack directly), optimized case-lambda
expressions, stack underflow and overflow handlers, etc. Highly
recommended papers: Dybvig's HOCS, Ghuloum's compiler paper.
diff --git a/doc/ref/libguile-concepts.texi b/doc/ref/libguile-concepts.texi
index 8979f0c..15d54f5 100644
--- a/doc/ref/libguile-concepts.texi
+++ b/doc/ref/libguile-concepts.texi
@@ -182,7 +182,7 @@ As explained above, the @code{SCM} type can represent all
Scheme values.
Some values fit entirely into a @code{SCM} value (such as small
integers), but other values require additional storage in the heap (such
as strings and vectors). This additional storage is managed
-automatically by Guile. You don't need to explicitely deallocate it
+automatically by Guile. You don't need to explicitly deallocate it
when a @code{SCM} value is no longer used.
Two things must be guaranteed so that Guile is able to manage the
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 0426452..49b420c 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -111,7 +111,7 @@ The registers that a VM has are as follows:
In other architectures, the instruction pointer is sometimes called
the ``program counter'' (pc). This set of registers is pretty typical
for stack machines; their exact meanings in the context of Guile's VM
-is described in the next section.
+are described in the next section.
A virtual machine executes by loading a compiled procedure, and
executing the object code associated with that procedure. Of course,
@@ -119,14 +119,17 @@ that procedure may call other procedures, tail-call
others, ad
infinitum---indeed, within a guile whose modules have all been
compiled to object code, one might never leave the virtual machine.
address@hidden wingo: I wish the following were true, but currently we just use
address@hidden the one engine. This kind of thing is possible tho.
address@hidden wingo: The following is true, but I don't know in what context to
address@hidden describe it. A documentation FIXME.
@c A VM may have one of three engines: reckless, regular, or debugging.
@c Reckless engine is fastest but dangerous. Regular engine is normally
@c fail-safe and reasonably fast. Debugging engine is safest and
@c functional but very slow.
address@hidden (Actually we have just a regular and a debugging engine; normally
address@hidden we use the latter, it's almost as fast as the ``regular''
engine.)
+
@node Stack Layout
@subsection Stack Layout
@@ -174,7 +177,7 @@ The structure of the fixed part of an application frame is
as follows:
In the above drawing, the stack grows upward. The intermediate values
stored in the application of this frame are stored above
@code{SCM_FRAME_UPPER_ADDRESS (fp)}. @code{bp} refers to the
address@hidden scm_program*} data associated with the program at
address@hidden scm_objcode} data associated with the program at
@code{fp - 1}. @code{nargs} and @code{nlocs} are properties of the
compiled procedure, which will be discussed later.
@@ -226,7 +229,7 @@ programs are implemented, @xref{VM Programs}.
@node Variables and the VM
@subsection Variables and the VM
-Let's think about the following Scheme code as an example:
+Consider the following Scheme code as an example:
@example
(define (foo a)
@@ -236,22 +239,15 @@ Let's think about the following Scheme code as an example:
Within the lambda expression, "foo" is a top-level variable, "a" is a
lexically captured variable, and "b" is a local variable.
-That is to say: @code{b} may safely be allocated on the stack, as
-there is no enclosed procedure that references it, nor is it ever
-mutated.
address@hidden may safely be allocated on the stack, as there is no enclosed
+procedure that references it, nor is it ever mutated.
@code{a}, on the other hand, is referenced by an enclosed procedure,
that of the lambda. Thus it must be allocated on the heap, as it may
(and will) outlive the dynamic extent of the invocation of @code{foo}.
address@hidden is a toplevel variable, as mandated by Scheme's semantics:
-
address@hidden
- (define proc (foo 'bar)) ; assuming prev. definition of @code{foo}
- (define foo 42) ; redefinition
- (proc 'baz)
- @result{} (42 bar baz)
address@hidden example
address@hidden is a top-level variable, because it names the procedure
address@hidden, which is here defined at the top-level.
Note that variables that are mutated (via @code{set!}) must be
allocated on the heap, even if they are local variables. This is
@@ -276,6 +272,7 @@ You can pick apart these pieces with the accessors in
@code{(system vm
program)}. @xref{Compiled Procedures}, for a full API reference.
@cindex object table
address@hidden object array
The object array of a compiled procedure, also known as the
@dfn{object table}, holds all Scheme objects whose values are known
not to change across invocations of the procedure: constant strings,
@@ -293,31 +290,27 @@ instruction, which uses the object vector, and are almost
as fast as
local variable references.
We can see how these concepts tie together by disassembling the
address@hidden function to see what is going on:
address@hidden function we defined earlier to see what is going on:
@smallexample
scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b)))
scheme@@(guile-user)> ,x foo
Disassembly of #<program foo (a)>:
-Bytecode:
-
0 (local-ref 0) ;; `a' (arg)
2 (external-set 0) ;; `a' (arg)
- 4 (object-ref 0) ;; #<program #(0 28 #f) (b)>
- 6 (make-closure) at (unknown
file):0:16
+ 4 (object-ref 1) ;; #<program b70d2910 at <unknown
port>:0:16 (b)>
+ 6 (make-closure)
7 (return)
----------------------------------------
-Disassembly of #<program #(0 28 #f) (b)>:
+Disassembly of #<program b70d2910 at <unknown port>:0:16 (b)>:
-Bytecode:
-
- 0 (toplevel-ref 0) ;; `list'
- 2 (toplevel-ref 1) ;; `foo'
- 4 (external-ref 0) ;; (closure variable)
- 6 (local-ref 0) ;; `b' (arg)
- 8 (goto/args 3) at (unknown
file):0:28
+ 0 (toplevel-ref 1) ;; `foo'
+ 2 (external-ref 0) ;; (closure variable)
+ 4 (local-ref 0) ;; `b' (arg)
+ 6 (list 0 3) ;; 3 elements at (unknown
file):0:28
+ 9 (return)
@end smallexample
At @code{ip} 0 and 2, we do the copy from argument to heap for
@@ -336,8 +329,9 @@ Control Instructions}, for more details.
Then we see a reference to an external variable, corresponding to
@code{a}. The disassembler doesn't have enough information to give a
name to that variable, so it just marks it as being a ``closure
-variable''. Finally we see the reference to @code{b}, then a tail call
-(@code{goto/args}) with three arguments.
+variable''. Finally we see the reference to @code{b}, then the
address@hidden opcode, an inline implementation of the @code{list} scheme
+routine.
@node Instruction Set
@subsection Instruction Set
@@ -365,7 +359,8 @@ their own test-and-branch instructions:
@end example
In addition, some Scheme primitives have their own inline
-implementations, e.g. @code{cons}.
+implementations, e.g. @code{cons}, and @code{list}, as we saw in the
+previous section.
So Guile's instruction set is a @emph{complete} instruction set, in
that it provides the instructions that are suited to the problem, and
@@ -421,12 +416,6 @@ efficient in the future via addressing by frame and index.
Currently,
external variables are all consed onto a list, which results in O(N)
lookup time.
address@hidden Instruction externals
-Pushes the current list of external variables onto the stack. This
-instruction is used in the implementation of
address@hidden @xref{The Scheme Compiler}.
address@hidden deffn
-
@deffn Instruction toplevel-ref index
Push the value of the toplevel binding whose location is stored in at
position @var{index} in the object table.
@@ -440,11 +429,11 @@ created.
Alternately, the lookup may be performed relative to a particular
module, determined at compile-time (e.g. via @code{@@} or
@code{@@@@}). In that case, the cell in the object table holds a list:
address@hidden(@var{modname} @var{sym} @var{interface?})}. The symbol
address@hidden will be looked up in the module named @var{modname} (a list
-of symbols). The lookup will be performed against the module's public
-interface, unless @var{interface?} is @code{#f}, which it is for
-example when compiling @code{@@@@}.
address@hidden(@var{modname} @var{sym} @var{public?})}. The symbol @var{sym}
+will be looked up in the module named @var{modname} (a list of
+symbols). The lookup will be performed against the module's public
+interface, unless @var{public?} is @code{#f}, which it is for example
+when compiling @code{@@@@}.
In any case, if the symbol is unbound, an error is signalled.
Otherwise the initial form is replaced with the looked-up variable, an
@@ -550,8 +539,9 @@ may be encoded in 1, 2, or 4 bytes.
@deffn Instruction load-integer length
@deffnx Instruction load-unsigned-integer length
-Load a 32-bit integer (respectively unsigned integer) from the
-instruction stream.
+Load a 32-bit integer or unsigned integer from the instruction stream.
+The bytes of the integer are read in order of decreasing significance
+(i.e., big-endian).
@end deffn
@deffn Instruction load-number length
Load an arbitrary number from the instruction stream. The number is
@@ -573,43 +563,23 @@ the current toplevel environment, creating the binding if
necessary.
Push the variable corresponding to the binding.
@end deffn
address@hidden Instruction load-program length
address@hidden Instruction load-program
Load bytecode from the instruction stream, and push a compiled
-procedure. This instruction pops the following values from the stack:
+procedure.
address@hidden
address@hidden Optionally, a thunk, which when called should return metadata
-associated with this program---for example its name, the names of its
-arguments, its documentation string, debugging information, etc.
-
-Normally, this thunk its itself a compiled procedure (with no
-metadata). Metadata is represented this way so that the initial load
-of a procedure is fast: the VM just mmap's the thunk and goes. The
-symbols and pairs associated with the metadata are only created if the
-user asks for them.
-
-For information on the format of the thunk's return value,
address@hidden Procedures}.
address@hidden Optionally, the program's object table, as a vector.
-
-A program that does not reference toplevel bindings and does not use
address@hidden does not need an object table.
address@hidden Finally, either one immediate integer or four immediate integers
-representing the arity of the program.
-
-In the four-fixnum case, the values are respectively the number of
-arguments taken by the function (@var{nargs}), the number of @dfn{rest
-arguments} (@var{nrest}, 0 or 1), the number of local variables
-(@var{nlocs}) and the number of external variables (@var{nexts})
-(@pxref{Environment Control Instructions}).
-
-The common single-fixnum case represents all of these values within a
-16-bit bitmask.
address@hidden itemize
+This instruction pops one value from the stack: the program's object
+table, as a vector, or @code{#f} in the case that the program has no
+object table. A program that does not reference toplevel bindings and
+does not use @code{object-ref} does not need an object table.
+
+This instruction is unlike the rest of the loading instructions,
+because instead of parsing its data, it directly maps the instruction
+stream onto a C structure, @code{struct scm_objcode}. @xref{Bytecode
+and Objcode}, for more information.
The resulting compiled procedure will not have any ``external''
-variables captured, so it will be loaded only once but may be used
-many times to create closures.
+variables captured, so it may be loaded only once but used many times
+to create closures.
@end deffn
Finally, while this instruction is not strictly a ``loading''
@@ -620,7 +590,10 @@ here:
Pop the program object from the stack, capture the current set of
``external'' variables, and assign those external variables to a copy
of the program. Push the new program object, which shares state with
-the original program. Also captures the current module.
+the original program.
+
+At the time of this writing, the space overhead of closures is 4 words
+per closure.
@end deffn
@node Procedural Instructions
@@ -640,22 +613,24 @@ set to the returned value.
@deffn Instruction call nargs
Call the procedure located at @code{sp[-nargs]} with the @var{nargs}
-arguments located from @code{sp[0]} to @code{sp[-nargs + 1]}.
+arguments located from @code{sp[-nargs + 1]} to @code{sp[0]}.
+
+For compiled procedures, this instruction sets up a new stack frame,
+as described in @ref{Stack Layout}, and then dispatches to the first
+instruction in the called procedure, relying on the called procedure
+to return one value to the newly-created continuation. Because the new
+frame pointer will point to sp[-nargs + 1], the arguments don't have
+to be shuffled around -- they are already in place.
For non-compiled procedures (continuations, primitives, and
interpreted procedures), @code{call} will pop the procedure and
arguments off the stack, and push the result of calling
@code{scm_apply}.
-
-For compiled procedures, this instruction sets up a new stack frame,
-as described in @ref{Stack Layout}, and then dispatches to the first
-instruction in the called procedure, relying on the called procedure
-to return one value to the newly-created continuation.
@end deffn
@deffn Instruction goto/args nargs
Like @code{call}, but reusing the current continuation. This
-instruction implements tail calling as required by RnRS.
+instruction implements tail calls as required by RnRS.
For compiled procedures, that means that @code{goto/args} reuses the
current frame instead of building a new one. The @code{goto/*}
@@ -726,14 +701,14 @@ values. This is an optimization for the common
@code{(apply values
@deffn Instruction truncate-values nbinds nrest
Used in multiple-value continuations, this instruction takes the
-values that are on the stack (including the number-of-value marker)
+values that are on the stack (including the number-of-values marker)
and truncates them for a binding construct.
For example, a call to @code{(receive (x y . z) (foo) ...)} would,
logically speaking, pop off the values returned from @code{(foo)} and
push them as three values, corresponding to @code{x}, @code{y}, and
@code{z}. In that case, @var{nbinds} would be 3, and @var{nrest} would
-be 1 (to indicate that one of the bindings was a rest arguments).
+be 1 (to indicate that one of the bindings was a rest argument).
Signals an error if there is an insufficient number of values.
@end deffn
@@ -779,12 +754,14 @@ Push @var{value}, an 8-bit character, onto the stack.
@deffn Instruction list n
Pops off the top @var{n} values off of the stack, consing them up into
a list, then pushes that list on the stack. What was the topmost value
-will be the last element in the list.
+will be the last element in the list. @var{n} is a two-byte value,
+most significant byte first.
@end deffn
@deffn Instruction vector n
Create and fill a vector with the top @var{n} values from the stack,
-popping off those values and pushing on the resulting vector.
+popping off those values and pushing on the resulting vector. @var{n}
+is a two-byte value, like in @code{vector}.
@end deffn
@deffn Instruction mark
@@ -850,9 +827,8 @@ Pushes ``the unspecified value'' onto the stack.
@subsubsection Inlined Scheme Instructions
The Scheme compiler can recognize the application of standard Scheme
-procedures, or unbound variables that look like they are bound to
-standard Scheme procedures. It tries to inline these small operations
-to avoid the overhead of creating new stack frames.
+procedures. It tries to inline these small operations to avoid the
+overhead of creating new stack frames.
Since most of these operations are historically implemented as C
primitives, not inlining them would entail constantly calling out from
@@ -876,12 +852,12 @@ stream.
@deffnx Instruction eqv? x y
@deffnx Instruction equal? x y
@deffnx Instruction pair? x y
address@hidden Instruction list? x y
address@hidden Instruction list? x
@deffnx Instruction set-car! pair x
@deffnx Instruction set-cdr! pair x
@deffnx Instruction slot-ref struct n
@deffnx Instruction slot-set struct n x
address@hidden Instruction cons x
address@hidden Instruction cons x y
@deffnx Instruction car x
@deffnx Instruction cdr x
Inlined implementations of their Scheme equivalents.
diff --git a/guile-readline/ice-9/readline.scm
b/guile-readline/ice-9/readline.scm
index c35602f..19dda94 100644
--- a/guile-readline/ice-9/readline.scm
+++ b/guile-readline/ice-9/readline.scm
@@ -169,24 +169,22 @@
(define-public (set-readline-read-hook! h)
(set! read-hook h))
+(define-public apropos-completion-function
+ (let ((completions '()))
+ (lambda (text cont?)
+ (if (not cont?)
+ (set! completions
+ (map symbol->string
+ (apropos-internal
+ (string-append "^" (regexp-quote text))))))
+ (if (null? completions)
+ #f
+ (let ((retval (car completions)))
+ (begin (set! completions (cdr completions))
+ retval))))))
+
(if (provided? 'regex)
- (begin
- (define-public apropos-completion-function
- (let ((completions '()))
- (lambda (text cont?)
- (if (not cont?)
- (set! completions
- (map symbol->string
- (apropos-internal
- (string-append "^" (regexp-quote text))))))
- (if (null? completions)
- #f
- (let ((retval (car completions)))
- (begin (set! completions (cdr completions))
- retval))))))
-
- (set! *readline-completion-function* apropos-completion-function)
- ))
+ (set! *readline-completion-function* apropos-completion-function))
(define-public (with-readline-completion-function completer thunk)
"With @var{completer} as readline completion function, call @var{thunk}."
diff --git a/lang/Makefile.am b/lang/Makefile.am
index 6dc2e29..97c440d 100644
--- a/lang/Makefile.am
+++ b/lang/Makefile.am
@@ -28,6 +28,7 @@ elisp_sources = \
elisp/example.el \
elisp/interface.scm \
elisp/transform.scm \
+ elisp/expand.scm \
elisp/variables.scm \
\
elisp/primitives/buffers.scm \
diff --git a/lang/elisp/expand.scm b/lang/elisp/expand.scm
new file mode 100644
index 0000000..0599d59
--- /dev/null
+++ b/lang/elisp/expand.scm
@@ -0,0 +1,4 @@
+(define-module (lang elisp expand)
+ #:export (expand))
+
+(define (expand x) x)
diff --git a/lang/elisp/interface.scm b/lang/elisp/interface.scm
index 1e07585..fcd748f 100644
--- a/lang/elisp/interface.scm
+++ b/lang/elisp/interface.scm
@@ -1,4 +1,5 @@
(define-module (lang elisp interface)
+ #:use-syntax (lang elisp expand)
#:use-module (lang elisp internals evaluation)
#:use-module (lang elisp internals fset)
#:use-module ((lang elisp internals load) #:select ((load . elisp:load)))
@@ -66,31 +67,39 @@ one of the directories of @code{load-path}."
(string->symbol (string-append "imports:"
(number->string counter)))))))
-(define-macro (use-elisp-file file-name . imports)
- "Load Elisp code file @var{file-name} and import its definitions
+(define use-elisp-file
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ "Load Elisp code file @var{file-name} and import its definitions
into the current Scheme module. If any @var{imports} are specified,
they are interpreted as selection and renaming specifiers as per
@code{use-modules}."
- (let ((export-module-name (export-module-name)))
- `(begin
- (fluid-set! ,elisp-export-module (resolve-module ',export-module-name))
- (beautify-user-module! (resolve-module ',export-module-name))
- (load-elisp-file ,file-name)
- (use-modules (,export-module-name ,@imports))
- (fluid-set! ,elisp-export-module #f))))
+ (let ((file-name (cadr exp))
+ (env (cddr exp)))
+ (let ((export-module-name (export-module-name)))
+ `(begin
+ (fluid-set! ,elisp-export-module (resolve-module
',export-module-name))
+ (beautify-user-module! (resolve-module ',export-module-name))
+ (load-elisp-file ,file-name)
+ (use-modules (,export-module-name ,@imports))
+ (fluid-set! ,elisp-export-module #f)))))))
-(define-macro (use-elisp-library library . imports)
- "Load Elisp library @var{library} and import its definitions into
+(define use-elisp-library
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ "Load Elisp library @var{library} and import its definitions into
the current Scheme module. If any @var{imports} are specified, they
are interpreted as selection and renaming specifiers as per
@code{use-modules}."
- (let ((export-module-name (export-module-name)))
- `(begin
- (fluid-set! ,elisp-export-module (resolve-module ',export-module-name))
- (beautify-user-module! (resolve-module ',export-module-name))
- (load-elisp-library ,library)
- (use-modules (,export-module-name ,@imports))
- (fluid-set! ,elisp-export-module #f))))
+ (let ((library (cadr exp))
+ (env (cddr exp)))
+ (let ((export-module-name (export-module-name)))
+ `(begin
+ (fluid-set! ,elisp-export-module (resolve-module
',export-module-name))
+ (beautify-user-module! (resolve-module ',export-module-name))
+ (load-elisp-library ,library)
+ (use-modules (,export-module-name ,@imports))
+ (fluid-set! ,elisp-export-module #f)))))))
(define (export-to-elisp . defs)
"Export procedures and variables specified by @var{defs} to Elisp.
diff --git a/lang/elisp/internals/lambda.scm b/lang/elisp/internals/lambda.scm
index 9917c08..f7c7a4d 100644
--- a/lang/elisp/internals/lambda.scm
+++ b/lang/elisp/internals/lambda.scm
@@ -1,4 +1,5 @@
(define-module (lang elisp internals lambda)
+ #:use-syntax (lang elisp expand)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp transform)
#:export (parse-formals
diff --git a/lang/elisp/primitives/fns.scm b/lang/elisp/primitives/fns.scm
index f7a4aa0..7beb8a5 100644
--- a/lang/elisp/primitives/fns.scm
+++ b/lang/elisp/primitives/fns.scm
@@ -26,7 +26,8 @@
(fset 'symbol-function fref/error-if-void)
-(fset 'macroexpand macroexpand)
+;; FIXME -- lost in the syncase conversion
+;; (fset 'macroexpand macroexpand)
(fset 'subrp
(lambda (obj)
diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm
index 6babb3d..118b3bc 100644
--- a/lang/elisp/primitives/syntax.scm
+++ b/lang/elisp/primitives/syntax.scm
@@ -1,4 +1,5 @@
(define-module (lang elisp primitives syntax)
+ #:use-syntax (lang elisp expand)
#:use-module (lang elisp internals evaluation)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals lambda)
diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm
index ee288a7..09159c0 100644
--- a/lang/elisp/transform.scm
+++ b/lang/elisp/transform.scm
@@ -1,4 +1,5 @@
(define-module (lang elisp transform)
+ #:use-syntax (lang elisp expand)
#:use-module (lang elisp internals trace)
#:use-module (lang elisp internals fset)
#:use-module (lang elisp internals evaluation)
@@ -26,23 +27,27 @@
(define (syntax-error x)
(error "Syntax error in expression" x))
-(define-macro (scheme exp . module)
- (let ((m (if (null? module)
- the-root-module
- (save-module-excursion
- (lambda ()
- ;; In order for `resolve-module' to work as
- ;; expected, the current module must contain the
- ;; `app' variable. This is not true for #:pure
- ;; modules, specifically (lang elisp base). So,
- ;; switch to the root module (guile) before calling
- ;; resolve-module.
- (set-current-module the-root-module)
- (resolve-module (car module)))))))
- (let ((x `(,eval (,quote ,exp) ,m)))
- ;;(write x)
- ;;(newline)
- x)))
+(define scheme
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((exp (cadr exp))
+ (module (cddr exp)))
+ (let ((m (if (null? module)
+ the-root-module
+ (save-module-excursion
+ (lambda ()
+ ;; In order for `resolve-module' to work as
+ ;; expected, the current module must contain the
+ ;; `app' variable. This is not true for #:pure
+ ;; modules, specifically (lang elisp base). So,
+ ;; switch to the root module (guile) before calling
+ ;; resolve-module.
+ (set-current-module the-root-module)
+ (resolve-module (car module)))))))
+ (let ((x `(,eval (,quote ,exp) ,m)))
+ ;;(write x)
+ ;;(newline)
+ x))))))
(define (transformer x)
(cond ((pair? x)
diff --git a/lib/Makefile.am b/lib/Makefile.am
index 309e941..6f2f5c5 100644
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -9,9 +9,9 @@
# 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 count-one-bits
extensions full-read full-write strcase strftime
+# 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
count-one-bits environ extensions flock fpieee full-read full-write
iconv_open-utf lib-symbol-visibility libunistring putenv stdlib strcase
strftime striconveh string
-AUTOMAKE_OPTIONS = 1.5 gnits
+AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
SUBDIRS =
noinst_HEADERS =
@@ -27,6 +27,7 @@ DISTCLEANFILES =
MAINTAINERCLEANFILES =
AM_CPPFLAGS =
+AM_CFLAGS =
noinst_LTLIBRARIES += libgnu.la
@@ -53,6 +54,42 @@ EXTRA_DIST += alloca.in.h
## end gnulib module alloca-opt
+## begin gnulib module byteswap
+
+BUILT_SOURCES += $(BYTESWAP_H)
+
+# We need the following in order to create <byteswap.h> when the system
+# doesn't have one.
+byteswap.h: byteswap.in.h
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ cat $(srcdir)/byteswap.in.h; \
+ } > address@hidden
+ mv -f address@hidden $@
+MOSTLYCLEANFILES += byteswap.h byteswap.h-t
+
+EXTRA_DIST += byteswap.in.h
+
+## end gnulib module byteswap
+
+## begin gnulib module c-ctype
+
+libgnu_la_SOURCES += c-ctype.h c-ctype.c
+
+## end gnulib module c-ctype
+
+## begin gnulib module c-strcase
+
+libgnu_la_SOURCES += c-strcase.h c-strcasecmp.c c-strncasecmp.c
+
+## end gnulib module c-strcase
+
+## begin gnulib module c-strcaseeq
+
+
+EXTRA_DIST += c-strcaseeq.h
+
+## end gnulib module c-strcaseeq
+
## begin gnulib module configmake
# Retrieve values of the variables through 'configure' followed by
@@ -73,7 +110,7 @@ EXTRA_DIST += alloca.in.h
# The Automake-defined pkg* macros are appended, in the order
# listed in the Automake 1.10a+ documentation.
configmake.h: Makefile
- rm -f address@hidden $@
+ rm -f address@hidden
{ echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
echo '#define PREFIX "$(prefix)"'; \
echo '#define EXEC_PREFIX "$(exec_prefix)"'; \
@@ -103,7 +140,12 @@ configmake.h: Makefile
echo '#define PKGLIBDIR "$(pkglibdir)"'; \
echo '#define PKGLIBEXECDIR "$(pkglibexecdir)"'; \
} | sed '/""/d' > address@hidden
- mv address@hidden $@
+ if test -f $@ && cmp address@hidden $@ > /dev/null; then \
+ rm -f address@hidden; \
+ else \
+ rm -f $@; mv address@hidden $@; \
+ fi
+
BUILT_SOURCES += configmake.h
CLEANFILES += configmake.h configmake.h-t
@@ -116,6 +158,15 @@ EXTRA_DIST += count-one-bits.h
## end gnulib module count-one-bits
+## begin gnulib module flock
+
+
+EXTRA_DIST += flock.c
+
+EXTRA_libgnu_la_SOURCES += flock.c
+
+## end gnulib module flock
+
## begin gnulib module full-read
libgnu_la_SOURCES += full-read.h full-read.c
@@ -128,6 +179,82 @@ libgnu_la_SOURCES += full-write.h full-write.c
## end gnulib module full-write
+## begin gnulib module gperf
+
+GPERF = gperf
+
+## end gnulib module gperf
+
+## begin gnulib module havelib
+
+
+EXTRA_DIST += $(top_srcdir)/build-aux/config.rpath
+
+## end gnulib module havelib
+
+## begin gnulib module iconv_open
+
+BUILT_SOURCES += $(ICONV_H)
+
+# We need the following in order to create <iconv.h> when the system
+# doesn't have one that works with the given compiler.
+iconv.h: iconv.in.h
+ rm -f address@hidden $@
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_ICONV_H''@|$(NEXT_ICONV_H)|g' \
+ -e 's|@''ICONV_CONST''@|$(ICONV_CONST)|g' \
+ -e 's|@''REPLACE_ICONV''@|$(REPLACE_ICONV)|g' \
+ -e 's|@''REPLACE_ICONV_OPEN''@|$(REPLACE_ICONV_OPEN)|g' \
+ -e 's|@''REPLACE_ICONV_UTF''@|$(REPLACE_ICONV_UTF)|g' \
+ < $(srcdir)/iconv.in.h; \
+ } > address@hidden
+ mv address@hidden $@
+MOSTLYCLEANFILES += iconv.h iconv.h-t
+
+iconv_open-aix.h: iconv_open-aix.gperf
+ $(GPERF) -m 10 $(srcdir)/iconv_open-aix.gperf >
$(srcdir)/iconv_open-aix.h-t
+ mv $(srcdir)/iconv_open-aix.h-t $(srcdir)/iconv_open-aix.h
+iconv_open-hpux.h: iconv_open-hpux.gperf
+ $(GPERF) -m 10 $(srcdir)/iconv_open-hpux.gperf >
$(srcdir)/iconv_open-hpux.h-t
+ mv $(srcdir)/iconv_open-hpux.h-t $(srcdir)/iconv_open-hpux.h
+iconv_open-irix.h: iconv_open-irix.gperf
+ $(GPERF) -m 10 $(srcdir)/iconv_open-irix.gperf >
$(srcdir)/iconv_open-irix.h-t
+ mv $(srcdir)/iconv_open-irix.h-t $(srcdir)/iconv_open-irix.h
+iconv_open-osf.h: iconv_open-osf.gperf
+ $(GPERF) -m 10 $(srcdir)/iconv_open-osf.gperf >
$(srcdir)/iconv_open-osf.h-t
+ mv $(srcdir)/iconv_open-osf.h-t $(srcdir)/iconv_open-osf.h
+BUILT_SOURCES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h
iconv_open-osf.h
+MOSTLYCLEANFILES += iconv_open-aix.h-t iconv_open-hpux.h-t
iconv_open-irix.h-t iconv_open-osf.h-t
+MAINTAINERCLEANFILES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h
iconv_open-osf.h
+EXTRA_DIST += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h
iconv_open-osf.h
+
+EXTRA_DIST += iconv.in.h iconv_open-aix.gperf iconv_open-hpux.gperf
iconv_open-irix.gperf iconv_open-osf.gperf iconv_open.c
+
+EXTRA_libgnu_la_SOURCES += iconv_open.c
+
+## end gnulib module iconv_open
+
+## begin gnulib module iconv_open-utf
+
+
+EXTRA_DIST += iconv.c iconv_close.c
+
+EXTRA_libgnu_la_SOURCES += iconv.c iconv_close.c
+
+## end gnulib module iconv_open-utf
+
+## begin gnulib module lib-symbol-visibility
+
+# The value of $(CFLAG_VISIBILITY) needs to be added to the CFLAGS for the
+# compilation of all sources that make up the library. This line here does it
+# only for the gnulib part of it. The developer is responsible for adding
+# $(CFLAG_VISIBILITY) to the Makefile.ams of the other portions of the library.
+AM_CFLAGS += $(CFLAG_VISIBILITY)
+
+## end gnulib module lib-symbol-visibility
+
## begin gnulib module link-warning
LINK_WARNING_H=$(top_srcdir)/build-aux/link-warning.h
@@ -151,21 +278,37 @@ all-local: charset.alias ref-add.sed ref-del.sed
charset_alias = $(DESTDIR)$(libdir)/charset.alias
charset_tmp = $(DESTDIR)$(libdir)/charset.tmp
-install-exec-local: all-local
- test $(GLIBC21) != no || $(mkinstalldirs) $(DESTDIR)$(libdir)
+install-exec-local: install-exec-localcharset
+install-exec-localcharset: all-local
+ if test $(GLIBC21) = no; then \
+ case '$(host_os)' in \
+ darwin[56]*) \
+ need_charset_alias=true ;; \
+ darwin* | cygwin* | mingw* | pw32* | cegcc*) \
+ need_charset_alias=false ;; \
+ *) \
+ need_charset_alias=true ;; \
+ esac ; \
+ else \
+ need_charset_alias=false ; \
+ fi ; \
+ if $$need_charset_alias; then \
+ $(mkinstalldirs) $(DESTDIR)$(libdir) ; \
+ fi ; \
if test -f $(charset_alias); then \
sed -f ref-add.sed $(charset_alias) > $(charset_tmp) ; \
$(INSTALL_DATA) $(charset_tmp) $(charset_alias) ; \
rm -f $(charset_tmp) ; \
else \
- if test $(GLIBC21) = no; then \
+ if $$need_charset_alias; then \
sed -f ref-add.sed charset.alias > $(charset_tmp) ; \
$(INSTALL_DATA) $(charset_tmp) $(charset_alias) ; \
rm -f $(charset_tmp) ; \
fi ; \
fi
-uninstall-local: all-local
+uninstall-local: uninstall-localcharset
+uninstall-localcharset: all-local
if test -f $(charset_alias); then \
sed -f ref-del.sed $(charset_alias) > $(charset_tmp); \
if grep '^# Packages using this file: $$' $(charset_tmp) \
@@ -194,6 +337,15 @@ EXTRA_DIST += config.charset ref-add.sin ref-del.sin
## end gnulib module localcharset
+## begin gnulib module malloc-posix
+
+
+EXTRA_DIST += malloc.c
+
+EXTRA_libgnu_la_SOURCES += malloc.c
+
+## end gnulib module malloc-posix
+
## begin gnulib module mbrlen
@@ -221,6 +373,15 @@ EXTRA_libgnu_la_SOURCES += mbsinit.c
## end gnulib module mbsinit
+## begin gnulib module putenv
+
+
+EXTRA_DIST += putenv.c
+
+EXTRA_libgnu_la_SOURCES += putenv.c
+
+## end gnulib module putenv
+
## begin gnulib module safe-read
@@ -257,6 +418,107 @@ EXTRA_DIST += stdbool.in.h
## end gnulib module stdbool
+## begin gnulib module stdint
+
+BUILT_SOURCES += $(STDINT_H)
+
+# We need the following in order to create <stdint.h> when the system
+# doesn't have one that works with the given compiler.
+stdint.h: stdint.in.h
+ rm -f address@hidden $@
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ sed -e 's/@''HAVE_STDINT_H''@/$(HAVE_STDINT_H)/g' \
+ -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_STDINT_H''@|$(NEXT_STDINT_H)|g' \
+ -e 's/@''HAVE_SYS_TYPES_H''@/$(HAVE_SYS_TYPES_H)/g' \
+ -e 's/@''HAVE_INTTYPES_H''@/$(HAVE_INTTYPES_H)/g' \
+ -e 's/@''HAVE_SYS_INTTYPES_H''@/$(HAVE_SYS_INTTYPES_H)/g' \
+ -e 's/@''HAVE_SYS_BITYPES_H''@/$(HAVE_SYS_BITYPES_H)/g' \
+ -e 's/@''HAVE_LONG_LONG_INT''@/$(HAVE_LONG_LONG_INT)/g' \
+ -e
's/@''HAVE_UNSIGNED_LONG_LONG_INT''@/$(HAVE_UNSIGNED_LONG_LONG_INT)/g' \
+ -e 's/@''APPLE_UNIVERSAL_BUILD''@/$(APPLE_UNIVERSAL_BUILD)/g' \
+ -e 's/@''BITSIZEOF_PTRDIFF_T''@/$(BITSIZEOF_PTRDIFF_T)/g' \
+ -e 's/@''PTRDIFF_T_SUFFIX''@/$(PTRDIFF_T_SUFFIX)/g' \
+ -e 's/@''BITSIZEOF_SIG_ATOMIC_T''@/$(BITSIZEOF_SIG_ATOMIC_T)/g' \
+ -e
's/@''HAVE_SIGNED_SIG_ATOMIC_T''@/$(HAVE_SIGNED_SIG_ATOMIC_T)/g' \
+ -e 's/@''SIG_ATOMIC_T_SUFFIX''@/$(SIG_ATOMIC_T_SUFFIX)/g' \
+ -e 's/@''BITSIZEOF_SIZE_T''@/$(BITSIZEOF_SIZE_T)/g' \
+ -e 's/@''SIZE_T_SUFFIX''@/$(SIZE_T_SUFFIX)/g' \
+ -e 's/@''BITSIZEOF_WCHAR_T''@/$(BITSIZEOF_WCHAR_T)/g' \
+ -e 's/@''HAVE_SIGNED_WCHAR_T''@/$(HAVE_SIGNED_WCHAR_T)/g' \
+ -e 's/@''WCHAR_T_SUFFIX''@/$(WCHAR_T_SUFFIX)/g' \
+ -e 's/@''BITSIZEOF_WINT_T''@/$(BITSIZEOF_WINT_T)/g' \
+ -e 's/@''HAVE_SIGNED_WINT_T''@/$(HAVE_SIGNED_WINT_T)/g' \
+ -e 's/@''WINT_T_SUFFIX''@/$(WINT_T_SUFFIX)/g' \
+ < $(srcdir)/stdint.in.h; \
+ } > address@hidden
+ mv address@hidden $@
+MOSTLYCLEANFILES += stdint.h stdint.h-t
+
+EXTRA_DIST += stdint.in.h
+
+## end gnulib module stdint
+
+## begin gnulib module stdlib
+
+BUILT_SOURCES += stdlib.h
+
+# We need the following in order to create <stdlib.h> when the system
+# doesn't have one that works with the given compiler.
+stdlib.h: stdlib.in.h
+ rm -f address@hidden $@
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_STDLIB_H''@|$(NEXT_STDLIB_H)|g' \
+ -e 's|@''HAVE_RANDOM_H''@|$(HAVE_RANDOM_H)|g' \
+ -e 's|@''GNULIB_MALLOC_POSIX''@|$(GNULIB_MALLOC_POSIX)|g' \
+ -e 's|@''GNULIB_REALLOC_POSIX''@|$(GNULIB_REALLOC_POSIX)|g' \
+ -e 's|@''GNULIB_CALLOC_POSIX''@|$(GNULIB_CALLOC_POSIX)|g' \
+ -e 's|@''GNULIB_ATOLL''@|$(GNULIB_ATOLL)|g' \
+ -e 's|@''GNULIB_GETLOADAVG''@|$(GNULIB_GETLOADAVG)|g' \
+ -e 's|@''GNULIB_GETSUBOPT''@|$(GNULIB_GETSUBOPT)|g' \
+ -e 's|@''GNULIB_MKDTEMP''@|$(GNULIB_MKDTEMP)|g' \
+ -e 's|@''GNULIB_MKSTEMP''@|$(GNULIB_MKSTEMP)|g' \
+ -e 's|@''GNULIB_PUTENV''@|$(GNULIB_PUTENV)|g' \
+ -e 's|@''GNULIB_RANDOM_R''@|$(GNULIB_RANDOM_R)|g' \
+ -e 's|@''GNULIB_RPMATCH''@|$(GNULIB_RPMATCH)|g' \
+ -e 's|@''GNULIB_SETENV''@|$(GNULIB_SETENV)|g' \
+ -e 's|@''GNULIB_STRTOD''@|$(GNULIB_STRTOD)|g' \
+ -e 's|@''GNULIB_STRTOLL''@|$(GNULIB_STRTOLL)|g' \
+ -e 's|@''GNULIB_STRTOULL''@|$(GNULIB_STRTOULL)|g' \
+ -e 's|@''GNULIB_UNSETENV''@|$(GNULIB_UNSETENV)|g' \
+ -e 's|@''HAVE_ATOLL''@|$(HAVE_ATOLL)|g' \
+ -e 's|@''HAVE_CALLOC_POSIX''@|$(HAVE_CALLOC_POSIX)|g' \
+ -e 's|@''HAVE_GETSUBOPT''@|$(HAVE_GETSUBOPT)|g' \
+ -e 's|@''HAVE_MALLOC_POSIX''@|$(HAVE_MALLOC_POSIX)|g' \
+ -e 's|@''HAVE_MKDTEMP''@|$(HAVE_MKDTEMP)|g' \
+ -e 's|@''HAVE_REALLOC_POSIX''@|$(HAVE_REALLOC_POSIX)|g' \
+ -e 's|@''HAVE_RANDOM_R''@|$(HAVE_RANDOM_R)|g' \
+ -e 's|@''HAVE_RPMATCH''@|$(HAVE_RPMATCH)|g' \
+ -e 's|@''HAVE_SETENV''@|$(HAVE_SETENV)|g' \
+ -e 's|@''HAVE_STRTOD''@|$(HAVE_STRTOD)|g' \
+ -e 's|@''HAVE_STRTOLL''@|$(HAVE_STRTOLL)|g' \
+ -e 's|@''HAVE_STRTOULL''@|$(HAVE_STRTOULL)|g' \
+ -e 's|@''HAVE_STRUCT_RANDOM_DATA''@|$(HAVE_STRUCT_RANDOM_DATA)|g'
\
+ -e 's|@''HAVE_SYS_LOADAVG_H''@|$(HAVE_SYS_LOADAVG_H)|g' \
+ -e 's|@''HAVE_UNSETENV''@|$(HAVE_UNSETENV)|g' \
+ -e 's|@''HAVE_DECL_GETLOADAVG''@|$(HAVE_DECL_GETLOADAVG)|g' \
+ -e 's|@''REPLACE_MKSTEMP''@|$(REPLACE_MKSTEMP)|g' \
+ -e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \
+ -e 's|@''REPLACE_STRTOD''@|$(REPLACE_STRTOD)|g' \
+ -e 's|@''VOID_UNSETENV''@|$(VOID_UNSETENV)|g' \
+ -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ < $(srcdir)/stdlib.in.h; \
+ } > address@hidden
+ mv address@hidden $@
+MOSTLYCLEANFILES += stdlib.h stdlib.h-t
+
+EXTRA_DIST += stdlib.in.h
+
+## end gnulib module stdlib
+
## begin gnulib module strcase
@@ -282,6 +544,95 @@ EXTRA_libgnu_la_SOURCES += strftime.c
## end gnulib module strftime
+## begin gnulib module striconveh
+
+libgnu_la_SOURCES += striconveh.h striconveh.c
+if GL_COND_LIBTOOL
+libgnu_la_LDFLAGS += $(LTLIBICONV)
+endif
+
+EXTRA_DIST += iconveh.h
+
+## end gnulib module striconveh
+
+## begin gnulib module string
+
+BUILT_SOURCES += string.h
+
+# We need the following in order to create <string.h> when the system
+# doesn't have one that works with the given compiler.
+string.h: string.in.h
+ rm -f address@hidden $@
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
+ sed -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_STRING_H''@|$(NEXT_STRING_H)|g' \
+ -e 's|@''GNULIB_MBSLEN''@|$(GNULIB_MBSLEN)|g' \
+ -e 's|@''GNULIB_MBSNLEN''@|$(GNULIB_MBSNLEN)|g' \
+ -e 's|@''GNULIB_MBSCHR''@|$(GNULIB_MBSCHR)|g' \
+ -e 's|@''GNULIB_MBSRCHR''@|$(GNULIB_MBSRCHR)|g' \
+ -e 's|@''GNULIB_MBSSTR''@|$(GNULIB_MBSSTR)|g' \
+ -e 's|@''GNULIB_MBSCASECMP''@|$(GNULIB_MBSCASECMP)|g' \
+ -e 's|@''GNULIB_MBSNCASECMP''@|$(GNULIB_MBSNCASECMP)|g' \
+ -e 's|@''GNULIB_MBSPCASECMP''@|$(GNULIB_MBSPCASECMP)|g' \
+ -e 's|@''GNULIB_MBSCASESTR''@|$(GNULIB_MBSCASESTR)|g' \
+ -e 's|@''GNULIB_MBSCSPN''@|$(GNULIB_MBSCSPN)|g' \
+ -e 's|@''GNULIB_MBSPBRK''@|$(GNULIB_MBSPBRK)|g' \
+ -e 's|@''GNULIB_MBSSPN''@|$(GNULIB_MBSSPN)|g' \
+ -e 's|@''GNULIB_MBSSEP''@|$(GNULIB_MBSSEP)|g' \
+ -e 's|@''GNULIB_MBSTOK_R''@|$(GNULIB_MBSTOK_R)|g' \
+ -e 's|@''GNULIB_MEMMEM''@|$(GNULIB_MEMMEM)|g' \
+ -e 's|@''GNULIB_MEMPCPY''@|$(GNULIB_MEMPCPY)|g' \
+ -e 's|@''GNULIB_MEMRCHR''@|$(GNULIB_MEMRCHR)|g' \
+ -e 's|@''GNULIB_RAWMEMCHR''@|$(GNULIB_RAWMEMCHR)|g' \
+ -e 's|@''GNULIB_STPCPY''@|$(GNULIB_STPCPY)|g' \
+ -e 's|@''GNULIB_STPNCPY''@|$(GNULIB_STPNCPY)|g' \
+ -e 's|@''GNULIB_STRCHRNUL''@|$(GNULIB_STRCHRNUL)|g' \
+ -e 's|@''GNULIB_STRDUP''@|$(GNULIB_STRDUP)|g' \
+ -e 's|@''GNULIB_STRNDUP''@|$(GNULIB_STRNDUP)|g' \
+ -e 's|@''GNULIB_STRNLEN''@|$(GNULIB_STRNLEN)|g' \
+ -e 's|@''GNULIB_STRPBRK''@|$(GNULIB_STRPBRK)|g' \
+ -e 's|@''GNULIB_STRSEP''@|$(GNULIB_STRSEP)|g' \
+ -e 's|@''GNULIB_STRSTR''@|$(GNULIB_STRSTR)|g' \
+ -e 's|@''GNULIB_STRCASESTR''@|$(GNULIB_STRCASESTR)|g' \
+ -e 's|@''GNULIB_STRTOK_R''@|$(GNULIB_STRTOK_R)|g' \
+ -e 's|@''GNULIB_STRERROR''@|$(GNULIB_STRERROR)|g' \
+ -e 's|@''GNULIB_STRSIGNAL''@|$(GNULIB_STRSIGNAL)|g' \
+ -e 's|@''GNULIB_STRVERSCMP''@|$(GNULIB_STRVERSCMP)|g' \
+ -e 's|@''HAVE_DECL_MEMMEM''@|$(HAVE_DECL_MEMMEM)|g' \
+ -e 's|@''HAVE_MEMPCPY''@|$(HAVE_MEMPCPY)|g' \
+ -e 's|@''HAVE_DECL_MEMRCHR''@|$(HAVE_DECL_MEMRCHR)|g' \
+ -e 's|@''HAVE_RAWMEMCHR''@|$(HAVE_RAWMEMCHR)|g' \
+ -e 's|@''HAVE_STPCPY''@|$(HAVE_STPCPY)|g' \
+ -e 's|@''HAVE_STPNCPY''@|$(HAVE_STPNCPY)|g' \
+ -e 's|@''HAVE_STRCHRNUL''@|$(HAVE_STRCHRNUL)|g' \
+ -e 's|@''HAVE_DECL_STRDUP''@|$(HAVE_DECL_STRDUP)|g' \
+ -e 's|@''HAVE_STRNDUP''@|$(HAVE_STRNDUP)|g' \
+ -e 's|@''HAVE_DECL_STRNDUP''@|$(HAVE_DECL_STRNDUP)|g' \
+ -e 's|@''HAVE_DECL_STRNLEN''@|$(HAVE_DECL_STRNLEN)|g' \
+ -e 's|@''HAVE_STRPBRK''@|$(HAVE_STRPBRK)|g' \
+ -e 's|@''HAVE_STRSEP''@|$(HAVE_STRSEP)|g' \
+ -e 's|@''HAVE_STRCASESTR''@|$(HAVE_STRCASESTR)|g' \
+ -e 's|@''HAVE_DECL_STRTOK_R''@|$(HAVE_DECL_STRTOK_R)|g' \
+ -e 's|@''HAVE_DECL_STRERROR''@|$(HAVE_DECL_STRERROR)|g' \
+ -e 's|@''HAVE_DECL_STRSIGNAL''@|$(HAVE_DECL_STRSIGNAL)|g' \
+ -e 's|@''HAVE_STRVERSCMP''@|$(HAVE_STRVERSCMP)|g' \
+ -e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \
+ -e 's|@''REPLACE_STRCASESTR''@|$(REPLACE_STRCASESTR)|g' \
+ -e 's|@''REPLACE_STRDUP''@|$(REPLACE_STRDUP)|g' \
+ -e 's|@''REPLACE_STRSTR''@|$(REPLACE_STRSTR)|g' \
+ -e 's|@''REPLACE_STRERROR''@|$(REPLACE_STRERROR)|g' \
+ -e 's|@''REPLACE_STRSIGNAL''@|$(REPLACE_STRSIGNAL)|g' \
+ -e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
+ < $(srcdir)/string.in.h; \
+ } > address@hidden
+ mv address@hidden $@
+MOSTLYCLEANFILES += string.h string.h-t
+
+EXTRA_DIST += string.in.h
+
+## end gnulib module string
+
## begin gnulib module strings
BUILT_SOURCES += strings.h
@@ -306,6 +657,32 @@ EXTRA_DIST += strings.in.h
## end gnulib module strings
+## begin gnulib module sys_file
+
+BUILT_SOURCES += $(SYS_FILE_H)
+
+# We need the following in order to create <sys/file.h> when the system
+# has one that is incomplete.
+sys/file.h: sys_file.in.h
+ @MKDIR_P@ sys
+ rm -f address@hidden $@
+ { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \
+ sed -e 's/@''HAVE_SYS_FILE_H''@/$(HAVE_SYS_FILE_H)/g' \
+ -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
+ -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
+ -e 's|@''NEXT_SYS_FILE_H''@|$(NEXT_SYS_FILE_H)|g' \
+ -e 's/@''HAVE_FLOCK''@/$(HAVE_FLOCK)/g' \
+ -e 's/@''GNULIB_FLOCK''@/$(GNULIB_FLOCK)/g' \
+ < $(srcdir)/sys_file.in.h; \
+ } > address@hidden
+ mv address@hidden $@
+MOSTLYCLEANFILES += sys/file.h sys/file.h-t
+MOSTLYCLEANDIRS += sys
+
+EXTRA_DIST += sys_file.in.h
+
+## end gnulib module sys_file
+
## begin gnulib module time
BUILT_SOURCES += time.h
@@ -371,6 +748,7 @@ unistd.h: unistd.in.h
-e 's|@''GNULIB_GETPAGESIZE''@|$(GNULIB_GETPAGESIZE)|g' \
-e 's|@''GNULIB_GETUSERSHELL''@|$(GNULIB_GETUSERSHELL)|g' \
-e 's|@''GNULIB_LCHOWN''@|$(GNULIB_LCHOWN)|g' \
+ -e 's|@''GNULIB_LINK''@|$(GNULIB_LINK)|g' \
-e 's|@''GNULIB_LSEEK''@|$(GNULIB_LSEEK)|g' \
-e 's|@''GNULIB_READLINK''@|$(GNULIB_READLINK)|g' \
-e 's|@''GNULIB_SLEEP''@|$(GNULIB_SLEEP)|g' \
@@ -385,6 +763,7 @@ unistd.h: unistd.in.h
-e 's|@''HAVE_GETHOSTNAME''@|$(HAVE_GETHOSTNAME)|g' \
-e 's|@''HAVE_GETPAGESIZE''@|$(HAVE_GETPAGESIZE)|g' \
-e 's|@''HAVE_GETUSERSHELL''@|$(HAVE_GETUSERSHELL)|g' \
+ -e 's|@''HAVE_LINK''@|$(HAVE_LINK)|g' \
-e 's|@''HAVE_READLINK''@|$(HAVE_READLINK)|g' \
-e 's|@''HAVE_SLEEP''@|$(HAVE_SLEEP)|g' \
-e 's|@''HAVE_DECL_ENVIRON''@|$(HAVE_DECL_ENVIRON)|g' \
@@ -410,6 +789,50 @@ EXTRA_DIST += unistd.in.h
## end gnulib module unistd
+## begin gnulib module unistr/base
+
+
+EXTRA_DIST += unistr.h
+
+## end gnulib module unistr/base
+
+## begin gnulib module unistr/u8-mbtouc
+
+libgnu_la_SOURCES += unistr/u8-mbtouc.c unistr/u8-mbtouc-aux.c
+
+## end gnulib module unistr/u8-mbtouc
+
+## begin gnulib module unistr/u8-mbtouc-unsafe
+
+libgnu_la_SOURCES += unistr/u8-mbtouc-unsafe.c unistr/u8-mbtouc-unsafe-aux.c
+
+## end gnulib module unistr/u8-mbtouc-unsafe
+
+## begin gnulib module unistr/u8-mbtoucr
+
+libgnu_la_SOURCES += unistr/u8-mbtoucr.c
+
+## end gnulib module unistr/u8-mbtoucr
+
+## begin gnulib module unistr/u8-prev
+
+libgnu_la_SOURCES += unistr/u8-prev.c
+
+## end gnulib module unistr/u8-prev
+
+## begin gnulib module unistr/u8-uctomb
+
+libgnu_la_SOURCES += unistr/u8-uctomb.c unistr/u8-uctomb-aux.c
+
+## end gnulib module unistr/u8-uctomb
+
+## begin gnulib module unitypes
+
+
+EXTRA_DIST += unitypes.h
+
+## end gnulib module unitypes
+
## begin gnulib module verify
libgnu_la_SOURCES += verify.h
@@ -462,6 +885,7 @@ wchar.h: wchar.in.h
-e 's|@''REPLACE_MBSNRTOWCS''@|$(REPLACE_MBSNRTOWCS)|g' \
-e 's|@''REPLACE_WCRTOMB''@|$(REPLACE_WCRTOMB)|g' \
-e 's|@''REPLACE_WCSRTOMBS''@|$(REPLACE_WCSRTOMBS)|g' \
+ -e 's|@''REPLACE_WCSNRTOMBS''@|$(REPLACE_WCSNRTOMBS)|g' \
-e 's|@''REPLACE_WCWIDTH''@|$(REPLACE_WCWIDTH)|g' \
-e '/definition of GL_LINK_WARNING/r $(LINK_WARNING_H)' \
< $(srcdir)/wchar.in.h; \
diff --git a/lib/byteswap.in.h b/lib/byteswap.in.h
new file mode 100644
index 0000000..f03463d
--- /dev/null
+++ b/lib/byteswap.in.h
@@ -0,0 +1,44 @@
+/* byteswap.h - Byte swapping
+ Copyright (C) 2005, 2007 Free Software Foundation, Inc.
+ Written by Oskar Liljeblad <address@hidden>, 2005.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef _GL_BYTESWAP_H
+#define _GL_BYTESWAP_H
+
+/* Given an unsigned 16-bit argument X, return the value corresponding to
+ X with reversed byte order. */
+#define bswap_16(x) ((((x) & 0x00FF) << 8) | \
+ (((x) & 0xFF00) >> 8))
+
+/* Given an unsigned 32-bit argument X, return the value corresponding to
+ X with reversed byte order. */
+#define bswap_32(x) ((((x) & 0x000000FF) << 24) | \
+ (((x) & 0x0000FF00) << 8) | \
+ (((x) & 0x00FF0000) >> 8) | \
+ (((x) & 0xFF000000) >> 24))
+
+/* Given an unsigned 64-bit argument X, return the value corresponding to
+ X with reversed byte order. */
+#define bswap_64(x) ((((x) & 0x00000000000000FFULL) << 56) | \
+ (((x) & 0x000000000000FF00ULL) << 40) | \
+ (((x) & 0x0000000000FF0000ULL) << 24) | \
+ (((x) & 0x00000000FF000000ULL) << 8) | \
+ (((x) & 0x000000FF00000000ULL) >> 8) | \
+ (((x) & 0x0000FF0000000000ULL) >> 24) | \
+ (((x) & 0x00FF000000000000ULL) >> 40) | \
+ (((x) & 0xFF00000000000000ULL) >> 56))
+
+#endif /* _GL_BYTESWAP_H */
diff --git a/lib/c-ctype.c b/lib/c-ctype.c
new file mode 100644
index 0000000..e36a513
--- /dev/null
+++ b/lib/c-ctype.c
@@ -0,0 +1,396 @@
+/* Character handling in C locale.
+
+ Copyright 2000-2003, 2006 Free Software Foundation, Inc.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU Lesser General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public License
+along with this program; if not, write to the Free Software Foundation,
+Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#include <config.h>
+
+/* Specification. */
+#define NO_C_CTYPE_MACROS
+#include "c-ctype.h"
+
+/* The function isascii is not locale dependent. Its use in EBCDIC is
+ questionable. */
+bool
+c_isascii (int c)
+{
+ return (c >= 0x00 && c <= 0x7f);
+}
+
+bool
+c_isalnum (int c)
+{
+#if C_CTYPE_CONSECUTIVE_DIGITS \
+ && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE
+#if C_CTYPE_ASCII
+ return ((c >= '0' && c <= '9')
+ || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'));
+#else
+ return ((c >= '0' && c <= '9')
+ || (c >= 'A' && c <= 'Z')
+ || (c >= 'a' && c <= 'z'));
+#endif
+#else
+ switch (c)
+ {
+ case '0': case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9':
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ case 'G': case 'H': case 'I': case 'J': case 'K': case 'L':
+ case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
+ case 'S': case 'T': case 'U': case 'V': case 'W': case 'X':
+ case 'Y': case 'Z':
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ case 'g': case 'h': case 'i': case 'j': case 'k': case 'l':
+ case 'm': case 'n': case 'o': case 'p': case 'q': case 'r':
+ case 's': case 't': case 'u': case 'v': case 'w': case 'x':
+ case 'y': case 'z':
+ return 1;
+ default:
+ return 0;
+ }
+#endif
+}
+
+bool
+c_isalpha (int c)
+{
+#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE
+#if C_CTYPE_ASCII
+ return ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z');
+#else
+ return ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z'));
+#endif
+#else
+ switch (c)
+ {
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ case 'G': case 'H': case 'I': case 'J': case 'K': case 'L':
+ case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
+ case 'S': case 'T': case 'U': case 'V': case 'W': case 'X':
+ case 'Y': case 'Z':
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ case 'g': case 'h': case 'i': case 'j': case 'k': case 'l':
+ case 'm': case 'n': case 'o': case 'p': case 'q': case 'r':
+ case 's': case 't': case 'u': case 'v': case 'w': case 'x':
+ case 'y': case 'z':
+ return 1;
+ default:
+ return 0;
+ }
+#endif
+}
+
+bool
+c_isblank (int c)
+{
+ return (c == ' ' || c == '\t');
+}
+
+bool
+c_iscntrl (int c)
+{
+#if C_CTYPE_ASCII
+ return ((c & ~0x1f) == 0 || c == 0x7f);
+#else
+ switch (c)
+ {
+ case ' ': case '!': case '"': case '#': case '$': case '%':
+ case '&': case '\'': case '(': case ')': case '*': case '+':
+ case ',': case '-': case '.': case '/':
+ case '0': case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9':
+ case ':': case ';': case '<': case '=': case '>': case '?':
+ case '@':
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ case 'G': case 'H': case 'I': case 'J': case 'K': case 'L':
+ case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
+ case 'S': case 'T': case 'U': case 'V': case 'W': case 'X':
+ case 'Y': case 'Z':
+ case '[': case '\\': case ']': case '^': case '_': case '`':
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ case 'g': case 'h': case 'i': case 'j': case 'k': case 'l':
+ case 'm': case 'n': case 'o': case 'p': case 'q': case 'r':
+ case 's': case 't': case 'u': case 'v': case 'w': case 'x':
+ case 'y': case 'z':
+ case '{': case '|': case '}': case '~':
+ return 0;
+ default:
+ return 1;
+ }
+#endif
+}
+
+bool
+c_isdigit (int c)
+{
+#if C_CTYPE_CONSECUTIVE_DIGITS
+ return (c >= '0' && c <= '9');
+#else
+ switch (c)
+ {
+ case '0': case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9':
+ return 1;
+ default:
+ return 0;
+ }
+#endif
+}
+
+bool
+c_islower (int c)
+{
+#if C_CTYPE_CONSECUTIVE_LOWERCASE
+ return (c >= 'a' && c <= 'z');
+#else
+ switch (c)
+ {
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ case 'g': case 'h': case 'i': case 'j': case 'k': case 'l':
+ case 'm': case 'n': case 'o': case 'p': case 'q': case 'r':
+ case 's': case 't': case 'u': case 'v': case 'w': case 'x':
+ case 'y': case 'z':
+ return 1;
+ default:
+ return 0;
+ }
+#endif
+}
+
+bool
+c_isgraph (int c)
+{
+#if C_CTYPE_ASCII
+ return (c >= '!' && c <= '~');
+#else
+ switch (c)
+ {
+ case '!': case '"': case '#': case '$': case '%': case '&':
+ case '\'': case '(': case ')': case '*': case '+': case ',':
+ case '-': case '.': case '/':
+ case '0': case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9':
+ case ':': case ';': case '<': case '=': case '>': case '?':
+ case '@':
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ case 'G': case 'H': case 'I': case 'J': case 'K': case 'L':
+ case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
+ case 'S': case 'T': case 'U': case 'V': case 'W': case 'X':
+ case 'Y': case 'Z':
+ case '[': case '\\': case ']': case '^': case '_': case '`':
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ case 'g': case 'h': case 'i': case 'j': case 'k': case 'l':
+ case 'm': case 'n': case 'o': case 'p': case 'q': case 'r':
+ case 's': case 't': case 'u': case 'v': case 'w': case 'x':
+ case 'y': case 'z':
+ case '{': case '|': case '}': case '~':
+ return 1;
+ default:
+ return 0;
+ }
+#endif
+}
+
+bool
+c_isprint (int c)
+{
+#if C_CTYPE_ASCII
+ return (c >= ' ' && c <= '~');
+#else
+ switch (c)
+ {
+ case ' ': case '!': case '"': case '#': case '$': case '%':
+ case '&': case '\'': case '(': case ')': case '*': case '+':
+ case ',': case '-': case '.': case '/':
+ case '0': case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9':
+ case ':': case ';': case '<': case '=': case '>': case '?':
+ case '@':
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ case 'G': case 'H': case 'I': case 'J': case 'K': case 'L':
+ case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
+ case 'S': case 'T': case 'U': case 'V': case 'W': case 'X':
+ case 'Y': case 'Z':
+ case '[': case '\\': case ']': case '^': case '_': case '`':
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ case 'g': case 'h': case 'i': case 'j': case 'k': case 'l':
+ case 'm': case 'n': case 'o': case 'p': case 'q': case 'r':
+ case 's': case 't': case 'u': case 'v': case 'w': case 'x':
+ case 'y': case 'z':
+ case '{': case '|': case '}': case '~':
+ return 1;
+ default:
+ return 0;
+ }
+#endif
+}
+
+bool
+c_ispunct (int c)
+{
+#if C_CTYPE_ASCII
+ return ((c >= '!' && c <= '~')
+ && !((c >= '0' && c <= '9')
+ || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z')));
+#else
+ switch (c)
+ {
+ case '!': case '"': case '#': case '$': case '%': case '&':
+ case '\'': case '(': case ')': case '*': case '+': case ',':
+ case '-': case '.': case '/':
+ case ':': case ';': case '<': case '=': case '>': case '?':
+ case '@':
+ case '[': case '\\': case ']': case '^': case '_': case '`':
+ case '{': case '|': case '}': case '~':
+ return 1;
+ default:
+ return 0;
+ }
+#endif
+}
+
+bool
+c_isspace (int c)
+{
+ return (c == ' ' || c == '\t'
+ || c == '\n' || c == '\v' || c == '\f' || c == '\r');
+}
+
+bool
+c_isupper (int c)
+{
+#if C_CTYPE_CONSECUTIVE_UPPERCASE
+ return (c >= 'A' && c <= 'Z');
+#else
+ switch (c)
+ {
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ case 'G': case 'H': case 'I': case 'J': case 'K': case 'L':
+ case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
+ case 'S': case 'T': case 'U': case 'V': case 'W': case 'X':
+ case 'Y': case 'Z':
+ return 1;
+ default:
+ return 0;
+ }
+#endif
+}
+
+bool
+c_isxdigit (int c)
+{
+#if C_CTYPE_CONSECUTIVE_DIGITS \
+ && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE
+#if C_CTYPE_ASCII
+ return ((c >= '0' && c <= '9')
+ || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'F'));
+#else
+ return ((c >= '0' && c <= '9')
+ || (c >= 'A' && c <= 'F')
+ || (c >= 'a' && c <= 'f'));
+#endif
+#else
+ switch (c)
+ {
+ case '0': case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9':
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ return 1;
+ default:
+ return 0;
+ }
+#endif
+}
+
+int
+c_tolower (int c)
+{
+#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE
+ return (c >= 'A' && c <= 'Z' ? c - 'A' + 'a' : c);
+#else
+ switch (c)
+ {
+ case 'A': return 'a';
+ case 'B': return 'b';
+ case 'C': return 'c';
+ case 'D': return 'd';
+ case 'E': return 'e';
+ case 'F': return 'f';
+ case 'G': return 'g';
+ case 'H': return 'h';
+ case 'I': return 'i';
+ case 'J': return 'j';
+ case 'K': return 'k';
+ case 'L': return 'l';
+ case 'M': return 'm';
+ case 'N': return 'n';
+ case 'O': return 'o';
+ case 'P': return 'p';
+ case 'Q': return 'q';
+ case 'R': return 'r';
+ case 'S': return 's';
+ case 'T': return 't';
+ case 'U': return 'u';
+ case 'V': return 'v';
+ case 'W': return 'w';
+ case 'X': return 'x';
+ case 'Y': return 'y';
+ case 'Z': return 'z';
+ default: return c;
+ }
+#endif
+}
+
+int
+c_toupper (int c)
+{
+#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE
+ return (c >= 'a' && c <= 'z' ? c - 'a' + 'A' : c);
+#else
+ switch (c)
+ {
+ case 'a': return 'A';
+ case 'b': return 'B';
+ case 'c': return 'C';
+ case 'd': return 'D';
+ case 'e': return 'E';
+ case 'f': return 'F';
+ case 'g': return 'G';
+ case 'h': return 'H';
+ case 'i': return 'I';
+ case 'j': return 'J';
+ case 'k': return 'K';
+ case 'l': return 'L';
+ case 'm': return 'M';
+ case 'n': return 'N';
+ case 'o': return 'O';
+ case 'p': return 'P';
+ case 'q': return 'Q';
+ case 'r': return 'R';
+ case 's': return 'S';
+ case 't': return 'T';
+ case 'u': return 'U';
+ case 'v': return 'V';
+ case 'w': return 'W';
+ case 'x': return 'X';
+ case 'y': return 'Y';
+ case 'z': return 'Z';
+ default: return c;
+ }
+#endif
+}
diff --git a/lib/c-ctype.h b/lib/c-ctype.h
new file mode 100644
index 0000000..d7b067e
--- /dev/null
+++ b/lib/c-ctype.h
@@ -0,0 +1,295 @@
+/* Character handling in C locale.
+
+ These functions work like the corresponding functions in <ctype.h>,
+ except that they have the C (POSIX) locale hardwired, whereas the
+ <ctype.h> functions' behaviour depends on the current locale set via
+ setlocale.
+
+ Copyright (C) 2000-2003, 2006, 2008 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 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public License
+along with this program; if not, write to the Free Software Foundation,
+Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#ifndef C_CTYPE_H
+#define C_CTYPE_H
+
+#include <stdbool.h>
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+/* The functions defined in this file assume the "C" locale and a character
+ set without diacritics (ASCII-US or EBCDIC-US or something like that).
+ Even if the "C" locale on a particular system is an extension of the ASCII
+ character set (like on BeOS, where it is UTF-8, or on AmigaOS, where it
+ is ISO-8859-1), the functions in this file recognize only the ASCII
+ characters. */
+
+
+/* Check whether the ASCII optimizations apply. */
+
+/* ANSI C89 (and ISO C99 5.2.1.3 too) already guarantees that
+ '0', '1', ..., '9' have consecutive integer values. */
+#define C_CTYPE_CONSECUTIVE_DIGITS 1
+
+#if ('A' <= 'Z') \
+ && ('A' + 1 == 'B') && ('B' + 1 == 'C') && ('C' + 1 == 'D') \
+ && ('D' + 1 == 'E') && ('E' + 1 == 'F') && ('F' + 1 == 'G') \
+ && ('G' + 1 == 'H') && ('H' + 1 == 'I') && ('I' + 1 == 'J') \
+ && ('J' + 1 == 'K') && ('K' + 1 == 'L') && ('L' + 1 == 'M') \
+ && ('M' + 1 == 'N') && ('N' + 1 == 'O') && ('O' + 1 == 'P') \
+ && ('P' + 1 == 'Q') && ('Q' + 1 == 'R') && ('R' + 1 == 'S') \
+ && ('S' + 1 == 'T') && ('T' + 1 == 'U') && ('U' + 1 == 'V') \
+ && ('V' + 1 == 'W') && ('W' + 1 == 'X') && ('X' + 1 == 'Y') \
+ && ('Y' + 1 == 'Z')
+#define C_CTYPE_CONSECUTIVE_UPPERCASE 1
+#endif
+
+#if ('a' <= 'z') \
+ && ('a' + 1 == 'b') && ('b' + 1 == 'c') && ('c' + 1 == 'd') \
+ && ('d' + 1 == 'e') && ('e' + 1 == 'f') && ('f' + 1 == 'g') \
+ && ('g' + 1 == 'h') && ('h' + 1 == 'i') && ('i' + 1 == 'j') \
+ && ('j' + 1 == 'k') && ('k' + 1 == 'l') && ('l' + 1 == 'm') \
+ && ('m' + 1 == 'n') && ('n' + 1 == 'o') && ('o' + 1 == 'p') \
+ && ('p' + 1 == 'q') && ('q' + 1 == 'r') && ('r' + 1 == 's') \
+ && ('s' + 1 == 't') && ('t' + 1 == 'u') && ('u' + 1 == 'v') \
+ && ('v' + 1 == 'w') && ('w' + 1 == 'x') && ('x' + 1 == 'y') \
+ && ('y' + 1 == 'z')
+#define C_CTYPE_CONSECUTIVE_LOWERCASE 1
+#endif
+
+#if (' ' == 32) && ('!' == 33) && ('"' == 34) && ('#' == 35) \
+ && ('%' == 37) && ('&' == 38) && ('\'' == 39) && ('(' == 40) \
+ && (')' == 41) && ('*' == 42) && ('+' == 43) && (',' == 44) \
+ && ('-' == 45) && ('.' == 46) && ('/' == 47) && ('0' == 48) \
+ && ('1' == 49) && ('2' == 50) && ('3' == 51) && ('4' == 52) \
+ && ('5' == 53) && ('6' == 54) && ('7' == 55) && ('8' == 56) \
+ && ('9' == 57) && (':' == 58) && (';' == 59) && ('<' == 60) \
+ && ('=' == 61) && ('>' == 62) && ('?' == 63) && ('A' == 65) \
+ && ('B' == 66) && ('C' == 67) && ('D' == 68) && ('E' == 69) \
+ && ('F' == 70) && ('G' == 71) && ('H' == 72) && ('I' == 73) \
+ && ('J' == 74) && ('K' == 75) && ('L' == 76) && ('M' == 77) \
+ && ('N' == 78) && ('O' == 79) && ('P' == 80) && ('Q' == 81) \
+ && ('R' == 82) && ('S' == 83) && ('T' == 84) && ('U' == 85) \
+ && ('V' == 86) && ('W' == 87) && ('X' == 88) && ('Y' == 89) \
+ && ('Z' == 90) && ('[' == 91) && ('\\' == 92) && (']' == 93) \
+ && ('^' == 94) && ('_' == 95) && ('a' == 97) && ('b' == 98) \
+ && ('c' == 99) && ('d' == 100) && ('e' == 101) && ('f' == 102) \
+ && ('g' == 103) && ('h' == 104) && ('i' == 105) && ('j' == 106) \
+ && ('k' == 107) && ('l' == 108) && ('m' == 109) && ('n' == 110) \
+ && ('o' == 111) && ('p' == 112) && ('q' == 113) && ('r' == 114) \
+ && ('s' == 115) && ('t' == 116) && ('u' == 117) && ('v' == 118) \
+ && ('w' == 119) && ('x' == 120) && ('y' == 121) && ('z' == 122) \
+ && ('{' == 123) && ('|' == 124) && ('}' == 125) && ('~' == 126)
+/* The character set is ASCII or one of its variants or extensions, not EBCDIC.
+ Testing the value of '\n' and '\r' is not relevant. */
+#define C_CTYPE_ASCII 1
+#endif
+
+
+/* Function declarations. */
+
+/* Unlike the functions in <ctype.h>, which require an argument in the range
+ of the 'unsigned char' type, the functions here operate on values that are
+ in the 'unsigned char' range or in the 'char' range. In other words,
+ when you have a 'char' value, you need to cast it before using it as
+ argument to a <ctype.h> function:
+
+ const char *s = ...;
+ if (isalpha ((unsigned char) *s)) ...
+
+ but you don't need to cast it for the functions defined in this file:
+
+ const char *s = ...;
+ if (c_isalpha (*s)) ...
+ */
+
+extern bool c_isascii (int c); /* not locale dependent */
+
+extern bool c_isalnum (int c);
+extern bool c_isalpha (int c);
+extern bool c_isblank (int c);
+extern bool c_iscntrl (int c);
+extern bool c_isdigit (int c);
+extern bool c_islower (int c);
+extern bool c_isgraph (int c);
+extern bool c_isprint (int c);
+extern bool c_ispunct (int c);
+extern bool c_isspace (int c);
+extern bool c_isupper (int c);
+extern bool c_isxdigit (int c);
+
+extern int c_tolower (int c);
+extern int c_toupper (int c);
+
+
+#if defined __GNUC__ && defined __OPTIMIZE__ && !defined __OPTIMIZE_SIZE__ &&
!defined NO_C_CTYPE_MACROS
+
+/* ASCII optimizations. */
+
+#undef c_isascii
+#define c_isascii(c) \
+ ({ int __c = (c); \
+ (__c >= 0x00 && __c <= 0x7f); \
+ })
+
+#if C_CTYPE_CONSECUTIVE_DIGITS \
+ && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE
+#if C_CTYPE_ASCII
+#undef c_isalnum
+#define c_isalnum(c) \
+ ({ int __c = (c); \
+ ((__c >= '0' && __c <= '9') \
+ || ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'Z')); \
+ })
+#else
+#undef c_isalnum
+#define c_isalnum(c) \
+ ({ int __c = (c); \
+ ((__c >= '0' && __c <= '9') \
+ || (__c >= 'A' && __c <= 'Z') \
+ || (__c >= 'a' && __c <= 'z')); \
+ })
+#endif
+#endif
+
+#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE
+#if C_CTYPE_ASCII
+#undef c_isalpha
+#define c_isalpha(c) \
+ ({ int __c = (c); \
+ ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'Z'); \
+ })
+#else
+#undef c_isalpha
+#define c_isalpha(c) \
+ ({ int __c = (c); \
+ ((__c >= 'A' && __c <= 'Z') || (__c >= 'a' && __c <= 'z')); \
+ })
+#endif
+#endif
+
+#undef c_isblank
+#define c_isblank(c) \
+ ({ int __c = (c); \
+ (__c == ' ' || __c == '\t'); \
+ })
+
+#if C_CTYPE_ASCII
+#undef c_iscntrl
+#define c_iscntrl(c) \
+ ({ int __c = (c); \
+ ((__c & ~0x1f) == 0 || __c == 0x7f); \
+ })
+#endif
+
+#if C_CTYPE_CONSECUTIVE_DIGITS
+#undef c_isdigit
+#define c_isdigit(c) \
+ ({ int __c = (c); \
+ (__c >= '0' && __c <= '9'); \
+ })
+#endif
+
+#if C_CTYPE_CONSECUTIVE_LOWERCASE
+#undef c_islower
+#define c_islower(c) \
+ ({ int __c = (c); \
+ (__c >= 'a' && __c <= 'z'); \
+ })
+#endif
+
+#if C_CTYPE_ASCII
+#undef c_isgraph
+#define c_isgraph(c) \
+ ({ int __c = (c); \
+ (__c >= '!' && __c <= '~'); \
+ })
+#endif
+
+#if C_CTYPE_ASCII
+#undef c_isprint
+#define c_isprint(c) \
+ ({ int __c = (c); \
+ (__c >= ' ' && __c <= '~'); \
+ })
+#endif
+
+#if C_CTYPE_ASCII
+#undef c_ispunct
+#define c_ispunct(c) \
+ ({ int _c = (c); \
+ (c_isgraph (_c) && ! c_isalnum (_c)); \
+ })
+#endif
+
+#undef c_isspace
+#define c_isspace(c) \
+ ({ int __c = (c); \
+ (__c == ' ' || __c == '\t' \
+ || __c == '\n' || __c == '\v' || __c == '\f' || __c == '\r'); \
+ })
+
+#if C_CTYPE_CONSECUTIVE_UPPERCASE
+#undef c_isupper
+#define c_isupper(c) \
+ ({ int __c = (c); \
+ (__c >= 'A' && __c <= 'Z'); \
+ })
+#endif
+
+#if C_CTYPE_CONSECUTIVE_DIGITS \
+ && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE
+#if C_CTYPE_ASCII
+#undef c_isxdigit
+#define c_isxdigit(c) \
+ ({ int __c = (c); \
+ ((__c >= '0' && __c <= '9') \
+ || ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'F')); \
+ })
+#else
+#undef c_isxdigit
+#define c_isxdigit(c) \
+ ({ int __c = (c); \
+ ((__c >= '0' && __c <= '9') \
+ || (__c >= 'A' && __c <= 'F') \
+ || (__c >= 'a' && __c <= 'f')); \
+ })
+#endif
+#endif
+
+#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE
+#undef c_tolower
+#define c_tolower(c) \
+ ({ int __c = (c); \
+ (__c >= 'A' && __c <= 'Z' ? __c - 'A' + 'a' : __c); \
+ })
+#undef c_toupper
+#define c_toupper(c) \
+ ({ int __c = (c); \
+ (__c >= 'a' && __c <= 'z' ? __c - 'a' + 'A' : __c); \
+ })
+#endif
+
+#endif /* optimizing for speed */
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* C_CTYPE_H */
diff --git a/lib/c-strcase.h b/lib/c-strcase.h
new file mode 100644
index 0000000..714a3c6
--- /dev/null
+++ b/lib/c-strcase.h
@@ -0,0 +1,55 @@
+/* Case-insensitive string comparison functions in C locale.
+ Copyright (C) 1995-1996, 2001, 2003, 2005 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 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#ifndef C_STRCASE_H
+#define C_STRCASE_H
+
+#include <stddef.h>
+
+
+/* The functions defined in this file assume the "C" locale and a character
+ set without diacritics (ASCII-US or EBCDIC-US or something like that).
+ Even if the "C" locale on a particular system is an extension of the ASCII
+ character set (like on BeOS, where it is UTF-8, or on AmigaOS, where it
+ is ISO-8859-1), the functions in this file recognize only the ASCII
+ characters. More precisely, one of the string arguments must be an ASCII
+ string; the other one can also contain non-ASCII characters (but then
+ the comparison result will be nonzero). */
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+/* Compare strings S1 and S2, ignoring case, returning less than, equal to or
+ greater than zero if S1 is lexicographically less than, equal to or greater
+ than S2. */
+extern int c_strcasecmp (const char *s1, const char *s2);
+
+/* Compare no more than N characters of strings S1 and S2, ignoring case,
+ returning less than, equal to or greater than zero if S1 is
+ lexicographically less than, equal to or greater than S2. */
+extern int c_strncasecmp (const char *s1, const char *s2, size_t n);
+
+
+#ifdef __cplusplus
+}
+#endif
+
+
+#endif /* C_STRCASE_H */
diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c
new file mode 100644
index 0000000..a523898
--- /dev/null
+++ b/lib/c-strcasecmp.c
@@ -0,0 +1,57 @@
+/* c-strcasecmp.c -- case insensitive string comparator in C locale
+ Copyright (C) 1998-1999, 2005-2006 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#include <config.h>
+
+/* Specification. */
+#include "c-strcase.h"
+
+#include <limits.h>
+
+#include "c-ctype.h"
+
+int
+c_strcasecmp (const char *s1, const char *s2)
+{
+ register const unsigned char *p1 = (const unsigned char *) s1;
+ register const unsigned char *p2 = (const unsigned char *) s2;
+ unsigned char c1, c2;
+
+ if (p1 == p2)
+ return 0;
+
+ do
+ {
+ c1 = c_tolower (*p1);
+ c2 = c_tolower (*p2);
+
+ if (c1 == '\0')
+ break;
+
+ ++p1;
+ ++p2;
+ }
+ while (c1 == c2);
+
+ if (UCHAR_MAX <= INT_MAX)
+ return c1 - c2;
+ else
+ /* On machines where 'char' and 'int' are types of the same size, the
+ difference of two 'unsigned char' values - including the sign bit -
+ doesn't fit in an 'int'. */
+ return (c1 > c2 ? 1 : c1 < c2 ? -1 : 0);
+}
diff --git a/lib/c-strcaseeq.h b/lib/c-strcaseeq.h
new file mode 100644
index 0000000..cd29b66
--- /dev/null
+++ b/lib/c-strcaseeq.h
@@ -0,0 +1,184 @@
+/* Optimized case-insensitive string comparison in C locale.
+ Copyright (C) 2001-2002, 2007 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+/* Written by Bruno Haible <address@hidden>. */
+
+#include "c-strcase.h"
+#include "c-ctype.h"
+
+/* STRCASEEQ allows to optimize string comparison with a small literal string.
+ STRCASEEQ (s, "UTF-8", 'U','T','F','-','8',0,0,0,0)
+ is semantically equivalent to
+ c_strcasecmp (s, "UTF-8") == 0
+ just faster. */
+
+/* Help GCC to generate good code for string comparisons with
+ immediate strings. */
+#if defined (__GNUC__) && defined (__OPTIMIZE__)
+
+/* Case insensitive comparison of ASCII characters. */
+# if C_CTYPE_ASCII
+# define CASEEQ(other,upper) \
+ (c_isupper (upper) ? ((other) & ~0x20) == (upper) : (other) == (upper))
+# elif C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE
+# define CASEEQ(other,upper) \
+ (c_isupper (upper) ? (other) == (upper) || (other) == (upper) - 'A' + 'a'
: (other) == (upper))
+# else
+# define CASEEQ(other,upper) \
+ (c_toupper (other) == (upper))
+# endif
+
+static inline int
+strcaseeq9 (const char *s1, const char *s2)
+{
+ return c_strcasecmp (s1 + 9, s2 + 9) == 0;
+}
+
+static inline int
+strcaseeq8 (const char *s1, const char *s2, char s28)
+{
+ if (CASEEQ (s1[8], s28))
+ {
+ if (s28 == 0)
+ return 1;
+ else
+ return strcaseeq9 (s1, s2);
+ }
+ else
+ return 0;
+}
+
+static inline int
+strcaseeq7 (const char *s1, const char *s2, char s27, char s28)
+{
+ if (CASEEQ (s1[7], s27))
+ {
+ if (s27 == 0)
+ return 1;
+ else
+ return strcaseeq8 (s1, s2, s28);
+ }
+ else
+ return 0;
+}
+
+static inline int
+strcaseeq6 (const char *s1, const char *s2, char s26, char s27, char s28)
+{
+ if (CASEEQ (s1[6], s26))
+ {
+ if (s26 == 0)
+ return 1;
+ else
+ return strcaseeq7 (s1, s2, s27, s28);
+ }
+ else
+ return 0;
+}
+
+static inline int
+strcaseeq5 (const char *s1, const char *s2, char s25, char s26, char s27, char
s28)
+{
+ if (CASEEQ (s1[5], s25))
+ {
+ if (s25 == 0)
+ return 1;
+ else
+ return strcaseeq6 (s1, s2, s26, s27, s28);
+ }
+ else
+ return 0;
+}
+
+static inline int
+strcaseeq4 (const char *s1, const char *s2, char s24, char s25, char s26, char
s27, char s28)
+{
+ if (CASEEQ (s1[4], s24))
+ {
+ if (s24 == 0)
+ return 1;
+ else
+ return strcaseeq5 (s1, s2, s25, s26, s27, s28);
+ }
+ else
+ return 0;
+}
+
+static inline int
+strcaseeq3 (const char *s1, const char *s2, char s23, char s24, char s25, char
s26, char s27, char s28)
+{
+ if (CASEEQ (s1[3], s23))
+ {
+ if (s23 == 0)
+ return 1;
+ else
+ return strcaseeq4 (s1, s2, s24, s25, s26, s27, s28);
+ }
+ else
+ return 0;
+}
+
+static inline int
+strcaseeq2 (const char *s1, const char *s2, char s22, char s23, char s24, char
s25, char s26, char s27, char s28)
+{
+ if (CASEEQ (s1[2], s22))
+ {
+ if (s22 == 0)
+ return 1;
+ else
+ return strcaseeq3 (s1, s2, s23, s24, s25, s26, s27, s28);
+ }
+ else
+ return 0;
+}
+
+static inline int
+strcaseeq1 (const char *s1, const char *s2, char s21, char s22, char s23, char
s24, char s25, char s26, char s27, char s28)
+{
+ if (CASEEQ (s1[1], s21))
+ {
+ if (s21 == 0)
+ return 1;
+ else
+ return strcaseeq2 (s1, s2, s22, s23, s24, s25, s26, s27, s28);
+ }
+ else
+ return 0;
+}
+
+static inline int
+strcaseeq0 (const char *s1, const char *s2, char s20, char s21, char s22, char
s23, char s24, char s25, char s26, char s27, char s28)
+{
+ if (CASEEQ (s1[0], s20))
+ {
+ if (s20 == 0)
+ return 1;
+ else
+ return strcaseeq1 (s1, s2, s21, s22, s23, s24, s25, s26, s27, s28);
+ }
+ else
+ return 0;
+}
+
+#define STRCASEEQ(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \
+ strcaseeq0 (s1, s2, s20, s21, s22, s23, s24, s25, s26, s27, s28)
+
+#else
+
+#define STRCASEEQ(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \
+ (c_strcasecmp (s1, s2) == 0)
+
+#endif
diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c
new file mode 100644
index 0000000..c1496ca
--- /dev/null
+++ b/lib/c-strncasecmp.c
@@ -0,0 +1,57 @@
+/* c-strncasecmp.c -- case insensitive string comparator in C locale
+ Copyright (C) 1998-1999, 2005-2006 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU Lesser 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#include <config.h>
+
+/* Specification. */
+#include "c-strcase.h"
+
+#include <limits.h>
+
+#include "c-ctype.h"
+
+int
+c_strncasecmp (const char *s1, const char *s2, size_t n)
+{
+ register const unsigned char *p1 = (const unsigned char *) s1;
+ register const unsigned char *p2 = (const unsigned char *) s2;
+ unsigned char c1, c2;
+
+ if (p1 == p2 || n == 0)
+ return 0;
+
+ do
+ {
+ c1 = c_tolower (*p1);
+ c2 = c_tolower (*p2);
+
+ if (--n == 0 || c1 == '\0')
+ break;
+
+ ++p1;
+ ++p2;
+ }
+ while (c1 == c2);
+
+ if (UCHAR_MAX <= INT_MAX)
+ return c1 - c2;
+ else
+ /* On machines where 'char' and 'int' are types of the same size, the
+ difference of two 'unsigned char' values - including the sign bit -
+ doesn't fit in an 'int'. */
+ return (c1 > c2 ? 1 : c1 < c2 ? -1 : 0);
+}
diff --git a/lib/config.charset b/lib/config.charset
index 50b4406..c1a7f5d 100755
--- a/lib/config.charset
+++ b/lib/config.charset
@@ -1,7 +1,7 @@
#! /bin/sh
# Output a system dependent table of character encoding aliases.
#
-# Copyright (C) 2000-2004, 2006-2008 Free Software Foundation, Inc.
+# Copyright (C) 2000-2004, 2006-2009 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as published by
@@ -63,12 +63,13 @@
# CP922 aix
# CP932 aix woe32 dos
# CP943 aix
-# CP949 osf woe32 dos
+# CP949 osf darwin woe32 dos
# CP950 woe32 dos
# CP1046 aix
# CP1124 aix
# CP1125 dos
# CP1129 aix
+# CP1131 darwin
# CP1250 woe32
# CP1251 glibc solaris netbsd openbsd darwin woe32
# CP1252 aix woe32
@@ -82,15 +83,17 @@
# EUC-KR Y glibc aix hpux irix osf solaris freebsd netbsd
darwin
# EUC-TW glibc aix hpux irix osf solaris netbsd
# BIG5 Y glibc aix hpux osf solaris freebsd netbsd
darwin
-# BIG5-HKSCS glibc solaris
-# GBK glibc aix osf solaris woe32 dos
-# GB18030 glibc solaris netbsd
+# BIG5-HKSCS glibc solaris darwin
+# GBK glibc aix osf solaris darwin woe32 dos
+# GB18030 glibc solaris netbsd darwin
# SHIFT_JIS Y hpux osf solaris freebsd netbsd darwin
# JOHAB glibc solaris woe32
# TIS-620 glibc aix hpux osf solaris
# VISCII Y glibc
# TCVN5712-1 glibc
+# ARMSCII-8 glibc darwin
# GEORGIAN-PS glibc
+# PT154 glibc
# HP-ROMAN8 hpux
# HP-ARABIC8 hpux
# HP-GREEK8 hpux
@@ -449,7 +452,8 @@ case "$os" in
echo "ko_KR.EUC EUC-KR"
;;
darwin*)
- # Darwin 7.5 has nl_langinfo(CODESET), but it is useless:
+ # Darwin 7.5 has nl_langinfo(CODESET), but sometimes its value is
+ # useless:
# - It returns the empty string when LANG is set to a locale of the
# form ll_CC, although ll_CC/LC_CTYPE is a symlink to an UTF-8
# LC_CTYPE file.
@@ -476,6 +480,36 @@ case "$os" in
# minimize the use of decomposed Unicode. Unfortunately, through the
# Darwin file system, decomposed UTF-8 strings are leaked into user
# space nevertheless.
+ # Then there are also the locales with encodings other than US-ASCII
+ # and UTF-8. These locales can be occasionally useful to users (e.g.
+ # when grepping through ISO-8859-1 encoded text files), when all their
+ # file names are in US-ASCII.
+ echo "ISO8859-1 ISO-8859-1"
+ echo "ISO8859-2 ISO-8859-2"
+ echo "ISO8859-4 ISO-8859-4"
+ echo "ISO8859-5 ISO-8859-5"
+ echo "ISO8859-7 ISO-8859-7"
+ echo "ISO8859-9 ISO-8859-9"
+ echo "ISO8859-13 ISO-8859-13"
+ echo "ISO8859-15 ISO-8859-15"
+ echo "KOI8-R KOI8-R"
+ echo "KOI8-U KOI8-U"
+ echo "CP866 CP866"
+ echo "CP949 CP949"
+ echo "CP1131 CP1131"
+ echo "CP1251 CP1251"
+ echo "eucCN GB2312"
+ echo "GB2312 GB2312"
+ echo "eucJP EUC-JP"
+ echo "eucKR EUC-KR"
+ echo "Big5 BIG5"
+ echo "Big5HKSCS BIG5-HKSCS"
+ echo "GBK GBK"
+ echo "GB18030 GB18030"
+ echo "SJIS SHIFT_JIS"
+ echo "ARMSCII-8 ARMSCII-8"
+ echo "PT154 PT154"
+ #echo "ISCII-DEV ?"
echo "* UTF-8"
;;
beos* | haiku*)
diff --git a/lib/flock.c b/lib/flock.c
new file mode 100644
index 0000000..2993432
--- /dev/null
+++ b/lib/flock.c
@@ -0,0 +1,222 @@
+/* Emulate flock on platforms that lack it, primarily Windows and MinGW.
+
+ This is derived from sqlite3 sources.
+ http://www.sqlite.org/cvstrac/rlog?f=sqlite/src/os_win.c
+ http://www.sqlite.org/copyright.html
+
+ Written by Richard W.M. Jones <rjones.at.redhat.com>
+
+ Copyright (C) 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 2.1 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+#include <sys/file.h>
+
+#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+
+/* _get_osfhandle */
+#include <io.h>
+
+/* LockFileEx */
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+
+#include <errno.h>
+
+/* Determine the current size of a file. Because the other braindead
+ * APIs we'll call need lower/upper 32 bit pairs, keep the file size
+ * like that too.
+ */
+static BOOL
+file_size (HANDLE h, DWORD * lower, DWORD * upper)
+{
+ *lower = GetFileSize (h, upper);
+ return 1;
+}
+
+/* LOCKFILE_FAIL_IMMEDIATELY is undefined on some Windows systems. */
+#ifndef LOCKFILE_FAIL_IMMEDIATELY
+# define LOCKFILE_FAIL_IMMEDIATELY 1
+#endif
+
+/* Acquire a lock. */
+static BOOL
+do_lock (HANDLE h, int non_blocking, int exclusive)
+{
+ BOOL res;
+ DWORD size_lower, size_upper;
+ OVERLAPPED ovlp;
+ int flags = 0;
+
+ /* We're going to lock the whole file, so get the file size. */
+ res = file_size (h, &size_lower, &size_upper);
+ if (!res)
+ return 0;
+
+ /* Start offset is 0, and also zero the remaining members of this struct. */
+ memset (&ovlp, 0, sizeof ovlp);
+
+ if (non_blocking)
+ flags |= LOCKFILE_FAIL_IMMEDIATELY;
+ if (exclusive)
+ flags |= LOCKFILE_EXCLUSIVE_LOCK;
+
+ return LockFileEx (h, flags, 0, size_lower, size_upper, &ovlp);
+}
+
+/* Unlock reader or exclusive lock. */
+static BOOL
+do_unlock (HANDLE h)
+{
+ int res;
+ DWORD size_lower, size_upper;
+
+ res = file_size (h, &size_lower, &size_upper);
+ if (!res)
+ return 0;
+
+ return UnlockFile (h, 0, 0, size_lower, size_upper);
+}
+
+/* Now our BSD-like flock operation. */
+int
+flock (int fd, int operation)
+{
+ HANDLE h = (HANDLE) _get_osfhandle (fd);
+ DWORD res;
+ int non_blocking;
+
+ if (h == INVALID_HANDLE_VALUE)
+ {
+ errno = EBADF;
+ return -1;
+ }
+
+ non_blocking = operation & LOCK_NB;
+ operation &= ~LOCK_NB;
+
+ switch (operation)
+ {
+ case LOCK_SH:
+ res = do_lock (h, non_blocking, 0);
+ break;
+ case LOCK_EX:
+ res = do_lock (h, non_blocking, 1);
+ break;
+ case LOCK_UN:
+ res = do_unlock (h);
+ break;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Map Windows errors into Unix errnos. As usual MSDN fails to
+ * document the permissible error codes.
+ */
+ if (!res)
+ {
+ DWORD err = GetLastError ();
+ switch (err)
+ {
+ /* This means someone else is holding a lock. */
+ case ERROR_LOCK_VIOLATION:
+ errno = EAGAIN;
+ break;
+
+ /* Out of memory. */
+ case ERROR_NOT_ENOUGH_MEMORY:
+ errno = ENOMEM;
+ break;
+
+ case ERROR_BAD_COMMAND:
+ errno = EINVAL;
+ break;
+
+ /* Unlikely to be other errors, but at least don't lose the
+ * error code.
+ */
+ default:
+ errno = err;
+ }
+
+ return -1;
+ }
+
+ return 0;
+}
+
+#else /* !Windows */
+
+#ifdef HAVE_STRUCT_FLOCK_L_TYPE
+/* We know how to implement flock in terms of fcntl. */
+
+#ifdef HAVE_FCNTL_H
+#include <fcntl.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#include <errno.h>
+#include <string.h>
+
+int
+flock (int fd, int operation)
+{
+ int cmd, r;
+ struct flock fl;
+
+ if (operation & LOCK_NB)
+ cmd = F_SETLK;
+ else
+ cmd = F_SETLKW;
+ operation &= ~LOCK_NB;
+
+ memset (&fl, 0, sizeof fl);
+ fl.l_whence = SEEK_SET;
+ /* l_start & l_len are 0, which as a special case means "whole file". */
+
+ switch (operation)
+ {
+ case LOCK_SH:
+ fl.l_type = F_RDLCK;
+ break;
+ case LOCK_EX:
+ fl.l_type = F_WRLCK;
+ break;
+ case LOCK_UN:
+ fl.l_type = F_UNLCK;
+ break;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+
+ r = fcntl (fd, cmd, &fl);
+ if (r == -1 && errno == EACCES)
+ errno = EAGAIN;
+
+ return r;
+}
+
+#else /* !HAVE_STRUCT_FLOCK_L_TYPE */
+
+#error "This platform lacks flock function, and Gnulib doesn't provide a
replacement. This is a bug in Gnulib."
+
+#endif /* !HAVE_STRUCT_FLOCK_L_TYPE */
+
+#endif /* !Windows */
diff --git a/lib/iconv.c b/lib/iconv.c
new file mode 100644
index 0000000..56a84c4
--- /dev/null
+++ b/lib/iconv.c
@@ -0,0 +1,450 @@
+/* Character set conversion.
+ Copyright (C) 1999-2001, 2007 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 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
along
+ with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#include <config.h>
+
+/* Specification. */
+#include <iconv.h>
+
+#include <stddef.h>
+
+#if REPLACE_ICONV_UTF
+# include <errno.h>
+# include <stdint.h>
+# include <stdlib.h>
+# include "unistr.h"
+# ifndef uintptr_t
+# define uintptr_t unsigned long
+# endif
+#endif
+
+#if REPLACE_ICONV_UTF
+
+/* UTF-{16,32}{BE,LE} converters taken from GNU libiconv 1.11. */
+
+/* Return code if invalid. (xxx_mbtowc) */
+# define RET_ILSEQ -1
+/* Return code if no bytes were read. (xxx_mbtowc) */
+# define RET_TOOFEW -2
+
+/* Return code if invalid. (xxx_wctomb) */
+# define RET_ILUNI -1
+/* Return code if output buffer is too small. (xxx_wctomb, xxx_reset) */
+# define RET_TOOSMALL -2
+
+/*
+ * UTF-16BE
+ */
+
+/* Specification: RFC 2781 */
+
+static int
+utf16be_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n)
+{
+ if (n >= 2)
+ {
+ ucs4_t wc = (s[0] << 8) + s[1];
+ if (wc >= 0xd800 && wc < 0xdc00)
+ {
+ if (n >= 4)
+ {
+ ucs4_t wc2 = (s[2] << 8) + s[3];
+ if (!(wc2 >= 0xdc00 && wc2 < 0xe000))
+ return RET_ILSEQ;
+ *pwc = 0x10000 + ((wc - 0xd800) << 10) + (wc2 - 0xdc00);
+ return 4;
+ }
+ }
+ else if (wc >= 0xdc00 && wc < 0xe000)
+ {
+ return RET_ILSEQ;
+ }
+ else
+ {
+ *pwc = wc;
+ return 2;
+ }
+ }
+ return RET_TOOFEW;
+}
+
+static int
+utf16be_wctomb (unsigned char *r, ucs4_t wc, size_t n)
+{
+ if (!(wc >= 0xd800 && wc < 0xe000))
+ {
+ if (wc < 0x10000)
+ {
+ if (n >= 2)
+ {
+ r[0] = (unsigned char) (wc >> 8);
+ r[1] = (unsigned char) wc;
+ return 2;
+ }
+ else
+ return RET_TOOSMALL;
+ }
+ else if (wc < 0x110000)
+ {
+ if (n >= 4)
+ {
+ ucs4_t wc1 = 0xd800 + ((wc - 0x10000) >> 10);
+ ucs4_t wc2 = 0xdc00 + ((wc - 0x10000) & 0x3ff);
+ r[0] = (unsigned char) (wc1 >> 8);
+ r[1] = (unsigned char) wc1;
+ r[2] = (unsigned char) (wc2 >> 8);
+ r[3] = (unsigned char) wc2;
+ return 4;
+ }
+ else
+ return RET_TOOSMALL;
+ }
+ }
+ return RET_ILUNI;
+}
+
+/*
+ * UTF-16LE
+ */
+
+/* Specification: RFC 2781 */
+
+static int
+utf16le_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n)
+{
+ if (n >= 2)
+ {
+ ucs4_t wc = s[0] + (s[1] << 8);
+ if (wc >= 0xd800 && wc < 0xdc00)
+ {
+ if (n >= 4)
+ {
+ ucs4_t wc2 = s[2] + (s[3] << 8);
+ if (!(wc2 >= 0xdc00 && wc2 < 0xe000))
+ return RET_ILSEQ;
+ *pwc = 0x10000 + ((wc - 0xd800) << 10) + (wc2 - 0xdc00);
+ return 4;
+ }
+ }
+ else if (wc >= 0xdc00 && wc < 0xe000)
+ {
+ return RET_ILSEQ;
+ }
+ else
+ {
+ *pwc = wc;
+ return 2;
+ }
+ }
+ return RET_TOOFEW;
+}
+
+static int
+utf16le_wctomb (unsigned char *r, ucs4_t wc, size_t n)
+{
+ if (!(wc >= 0xd800 && wc < 0xe000))
+ {
+ if (wc < 0x10000)
+ {
+ if (n >= 2)
+ {
+ r[0] = (unsigned char) wc;
+ r[1] = (unsigned char) (wc >> 8);
+ return 2;
+ }
+ else
+ return RET_TOOSMALL;
+ }
+ else if (wc < 0x110000)
+ {
+ if (n >= 4)
+ {
+ ucs4_t wc1 = 0xd800 + ((wc - 0x10000) >> 10);
+ ucs4_t wc2 = 0xdc00 + ((wc - 0x10000) & 0x3ff);
+ r[0] = (unsigned char) wc1;
+ r[1] = (unsigned char) (wc1 >> 8);
+ r[2] = (unsigned char) wc2;
+ r[3] = (unsigned char) (wc2 >> 8);
+ return 4;
+ }
+ else
+ return RET_TOOSMALL;
+ }
+ }
+ return RET_ILUNI;
+}
+
+/*
+ * UTF-32BE
+ */
+
+/* Specification: Unicode 3.1 Standard Annex #19 */
+
+static int
+utf32be_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n)
+{
+ if (n >= 4)
+ {
+ ucs4_t wc = (s[0] << 24) + (s[1] << 16) + (s[2] << 8) + s[3];
+ if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000))
+ {
+ *pwc = wc;
+ return 4;
+ }
+ else
+ return RET_ILSEQ;
+ }
+ return RET_TOOFEW;
+}
+
+static int
+utf32be_wctomb (unsigned char *r, ucs4_t wc, size_t n)
+{
+ if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000))
+ {
+ if (n >= 4)
+ {
+ r[0] = 0;
+ r[1] = (unsigned char) (wc >> 16);
+ r[2] = (unsigned char) (wc >> 8);
+ r[3] = (unsigned char) wc;
+ return 4;
+ }
+ else
+ return RET_TOOSMALL;
+ }
+ return RET_ILUNI;
+}
+
+/*
+ * UTF-32LE
+ */
+
+/* Specification: Unicode 3.1 Standard Annex #19 */
+
+static int
+utf32le_mbtowc (ucs4_t *pwc, const unsigned char *s, size_t n)
+{
+ if (n >= 4)
+ {
+ ucs4_t wc = s[0] + (s[1] << 8) + (s[2] << 16) + (s[3] << 24);
+ if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000))
+ {
+ *pwc = wc;
+ return 4;
+ }
+ else
+ return RET_ILSEQ;
+ }
+ return RET_TOOFEW;
+}
+
+static int
+utf32le_wctomb (unsigned char *r, ucs4_t wc, size_t n)
+{
+ if (wc < 0x110000 && !(wc >= 0xd800 && wc < 0xe000))
+ {
+ if (n >= 4)
+ {
+ r[0] = (unsigned char) wc;
+ r[1] = (unsigned char) (wc >> 8);
+ r[2] = (unsigned char) (wc >> 16);
+ r[3] = 0;
+ return 4;
+ }
+ else
+ return RET_TOOSMALL;
+ }
+ return RET_ILUNI;
+}
+
+#endif
+
+size_t
+rpl_iconv (iconv_t cd,
+ ICONV_CONST char **inbuf, size_t *inbytesleft,
+ char **outbuf, size_t *outbytesleft)
+#undef iconv
+{
+#if REPLACE_ICONV_UTF
+ switch ((uintptr_t) cd)
+ {
+ {
+ int (*xxx_wctomb) (unsigned char *, ucs4_t, size_t);
+
+ case (uintptr_t) _ICONV_UTF8_UTF16BE:
+ xxx_wctomb = utf16be_wctomb;
+ goto loop_from_utf8;
+ case (uintptr_t) _ICONV_UTF8_UTF16LE:
+ xxx_wctomb = utf16le_wctomb;
+ goto loop_from_utf8;
+ case (uintptr_t) _ICONV_UTF8_UTF32BE:
+ xxx_wctomb = utf32be_wctomb;
+ goto loop_from_utf8;
+ case (uintptr_t) _ICONV_UTF8_UTF32LE:
+ xxx_wctomb = utf32le_wctomb;
+ goto loop_from_utf8;
+
+ loop_from_utf8:
+ if (inbuf == NULL || *inbuf == NULL)
+ return 0;
+ {
+ ICONV_CONST char *inptr = *inbuf;
+ size_t inleft = *inbytesleft;
+ char *outptr = *outbuf;
+ size_t outleft = *outbytesleft;
+ size_t res = 0;
+ while (inleft > 0)
+ {
+ ucs4_t uc;
+ int m = u8_mbtoucr (&uc, (const uint8_t *) inptr, inleft);
+ if (m <= 0)
+ {
+ if (m == -1)
+ {
+ errno = EILSEQ;
+ res = (size_t)(-1);
+ break;
+ }
+ if (m == -2)
+ {
+ errno = EINVAL;
+ res = (size_t)(-1);
+ break;
+ }
+ abort ();
+ }
+ else
+ {
+ int n = xxx_wctomb ((uint8_t *) outptr, uc, outleft);
+ if (n < 0)
+ {
+ if (n == RET_ILUNI)
+ {
+ errno = EILSEQ;
+ res = (size_t)(-1);
+ break;
+ }
+ if (n == RET_TOOSMALL)
+ {
+ errno = E2BIG;
+ res = (size_t)(-1);
+ break;
+ }
+ abort ();
+ }
+ else
+ {
+ inptr += m;
+ inleft -= m;
+ outptr += n;
+ outleft -= n;
+ }
+ }
+ }
+ *inbuf = inptr;
+ *inbytesleft = inleft;
+ *outbuf = outptr;
+ *outbytesleft = outleft;
+ return res;
+ }
+ }
+
+ {
+ int (*xxx_mbtowc) (ucs4_t *, const unsigned char *, size_t);
+
+ case (uintptr_t) _ICONV_UTF16BE_UTF8:
+ xxx_mbtowc = utf16be_mbtowc;
+ goto loop_to_utf8;
+ case (uintptr_t) _ICONV_UTF16LE_UTF8:
+ xxx_mbtowc = utf16le_mbtowc;
+ goto loop_to_utf8;
+ case (uintptr_t) _ICONV_UTF32BE_UTF8:
+ xxx_mbtowc = utf32be_mbtowc;
+ goto loop_to_utf8;
+ case (uintptr_t) _ICONV_UTF32LE_UTF8:
+ xxx_mbtowc = utf32le_mbtowc;
+ goto loop_to_utf8;
+
+ loop_to_utf8:
+ if (inbuf == NULL || *inbuf == NULL)
+ return 0;
+ {
+ ICONV_CONST char *inptr = *inbuf;
+ size_t inleft = *inbytesleft;
+ char *outptr = *outbuf;
+ size_t outleft = *outbytesleft;
+ size_t res = 0;
+ while (inleft > 0)
+ {
+ ucs4_t uc;
+ int m = xxx_mbtowc (&uc, (const uint8_t *) inptr, inleft);
+ if (m <= 0)
+ {
+ if (m == RET_ILSEQ)
+ {
+ errno = EILSEQ;
+ res = (size_t)(-1);
+ break;
+ }
+ if (m == RET_TOOFEW)
+ {
+ errno = EINVAL;
+ res = (size_t)(-1);
+ break;
+ }
+ abort ();
+ }
+ else
+ {
+ int n = u8_uctomb ((uint8_t *) outptr, uc, outleft);
+ if (n < 0)
+ {
+ if (n == -1)
+ {
+ errno = EILSEQ;
+ res = (size_t)(-1);
+ break;
+ }
+ if (n == -2)
+ {
+ errno = E2BIG;
+ res = (size_t)(-1);
+ break;
+ }
+ abort ();
+ }
+ else
+ {
+ inptr += m;
+ inleft -= m;
+ outptr += n;
+ outleft -= n;
+ }
+ }
+ }
+ *inbuf = inptr;
+ *inbytesleft = inleft;
+ *outbuf = outptr;
+ *outbytesleft = outleft;
+ return res;
+ }
+ }
+ }
+#endif
+ return iconv (cd, inbuf, inbytesleft, outbuf, outbytesleft);
+}
diff --git a/lib/iconv.in.h b/lib/iconv.in.h
new file mode 100644
index 0000000..915dce2
--- /dev/null
+++ b/lib/iconv.in.h
@@ -0,0 +1,71 @@
+/* A GNU-like <iconv.h>.
+
+ Copyright (C) 2007-2008 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 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#ifndef _GL_ICONV_H
+
+#if __GNUC__ >= 3
address@hidden@
+#endif
+
+/* The include_next requires a split double-inclusion guard. */
address@hidden@ @NEXT_ICONV_H@
+
+#ifndef _GL_ICONV_H
+#define _GL_ICONV_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+#if @REPLACE_ICONV_OPEN@
+/* An iconv_open wrapper that supports the IANA standardized encoding names
+ ("ISO-8859-1" etc.) as far as possible. */
+# define iconv_open rpl_iconv_open
+extern iconv_t iconv_open (const char *tocode, const char *fromcode);
+#endif
+
+#if @REPLACE_ICONV_UTF@
+/* Special constants for supporting UTF-{16,32}{BE,LE} encodings.
+ Not public. */
+# define _ICONV_UTF8_UTF16BE (iconv_t)(-161)
+# define _ICONV_UTF8_UTF16LE (iconv_t)(-162)
+# define _ICONV_UTF8_UTF32BE (iconv_t)(-163)
+# define _ICONV_UTF8_UTF32LE (iconv_t)(-164)
+# define _ICONV_UTF16BE_UTF8 (iconv_t)(-165)
+# define _ICONV_UTF16LE_UTF8 (iconv_t)(-166)
+# define _ICONV_UTF32BE_UTF8 (iconv_t)(-167)
+# define _ICONV_UTF32LE_UTF8 (iconv_t)(-168)
+#endif
+
+#if @REPLACE_ICONV@
+# define iconv rpl_iconv
+extern size_t iconv (iconv_t cd,
+ @ICONV_CONST@ char **inbuf, size_t *inbytesleft,
+ char **outbuf, size_t *outbytesleft);
+# define iconv_close rpl_iconv_close
+extern int iconv_close (iconv_t cd);
+#endif
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _GL_ICONV_H */
+#endif /* _GL_ICONV_H */
diff --git a/lib/iconv_close.c b/lib/iconv_close.c
new file mode 100644
index 0000000..3680412
--- /dev/null
+++ b/lib/iconv_close.c
@@ -0,0 +1,47 @@
+/* Character set conversion.
+ Copyright (C) 2007 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 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
along
+ with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#include <config.h>
+
+/* Specification. */
+#include <iconv.h>
+
+#include <stdint.h>
+#ifndef uintptr_t
+# define uintptr_t unsigned long
+#endif
+
+int
+rpl_iconv_close (iconv_t cd)
+#undef iconv_close
+{
+#if REPLACE_ICONV_UTF
+ switch ((uintptr_t) cd)
+ {
+ case (uintptr_t) _ICONV_UTF8_UTF16BE:
+ case (uintptr_t) _ICONV_UTF8_UTF16LE:
+ case (uintptr_t) _ICONV_UTF8_UTF32BE:
+ case (uintptr_t) _ICONV_UTF8_UTF32LE:
+ case (uintptr_t) _ICONV_UTF16BE_UTF8:
+ case (uintptr_t) _ICONV_UTF16LE_UTF8:
+ case (uintptr_t) _ICONV_UTF32BE_UTF8:
+ case (uintptr_t) _ICONV_UTF32LE_UTF8:
+ return 0;
+ }
+#endif
+ return iconv_close (cd);
+}
diff --git a/lib/iconv_open-aix.gperf b/lib/iconv_open-aix.gperf
new file mode 100644
index 0000000..6782b99
--- /dev/null
+++ b/lib/iconv_open-aix.gperf
@@ -0,0 +1,44 @@
+struct mapping { int standard_name; const char vendor_name[10 + 1]; };
+%struct-type
+%language=ANSI-C
+%define slot-name standard_name
+%define hash-function-name mapping_hash
+%define lookup-function-name mapping_lookup
+%readonly-tables
+%global-table
+%define word-array-name mappings
+%pic
+%%
+# On AIX 5.1, look in /usr/lib/nls/loc/uconvTable.
+ISO-8859-1, "ISO8859-1"
+ISO-8859-2, "ISO8859-2"
+ISO-8859-3, "ISO8859-3"
+ISO-8859-4, "ISO8859-4"
+ISO-8859-5, "ISO8859-5"
+ISO-8859-6, "ISO8859-6"
+ISO-8859-7, "ISO8859-7"
+ISO-8859-8, "ISO8859-8"
+ISO-8859-9, "ISO8859-9"
+ISO-8859-15, "ISO8859-15"
+CP437, "IBM-437"
+CP850, "IBM-850"
+CP852, "IBM-852"
+CP856, "IBM-856"
+CP857, "IBM-857"
+CP861, "IBM-861"
+CP865, "IBM-865"
+CP869, "IBM-869"
+ISO-8859-13, "IBM-921"
+CP922, "IBM-922"
+CP932, "IBM-932"
+CP943, "IBM-943"
+CP1046, "IBM-1046"
+CP1124, "IBM-1124"
+CP1125, "IBM-1125"
+CP1129, "IBM-1129"
+CP1252, "IBM-1252"
+GB2312, "IBM-eucCN"
+EUC-JP, "IBM-eucJP"
+EUC-KR, "IBM-eucKR"
+EUC-TW, "IBM-eucTW"
+BIG5, "big5"
diff --git a/lib/iconv_open-hpux.gperf b/lib/iconv_open-hpux.gperf
new file mode 100644
index 0000000..5a35c83
--- /dev/null
+++ b/lib/iconv_open-hpux.gperf
@@ -0,0 +1,56 @@
+struct mapping { int standard_name; const char vendor_name[9 + 1]; };
+%struct-type
+%language=ANSI-C
+%define slot-name standard_name
+%define hash-function-name mapping_hash
+%define lookup-function-name mapping_lookup
+%readonly-tables
+%global-table
+%define word-array-name mappings
+%pic
+%%
+# On HP-UX 11.11, look in /usr/lib/nls/iconv.
+ISO-8859-1, "iso88591"
+ISO-8859-2, "iso88592"
+ISO-8859-5, "iso88595"
+ISO-8859-6, "iso88596"
+ISO-8859-7, "iso88597"
+ISO-8859-8, "iso88598"
+ISO-8859-9, "iso88599"
+ISO-8859-15, "iso885915"
+CP437, "cp437"
+CP775, "cp775"
+CP850, "cp850"
+CP852, "cp852"
+CP855, "cp855"
+CP857, "cp857"
+CP861, "cp861"
+CP862, "cp862"
+CP864, "cp864"
+CP865, "cp865"
+CP866, "cp866"
+CP869, "cp869"
+CP874, "cp874"
+CP1250, "cp1250"
+CP1251, "cp1251"
+CP1252, "cp1252"
+CP1253, "cp1253"
+CP1254, "cp1254"
+CP1255, "cp1255"
+CP1256, "cp1256"
+CP1257, "cp1257"
+CP1258, "cp1258"
+HP-ROMAN8, "roman8"
+HP-ARABIC8, "arabic8"
+HP-GREEK8, "greek8"
+HP-HEBREW8, "hebrew8"
+HP-TURKISH8, "turkish8"
+HP-KANA8, "kana8"
+TIS-620, "tis620"
+GB2312, "hp15CN"
+EUC-JP, "eucJP"
+EUC-KR, "eucKR"
+EUC-TW, "eucTW"
+BIG5, "big5"
+SHIFT_JIS, "sjis"
+UTF-8, "utf8"
diff --git a/lib/iconv_open-irix.gperf b/lib/iconv_open-irix.gperf
new file mode 100644
index 0000000..3672a80
--- /dev/null
+++ b/lib/iconv_open-irix.gperf
@@ -0,0 +1,31 @@
+struct mapping { int standard_name; const char vendor_name[10 + 1]; };
+%struct-type
+%language=ANSI-C
+%define slot-name standard_name
+%define hash-function-name mapping_hash
+%define lookup-function-name mapping_lookup
+%readonly-tables
+%global-table
+%define word-array-name mappings
+%pic
+%%
+# On IRIX 6.5, look in /usr/lib/iconv and /usr/lib/international/encodings.
+ISO-8859-1, "ISO8859-1"
+ISO-8859-2, "ISO8859-2"
+ISO-8859-3, "ISO8859-3"
+ISO-8859-4, "ISO8859-4"
+ISO-8859-5, "ISO8859-5"
+ISO-8859-6, "ISO8859-6"
+ISO-8859-7, "ISO8859-7"
+ISO-8859-8, "ISO8859-8"
+ISO-8859-9, "ISO8859-9"
+ISO-8859-15, "ISO8859-15"
+KOI8-R, "KOI8"
+CP855, "DOS855"
+CP1251, "WIN1251"
+GB2312, "eucCN"
+EUC-JP, "eucJP"
+EUC-KR, "eucKR"
+EUC-TW, "eucTW"
+SHIFT_JIS, "sjis"
+TIS-620, "TIS620"
diff --git a/lib/iconv_open-osf.gperf b/lib/iconv_open-osf.gperf
new file mode 100644
index 0000000..f468ff6
--- /dev/null
+++ b/lib/iconv_open-osf.gperf
@@ -0,0 +1,50 @@
+struct mapping { int standard_name; const char vendor_name[10 + 1]; };
+%struct-type
+%language=ANSI-C
+%define slot-name standard_name
+%define hash-function-name mapping_hash
+%define lookup-function-name mapping_lookup
+%readonly-tables
+%global-table
+%define word-array-name mappings
+%pic
+%%
+# On OSF/1 5.1, look in /usr/lib/nls/loc/iconv.
+ISO-8859-1, "ISO8859-1"
+ISO-8859-2, "ISO8859-2"
+ISO-8859-3, "ISO8859-3"
+ISO-8859-4, "ISO8859-4"
+ISO-8859-5, "ISO8859-5"
+ISO-8859-6, "ISO8859-6"
+ISO-8859-7, "ISO8859-7"
+ISO-8859-8, "ISO8859-8"
+ISO-8859-9, "ISO8859-9"
+ISO-8859-15, "ISO8859-15"
+CP437, "cp437"
+CP775, "cp775"
+CP850, "cp850"
+CP852, "cp852"
+CP855, "cp855"
+CP857, "cp857"
+CP861, "cp861"
+CP862, "cp862"
+CP865, "cp865"
+CP866, "cp866"
+CP869, "cp869"
+CP874, "cp874"
+CP949, "KSC5601"
+CP1250, "cp1250"
+CP1251, "cp1251"
+CP1252, "cp1252"
+CP1253, "cp1253"
+CP1254, "cp1254"
+CP1255, "cp1255"
+CP1256, "cp1256"
+CP1257, "cp1257"
+CP1258, "cp1258"
+EUC-JP, "eucJP"
+EUC-KR, "eucKR"
+EUC-TW, "eucTW"
+BIG5, "big5"
+SHIFT_JIS, "SJIS"
+TIS-620, "TACTIS"
diff --git a/lib/iconv_open.c b/lib/iconv_open.c
new file mode 100644
index 0000000..3d873ac
--- /dev/null
+++ b/lib/iconv_open.c
@@ -0,0 +1,172 @@
+/* Character set conversion.
+ Copyright (C) 2007 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 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
along
+ with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#include <config.h>
+
+/* Specification. */
+#include <iconv.h>
+
+#include <errno.h>
+#include <string.h>
+#include "c-ctype.h"
+#include "c-strcase.h"
+
+#define SIZEOF(a) (sizeof(a) / sizeof(a[0]))
+
+/* Namespace cleanliness. */
+#define mapping_lookup rpl_iconv_open_mapping_lookup
+
+/* The macro ICONV_FLAVOR is defined to one of these or undefined. */
+
+#define ICONV_FLAVOR_AIX "iconv_open-aix.h"
+#define ICONV_FLAVOR_HPUX "iconv_open-hpux.h"
+#define ICONV_FLAVOR_IRIX "iconv_open-irix.h"
+#define ICONV_FLAVOR_OSF "iconv_open-osf.h"
+
+#ifdef ICONV_FLAVOR
+# include ICONV_FLAVOR
+#endif
+
+iconv_t
+rpl_iconv_open (const char *tocode, const char *fromcode)
+#undef iconv_open
+{
+ char fromcode_upper[32];
+ char tocode_upper[32];
+ char *fromcode_upper_end;
+ char *tocode_upper_end;
+
+#if REPLACE_ICONV_UTF
+ /* Special handling of conversion between UTF-8 and UTF-{16,32}{BE,LE}.
+ Do this here, before calling the real iconv_open(), because OSF/1 5.1
+ iconv() to these encoding inserts a BOM, which is wrong.
+ We do not need to handle conversion between arbitrary encodings and
+ UTF-{16,32}{BE,LE}, because the 'striconveh' module implements two-step
+ conversion throough UTF-8.
+ The _ICONV_* constants are chosen to be disjoint from any iconv_t
+ returned by the system's iconv_open() functions. Recall that iconv_t
+ is a scalar type. */
+ if (c_toupper (fromcode[0]) == 'U'
+ && c_toupper (fromcode[1]) == 'T'
+ && c_toupper (fromcode[2]) == 'F'
+ && fromcode[3] == '-')
+ {
+ if (c_toupper (tocode[0]) == 'U'
+ && c_toupper (tocode[1]) == 'T'
+ && c_toupper (tocode[2]) == 'F'
+ && tocode[3] == '-')
+ {
+ if (strcmp (fromcode + 4, "8") == 0)
+ {
+ if (c_strcasecmp (tocode + 4, "16BE") == 0)
+ return _ICONV_UTF8_UTF16BE;
+ if (c_strcasecmp (tocode + 4, "16LE") == 0)
+ return _ICONV_UTF8_UTF16LE;
+ if (c_strcasecmp (tocode + 4, "32BE") == 0)
+ return _ICONV_UTF8_UTF32BE;
+ if (c_strcasecmp (tocode + 4, "32LE") == 0)
+ return _ICONV_UTF8_UTF32LE;
+ }
+ else if (strcmp (tocode + 4, "8") == 0)
+ {
+ if (c_strcasecmp (fromcode + 4, "16BE") == 0)
+ return _ICONV_UTF16BE_UTF8;
+ if (c_strcasecmp (fromcode + 4, "16LE") == 0)
+ return _ICONV_UTF16LE_UTF8;
+ if (c_strcasecmp (fromcode + 4, "32BE") == 0)
+ return _ICONV_UTF32BE_UTF8;
+ if (c_strcasecmp (fromcode + 4, "32LE") == 0)
+ return _ICONV_UTF32LE_UTF8;
+ }
+ }
+ }
+#endif
+
+ /* Do *not* add special support for 8-bit encodings like ASCII or ISO-8859-1
+ here. This would lead to programs that work in some locales (such as the
+ "C" or "en_US" locales) but do not work in East Asian locales. It is
+ better if programmers make their programs depend on GNU libiconv (except
+ on glibc systems), e.g. by using the AM_ICONV macro and documenting the
+ dependency in an INSTALL or DEPENDENCIES file. */
+
+ /* Try with the original names first.
+ This covers the case when fromcode or tocode is a lowercase encoding name
+ that is understood by the system's iconv_open but not listed in our
+ mappings table. */
+ {
+ iconv_t cd = iconv_open (tocode, fromcode);
+ if (cd != (iconv_t)(-1))
+ return cd;
+ }
+
+ /* Convert the encodings to upper case, because
+ 1. in the arguments of iconv_open() on AIX, HP-UX, and OSF/1 the case
+ matters,
+ 2. it makes searching in the table faster. */
+ {
+ const char *p = fromcode;
+ char *q = fromcode_upper;
+ while ((*q = c_toupper (*p)) != '\0')
+ {
+ p++;
+ q++;
+ if (q == &fromcode_upper[SIZEOF (fromcode_upper)])
+ {
+ errno = EINVAL;
+ return (iconv_t)(-1);
+ }
+ }
+ fromcode_upper_end = q;
+ }
+
+ {
+ const char *p = tocode;
+ char *q = tocode_upper;
+ while ((*q = c_toupper (*p)) != '\0')
+ {
+ p++;
+ q++;
+ if (q == &tocode_upper[SIZEOF (tocode_upper)])
+ {
+ errno = EINVAL;
+ return (iconv_t)(-1);
+ }
+ }
+ tocode_upper_end = q;
+ }
+
+#ifdef ICONV_FLAVOR
+ /* Apply the mappings. */
+ {
+ const struct mapping *m =
+ mapping_lookup (fromcode_upper, fromcode_upper_end - fromcode_upper);
+
+ fromcode = (m != NULL ? m->vendor_name : fromcode_upper);
+ }
+ {
+ const struct mapping *m =
+ mapping_lookup (tocode_upper, tocode_upper_end - tocode_upper);
+
+ tocode = (m != NULL ? m->vendor_name : tocode_upper);
+ }
+#else
+ fromcode = fromcode_upper;
+ tocode = tocode_upper;
+#endif
+
+ return iconv_open (tocode, fromcode);
+}
diff --git a/lib/iconveh.h b/lib/iconveh.h
new file mode 100644
index 0000000..06cda52
--- /dev/null
+++ b/lib/iconveh.h
@@ -0,0 +1,41 @@
+/* Character set conversion handler type.
+ Copyright (C) 2001-2007, 2009 Free Software Foundation, Inc.
+ Written by Bruno Haible.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef _ICONVEH_H
+#define _ICONVEH_H
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+/* Handling of unconvertible characters. */
+enum iconv_ilseq_handler
+{
+ iconveh_error, /* return and set errno = EILSEQ */
+ iconveh_question_mark, /* use one '?' per unconvertible character */
+ iconveh_escape_sequence /* use escape sequence \uxxxx or \Uxxxxxxxx */
+};
+
+
+#ifdef __cplusplus
+}
+#endif
+
+
+#endif /* _ICONVEH_H */
diff --git a/lib/localcharset.c b/lib/localcharset.c
index c3e3937..93da170 100644
--- a/lib/localcharset.c
+++ b/lib/localcharset.c
@@ -1,6 +1,6 @@
/* Determine a canonical name for the current locale's character encoding.
- Copyright (C) 2000-2006, 2008 Free Software Foundation, Inc.
+ Copyright (C) 2000-2006, 2008-2009 Free Software Foundation, Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
@@ -28,6 +28,10 @@
#include <string.h>
#include <stdlib.h>
+#if defined __APPLE__ && defined __MACH__ && HAVE_LANGINFO_CODESET
+# define DARWIN7 /* Darwin 7 or newer, i.e. MacOS X 10.3 or newer */
+#endif
+
#if defined _WIN32 || defined __WIN32__
# define WIN32_NATIVE
#endif
@@ -112,7 +116,7 @@ get_charset_aliases (void)
cp = charset_aliases;
if (cp == NULL)
{
-#if !(defined VMS || defined WIN32_NATIVE || defined __CYGWIN__)
+#if !(defined DARWIN7 || defined VMS || defined WIN32_NATIVE || defined
__CYGWIN__)
FILE *fp;
const char *dir;
const char *base = "charset.alias";
@@ -213,6 +217,39 @@ get_charset_aliases (void)
#else
+# if defined DARWIN7
+ /* To avoid the trouble of installing a file that is shared by many
+ GNU packages -- many packaging systems have problems with this --,
+ simply inline the aliases here. */
+ cp = "ISO8859-1" "\0" "ISO-8859-1" "\0"
+ "ISO8859-2" "\0" "ISO-8859-2" "\0"
+ "ISO8859-4" "\0" "ISO-8859-4" "\0"
+ "ISO8859-5" "\0" "ISO-8859-5" "\0"
+ "ISO8859-7" "\0" "ISO-8859-7" "\0"
+ "ISO8859-9" "\0" "ISO-8859-9" "\0"
+ "ISO8859-13" "\0" "ISO-8859-13" "\0"
+ "ISO8859-15" "\0" "ISO-8859-15" "\0"
+ "KOI8-R" "\0" "KOI8-R" "\0"
+ "KOI8-U" "\0" "KOI8-U" "\0"
+ "CP866" "\0" "CP866" "\0"
+ "CP949" "\0" "CP949" "\0"
+ "CP1131" "\0" "CP1131" "\0"
+ "CP1251" "\0" "CP1251" "\0"
+ "eucCN" "\0" "GB2312" "\0"
+ "GB2312" "\0" "GB2312" "\0"
+ "eucJP" "\0" "EUC-JP" "\0"
+ "eucKR" "\0" "EUC-KR" "\0"
+ "Big5" "\0" "BIG5" "\0"
+ "Big5HKSCS" "\0" "BIG5-HKSCS" "\0"
+ "GBK" "\0" "GBK" "\0"
+ "GB18030" "\0" "GB18030" "\0"
+ "SJIS" "\0" "SHIFT_JIS" "\0"
+ "ARMSCII-8" "\0" "ARMSCII-8" "\0"
+ "PT154" "\0" "PT154" "\0"
+ /*"ISCII-DEV" "\0" "?" "\0"*/
+ "*" "\0" "UTF-8" "\0";
+# endif
+
# if defined VMS
/* To avoid the troubles of an extra file charset.alias_vms in the
sources of many GNU packages, simply inline the aliases here. */
diff --git a/lib/malloc.c b/lib/malloc.c
new file mode 100644
index 0000000..9111c7a
--- /dev/null
+++ b/lib/malloc.c
@@ -0,0 +1,57 @@
+/* malloc() function that is glibc compatible.
+
+ Copyright (C) 1997, 1998, 2006, 2007 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 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+/* written by Jim Meyering and Bruno Haible */
+
+#include <config.h>
+/* Only the AC_FUNC_MALLOC macro defines 'malloc' already in config.h. */
+#ifdef malloc
+# define NEED_MALLOC_GNU
+# undef malloc
+#endif
+
+/* Specification. */
+#include <stdlib.h>
+
+#include <errno.h>
+
+/* Call the system's malloc below. */
+#undef malloc
+
+/* Allocate an N-byte block of memory from the heap.
+ If N is zero, allocate a 1-byte block. */
+
+void *
+rpl_malloc (size_t n)
+{
+ void *result;
+
+#ifdef NEED_MALLOC_GNU
+ if (n == 0)
+ n = 1;
+#endif
+
+ result = malloc (n);
+
+#if !HAVE_MALLOC_POSIX
+ if (result == NULL)
+ errno = ENOMEM;
+#endif
+
+ return result;
+}
diff --git a/lib/mbrtowc.c b/lib/mbrtowc.c
index 17b3de5..7b528e8 100644
--- a/lib/mbrtowc.c
+++ b/lib/mbrtowc.c
@@ -1,5 +1,5 @@
/* Convert multibyte character to wide character.
- Copyright (C) 1999-2002, 2005-2008 Free Software Foundation, Inc.
+ Copyright (C) 1999-2002, 2005-2009 Free Software Foundation, Inc.
Written by Bruno Haible <address@hidden>, 2008.
This program is free software: you can redistribute it and/or modify
@@ -89,7 +89,7 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps)
return (size_t)(-1);
}
- /* Here 0 < m ⤠4. */
+ /* Here m > 0. */
# if __GLIBC__
/* Work around bug <http://sourceware.org/bugzilla/show_bug.cgi?id=9674> */
@@ -118,7 +118,7 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t
*ps)
lack mbrtowc(), we use the second approach.
The possible encodings are:
- 8-bit encodings,
- - EUC-JP, EUC-KR, GB2312, EUC-TW, BIG5, SJIS,
+ - EUC-JP, EUC-KR, GB2312, EUC-TW, BIG5, GB18030, SJIS,
- UTF-8.
Use specialized code for each. */
if (m >= 4 || m >= MB_CUR_MAX)
@@ -238,6 +238,39 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t
*ps)
}
goto invalid;
}
+ if (STREQ (encoding, "GB18030", 'G', 'B', '1', '8', '0', '3', '0', 0,
0))
+ {
+ if (m == 1)
+ {
+ unsigned char c = (unsigned char) p[0];
+
+ if ((c >= 0x90 && c <= 0xe3) || (c >= 0xf8 && c <= 0xfe))
+ goto incomplete;
+ }
+ else /* m == 2 || m == 3 */
+ {
+ unsigned char c = (unsigned char) p[0];
+
+ if (c >= 0x90 && c <= 0xe3)
+ {
+ unsigned char c2 = (unsigned char) p[1];
+
+ if (c2 >= 0x30 && c2 <= 0x39)
+ {
+ if (m == 2)
+ goto incomplete;
+ else /* m == 3 */
+ {
+ unsigned char c3 = (unsigned char) p[2];
+
+ if (c3 >= 0x81 && c3 <= 0xfe)
+ goto incomplete;
+ }
+ }
+ }
+ }
+ goto invalid;
+ }
if (STREQ (encoding, "SJIS", 'S', 'J', 'I', 'S', 0, 0, 0, 0, 0))
{
if (m == 1)
@@ -258,10 +291,14 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t
*ps)
incomplete:
{
size_t k = nstate;
- /* Here 0 < k < m < 4. */
+ /* Here 0 <= k < m < 4. */
pstate[++k] = s[0];
if (k < m)
- pstate[++k] = s[1];
+ {
+ pstate[++k] = s[1];
+ if (k < m)
+ pstate[++k] = s[2];
+ }
if (k != m)
abort ();
}
diff --git a/lib/putenv.c b/lib/putenv.c
new file mode 100644
index 0000000..53cc839
--- /dev/null
+++ b/lib/putenv.c
@@ -0,0 +1,132 @@
+/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2008
+ Free Software Foundation, Inc.
+
+ NOTE: The canonical source of this file is maintained with the GNU C
+ Library. Bugs can be reported to address@hidden
+
+ 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 of the License, or 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 program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+/* Specification. */
+#include <stdlib.h>
+
+#include <stddef.h>
+
+/* Include errno.h *after* sys/types.h to work around header problems
+ on AIX 3.2.5. */
+#include <errno.h>
+#ifndef __set_errno
+# define __set_errno(ev) ((errno) = (ev))
+#endif
+
+#include <string.h>
+#include <unistd.h>
+
+#if HAVE_GNU_LD
+# define environ __environ
+#else
+extern char **environ;
+#endif
+
+#if _LIBC
+/* This lock protects against simultaneous modifications of `environ'. */
+# include <bits/libc-lock.h>
+__libc_lock_define_initialized (static, envlock)
+# define LOCK __libc_lock_lock (envlock)
+# define UNLOCK __libc_lock_unlock (envlock)
+#else
+# define LOCK
+# define UNLOCK
+#endif
+
+static int
+_unsetenv (const char *name)
+{
+ size_t len;
+ char **ep;
+
+ if (name == NULL || *name == '\0' || strchr (name, '=') != NULL)
+ {
+ __set_errno (EINVAL);
+ return -1;
+ }
+
+ len = strlen (name);
+
+ LOCK;
+
+ ep = environ;
+ while (*ep != NULL)
+ if (!strncmp (*ep, name, len) && (*ep)[len] == '=')
+ {
+ /* Found it. Remove this pointer by moving later ones back. */
+ char **dp = ep;
+
+ do
+ dp[0] = dp[1];
+ while (*dp++);
+ /* Continue the loop in case NAME appears again. */
+ }
+ else
+ ++ep;
+
+ UNLOCK;
+
+ return 0;
+}
+
+
+/* Put STRING, which is of the form "NAME=VALUE", in the environment.
+ If STRING contains no `=', then remove STRING from the environment. */
+int
+putenv (char *string)
+{
+ const char *const name_end = strchr (string, '=');
+ register size_t size;
+ register char **ep;
+
+ if (name_end == NULL)
+ {
+ /* Remove the variable from the environment. */
+ return _unsetenv (string);
+ }
+
+ size = 0;
+ for (ep = environ; *ep != NULL; ++ep)
+ if (!strncmp (*ep, string, name_end - string) &&
+ (*ep)[name_end - string] == '=')
+ break;
+ else
+ ++size;
+
+ if (*ep == NULL)
+ {
+ static char **last_environ = NULL;
+ char **new_environ = (char **) malloc ((size + 2) * sizeof (char *));
+ if (new_environ == NULL)
+ return -1;
+ (void) memcpy ((void *) new_environ, (void *) environ,
+ size * sizeof (char *));
+ new_environ[size] = (char *) string;
+ new_environ[size + 1] = NULL;
+ free (last_environ);
+ last_environ = new_environ;
+ environ = new_environ;
+ }
+ else
+ *ep = string;
+
+ return 0;
+}
diff --git a/lib/stdint.in.h b/lib/stdint.in.h
new file mode 100644
index 0000000..11a2117
--- /dev/null
+++ b/lib/stdint.in.h
@@ -0,0 +1,567 @@
+/* Copyright (C) 2001-2002, 2004-2009 Free Software Foundation, Inc.
+ Written by Paul Eggert, Bruno Haible, Sam Steingold, Peter Burwood.
+ This file is part of gnulib.
+
+ 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 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+/*
+ * ISO C 99 <stdint.h> for platforms that lack it.
+ * <http://www.opengroup.org/susv3xbd/stdint.h.html>
+ */
+
+#ifndef _GL_STDINT_H
+
+/* When including a system file that in turn includes <inttypes.h>,
+ use the system <inttypes.h>, not our substitute. This avoids
+ problems with (for example) VMS, whose <sys/bitypes.h> includes
+ <inttypes.h>. */
+#define _GL_JUST_INCLUDE_SYSTEM_INTTYPES_H
+
+/* Get those types that are already defined in other system include
+ files, so that we can "#define int8_t signed char" below without
+ worrying about a later system include file containing a "typedef
+ signed char int8_t;" that will get messed up by our macro. Our
+ macros should all be consistent with the system versions, except
+ for the "fast" types and macros, which we recommend against using
+ in public interfaces due to compiler differences. */
+
+#if @HAVE_STDINT_H@
+# if defined __sgi && ! defined __c99
+ /* Bypass IRIX's <stdint.h> if in C89 mode, since it merely annoys users
+ with "This header file is to be used only for c99 mode compilations"
+ diagnostics. */
+# define __STDINT_H__
+# endif
+ /* Other systems may have an incomplete or buggy <stdint.h>.
+ Include it before <inttypes.h>, since any "#include <stdint.h>"
+ in <inttypes.h> would reinclude us, skipping our contents because
+ _GL_STDINT_H is defined.
+ The include_next requires a split double-inclusion guard. */
+# if __GNUC__ >= 3
address@hidden@
+# endif
+# @INCLUDE_NEXT@ @NEXT_STDINT_H@
+#endif
+
+#if ! defined _GL_STDINT_H && ! defined _GL_JUST_INCLUDE_SYSTEM_STDINT_H
+#define _GL_STDINT_H
+
+/* <sys/types.h> defines some of the stdint.h types as well, on glibc,
+ IRIX 6.5, and OpenBSD 3.8 (via <machine/types.h>).
+ AIX 5.2 <sys/types.h> isn't needed and causes troubles.
+ MacOS X 10.4.6 <sys/types.h> includes <stdint.h> (which is us), but
+ relies on the system <stdint.h> definitions, so include
+ <sys/types.h> after @address@hidden */
+#if @HAVE_SYS_TYPES_H@ && ! defined _AIX
+# include <sys/types.h>
+#endif
+
+/* Get LONG_MIN, LONG_MAX, ULONG_MAX. */
+#include <limits.h>
+
+#if @HAVE_INTTYPES_H@
+ /* In OpenBSD 3.8, <inttypes.h> includes <machine/types.h>, which defines
+ int{8,16,32,64}_t, uint{8,16,32,64}_t and __BIT_TYPES_DEFINED__.
+ <inttypes.h> also defines intptr_t and uintptr_t. */
+# include <inttypes.h>
+#elif @HAVE_SYS_INTTYPES_H@
+ /* Solaris 7 <sys/inttypes.h> has the types except the *_fast*_t types, and
+ the macros except for *_FAST*_*, INTPTR_MIN, PTRDIFF_MIN, PTRDIFF_MAX. */
+# include <sys/inttypes.h>
+#endif
+
+#if @HAVE_SYS_BITYPES_H@ && ! defined __BIT_TYPES_DEFINED__
+ /* Linux libc4 >= 4.6.7 and libc5 have a <sys/bitypes.h> that defines
+ int{8,16,32,64}_t and __BIT_TYPES_DEFINED__. In libc5 >= 5.2.2 it is
+ included by <sys/types.h>. */
+# include <sys/bitypes.h>
+#endif
+
+#undef _GL_JUST_INCLUDE_SYSTEM_INTTYPES_H
+
+/* Minimum and maximum values for a integer type under the usual assumption.
+ Return an unspecified value if BITS == 0, adding a check to pacify
+ picky compilers. */
+
+#define _STDINT_MIN(signed, bits, zero) \
+ ((signed) ? (- ((zero) + 1) << ((bits) ? (bits) - 1 : 0)) : (zero))
+
+#define _STDINT_MAX(signed, bits, zero) \
+ ((signed) \
+ ? ~ _STDINT_MIN (signed, bits, zero) \
+ : /* The expression for the unsigned case. The subtraction of (signed) \
+ is a nop in the unsigned case and avoids "signed integer overflow" \
+ warnings in the signed case. */ \
+ ((((zero) + 1) << ((bits) ? (bits) - 1 - (signed) : 0)) - 1) * 2 + 1)
+
+/* 7.18.1.1. Exact-width integer types */
+
+/* Here we assume a standard architecture where the hardware integer
+ types have 8, 16, 32, optionally 64 bits. */
+
+#undef int8_t
+#undef uint8_t
+typedef signed char gl_int8_t;
+typedef unsigned char gl_uint8_t;
+#define int8_t gl_int8_t
+#define uint8_t gl_uint8_t
+
+#undef int16_t
+#undef uint16_t
+typedef short int gl_int16_t;
+typedef unsigned short int gl_uint16_t;
+#define int16_t gl_int16_t
+#define uint16_t gl_uint16_t
+
+#undef int32_t
+#undef uint32_t
+typedef int gl_int32_t;
+typedef unsigned int gl_uint32_t;
+#define int32_t gl_int32_t
+#define uint32_t gl_uint32_t
+
+/* Do not undefine int64_t if gnulib is not being used with 64-bit
+ types, since otherwise it breaks platforms like Tandem/NSK. */
+#if LONG_MAX >> 31 >> 31 == 1
+# undef int64_t
+typedef long int gl_int64_t;
+# define int64_t gl_int64_t
+# define GL_INT64_T
+#elif defined _MSC_VER
+# undef int64_t
+typedef __int64 gl_int64_t;
+# define int64_t gl_int64_t
+# define GL_INT64_T
+#elif @HAVE_LONG_LONG_INT@
+# undef int64_t
+typedef long long int gl_int64_t;
+# define int64_t gl_int64_t
+# define GL_INT64_T
+#endif
+
+#if ULONG_MAX >> 31 >> 31 >> 1 == 1
+# undef uint64_t
+typedef unsigned long int gl_uint64_t;
+# define uint64_t gl_uint64_t
+# define GL_UINT64_T
+#elif defined _MSC_VER
+# undef uint64_t
+typedef unsigned __int64 gl_uint64_t;
+# define uint64_t gl_uint64_t
+# define GL_UINT64_T
+#elif @HAVE_UNSIGNED_LONG_LONG_INT@
+# undef uint64_t
+typedef unsigned long long int gl_uint64_t;
+# define uint64_t gl_uint64_t
+# define GL_UINT64_T
+#endif
+
+/* Avoid collision with Solaris 2.5.1 <pthread.h> etc. */
+#define _UINT8_T
+#define _UINT32_T
+#define _UINT64_T
+
+
+/* 7.18.1.2. Minimum-width integer types */
+
+/* Here we assume a standard architecture where the hardware integer
+ types have 8, 16, 32, optionally 64 bits. Therefore the leastN_t types
+ are the same as the corresponding N_t types. */
+
+#undef int_least8_t
+#undef uint_least8_t
+#undef int_least16_t
+#undef uint_least16_t
+#undef int_least32_t
+#undef uint_least32_t
+#undef int_least64_t
+#undef uint_least64_t
+#define int_least8_t int8_t
+#define uint_least8_t uint8_t
+#define int_least16_t int16_t
+#define uint_least16_t uint16_t
+#define int_least32_t int32_t
+#define uint_least32_t uint32_t
+#ifdef GL_INT64_T
+# define int_least64_t int64_t
+#endif
+#ifdef GL_UINT64_T
+# define uint_least64_t uint64_t
+#endif
+
+/* 7.18.1.3. Fastest minimum-width integer types */
+
+/* Note: Other <stdint.h> substitutes may define these types differently.
+ It is not recommended to use these types in public header files. */
+
+/* Here we assume a standard architecture where the hardware integer
+ types have 8, 16, 32, optionally 64 bits. Therefore the fastN_t types
+ are taken from the same list of types. Assume that 'long int'
+ is fast enough for all narrower integers. */
+
+#undef int_fast8_t
+#undef uint_fast8_t
+#undef int_fast16_t
+#undef uint_fast16_t
+#undef int_fast32_t
+#undef uint_fast32_t
+#undef int_fast64_t
+#undef uint_fast64_t
+typedef long int gl_int_fast8_t;
+typedef unsigned long int gl_uint_fast8_t;
+typedef long int gl_int_fast16_t;
+typedef unsigned long int gl_uint_fast16_t;
+typedef long int gl_int_fast32_t;
+typedef unsigned long int gl_uint_fast32_t;
+#define int_fast8_t gl_int_fast8_t
+#define uint_fast8_t gl_uint_fast8_t
+#define int_fast16_t gl_int_fast16_t
+#define uint_fast16_t gl_uint_fast16_t
+#define int_fast32_t gl_int_fast32_t
+#define uint_fast32_t gl_uint_fast32_t
+#ifdef GL_INT64_T
+# define int_fast64_t int64_t
+#endif
+#ifdef GL_UINT64_T
+# define uint_fast64_t uint64_t
+#endif
+
+/* 7.18.1.4. Integer types capable of holding object pointers */
+
+#undef intptr_t
+#undef uintptr_t
+typedef long int gl_intptr_t;
+typedef unsigned long int gl_uintptr_t;
+#define intptr_t gl_intptr_t
+#define uintptr_t gl_uintptr_t
+
+/* 7.18.1.5. Greatest-width integer types */
+
+/* Note: These types are compiler dependent. It may be unwise to use them in
+ public header files. */
+
+#undef intmax_t
+#if @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1
+typedef long long int gl_intmax_t;
+# define intmax_t gl_intmax_t
+#elif defined GL_INT64_T
+# define intmax_t int64_t
+#else
+typedef long int gl_intmax_t;
+# define intmax_t gl_intmax_t
+#endif
+
+#undef uintmax_t
+#if @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1
+typedef unsigned long long int gl_uintmax_t;
+# define uintmax_t gl_uintmax_t
+#elif defined GL_UINT64_T
+# define uintmax_t uint64_t
+#else
+typedef unsigned long int gl_uintmax_t;
+# define uintmax_t gl_uintmax_t
+#endif
+
+/* Verify that intmax_t and uintmax_t have the same size. Too much code
+ breaks if this is not the case. If this check fails, the reason is likely
+ to be found in the autoconf macros. */
+typedef int _verify_intmax_size[2 * (sizeof (intmax_t) == sizeof (uintmax_t))
- 1];
+
+/* 7.18.2. Limits of specified-width integer types */
+
+#if ! defined __cplusplus || defined __STDC_LIMIT_MACROS
+
+/* 7.18.2.1. Limits of exact-width integer types */
+
+/* Here we assume a standard architecture where the hardware integer
+ types have 8, 16, 32, optionally 64 bits. */
+
+#undef INT8_MIN
+#undef INT8_MAX
+#undef UINT8_MAX
+#define INT8_MIN (~ INT8_MAX)
+#define INT8_MAX 127
+#define UINT8_MAX 255
+
+#undef INT16_MIN
+#undef INT16_MAX
+#undef UINT16_MAX
+#define INT16_MIN (~ INT16_MAX)
+#define INT16_MAX 32767
+#define UINT16_MAX 65535
+
+#undef INT32_MIN
+#undef INT32_MAX
+#undef UINT32_MAX
+#define INT32_MIN (~ INT32_MAX)
+#define INT32_MAX 2147483647
+#define UINT32_MAX 4294967295U
+
+#undef INT64_MIN
+#undef INT64_MAX
+#ifdef GL_INT64_T
+/* Prefer (- INTMAX_C (1) << 63) over (~ INT64_MAX) because SunPRO C 5.0
+ evaluates the latter incorrectly in preprocessor expressions. */
+# define INT64_MIN (- INTMAX_C (1) << 63)
+# define INT64_MAX INTMAX_C (9223372036854775807)
+#endif
+
+#undef UINT64_MAX
+#ifdef GL_UINT64_T
+# define UINT64_MAX UINTMAX_C (18446744073709551615)
+#endif
+
+/* 7.18.2.2. Limits of minimum-width integer types */
+
+/* Here we assume a standard architecture where the hardware integer
+ types have 8, 16, 32, optionally 64 bits. Therefore the leastN_t types
+ are the same as the corresponding N_t types. */
+
+#undef INT_LEAST8_MIN
+#undef INT_LEAST8_MAX
+#undef UINT_LEAST8_MAX
+#define INT_LEAST8_MIN INT8_MIN
+#define INT_LEAST8_MAX INT8_MAX
+#define UINT_LEAST8_MAX UINT8_MAX
+
+#undef INT_LEAST16_MIN
+#undef INT_LEAST16_MAX
+#undef UINT_LEAST16_MAX
+#define INT_LEAST16_MIN INT16_MIN
+#define INT_LEAST16_MAX INT16_MAX
+#define UINT_LEAST16_MAX UINT16_MAX
+
+#undef INT_LEAST32_MIN
+#undef INT_LEAST32_MAX
+#undef UINT_LEAST32_MAX
+#define INT_LEAST32_MIN INT32_MIN
+#define INT_LEAST32_MAX INT32_MAX
+#define UINT_LEAST32_MAX UINT32_MAX
+
+#undef INT_LEAST64_MIN
+#undef INT_LEAST64_MAX
+#ifdef GL_INT64_T
+# define INT_LEAST64_MIN INT64_MIN
+# define INT_LEAST64_MAX INT64_MAX
+#endif
+
+#undef UINT_LEAST64_MAX
+#ifdef GL_UINT64_T
+# define UINT_LEAST64_MAX UINT64_MAX
+#endif
+
+/* 7.18.2.3. Limits of fastest minimum-width integer types */
+
+/* Here we assume a standard architecture where the hardware integer
+ types have 8, 16, 32, optionally 64 bits. Therefore the fastN_t types
+ are taken from the same list of types. */
+
+#undef INT_FAST8_MIN
+#undef INT_FAST8_MAX
+#undef UINT_FAST8_MAX
+#define INT_FAST8_MIN LONG_MIN
+#define INT_FAST8_MAX LONG_MAX
+#define UINT_FAST8_MAX ULONG_MAX
+
+#undef INT_FAST16_MIN
+#undef INT_FAST16_MAX
+#undef UINT_FAST16_MAX
+#define INT_FAST16_MIN LONG_MIN
+#define INT_FAST16_MAX LONG_MAX
+#define UINT_FAST16_MAX ULONG_MAX
+
+#undef INT_FAST32_MIN
+#undef INT_FAST32_MAX
+#undef UINT_FAST32_MAX
+#define INT_FAST32_MIN LONG_MIN
+#define INT_FAST32_MAX LONG_MAX
+#define UINT_FAST32_MAX ULONG_MAX
+
+#undef INT_FAST64_MIN
+#undef INT_FAST64_MAX
+#ifdef GL_INT64_T
+# define INT_FAST64_MIN INT64_MIN
+# define INT_FAST64_MAX INT64_MAX
+#endif
+
+#undef UINT_FAST64_MAX
+#ifdef GL_UINT64_T
+# define UINT_FAST64_MAX UINT64_MAX
+#endif
+
+/* 7.18.2.4. Limits of integer types capable of holding object pointers */
+
+#undef INTPTR_MIN
+#undef INTPTR_MAX
+#undef UINTPTR_MAX
+#define INTPTR_MIN LONG_MIN
+#define INTPTR_MAX LONG_MAX
+#define UINTPTR_MAX ULONG_MAX
+
+/* 7.18.2.5. Limits of greatest-width integer types */
+
+#undef INTMAX_MIN
+#undef INTMAX_MAX
+#ifdef INT64_MAX
+# define INTMAX_MIN INT64_MIN
+# define INTMAX_MAX INT64_MAX
+#else
+# define INTMAX_MIN INT32_MIN
+# define INTMAX_MAX INT32_MAX
+#endif
+
+#undef UINTMAX_MAX
+#ifdef UINT64_MAX
+# define UINTMAX_MAX UINT64_MAX
+#else
+# define UINTMAX_MAX UINT32_MAX
+#endif
+
+/* 7.18.3. Limits of other integer types */
+
+/* ptrdiff_t limits */
+#undef PTRDIFF_MIN
+#undef PTRDIFF_MAX
+#if @APPLE_UNIVERSAL_BUILD@
+# ifdef _LP64
+# define PTRDIFF_MIN _STDINT_MIN (1, 64, 0l)
+# define PTRDIFF_MAX _STDINT_MAX (1, 64, 0l)
+# else
+# define PTRDIFF_MIN _STDINT_MIN (1, 32, 0)
+# define PTRDIFF_MAX _STDINT_MAX (1, 32, 0)
+# endif
+#else
+# define PTRDIFF_MIN \
+ _STDINT_MIN (1, @BITSIZEOF_PTRDIFF_T@, address@hidden@)
+# define PTRDIFF_MAX \
+ _STDINT_MAX (1, @BITSIZEOF_PTRDIFF_T@, address@hidden@)
+#endif
+
+/* sig_atomic_t limits */
+#undef SIG_ATOMIC_MIN
+#undef SIG_ATOMIC_MAX
+#define SIG_ATOMIC_MIN \
+ _STDINT_MIN (@HAVE_SIGNED_SIG_ATOMIC_T@, @BITSIZEOF_SIG_ATOMIC_T@, \
+ address@hidden@)
+#define SIG_ATOMIC_MAX \
+ _STDINT_MAX (@HAVE_SIGNED_SIG_ATOMIC_T@, @BITSIZEOF_SIG_ATOMIC_T@, \
+ address@hidden@)
+
+
+/* size_t limit */
+#undef SIZE_MAX
+#if @APPLE_UNIVERSAL_BUILD@
+# ifdef _LP64
+# define SIZE_MAX _STDINT_MAX (0, 64, 0ul)
+# else
+# define SIZE_MAX _STDINT_MAX (0, 32, 0ul)
+# endif
+#else
+# define SIZE_MAX _STDINT_MAX (0, @BITSIZEOF_SIZE_T@, address@hidden@)
+#endif
+
+/* wchar_t limits */
+/* Get WCHAR_MIN, WCHAR_MAX.
+ This include is not on the top, above, because on OSF/1 4.0 we have a
sequence of nested
+ includes <wchar.h> -> <stdio.h> -> <getopt.h> -> <stdlib.h>, and the latter
includes
+ <stdint.h> and assumes its types are already defined. */
+#if ! (defined WCHAR_MIN && defined WCHAR_MAX)
+# define _GL_JUST_INCLUDE_SYSTEM_WCHAR_H
+# include <wchar.h>
+# undef _GL_JUST_INCLUDE_SYSTEM_WCHAR_H
+#endif
+#undef WCHAR_MIN
+#undef WCHAR_MAX
+#define WCHAR_MIN \
+ _STDINT_MIN (@HAVE_SIGNED_WCHAR_T@, @BITSIZEOF_WCHAR_T@, address@hidden@)
+#define WCHAR_MAX \
+ _STDINT_MAX (@HAVE_SIGNED_WCHAR_T@, @BITSIZEOF_WCHAR_T@, address@hidden@)
+
+/* wint_t limits */
+#undef WINT_MIN
+#undef WINT_MAX
+#define WINT_MIN \
+ _STDINT_MIN (@HAVE_SIGNED_WINT_T@, @BITSIZEOF_WINT_T@, address@hidden@)
+#define WINT_MAX \
+ _STDINT_MAX (@HAVE_SIGNED_WINT_T@, @BITSIZEOF_WINT_T@, address@hidden@)
+
+#endif /* !defined __cplusplus || defined __STDC_LIMIT_MACROS */
+
+/* 7.18.4. Macros for integer constants */
+
+#if ! defined __cplusplus || defined __STDC_CONSTANT_MACROS
+
+/* 7.18.4.1. Macros for minimum-width integer constants */
+/* According to ISO C 99 Technical Corrigendum 1 */
+
+/* Here we assume a standard architecture where the hardware integer
+ types have 8, 16, 32, optionally 64 bits, and int is 32 bits. */
+
+#undef INT8_C
+#undef UINT8_C
+#define INT8_C(x) x
+#define UINT8_C(x) x
+
+#undef INT16_C
+#undef UINT16_C
+#define INT16_C(x) x
+#define UINT16_C(x) x
+
+#undef INT32_C
+#undef UINT32_C
+#define INT32_C(x) x
+#define UINT32_C(x) x ## U
+
+#undef INT64_C
+#undef UINT64_C
+#if LONG_MAX >> 31 >> 31 == 1
+# define INT64_C(x) x##L
+#elif defined _MSC_VER
+# define INT64_C(x) x##i64
+#elif @HAVE_LONG_LONG_INT@
+# define INT64_C(x) x##LL
+#endif
+#if ULONG_MAX >> 31 >> 31 >> 1 == 1
+# define UINT64_C(x) x##UL
+#elif defined _MSC_VER
+# define UINT64_C(x) x##ui64
+#elif @HAVE_UNSIGNED_LONG_LONG_INT@
+# define UINT64_C(x) x##ULL
+#endif
+
+/* 7.18.4.2. Macros for greatest-width integer constants */
+
+#undef INTMAX_C
+#if @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1
+# define INTMAX_C(x) x##LL
+#elif defined GL_INT64_T
+# define INTMAX_C(x) INT64_C(x)
+#else
+# define INTMAX_C(x) x##L
+#endif
+
+#undef UINTMAX_C
+#if @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1
+# define UINTMAX_C(x) x##ULL
+#elif defined GL_UINT64_T
+# define UINTMAX_C(x) UINT64_C(x)
+#else
+# define UINTMAX_C(x) x##UL
+#endif
+
+#endif /* !defined __cplusplus || defined __STDC_CONSTANT_MACROS */
+
+#endif /* _GL_STDINT_H */
+#endif /* !defined _GL_STDINT_H && !defined _GL_JUST_INCLUDE_SYSTEM_STDINT_H */
diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h
new file mode 100644
index 0000000..23325b5
--- /dev/null
+++ b/lib/stdlib.in.h
@@ -0,0 +1,383 @@
+/* A GNU-like <stdlib.h>.
+
+ Copyright (C) 1995, 2001-2004, 2006-2009 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify
+ it under the terms of the GNU Lesser General Public License as published by
+ the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#if __GNUC__ >= 3
address@hidden@
+#endif
+
+#if defined __need_malloc_and_calloc
+/* Special invocation convention inside glibc header files. */
+
address@hidden@ @NEXT_STDLIB_H@
+
+#else
+/* Normal invocation convention. */
+
+#ifndef _GL_STDLIB_H
+
+/* The include_next requires a split double-inclusion guard. */
address@hidden@ @NEXT_STDLIB_H@
+
+#ifndef _GL_STDLIB_H
+#define _GL_STDLIB_H
+
+
+/* Solaris declares getloadavg() in <sys/loadavg.h>. */
+#if @GNULIB_GETLOADAVG@ && @HAVE_SYS_LOADAVG_H@
+# include <sys/loadavg.h>
+#endif
+
+/* OSF/1 5.1 declares 'struct random_data' in <random.h>, which is included
+ from <stdlib.h> if _REENTRANT is defined. Include it always. */
+#if @HAVE_RANDOM_H@
+# include <random.h>
+#endif
+
+#if @GNULIB_RANDOM_R@ || address@hidden@
+# include <stdint.h>
+#endif
+
+#if address@hidden@
+struct random_data
+{
+ int32_t *fptr; /* Front pointer. */
+ int32_t *rptr; /* Rear pointer. */
+ int32_t *state; /* Array of state values. */
+ int rand_type; /* Type of random number generator. */
+ int rand_deg; /* Degree of random number generator.
*/
+ int rand_sep; /* Distance between front and rear. */
+ int32_t *end_ptr; /* Pointer behind state table. */
+};
+#endif
+
+/* The definition of GL_LINK_WARNING is copied here. */
+
+
+/* Some systems do not define EXIT_*, despite otherwise supporting C89. */
+#ifndef EXIT_SUCCESS
+# define EXIT_SUCCESS 0
+#endif
+/* Tandem/NSK and other platforms that define EXIT_FAILURE as -1 interfere
+ with proper operation of xargs. */
+#ifndef EXIT_FAILURE
+# define EXIT_FAILURE 1
+#elif EXIT_FAILURE != 1
+# undef EXIT_FAILURE
+# define EXIT_FAILURE 1
+#endif
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+#if @GNULIB_MALLOC_POSIX@
+# if address@hidden@
+# undef malloc
+# define malloc rpl_malloc
+extern void * malloc (size_t size);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef malloc
+# define malloc(s) \
+ (GL_LINK_WARNING ("malloc is not POSIX compliant everywhere - " \
+ "use gnulib module malloc-posix for portability"), \
+ malloc (s))
+#endif
+
+
+#if @GNULIB_REALLOC_POSIX@
+# if address@hidden@
+# undef realloc
+# define realloc rpl_realloc
+extern void * realloc (void *ptr, size_t size);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef realloc
+# define realloc(p,s) \
+ (GL_LINK_WARNING ("realloc is not POSIX compliant everywhere - " \
+ "use gnulib module realloc-posix for portability"), \
+ realloc (p, s))
+#endif
+
+
+#if @GNULIB_CALLOC_POSIX@
+# if address@hidden@
+# undef calloc
+# define calloc rpl_calloc
+extern void * calloc (size_t nmemb, size_t size);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef calloc
+# define calloc(n,s) \
+ (GL_LINK_WARNING ("calloc is not POSIX compliant everywhere - " \
+ "use gnulib module calloc-posix for portability"), \
+ calloc (n, s))
+#endif
+
+
+#if @GNULIB_ATOLL@
+# if address@hidden@
+/* Parse a signed decimal integer.
+ Returns the value of the integer. Errors are not detected. */
+extern long long atoll (const char *string);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef atoll
+# define atoll(s) \
+ (GL_LINK_WARNING ("atoll is unportable - " \
+ "use gnulib module atoll for portability"), \
+ atoll (s))
+#endif
+
+
+#if @GNULIB_GETLOADAVG@
+# if address@hidden@
+/* Store max(NELEM,3) load average numbers in LOADAVG[].
+ The three numbers are the load average of the last 1 minute, the last 5
+ minutes, and the last 15 minutes, respectively.
+ LOADAVG is an array of NELEM numbers. */
+extern int getloadavg (double loadavg[], int nelem);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef getloadavg
+# define getloadavg(l,n) \
+ (GL_LINK_WARNING ("getloadavg is not portable - " \
+ "use gnulib module getloadavg for portability"), \
+ getloadavg (l, n))
+#endif
+
+
+#if @GNULIB_GETSUBOPT@
+/* Assuming *OPTIONP is a comma separated list of elements of the form
+ "token" or "token=value", getsubopt parses the first of these elements.
+ If the first element refers to a "token" that is member of the given
+ NULL-terminated array of tokens:
+ - It replaces the comma with a NUL byte, updates *OPTIONP to point past
+ the first option and the comma, sets *VALUEP to the value of the
+ element (or NULL if it doesn't contain an "=" sign),
+ - It returns the index of the "token" in the given array of tokens.
+ Otherwise it returns -1, and *OPTIONP and *VALUEP are undefined.
+ For more details see the POSIX:2001 specification.
+ http://www.opengroup.org/susv3xsh/getsubopt.html */
+# if address@hidden@
+extern int getsubopt (char **optionp, char *const *tokens, char **valuep);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef getsubopt
+# define getsubopt(o,t,v) \
+ (GL_LINK_WARNING ("getsubopt is unportable - " \
+ "use gnulib module getsubopt for portability"), \
+ getsubopt (o, t, v))
+#endif
+
+
+#if @GNULIB_MKDTEMP@
+# if address@hidden@
+/* Create a unique temporary directory from TEMPLATE.
+ The last six characters of TEMPLATE must be "XXXXXX";
+ they are replaced with a string that makes the directory name unique.
+ Returns TEMPLATE, or a null pointer if it cannot get a unique name.
+ The directory is created mode 700. */
+extern char * mkdtemp (char * /*template*/);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mkdtemp
+# define mkdtemp(t) \
+ (GL_LINK_WARNING ("mkdtemp is unportable - " \
+ "use gnulib module mkdtemp for portability"), \
+ mkdtemp (t))
+#endif
+
+
+#if @GNULIB_MKSTEMP@
+# if @REPLACE_MKSTEMP@
+/* Create a unique temporary file from TEMPLATE.
+ The last six characters of TEMPLATE must be "XXXXXX";
+ they are replaced with a string that makes the file name unique.
+ The file is then created, ensuring it didn't exist before.
+ The file is created read-write (mask at least 0600 & ~umask), but it may be
+ world-readable and world-writable (mask 0666 & ~umask), depending on the
+ implementation.
+ Returns the open file descriptor if successful, otherwise -1 and errno
+ set. */
+# define mkstemp rpl_mkstemp
+extern int mkstemp (char * /*template*/);
+# else
+/* On MacOS X 10.3, only <unistd.h> declares mkstemp. */
+# include <unistd.h>
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mkstemp
+# define mkstemp(t) \
+ (GL_LINK_WARNING ("mkstemp is unportable - " \
+ "use gnulib module mkstemp for portability"), \
+ mkstemp (t))
+#endif
+
+
+#if @GNULIB_PUTENV@
+# if @REPLACE_PUTENV@
+# undef putenv
+# define putenv rpl_putenv
+extern int putenv (char *string);
+# endif
+#endif
+
+
+#if @GNULIB_RANDOM_R@
+# if address@hidden@
+
+# ifndef RAND_MAX
+# define RAND_MAX 2147483647
+# endif
+
+int srandom_r (unsigned int seed, struct random_data *rand_state);
+int initstate_r (unsigned int seed, char *buf, size_t buf_size,
+ struct random_data *rand_state);
+int setstate_r (char *arg_state, struct random_data *rand_state);
+int random_r (struct random_data *buf, int32_t *result);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef random_r
+# define random_r(b,r) \
+ (GL_LINK_WARNING ("random_r is unportable - " \
+ "use gnulib module random_r for portability"), \
+ random_r (b,r))
+# undef initstate_r
+# define initstate_r(s,b,sz,r) \
+ (GL_LINK_WARNING ("initstate_r is unportable - " \
+ "use gnulib module random_r for portability"), \
+ initstate_r (s,b,sz,r))
+# undef srandom_r
+# define srandom_r(s,r) \
+ (GL_LINK_WARNING ("srandom_r is unportable - " \
+ "use gnulib module random_r for portability"), \
+ srandom_r (s,r))
+# undef setstate_r
+# define setstate_r(a,r) \
+ (GL_LINK_WARNING ("setstate_r is unportable - " \
+ "use gnulib module random_r for portability"), \
+ setstate_r (a,r))
+#endif
+
+
+#if @GNULIB_RPMATCH@
+# if address@hidden@
+/* Test a user response to a question.
+ Return 1 if it is affirmative, 0 if it is negative, or -1 if not clear. */
+extern int rpmatch (const char *response);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef rpmatch
+# define rpmatch(r) \
+ (GL_LINK_WARNING ("rpmatch is unportable - " \
+ "use gnulib module rpmatch for portability"), \
+ rpmatch (r))
+#endif
+
+
+#if @GNULIB_SETENV@
+# if address@hidden@
+/* Set NAME to VALUE in the environment.
+ If REPLACE is nonzero, overwrite an existing value. */
+extern int setenv (const char *name, const char *value, int replace);
+# endif
+#endif
+
+
+#if @GNULIB_UNSETENV@
+# if @HAVE_UNSETENV@
+# if @VOID_UNSETENV@
+/* On some systems, unsetenv() returns void.
+ This is the case for MacOS X 10.3, FreeBSD 4.8, NetBSD 1.6, OpenBSD 3.4. */
+# define unsetenv(name) ((unsetenv)(name), 0)
+# endif
+# else
+/* Remove the variable NAME from the environment. */
+extern int unsetenv (const char *name);
+# endif
+#endif
+
+
+#if @GNULIB_STRTOD@
+# if @REPLACE_STRTOD@
+# define strtod rpl_strtod
+# endif
+# if address@hidden@ || @REPLACE_STRTOD@
+ /* Parse a double from STRING, updating ENDP if appropriate. */
+extern double strtod (const char *str, char **endp);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strtod
+# define strtod(s, e) \
+ (GL_LINK_WARNING ("strtod is unportable - " \
+ "use gnulib module strtod for portability"), \
+ strtod (s, e))
+#endif
+
+
+#if @GNULIB_STRTOLL@
+# if address@hidden@
+/* Parse a signed integer whose textual representation starts at STRING.
+ The integer is expected to be in base BASE (2 <= BASE <= 36); if BASE == 0,
+ it may be decimal or octal (with prefix "0") or hexadecimal (with prefix
+ "0x").
+ If ENDPTR is not NULL, the address of the first byte after the integer is
+ stored in *ENDPTR.
+ Upon overflow, the return value is LLONG_MAX or LLONG_MIN, and errno is set
+ to ERANGE. */
+extern long long strtoll (const char *string, char **endptr, int base);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strtoll
+# define strtoll(s,e,b) \
+ (GL_LINK_WARNING ("strtoll is unportable - " \
+ "use gnulib module strtoll for portability"), \
+ strtoll (s, e, b))
+#endif
+
+
+#if @GNULIB_STRTOULL@
+# if address@hidden@
+/* Parse an unsigned integer whose textual representation starts at STRING.
+ The integer is expected to be in base BASE (2 <= BASE <= 36); if BASE == 0,
+ it may be decimal or octal (with prefix "0") or hexadecimal (with prefix
+ "0x").
+ If ENDPTR is not NULL, the address of the first byte after the integer is
+ stored in *ENDPTR.
+ Upon overflow, the return value is ULLONG_MAX, and errno is set to
+ ERANGE. */
+extern unsigned long long strtoull (const char *string, char **endptr, int
base);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strtoull
+# define strtoull(s,e,b) \
+ (GL_LINK_WARNING ("strtoull is unportable - " \
+ "use gnulib module strtoull for portability"), \
+ strtoull (s, e, b))
+#endif
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _GL_STDLIB_H */
+#endif /* _GL_STDLIB_H */
+#endif
diff --git a/lib/strftime.c b/lib/strftime.c
index ac011d4..e340223 100644
--- a/lib/strftime.c
+++ b/lib/strftime.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1991-1999, 2000, 2001, 2003, 2004, 2005, 2006, 2007 Free
Software
+/* Copyright (C) 1991-1999, 2000, 2001, 2003, 2004, 2005, 2006, 2007, 2009
Free Software
Foundation, Inc.
NOTE: The canonical source of this file is maintained with the GNU C
Library.
@@ -18,19 +18,18 @@
along with this program. If not, see <http://www.gnu.org/licenses/>. */
#ifdef _LIBC
-# define HAVE_MBLEN 1
-# define HAVE_MBRLEN 1
# define HAVE_STRUCT_ERA_ENTRY 1
# define HAVE_TM_GMTOFF 1
# define HAVE_TM_ZONE 1
# define HAVE_TZNAME 1
# define HAVE_TZSET 1
-# define MULTIBYTE_IS_FORMAT_SAFE 1
# include "../locale/localeinfo.h"
#else
# include <config.h>
# if FPRINTFTIME
# include "fprintftime.h"
+# else
+# include "strftime.h"
# endif
#endif
@@ -44,10 +43,16 @@ extern char *tzname[];
/* Do multibyte processing if multibytes are supported, unless
multibyte sequences are safe in formats. Multibyte sequences are
safe if they cannot contain byte sequences that look like format
- conversion specifications. The GNU C Library uses UTF8 multibyte
- encoding, which is safe for formats, but strftime.c can be used
- with other C libraries that use unsafe encodings. */
-#define DO_MULTIBYTE (HAVE_MBLEN && ! MULTIBYTE_IS_FORMAT_SAFE)
+ conversion specifications. The multibyte encodings used by the
+ C library on the various platforms (UTF-8, GB2312, GBK, CP936,
+ GB18030, EUC-TW, BIG5, BIG5-HKSCS, CP950, EUC-JP, EUC-KR, CP949,
+ SHIFT_JIS, CP932, JOHAB) are safe for formats, because the byte '%'
+ cannot occur in a multibyte character except in the first byte.
+ But this does not hold for the DEC-HANYU encoding used on OSF/1. */
+#if !defined __osf__
+# define MULTIBYTE_IS_FORMAT_SAFE 1
+#endif
+#define DO_MULTIBYTE (! MULTIBYTE_IS_FORMAT_SAFE)
#if DO_MULTIBYTE
# include <wchar.h>
@@ -79,13 +84,6 @@ extern char *tzname[];
# define MEMCPY(d, s, n) memcpy (d, s, n)
# define STRLEN(s) strlen (s)
-# ifdef _LIBC
-# define MEMPCPY(d, s, n) __mempcpy (d, s, n)
-# else
-# ifndef HAVE_MEMPCPY
-# define MEMPCPY(d, s, n) ((void *) ((char *) memcpy (d, s, n) + (n)))
-# endif
-# endif
#endif
/* Shift A right by B bits portably, by dividing A by 2**B and
diff --git a/lib/striconveh.c b/lib/striconveh.c
new file mode 100644
index 0000000..b39a01f
--- /dev/null
+++ b/lib/striconveh.c
@@ -0,0 +1,1251 @@
+/* Character set conversion with error handling.
+ Copyright (C) 2001-2008 Free Software Foundation, Inc.
+ Written by Bruno Haible and Simon Josefsson.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+/* Specification. */
+#include "striconveh.h"
+
+#include <errno.h>
+#include <stdbool.h>
+#include <stdlib.h>
+#include <string.h>
+
+#if HAVE_ICONV
+# include <iconv.h>
+# include "unistr.h"
+#endif
+
+#include "c-strcase.h"
+#include "c-strcaseeq.h"
+
+#ifndef SIZE_MAX
+# define SIZE_MAX ((size_t) -1)
+#endif
+
+
+#if HAVE_ICONV
+
+/* The caller must provide CD, CD1, CD2, not just CD, because when a conversion
+ error occurs, we may have to determine the Unicode representation of the
+ inconvertible character. */
+
+/* iconv_carefully is like iconv, except that it stops as soon as it encounters
+ a conversion error, and it returns in *INCREMENTED a boolean telling whether
+ it has incremented the input pointers past the error location. */
+# if !defined _LIBICONV_VERSION && !defined __GLIBC__
+/* Irix iconv() inserts a NUL byte if it cannot convert.
+ NetBSD iconv() inserts a question mark if it cannot convert.
+ Only GNU libiconv and GNU libc are known to prefer to fail rather
+ than doing a lossy conversion. */
+static size_t
+iconv_carefully (iconv_t cd,
+ const char **inbuf, size_t *inbytesleft,
+ char **outbuf, size_t *outbytesleft,
+ bool *incremented)
+{
+ const char *inptr = *inbuf;
+ const char *inptr_end = inptr + *inbytesleft;
+ char *outptr = *outbuf;
+ size_t outsize = *outbytesleft;
+ const char *inptr_before;
+ size_t res;
+
+ do
+ {
+ size_t insize;
+
+ inptr_before = inptr;
+ res = (size_t)(-1);
+
+ for (insize = 1; inptr + insize <= inptr_end; insize++)
+ {
+ res = iconv (cd,
+ (ICONV_CONST char **) &inptr, &insize,
+ &outptr, &outsize);
+ if (!(res == (size_t)(-1) && errno == EINVAL))
+ break;
+ /* iconv can eat up a shift sequence but give EINVAL while attempting
+ to convert the first character. E.g. libiconv does this. */
+ if (inptr > inptr_before)
+ {
+ res = 0;
+ break;
+ }
+ }
+
+ if (res == 0)
+ {
+ *outbuf = outptr;
+ *outbytesleft = outsize;
+ }
+ }
+ while (res == 0 && inptr < inptr_end);
+
+ *inbuf = inptr;
+ *inbytesleft = inptr_end - inptr;
+ if (res != (size_t)(-1) && res > 0)
+ {
+ /* iconv() has already incremented INPTR. We cannot go back to a
+ previous INPTR, otherwise the state inside CD would become invalid,
+ if FROM_CODESET is a stateful encoding. So, tell the caller that
+ *INBUF has already been incremented. */
+ *incremented = (inptr > inptr_before);
+ errno = EILSEQ;
+ return (size_t)(-1);
+ }
+ else
+ {
+ *incremented = false;
+ return res;
+ }
+}
+# else
+# define iconv_carefully(cd, inbuf, inbytesleft, outbuf, outbytesleft,
incremented) \
+ (*(incremented) = false, \
+ iconv (cd, (ICONV_CONST char **) (inbuf), inbytesleft, outbuf,
outbytesleft))
+# endif
+
+/* iconv_carefully_1 is like iconv_carefully, except that it stops after
+ converting one character or one shift sequence. */
+static size_t
+iconv_carefully_1 (iconv_t cd,
+ const char **inbuf, size_t *inbytesleft,
+ char **outbuf, size_t *outbytesleft,
+ bool *incremented)
+{
+ const char *inptr_before = *inbuf;
+ const char *inptr = inptr_before;
+ const char *inptr_end = inptr_before + *inbytesleft;
+ char *outptr = *outbuf;
+ size_t outsize = *outbytesleft;
+ size_t res = (size_t)(-1);
+ size_t insize;
+
+ for (insize = 1; inptr_before + insize <= inptr_end; insize++)
+ {
+ inptr = inptr_before;
+ res = iconv (cd,
+ (ICONV_CONST char **) &inptr, &insize,
+ &outptr, &outsize);
+ if (!(res == (size_t)(-1) && errno == EINVAL))
+ break;
+ /* iconv can eat up a shift sequence but give EINVAL while attempting
+ to convert the first character. E.g. libiconv does this. */
+ if (inptr > inptr_before)
+ {
+ res = 0;
+ break;
+ }
+ }
+
+ *inbuf = inptr;
+ *inbytesleft = inptr_end - inptr;
+# if !defined _LIBICONV_VERSION && !defined __GLIBC__
+ /* Irix iconv() inserts a NUL byte if it cannot convert.
+ NetBSD iconv() inserts a question mark if it cannot convert.
+ Only GNU libiconv and GNU libc are known to prefer to fail rather
+ than doing a lossy conversion. */
+ if (res != (size_t)(-1) && res > 0)
+ {
+ /* iconv() has already incremented INPTR. We cannot go back to a
+ previous INPTR, otherwise the state inside CD would become invalid,
+ if FROM_CODESET is a stateful encoding. So, tell the caller that
+ *INBUF has already been incremented. */
+ *incremented = (inptr > inptr_before);
+ errno = EILSEQ;
+ return (size_t)(-1);
+ }
+# endif
+
+ if (res != (size_t)(-1))
+ {
+ *outbuf = outptr;
+ *outbytesleft = outsize;
+ }
+ *incremented = false;
+ return res;
+}
+
+/* utf8conv_carefully is like iconv, except that
+ - it converts from UTF-8 to UTF-8,
+ - it stops as soon as it encounters a conversion error, and it returns
+ in *INCREMENTED a boolean telling whether it has incremented the input
+ pointers past the error location,
+ - if one_character_only is true, it stops after converting one
+ character. */
+static size_t
+utf8conv_carefully (bool one_character_only,
+ const char **inbuf, size_t *inbytesleft,
+ char **outbuf, size_t *outbytesleft,
+ bool *incremented)
+{
+ const char *inptr = *inbuf;
+ size_t insize = *inbytesleft;
+ char *outptr = *outbuf;
+ size_t outsize = *outbytesleft;
+ size_t res;
+
+ res = 0;
+ do
+ {
+ ucs4_t uc;
+ int n;
+ int m;
+
+ n = u8_mbtoucr (&uc, (const uint8_t *) inptr, insize);
+ if (n < 0)
+ {
+ errno = (n == -2 ? EINVAL : EILSEQ);
+ n = u8_mbtouc (&uc, (const uint8_t *) inptr, insize);
+ inptr += n;
+ insize -= n;
+ res = (size_t)(-1);
+ *incremented = true;
+ break;
+ }
+ if (outsize == 0)
+ {
+ errno = E2BIG;
+ res = (size_t)(-1);
+ *incremented = false;
+ break;
+ }
+ m = u8_uctomb ((uint8_t *) outptr, uc, outsize);
+ if (m == -2)
+ {
+ errno = E2BIG;
+ res = (size_t)(-1);
+ *incremented = false;
+ break;
+ }
+ inptr += n;
+ insize -= n;
+ if (m == -1)
+ {
+ errno = EILSEQ;
+ res = (size_t)(-1);
+ *incremented = true;
+ break;
+ }
+ outptr += m;
+ outsize -= m;
+ }
+ while (!one_character_only && insize > 0);
+
+ *inbuf = inptr;
+ *inbytesleft = insize;
+ *outbuf = outptr;
+ *outbytesleft = outsize;
+ return res;
+}
+
+static int
+mem_cd_iconveh_internal (const char *src, size_t srclen,
+ iconv_t cd, iconv_t cd1, iconv_t cd2,
+ enum iconv_ilseq_handler handler,
+ size_t extra_alloc,
+ size_t *offsets,
+ char **resultp, size_t *lengthp)
+{
+ /* When a conversion error occurs, we cannot start using CD1 and CD2 at
+ this point: FROM_CODESET may be a stateful encoding like ISO-2022-KR.
+ Instead, we have to start afresh from the beginning of SRC. */
+ /* Use a temporary buffer, so that for small strings, a single malloc()
+ call will be sufficient. */
+# define tmpbufsize 4096
+ /* The alignment is needed when converting e.g. to glibc's WCHAR_T or
+ libiconv's UCS-4-INTERNAL encoding. */
+ union { unsigned int align; char buf[tmpbufsize]; } tmp;
+# define tmpbuf tmp.buf
+
+ char *initial_result;
+ char *result;
+ size_t allocated;
+ size_t length;
+ size_t last_length = (size_t)(-1); /* only needed if offsets != NULL */
+
+ if (*resultp != NULL && *lengthp >= sizeof (tmpbuf))
+ {
+ initial_result = *resultp;
+ allocated = *lengthp;
+ }
+ else
+ {
+ initial_result = tmpbuf;
+ allocated = sizeof (tmpbuf);
+ }
+ result = initial_result;
+
+ /* Test whether a direct conversion is possible at all. */
+ if (cd == (iconv_t)(-1))
+ goto indirectly;
+
+ if (offsets != NULL)
+ {
+ size_t i;
+
+ for (i = 0; i < srclen; i++)
+ offsets[i] = (size_t)(-1);
+
+ last_length = (size_t)(-1);
+ }
+ length = 0;
+
+ /* First, try a direct conversion, and see whether a conversion error
+ occurs at all. */
+ {
+ const char *inptr = src;
+ size_t insize = srclen;
+
+ /* Avoid glibc-2.1 bug and Solaris 2.7-2.9 bug. */
+# if defined _LIBICONV_VERSION \
+ || !((__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) || defined __sun)
+ /* Set to the initial state. */
+ iconv (cd, NULL, NULL, NULL, NULL);
+# endif
+
+ while (insize > 0)
+ {
+ char *outptr = result + length;
+ size_t outsize = allocated - extra_alloc - length;
+ bool incremented;
+ size_t res;
+ bool grow;
+
+ if (offsets != NULL)
+ {
+ if (length != last_length) /* ensure that offset[] be increasing */
+ {
+ offsets[inptr - src] = length;
+ last_length = length;
+ }
+ res = iconv_carefully_1 (cd,
+ &inptr, &insize,
+ &outptr, &outsize,
+ &incremented);
+ }
+ else
+ /* Use iconv_carefully instead of iconv here, because:
+ - If TO_CODESET is UTF-8, we can do the error handling in this
+ loop, no need for a second loop,
+ - With iconv() implementations other than GNU libiconv and GNU
+ libc, if we use iconv() in a big swoop, checking for an E2BIG
+ return, we lose the number of irreversible conversions. */
+ res = iconv_carefully (cd,
+ &inptr, &insize,
+ &outptr, &outsize,
+ &incremented);
+
+ length = outptr - result;
+ grow = (length + extra_alloc > allocated / 2);
+ if (res == (size_t)(-1))
+ {
+ if (errno == E2BIG)
+ grow = true;
+ else if (errno == EINVAL)
+ break;
+ else if (errno == EILSEQ && handler != iconveh_error)
+ {
+ if (cd2 == (iconv_t)(-1))
+ {
+ /* TO_CODESET is UTF-8. */
+ /* Error handling can produce up to 1 byte of output. */
+ if (length + 1 + extra_alloc > allocated)
+ {
+ char *memory;
+
+ allocated = 2 * allocated;
+ if (length + 1 + extra_alloc > allocated)
+ abort ();
+ if (result == initial_result)
+ memory = (char *) malloc (allocated);
+ else
+ memory = (char *) realloc (result, allocated);
+ if (memory == NULL)
+ {
+ if (result != initial_result)
+ free (result);
+ errno = ENOMEM;
+ return -1;
+ }
+ if (result == initial_result)
+ memcpy (memory, initial_result, length);
+ result = memory;
+ grow = false;
+ }
+ /* The input is invalid in FROM_CODESET. Eat up one byte
+ and emit a question mark. */
+ if (!incremented)
+ {
+ if (insize == 0)
+ abort ();
+ inptr++;
+ insize--;
+ }
+ result[length] = '?';
+ length++;
+ }
+ else
+ goto indirectly;
+ }
+ else
+ {
+ if (result != initial_result)
+ {
+ int saved_errno = errno;
+ free (result);
+ errno = saved_errno;
+ }
+ return -1;
+ }
+ }
+ if (insize == 0)
+ break;
+ if (grow)
+ {
+ char *memory;
+
+ allocated = 2 * allocated;
+ if (result == initial_result)
+ memory = (char *) malloc (allocated);
+ else
+ memory = (char *) realloc (result, allocated);
+ if (memory == NULL)
+ {
+ if (result != initial_result)
+ free (result);
+ errno = ENOMEM;
+ return -1;
+ }
+ if (result == initial_result)
+ memcpy (memory, initial_result, length);
+ result = memory;
+ }
+ }
+ }
+
+ /* Now get the conversion state back to the initial state.
+ But avoid glibc-2.1 bug and Solaris 2.7 bug. */
+#if defined _LIBICONV_VERSION \
+ || !((__GLIBC__ == 2 && __GLIBC_MINOR__ <= 1) || defined __sun)
+ for (;;)
+ {
+ char *outptr = result + length;
+ size_t outsize = allocated - extra_alloc - length;
+ size_t res;
+
+ res = iconv (cd, NULL, NULL, &outptr, &outsize);
+ length = outptr - result;
+ if (res == (size_t)(-1))
+ {
+ if (errno == E2BIG)
+ {
+ char *memory;
+
+ allocated = 2 * allocated;
+ if (result == initial_result)
+ memory = (char *) malloc (allocated);
+ else
+ memory = (char *) realloc (result, allocated);
+ if (memory == NULL)
+ {
+ if (result != initial_result)
+ free (result);
+ errno = ENOMEM;
+ return -1;
+ }
+ if (result == initial_result)
+ memcpy (memory, initial_result, length);
+ result = memory;
+ }
+ else
+ {
+ if (result != initial_result)
+ {
+ int saved_errno = errno;
+ free (result);
+ errno = saved_errno;
+ }
+ return -1;
+ }
+ }
+ else
+ break;
+ }
+#endif
+
+ /* The direct conversion succeeded. */
+ goto done;
+
+ indirectly:
+ /* The direct conversion failed.
+ Use a conversion through UTF-8. */
+ if (offsets != NULL)
+ {
+ size_t i;
+
+ for (i = 0; i < srclen; i++)
+ offsets[i] = (size_t)(-1);
+
+ last_length = (size_t)(-1);
+ }
+ length = 0;
+ {
+ const bool slowly = (offsets != NULL || handler == iconveh_error);
+# define utf8bufsize 4096 /* may also be smaller or larger than tmpbufsize */
+ char utf8buf[utf8bufsize + 1];
+ size_t utf8len = 0;
+ const char *in1ptr = src;
+ size_t in1size = srclen;
+ bool do_final_flush1 = true;
+ bool do_final_flush2 = true;
+
+ /* Avoid glibc-2.1 bug and Solaris 2.7-2.9 bug. */
+# if defined _LIBICONV_VERSION \
+ || !((__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) || defined __sun)
+ /* Set to the initial state. */
+ if (cd1 != (iconv_t)(-1))
+ iconv (cd1, NULL, NULL, NULL, NULL);
+ if (cd2 != (iconv_t)(-1))
+ iconv (cd2, NULL, NULL, NULL, NULL);
+# endif
+
+ while (in1size > 0 || do_final_flush1 || utf8len > 0 || do_final_flush2)
+ {
+ char *out1ptr = utf8buf + utf8len;
+ size_t out1size = utf8bufsize - utf8len;
+ bool incremented1;
+ size_t res1;
+ int errno1;
+
+ /* Conversion step 1: from FROM_CODESET to UTF-8. */
+ if (in1size > 0)
+ {
+ if (offsets != NULL
+ && length != last_length) /* ensure that offset[] be increasing
*/
+ {
+ offsets[in1ptr - src] = length;
+ last_length = length;
+ }
+ if (cd1 != (iconv_t)(-1))
+ {
+ if (slowly)
+ res1 = iconv_carefully_1 (cd1,
+ &in1ptr, &in1size,
+ &out1ptr, &out1size,
+ &incremented1);
+ else
+ res1 = iconv_carefully (cd1,
+ &in1ptr, &in1size,
+ &out1ptr, &out1size,
+ &incremented1);
+ }
+ else
+ {
+ /* FROM_CODESET is UTF-8. */
+ res1 = utf8conv_carefully (slowly,
+ &in1ptr, &in1size,
+ &out1ptr, &out1size,
+ &incremented1);
+ }
+ }
+ else if (do_final_flush1)
+ {
+ /* Now get the conversion state of CD1 back to the initial state.
+ But avoid glibc-2.1 bug and Solaris 2.7 bug. */
+# if defined _LIBICONV_VERSION \
+ || !((__GLIBC__ == 2 && __GLIBC_MINOR__ <= 1) || defined __sun)
+ if (cd1 != (iconv_t)(-1))
+ res1 = iconv (cd1, NULL, NULL, &out1ptr, &out1size);
+ else
+# endif
+ res1 = 0;
+ do_final_flush1 = false;
+ incremented1 = true;
+ }
+ else
+ {
+ res1 = 0;
+ incremented1 = true;
+ }
+ if (res1 == (size_t)(-1)
+ && !(errno == E2BIG || errno == EINVAL || errno == EILSEQ))
+ {
+ if (result != initial_result)
+ {
+ int saved_errno = errno;
+ free (result);
+ errno = saved_errno;
+ }
+ return -1;
+ }
+ if (res1 == (size_t)(-1)
+ && errno == EILSEQ && handler != iconveh_error)
+ {
+ /* The input is invalid in FROM_CODESET. Eat up one byte and
+ emit a question mark. Room for the question mark was allocated
+ at the end of utf8buf. */
+ if (!incremented1)
+ {
+ if (in1size == 0)
+ abort ();
+ in1ptr++;
+ in1size--;
+ }
+ utf8buf[utf8len++] = '?';
+ }
+ errno1 = errno;
+ utf8len = out1ptr - utf8buf;
+
+ if (offsets != NULL
+ || in1size == 0
+ || utf8len > utf8bufsize / 2
+ || (res1 == (size_t)(-1) && errno1 == E2BIG))
+ {
+ /* Conversion step 2: from UTF-8 to TO_CODESET. */
+ const char *in2ptr = utf8buf;
+ size_t in2size = utf8len;
+
+ while (in2size > 0
+ || (in1size == 0 && !do_final_flush1 && do_final_flush2))
+ {
+ char *out2ptr = result + length;
+ size_t out2size = allocated - extra_alloc - length;
+ bool incremented2;
+ size_t res2;
+ bool grow;
+
+ if (in2size > 0)
+ {
+ if (cd2 != (iconv_t)(-1))
+ res2 = iconv_carefully (cd2,
+ &in2ptr, &in2size,
+ &out2ptr, &out2size,
+ &incremented2);
+ else
+ /* TO_CODESET is UTF-8. */
+ res2 = utf8conv_carefully (false,
+ &in2ptr, &in2size,
+ &out2ptr, &out2size,
+ &incremented2);
+ }
+ else /* in1size == 0 && !do_final_flush1
+ && in2size == 0 && do_final_flush2 */
+ {
+ /* Now get the conversion state of CD1 back to the initial
+ state. But avoid glibc-2.1 bug and Solaris 2.7 bug. */
+# if defined _LIBICONV_VERSION \
+ || !((__GLIBC__ == 2 && __GLIBC_MINOR__ <= 1) || defined __sun)
+ if (cd2 != (iconv_t)(-1))
+ res2 = iconv (cd2, NULL, NULL, &out2ptr, &out2size);
+ else
+# endif
+ res2 = 0;
+ do_final_flush2 = false;
+ incremented2 = true;
+ }
+
+ length = out2ptr - result;
+ grow = (length + extra_alloc > allocated / 2);
+ if (res2 == (size_t)(-1))
+ {
+ if (errno == E2BIG)
+ grow = true;
+ else if (errno == EINVAL)
+ break;
+ else if (errno == EILSEQ && handler != iconveh_error)
+ {
+ /* Error handling can produce up to 10 bytes of ASCII
+ output. But TO_CODESET may be UCS-2, UTF-16 or
+ UCS-4, so use CD2 here as well. */
+ char scratchbuf[10];
+ size_t scratchlen;
+ ucs4_t uc;
+ const char *inptr;
+ size_t insize;
+ size_t res;
+
+ if (incremented2)
+ {
+ if (u8_prev (&uc, (const uint8_t *) in2ptr,
+ (const uint8_t *) utf8buf)
+ == NULL)
+ abort ();
+ }
+ else
+ {
+ int n;
+ if (in2size == 0)
+ abort ();
+ n = u8_mbtouc_unsafe (&uc, (const uint8_t *) in2ptr,
+ in2size);
+ in2ptr += n;
+ in2size -= n;
+ }
+
+ if (handler == iconveh_escape_sequence)
+ {
+ static char hex[16] = "0123456789ABCDEF";
+ scratchlen = 0;
+ scratchbuf[scratchlen++] = '\\';
+ if (uc < 0x10000)
+ scratchbuf[scratchlen++] = 'u';
+ else
+ {
+ scratchbuf[scratchlen++] = 'U';
+ scratchbuf[scratchlen++] = hex[(uc>>28) & 15];
+ scratchbuf[scratchlen++] = hex[(uc>>24) & 15];
+ scratchbuf[scratchlen++] = hex[(uc>>20) & 15];
+ scratchbuf[scratchlen++] = hex[(uc>>16) & 15];
+ }
+ scratchbuf[scratchlen++] = hex[(uc>>12) & 15];
+ scratchbuf[scratchlen++] = hex[(uc>>8) & 15];
+ scratchbuf[scratchlen++] = hex[(uc>>4) & 15];
+ scratchbuf[scratchlen++] = hex[uc & 15];
+ }
+ else
+ {
+ scratchbuf[0] = '?';
+ scratchlen = 1;
+ }
+
+ inptr = scratchbuf;
+ insize = scratchlen;
+ if (cd2 != (iconv_t)(-1))
+ res = iconv (cd2,
+ (ICONV_CONST char **) &inptr, &insize,
+ &out2ptr, &out2size);
+ else
+ {
+ /* TO_CODESET is UTF-8. */
+ if (out2size >= insize)
+ {
+ memcpy (out2ptr, inptr, insize);
+ out2ptr += insize;
+ out2size -= insize;
+ inptr += insize;
+ insize = 0;
+ res = 0;
+ }
+ else
+ {
+ errno = E2BIG;
+ res = (size_t)(-1);
+ }
+ }
+ length = out2ptr - result;
+ if (res == (size_t)(-1) && errno == E2BIG)
+ {
+ char *memory;
+
+ allocated = 2 * allocated;
+ if (length + 1 + extra_alloc > allocated)
+ abort ();
+ if (result == initial_result)
+ memory = (char *) malloc (allocated);
+ else
+ memory = (char *) realloc (result, allocated);
+ if (memory == NULL)
+ {
+ if (result != initial_result)
+ free (result);
+ errno = ENOMEM;
+ return -1;
+ }
+ if (result == initial_result)
+ memcpy (memory, initial_result, length);
+ result = memory;
+ grow = false;
+
+ out2ptr = result + length;
+ out2size = allocated - extra_alloc - length;
+ if (cd2 != (iconv_t)(-1))
+ res = iconv (cd2,
+ (ICONV_CONST char **) &inptr,
+ &insize,
+ &out2ptr, &out2size);
+ else
+ {
+ /* TO_CODESET is UTF-8. */
+ if (!(out2size >= insize))
+ abort ();
+ memcpy (out2ptr, inptr, insize);
+ out2ptr += insize;
+ out2size -= insize;
+ inptr += insize;
+ insize = 0;
+ res = 0;
+ }
+ length = out2ptr - result;
+ }
+# if !defined _LIBICONV_VERSION && !defined __GLIBC__
+ /* Irix iconv() inserts a NUL byte if it cannot convert.
+ NetBSD iconv() inserts a question mark if it cannot
+ convert.
+ Only GNU libiconv and GNU libc are known to prefer
+ to fail rather than doing a lossy conversion. */
+ if (res != (size_t)(-1) && res > 0)
+ {
+ errno = EILSEQ;
+ res = (size_t)(-1);
+ }
+# endif
+ if (res == (size_t)(-1))
+ {
+ /* Failure converting the ASCII replacement. */
+ if (result != initial_result)
+ {
+ int saved_errno = errno;
+ free (result);
+ errno = saved_errno;
+ }
+ return -1;
+ }
+ }
+ else
+ {
+ if (result != initial_result)
+ {
+ int saved_errno = errno;
+ free (result);
+ errno = saved_errno;
+ }
+ return -1;
+ }
+ }
+ if (!(in2size > 0
+ || (in1size == 0 && !do_final_flush1 && do_final_flush2)))
+ break;
+ if (grow)
+ {
+ char *memory;
+
+ allocated = 2 * allocated;
+ if (result == initial_result)
+ memory = (char *) malloc (allocated);
+ else
+ memory = (char *) realloc (result, allocated);
+ if (memory == NULL)
+ {
+ if (result != initial_result)
+ free (result);
+ errno = ENOMEM;
+ return -1;
+ }
+ if (result == initial_result)
+ memcpy (memory, initial_result, length);
+ result = memory;
+ }
+ }
+
+ /* Move the remaining bytes to the beginning of utf8buf. */
+ if (in2size > 0)
+ memmove (utf8buf, in2ptr, in2size);
+ utf8len = in2size;
+ }
+
+ if (res1 == (size_t)(-1))
+ {
+ if (errno1 == EINVAL)
+ in1size = 0;
+ else if (errno1 == EILSEQ)
+ {
+ if (result != initial_result)
+ free (result);
+ errno = errno1;
+ return -1;
+ }
+ }
+ }
+# undef utf8bufsize
+ }
+
+ done:
+ /* Now the final memory allocation. */
+ if (result == tmpbuf)
+ {
+ size_t memsize = length + extra_alloc;
+ char *memory;
+
+ memory = (char *) malloc (memsize > 0 ? memsize : 1);
+ if (memory != NULL)
+ {
+ memcpy (memory, tmpbuf, length);
+ result = memory;
+ }
+ else
+ {
+ errno = ENOMEM;
+ return -1;
+ }
+ }
+ else if (result != *resultp && length + extra_alloc < allocated)
+ {
+ /* Shrink the allocated memory if possible. */
+ size_t memsize = length + extra_alloc;
+ char *memory;
+
+ memory = (char *) realloc (result, memsize > 0 ? memsize : 1);
+ if (memory != NULL)
+ result = memory;
+ }
+ *resultp = result;
+ *lengthp = length;
+ return 0;
+# undef tmpbuf
+# undef tmpbufsize
+}
+
+int
+mem_cd_iconveh (const char *src, size_t srclen,
+ iconv_t cd, iconv_t cd1, iconv_t cd2,
+ enum iconv_ilseq_handler handler,
+ size_t *offsets,
+ char **resultp, size_t *lengthp)
+{
+ return mem_cd_iconveh_internal (src, srclen, cd, cd1, cd2, handler, 0,
+ offsets, resultp, lengthp);
+}
+
+char *
+str_cd_iconveh (const char *src,
+ iconv_t cd, iconv_t cd1, iconv_t cd2,
+ enum iconv_ilseq_handler handler)
+{
+ /* For most encodings, a trailing NUL byte in the input will be converted
+ to a trailing NUL byte in the output. But not for UTF-7. So that this
+ function is usable for UTF-7, we have to exclude the NUL byte from the
+ conversion and add it by hand afterwards. */
+ char *result = NULL;
+ size_t length = 0;
+ int retval = mem_cd_iconveh_internal (src, strlen (src),
+ cd, cd1, cd2, handler, 1, NULL,
+ &result, &length);
+
+ if (retval < 0)
+ {
+ if (result != NULL)
+ {
+ int saved_errno = errno;
+ free (result);
+ errno = saved_errno;
+ }
+ return NULL;
+ }
+
+ /* Add the terminating NUL byte. */
+ result[length] = '\0';
+
+ return result;
+}
+
+#endif
+
+int
+mem_iconveh (const char *src, size_t srclen,
+ const char *from_codeset, const char *to_codeset,
+ enum iconv_ilseq_handler handler,
+ size_t *offsets,
+ char **resultp, size_t *lengthp)
+{
+ if (srclen == 0)
+ {
+ /* Nothing to convert. */
+ *lengthp = 0;
+ return 0;
+ }
+ else if (offsets == NULL && c_strcasecmp (from_codeset, to_codeset) == 0)
+ {
+ char *result;
+
+ if (*resultp != NULL && *lengthp >= srclen)
+ result = *resultp;
+ else
+ {
+ result = (char *) malloc (srclen);
+ if (result == NULL)
+ {
+ errno = ENOMEM;
+ return -1;
+ }
+ }
+ memcpy (result, src, srclen);
+ *resultp = result;
+ *lengthp = srclen;
+ return 0;
+ }
+ else
+ {
+#if HAVE_ICONV
+ iconv_t cd;
+ iconv_t cd1;
+ iconv_t cd2;
+ char *result;
+ size_t length;
+ int retval;
+
+ /* Avoid glibc-2.1 bug with EUC-KR. */
+# if (__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) && !defined
_LIBICONV_VERSION
+ if (c_strcasecmp (from_codeset, "EUC-KR") == 0
+ || c_strcasecmp (to_codeset, "EUC-KR") == 0)
+ {
+ errno = EINVAL;
+ return -1;
+ }
+# endif
+
+ cd = iconv_open (to_codeset, from_codeset);
+
+ if (STRCASEEQ (from_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0))
+ cd1 = (iconv_t)(-1);
+ else
+ {
+ cd1 = iconv_open ("UTF-8", from_codeset);
+ if (cd1 == (iconv_t)(-1))
+ {
+ int saved_errno = errno;
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ errno = saved_errno;
+ return -1;
+ }
+ }
+
+ if (STRCASEEQ (to_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0)
+# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2) || __GLIBC__ > 2 ||
_LIBICONV_VERSION >= 0x0105
+ || c_strcasecmp (to_codeset, "UTF-8//TRANSLIT") == 0
+# endif
+ )
+ cd2 = (iconv_t)(-1);
+ else
+ {
+ cd2 = iconv_open (to_codeset, "UTF-8");
+ if (cd2 == (iconv_t)(-1))
+ {
+ int saved_errno = errno;
+ if (cd1 != (iconv_t)(-1))
+ iconv_close (cd1);
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ errno = saved_errno;
+ return -1;
+ }
+ }
+
+ result = *resultp;
+ length = *lengthp;
+ retval = mem_cd_iconveh (src, srclen, cd, cd1, cd2, handler, offsets,
+ &result, &length);
+
+ if (retval < 0)
+ {
+ /* Close cd, cd1, cd2, but preserve the errno from str_cd_iconv. */
+ int saved_errno = errno;
+ if (cd2 != (iconv_t)(-1))
+ iconv_close (cd2);
+ if (cd1 != (iconv_t)(-1))
+ iconv_close (cd1);
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ errno = saved_errno;
+ }
+ else
+ {
+ if (cd2 != (iconv_t)(-1) && iconv_close (cd2) < 0)
+ {
+ /* Return -1, but free the allocated memory, and while doing
+ that, preserve the errno from iconv_close. */
+ int saved_errno = errno;
+ if (cd1 != (iconv_t)(-1))
+ iconv_close (cd1);
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ if (result != *resultp && result != NULL)
+ free (result);
+ errno = saved_errno;
+ return -1;
+ }
+ if (cd1 != (iconv_t)(-1) && iconv_close (cd1) < 0)
+ {
+ /* Return -1, but free the allocated memory, and while doing
+ that, preserve the errno from iconv_close. */
+ int saved_errno = errno;
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ if (result != *resultp && result != NULL)
+ free (result);
+ errno = saved_errno;
+ return -1;
+ }
+ if (cd != (iconv_t)(-1) && iconv_close (cd) < 0)
+ {
+ /* Return -1, but free the allocated memory, and while doing
+ that, preserve the errno from iconv_close. */
+ int saved_errno = errno;
+ if (result != *resultp && result != NULL)
+ free (result);
+ errno = saved_errno;
+ return -1;
+ }
+ *resultp = result;
+ *lengthp = length;
+ }
+ return retval;
+#else
+ /* This is a different error code than if iconv_open existed but didn't
+ support from_codeset and to_codeset, so that the caller can emit
+ an error message such as
+ "iconv() is not supported. Installing GNU libiconv and
+ then reinstalling this package would fix this." */
+ errno = ENOSYS;
+ return -1;
+#endif
+ }
+}
+
+char *
+str_iconveh (const char *src,
+ const char *from_codeset, const char *to_codeset,
+ enum iconv_ilseq_handler handler)
+{
+ if (*src == '\0' || c_strcasecmp (from_codeset, to_codeset) == 0)
+ {
+ char *result = strdup (src);
+
+ if (result == NULL)
+ errno = ENOMEM;
+ return result;
+ }
+ else
+ {
+#if HAVE_ICONV
+ iconv_t cd;
+ iconv_t cd1;
+ iconv_t cd2;
+ char *result;
+
+ /* Avoid glibc-2.1 bug with EUC-KR. */
+# if (__GLIBC__ - 0 == 2 && __GLIBC_MINOR__ - 0 <= 1) && !defined
_LIBICONV_VERSION
+ if (c_strcasecmp (from_codeset, "EUC-KR") == 0
+ || c_strcasecmp (to_codeset, "EUC-KR") == 0)
+ {
+ errno = EINVAL;
+ return NULL;
+ }
+# endif
+
+ cd = iconv_open (to_codeset, from_codeset);
+
+ if (STRCASEEQ (from_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0))
+ cd1 = (iconv_t)(-1);
+ else
+ {
+ cd1 = iconv_open ("UTF-8", from_codeset);
+ if (cd1 == (iconv_t)(-1))
+ {
+ int saved_errno = errno;
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ errno = saved_errno;
+ return NULL;
+ }
+ }
+
+ if (STRCASEEQ (to_codeset, "UTF-8", 'U','T','F','-','8',0,0,0,0)
+# if (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2) || __GLIBC__ > 2 ||
_LIBICONV_VERSION >= 0x0105
+ || c_strcasecmp (to_codeset, "UTF-8//TRANSLIT") == 0
+# endif
+ )
+ cd2 = (iconv_t)(-1);
+ else
+ {
+ cd2 = iconv_open (to_codeset, "UTF-8");
+ if (cd2 == (iconv_t)(-1))
+ {
+ int saved_errno = errno;
+ if (cd1 != (iconv_t)(-1))
+ iconv_close (cd1);
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ errno = saved_errno;
+ return NULL;
+ }
+ }
+
+ result = str_cd_iconveh (src, cd, cd1, cd2, handler);
+
+ if (result == NULL)
+ {
+ /* Close cd, cd1, cd2, but preserve the errno from str_cd_iconv. */
+ int saved_errno = errno;
+ if (cd2 != (iconv_t)(-1))
+ iconv_close (cd2);
+ if (cd1 != (iconv_t)(-1))
+ iconv_close (cd1);
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ errno = saved_errno;
+ }
+ else
+ {
+ if (cd2 != (iconv_t)(-1) && iconv_close (cd2) < 0)
+ {
+ /* Return NULL, but free the allocated memory, and while doing
+ that, preserve the errno from iconv_close. */
+ int saved_errno = errno;
+ if (cd1 != (iconv_t)(-1))
+ iconv_close (cd1);
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ free (result);
+ errno = saved_errno;
+ return NULL;
+ }
+ if (cd1 != (iconv_t)(-1) && iconv_close (cd1) < 0)
+ {
+ /* Return NULL, but free the allocated memory, and while doing
+ that, preserve the errno from iconv_close. */
+ int saved_errno = errno;
+ if (cd != (iconv_t)(-1))
+ iconv_close (cd);
+ free (result);
+ errno = saved_errno;
+ return NULL;
+ }
+ if (cd != (iconv_t)(-1) && iconv_close (cd) < 0)
+ {
+ /* Return NULL, but free the allocated memory, and while doing
+ that, preserve the errno from iconv_close. */
+ int saved_errno = errno;
+ free (result);
+ errno = saved_errno;
+ return NULL;
+ }
+ }
+ return result;
+#else
+ /* This is a different error code than if iconv_open existed but didn't
+ support from_codeset and to_codeset, so that the caller can emit
+ an error message such as
+ "iconv() is not supported. Installing GNU libiconv and
+ then reinstalling this package would fix this." */
+ errno = ENOSYS;
+ return NULL;
+#endif
+ }
+}
diff --git a/lib/striconveh.h b/lib/striconveh.h
new file mode 100644
index 0000000..98b4d0c
--- /dev/null
+++ b/lib/striconveh.h
@@ -0,0 +1,120 @@
+/* Character set conversion with error handling.
+ Copyright (C) 2001-2007, 2009 Free Software Foundation, Inc.
+ Written by Bruno Haible and Simon Josefsson.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef _STRICONVEH_H
+#define _STRICONVEH_H
+
+#include <stddef.h>
+#if HAVE_ICONV
+#include <iconv.h>
+#endif
+
+#include "iconveh.h"
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+#if HAVE_ICONV
+
+/* Convert an entire string from one encoding to another, using iconv.
+ The original string is at [SRC,...,SRC+SRCLEN-1].
+ CD is the conversion descriptor from FROMCODE to TOCODE, or (iconv_t)(-1) if
+ the system does not support a direct conversion from FROMCODE to TOCODE.
+ CD1 is the conversion descriptor from FROM_CODESET to UTF-8 (or
+ (iconv_t)(-1) if FROM_CODESET is UTF-8).
+ CD2 is the conversion descriptor from UTF-8 to TO_CODESET (or (iconv_t)(-1)
+ if TO_CODESET is UTF-8).
+ If OFFSETS is not NULL, it should point to an array of SRCLEN integers; this
+ array is filled with offsets into the result, i.e. the character starting
+ at SRC[i] corresponds to the character starting at (*RESULTP)[OFFSETS[i]],
+ and other offsets are set to (size_t)(-1).
+ *RESULTP and *LENGTH should initially be a scratch buffer and its size,
+ or *RESULTP can initially be NULL.
+ May erase the contents of the memory at *RESULTP.
+ Return value: 0 if successful, otherwise -1 and errno set.
+ If successful: The resulting string is stored in *RESULTP and its length
+ in *LENGTHP. *RESULTP is set to a freshly allocated memory block, or is
+ unchanged if no dynamic memory allocation was necessary. */
+extern int
+ mem_cd_iconveh (const char *src, size_t srclen,
+ iconv_t cd, iconv_t cd1, iconv_t cd2,
+ enum iconv_ilseq_handler handler,
+ size_t *offsets,
+ char **resultp, size_t *lengthp);
+
+/* Convert an entire string from one encoding to another, using iconv.
+ The original string is the NUL-terminated string starting at SRC.
+ CD is the conversion descriptor from FROMCODE to TOCODE, or (iconv_t)(-1) if
+ the system does not support a direct conversion from FROMCODE to TOCODE.
+ Both the "from" and the "to" encoding must use a single NUL byte at the end
+ of the string (i.e. not UCS-2, UCS-4, UTF-16, UTF-32).
+ CD1 is the conversion descriptor from FROM_CODESET to UTF-8 (or
+ (iconv_t)(-1) if FROM_CODESET is UTF-8).
+ CD2 is the conversion descriptor from UTF-8 to TO_CODESET (or (iconv_t)(-1)
+ if TO_CODESET is UTF-8).
+ Allocate a malloced memory block for the result.
+ Return value: the freshly allocated resulting NUL-terminated string if
+ successful, otherwise NULL and errno set. */
+extern char *
+ str_cd_iconveh (const char *src,
+ iconv_t cd, iconv_t cd1, iconv_t cd2,
+ enum iconv_ilseq_handler handler);
+
+#endif
+
+/* Convert an entire string from one encoding to another, using iconv.
+ The original string is at [SRC,...,SRC+SRCLEN-1].
+ If OFFSETS is not NULL, it should point to an array of SRCLEN integers; this
+ array is filled with offsets into the result, i.e. the character starting
+ at SRC[i] corresponds to the character starting at (*RESULTP)[OFFSETS[i]],
+ and other offsets are set to (size_t)(-1).
+ *RESULTP and *LENGTH should initially be a scratch buffer and its size,
+ or *RESULTP can initially be NULL.
+ May erase the contents of the memory at *RESULTP.
+ Return value: 0 if successful, otherwise -1 and errno set.
+ If successful: The resulting string is stored in *RESULTP and its length
+ in *LENGTHP. *RESULTP is set to a freshly allocated memory block, or is
+ unchanged if no dynamic memory allocation was necessary. */
+extern int
+ mem_iconveh (const char *src, size_t srclen,
+ const char *from_codeset, const char *to_codeset,
+ enum iconv_ilseq_handler handler,
+ size_t *offsets,
+ char **resultp, size_t *lengthp);
+
+/* Convert an entire string from one encoding to another, using iconv.
+ The original string is the NUL-terminated string starting at SRC.
+ Both the "from" and the "to" encoding must use a single NUL byte at the
+ end of the string (i.e. not UCS-2, UCS-4, UTF-16, UTF-32).
+ Allocate a malloced memory block for the result.
+ Return value: the freshly allocated resulting NUL-terminated string if
+ successful, otherwise NULL and errno set. */
+extern char *
+ str_iconveh (const char *src,
+ const char *from_codeset, const char *to_codeset,
+ enum iconv_ilseq_handler handler);
+
+
+#ifdef __cplusplus
+}
+#endif
+
+
+#endif /* _STRICONVEH_H */
diff --git a/lib/string.in.h b/lib/string.in.h
new file mode 100644
index 0000000..ca029d7
--- /dev/null
+++ b/lib/string.in.h
@@ -0,0 +1,605 @@
+/* A GNU-like <string.h>.
+
+ Copyright (C) 1995-1996, 2001-2008 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 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+#ifndef _GL_STRING_H
+
+#if __GNUC__ >= 3
address@hidden@
+#endif
+
+/* The include_next requires a split double-inclusion guard. */
address@hidden@ @NEXT_STRING_H@
+
+#ifndef _GL_STRING_H
+#define _GL_STRING_H
+
+
+#ifndef __attribute__
+/* This feature is available in gcc versions 2.5 and later. */
+# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 5)
+# define __attribute__(Spec) /* empty */
+# endif
+/* The attribute __pure__ was added in gcc 2.96. */
+# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
+# define __pure__ /* empty */
+# endif
+#endif
+
+
+/* The definition of GL_LINK_WARNING is copied here. */
+
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+/* Return the first occurrence of NEEDLE in HAYSTACK. */
+#if @GNULIB_MEMMEM@
+# if @REPLACE_MEMMEM@
+# define memmem rpl_memmem
+# endif
+# if ! @HAVE_DECL_MEMMEM@ || @REPLACE_MEMMEM@
+extern void *memmem (void const *__haystack, size_t __haystack_len,
+ void const *__needle, size_t __needle_len)
+ __attribute__ ((__pure__));
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef memmem
+# define memmem(a,al,b,bl) \
+ (GL_LINK_WARNING ("memmem is unportable and often quadratic - " \
+ "use gnulib module memmem-simple for portability, " \
+ "and module memmem for speed" ), \
+ memmem (a, al, b, bl))
+#endif
+
+/* Copy N bytes of SRC to DEST, return pointer to bytes after the
+ last written byte. */
+#if @GNULIB_MEMPCPY@
+# if ! @HAVE_MEMPCPY@
+extern void *mempcpy (void *restrict __dest, void const *restrict __src,
+ size_t __n);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef mempcpy
+# define mempcpy(a,b,n) \
+ (GL_LINK_WARNING ("mempcpy is unportable - " \
+ "use gnulib module mempcpy for portability"), \
+ mempcpy (a, b, n))
+#endif
+
+/* Search backwards through a block for a byte (specified as an int). */
+#if @GNULIB_MEMRCHR@
+# if ! @HAVE_DECL_MEMRCHR@
+extern void *memrchr (void const *, int, size_t)
+ __attribute__ ((__pure__));
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef memrchr
+# define memrchr(a,b,c) \
+ (GL_LINK_WARNING ("memrchr is unportable - " \
+ "use gnulib module memrchr for portability"), \
+ memrchr (a, b, c))
+#endif
+
+/* Find the first occurrence of C in S. More efficient than
+ memchr(S,C,N), at the expense of undefined behavior if C does not
+ occur within N bytes. */
+#if @GNULIB_RAWMEMCHR@
+# if ! @HAVE_RAWMEMCHR@
+extern void *rawmemchr (void const *__s, int __c_in)
+ __attribute__ ((__pure__));
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef rawmemchr
+# define rawmemchr(a,b) \
+ (GL_LINK_WARNING ("rawmemchr is unportable - " \
+ "use gnulib module rawmemchr for portability"), \
+ rawmemchr (a, b))
+#endif
+
+/* Copy SRC to DST, returning the address of the terminating '\0' in DST. */
+#if @GNULIB_STPCPY@
+# if ! @HAVE_STPCPY@
+extern char *stpcpy (char *restrict __dst, char const *restrict __src);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef stpcpy
+# define stpcpy(a,b) \
+ (GL_LINK_WARNING ("stpcpy is unportable - " \
+ "use gnulib module stpcpy for portability"), \
+ stpcpy (a, b))
+#endif
+
+/* Copy no more than N bytes of SRC to DST, returning a pointer past the
+ last non-NUL byte written into DST. */
+#if @GNULIB_STPNCPY@
+# if ! @HAVE_STPNCPY@
+# define stpncpy gnu_stpncpy
+extern char *stpncpy (char *restrict __dst, char const *restrict __src,
+ size_t __n);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef stpncpy
+# define stpncpy(a,b,n) \
+ (GL_LINK_WARNING ("stpncpy is unportable - " \
+ "use gnulib module stpncpy for portability"), \
+ stpncpy (a, b, n))
+#endif
+
+#if defined GNULIB_POSIXCHECK
+/* strchr() does not work with multibyte strings if the locale encoding is
+ GB18030 and the character to be searched is a digit. */
+# undef strchr
+# define strchr(s,c) \
+ (GL_LINK_WARNING ("strchr cannot work correctly on character strings " \
+ "in some multibyte locales - " \
+ "use mbschr if you care about internationalization"), \
+ strchr (s, c))
+#endif
+
+/* Find the first occurrence of C in S or the final NUL byte. */
+#if @GNULIB_STRCHRNUL@
+# if ! @HAVE_STRCHRNUL@
+extern char *strchrnul (char const *__s, int __c_in)
+ __attribute__ ((__pure__));
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strchrnul
+# define strchrnul(a,b) \
+ (GL_LINK_WARNING ("strchrnul is unportable - " \
+ "use gnulib module strchrnul for portability"), \
+ strchrnul (a, b))
+#endif
+
+/* Duplicate S, returning an identical malloc'd string. */
+#if @GNULIB_STRDUP@
+# if @REPLACE_STRDUP@
+# undef strdup
+# define strdup rpl_strdup
+# endif
+# if !(@HAVE_DECL_STRDUP@ || defined strdup) || @REPLACE_STRDUP@
+extern char *strdup (char const *__s);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strdup
+# define strdup(a) \
+ (GL_LINK_WARNING ("strdup is unportable - " \
+ "use gnulib module strdup for portability"), \
+ strdup (a))
+#endif
+
+/* Return a newly allocated copy of at most N bytes of STRING. */
+#if @GNULIB_STRNDUP@
+# if ! @HAVE_STRNDUP@
+# undef strndup
+# define strndup rpl_strndup
+# endif
+# if ! @HAVE_STRNDUP@ || ! @HAVE_DECL_STRNDUP@
+extern char *strndup (char const *__string, size_t __n);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strndup
+# define strndup(a,n) \
+ (GL_LINK_WARNING ("strndup is unportable - " \
+ "use gnulib module strndup for portability"), \
+ strndup (a, n))
+#endif
+
+/* Find the length (number of bytes) of STRING, but scan at most
+ MAXLEN bytes. If no '\0' terminator is found in that many bytes,
+ return MAXLEN. */
+#if @GNULIB_STRNLEN@
+# if ! @HAVE_DECL_STRNLEN@
+extern size_t strnlen (char const *__string, size_t __maxlen)
+ __attribute__ ((__pure__));
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strnlen
+# define strnlen(a,n) \
+ (GL_LINK_WARNING ("strnlen is unportable - " \
+ "use gnulib module strnlen for portability"), \
+ strnlen (a, n))
+#endif
+
+#if defined GNULIB_POSIXCHECK
+/* strcspn() assumes the second argument is a list of single-byte characters.
+ Even in this simple case, it does not work with multibyte strings if the
+ locale encoding is GB18030 and one of the characters to be searched is a
+ digit. */
+# undef strcspn
+# define strcspn(s,a) \
+ (GL_LINK_WARNING ("strcspn cannot work correctly on character strings " \
+ "in multibyte locales - " \
+ "use mbscspn if you care about internationalization"), \
+ strcspn (s, a))
+#endif
+
+/* Find the first occurrence in S of any character in ACCEPT. */
+#if @GNULIB_STRPBRK@
+# if ! @HAVE_STRPBRK@
+extern char *strpbrk (char const *__s, char const *__accept)
+ __attribute__ ((__pure__));
+# endif
+# if defined GNULIB_POSIXCHECK
+/* strpbrk() assumes the second argument is a list of single-byte characters.
+ Even in this simple case, it does not work with multibyte strings if the
+ locale encoding is GB18030 and one of the characters to be searched is a
+ digit. */
+# undef strpbrk
+# define strpbrk(s,a) \
+ (GL_LINK_WARNING ("strpbrk cannot work correctly on character strings " \
+ "in multibyte locales - " \
+ "use mbspbrk if you care about internationalization"), \
+ strpbrk (s, a))
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strpbrk
+# define strpbrk(s,a) \
+ (GL_LINK_WARNING ("strpbrk is unportable - " \
+ "use gnulib module strpbrk for portability"), \
+ strpbrk (s, a))
+#endif
+
+#if defined GNULIB_POSIXCHECK
+/* strspn() assumes the second argument is a list of single-byte characters.
+ Even in this simple case, it cannot work with multibyte strings. */
+# undef strspn
+# define strspn(s,a) \
+ (GL_LINK_WARNING ("strspn cannot work correctly on character strings " \
+ "in multibyte locales - " \
+ "use mbsspn if you care about internationalization"), \
+ strspn (s, a))
+#endif
+
+#if defined GNULIB_POSIXCHECK
+/* strrchr() does not work with multibyte strings if the locale encoding is
+ GB18030 and the character to be searched is a digit. */
+# undef strrchr
+# define strrchr(s,c) \
+ (GL_LINK_WARNING ("strrchr cannot work correctly on character strings " \
+ "in some multibyte locales - " \
+ "use mbsrchr if you care about internationalization"), \
+ strrchr (s, c))
+#endif
+
+/* Search the next delimiter (char listed in DELIM) starting at *STRINGP.
+ If one is found, overwrite it with a NUL, and advance *STRINGP
+ to point to the next char after it. Otherwise, set *STRINGP to NULL.
+ If *STRINGP was already NULL, nothing happens.
+ Return the old value of *STRINGP.
+
+ This is a variant of strtok() that is multithread-safe and supports
+ empty fields.
+
+ Caveat: It modifies the original string.
+ Caveat: These functions cannot be used on constant strings.
+ Caveat: The identity of the delimiting character is lost.
+ Caveat: It doesn't work with multibyte strings unless all of the delimiter
+ characters are ASCII characters < 0x30.
+
+ See also strtok_r(). */
+#if @GNULIB_STRSEP@
+# if ! @HAVE_STRSEP@
+extern char *strsep (char **restrict __stringp, char const *restrict __delim);
+# endif
+# if defined GNULIB_POSIXCHECK
+# undef strsep
+# define strsep(s,d) \
+ (GL_LINK_WARNING ("strsep cannot work correctly on character strings " \
+ "in multibyte locales - " \
+ "use mbssep if you care about internationalization"), \
+ strsep (s, d))
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strsep
+# define strsep(s,d) \
+ (GL_LINK_WARNING ("strsep is unportable - " \
+ "use gnulib module strsep for portability"), \
+ strsep (s, d))
+#endif
+
+#if @GNULIB_STRSTR@
+# if @REPLACE_STRSTR@
+# define strstr rpl_strstr
+char *strstr (const char *haystack, const char *needle)
+ __attribute__ ((__pure__));
+# endif
+#elif defined GNULIB_POSIXCHECK
+/* strstr() does not work with multibyte strings if the locale encoding is
+ different from UTF-8:
+ POSIX says that it operates on "strings", and "string" in POSIX is defined
+ as a sequence of bytes, not of characters. */
+# undef strstr
+# define strstr(a,b) \
+ (GL_LINK_WARNING ("strstr is quadratic on many systems, and cannot " \
+ "work correctly on character strings in most " \
+ "multibyte locales - " \
+ "use mbsstr if you care about internationalization, " \
+ "or use strstr if you care about speed"), \
+ strstr (a, b))
+#endif
+
+/* Find the first occurrence of NEEDLE in HAYSTACK, using case-insensitive
+ comparison. */
+#if @GNULIB_STRCASESTR@
+# if @REPLACE_STRCASESTR@
+# define strcasestr rpl_strcasestr
+# endif
+# if ! @HAVE_STRCASESTR@ || @REPLACE_STRCASESTR@
+extern char *strcasestr (const char *haystack, const char *needle)
+ __attribute__ ((__pure__));
+# endif
+#elif defined GNULIB_POSIXCHECK
+/* strcasestr() does not work with multibyte strings:
+ It is a glibc extension, and glibc implements it only for unibyte
+ locales. */
+# undef strcasestr
+# define strcasestr(a,b) \
+ (GL_LINK_WARNING ("strcasestr does work correctly on character strings " \
+ "in multibyte locales - " \
+ "use mbscasestr if you care about " \
+ "internationalization, or use c-strcasestr if you want "
\
+ "a locale independent function"), \
+ strcasestr (a, b))
+#endif
+
+/* Parse S into tokens separated by characters in DELIM.
+ If S is NULL, the saved pointer in SAVE_PTR is used as
+ the next starting point. For example:
+ char s[] = "-abc-=-def";
+ char *sp;
+ x = strtok_r(s, "-", &sp); // x = "abc", sp = "=-def"
+ x = strtok_r(NULL, "-=", &sp); // x = "def", sp = NULL
+ x = strtok_r(NULL, "=", &sp); // x = NULL
+ // s = "abc\0-def\0"
+
+ This is a variant of strtok() that is multithread-safe.
+
+ For the POSIX documentation for this function, see:
+ http://www.opengroup.org/susv3xsh/strtok.html
+
+ Caveat: It modifies the original string.
+ Caveat: These functions cannot be used on constant strings.
+ Caveat: The identity of the delimiting character is lost.
+ Caveat: It doesn't work with multibyte strings unless all of the delimiter
+ characters are ASCII characters < 0x30.
+
+ See also strsep(). */
+#if @GNULIB_STRTOK_R@
+# if ! @HAVE_DECL_STRTOK_R@
+extern char *strtok_r (char *restrict s, char const *restrict delim,
+ char **restrict save_ptr);
+# endif
+# if defined GNULIB_POSIXCHECK
+# undef strtok_r
+# define strtok_r(s,d,p) \
+ (GL_LINK_WARNING ("strtok_r cannot work correctly on character strings " \
+ "in multibyte locales - " \
+ "use mbstok_r if you care about internationalization"),
\
+ strtok_r (s, d, p))
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strtok_r
+# define strtok_r(s,d,p) \
+ (GL_LINK_WARNING ("strtok_r is unportable - " \
+ "use gnulib module strtok_r for portability"), \
+ strtok_r (s, d, p))
+#endif
+
+
+/* The following functions are not specified by POSIX. They are gnulib
+ extensions. */
+
+#if @GNULIB_MBSLEN@
+/* Return the number of multibyte characters in the character string STRING.
+ This considers multibyte characters, unlike strlen, which counts bytes. */
+extern size_t mbslen (const char *string);
+#endif
+
+#if @GNULIB_MBSNLEN@
+/* Return the number of multibyte characters in the character string starting
+ at STRING and ending at STRING + LEN. */
+extern size_t mbsnlen (const char *string, size_t len);
+#endif
+
+#if @GNULIB_MBSCHR@
+/* Locate the first single-byte character C in the character string STRING,
+ and return a pointer to it. Return NULL if C is not found in STRING.
+ Unlike strchr(), this function works correctly in multibyte locales with
+ encodings such as GB18030. */
+# define mbschr rpl_mbschr /* avoid collision with HP-UX function */
+extern char * mbschr (const char *string, int c);
+#endif
+
+#if @GNULIB_MBSRCHR@
+/* Locate the last single-byte character C in the character string STRING,
+ and return a pointer to it. Return NULL if C is not found in STRING.
+ Unlike strrchr(), this function works correctly in multibyte locales with
+ encodings such as GB18030. */
+# define mbsrchr rpl_mbsrchr /* avoid collision with HP-UX function */
+extern char * mbsrchr (const char *string, int c);
+#endif
+
+#if @GNULIB_MBSSTR@
+/* Find the first occurrence of the character string NEEDLE in the character
+ string HAYSTACK. Return NULL if NEEDLE is not found in HAYSTACK.
+ Unlike strstr(), this function works correctly in multibyte locales with
+ encodings different from UTF-8. */
+extern char * mbsstr (const char *haystack, const char *needle);
+#endif
+
+#if @GNULIB_MBSCASECMP@
+/* Compare the character strings S1 and S2, ignoring case, returning less than,
+ equal to or greater than zero if S1 is lexicographically less than, equal to
+ or greater than S2.
+ Note: This function may, in multibyte locales, return 0 for strings of
+ different lengths!
+ Unlike strcasecmp(), this function works correctly in multibyte locales. */
+extern int mbscasecmp (const char *s1, const char *s2);
+#endif
+
+#if @GNULIB_MBSNCASECMP@
+/* Compare the initial segment of the character string S1 consisting of at most
+ N characters with the initial segment of the character string S2 consisting
+ of at most N characters, ignoring case, returning less than, equal to or
+ greater than zero if the initial segment of S1 is lexicographically less
+ than, equal to or greater than the initial segment of S2.
+ Note: This function may, in multibyte locales, return 0 for initial segments
+ of different lengths!
+ Unlike strncasecmp(), this function works correctly in multibyte locales.
+ But beware that N is not a byte count but a character count! */
+extern int mbsncasecmp (const char *s1, const char *s2, size_t n);
+#endif
+
+#if @GNULIB_MBSPCASECMP@
+/* Compare the initial segment of the character string STRING consisting of
+ at most mbslen (PREFIX) characters with the character string PREFIX,
+ ignoring case, returning less than, equal to or greater than zero if this
+ initial segment is lexicographically less than, equal to or greater than
+ PREFIX.
+ Note: This function may, in multibyte locales, return 0 if STRING is of
+ smaller length than PREFIX!
+ Unlike strncasecmp(), this function works correctly in multibyte
+ locales. */
+extern char * mbspcasecmp (const char *string, const char *prefix);
+#endif
+
+#if @GNULIB_MBSCASESTR@
+/* Find the first occurrence of the character string NEEDLE in the character
+ string HAYSTACK, using case-insensitive comparison.
+ Note: This function may, in multibyte locales, return success even if
+ strlen (haystack) < strlen (needle) !
+ Unlike strcasestr(), this function works correctly in multibyte locales. */
+extern char * mbscasestr (const char *haystack, const char *needle);
+#endif
+
+#if @GNULIB_MBSCSPN@
+/* Find the first occurrence in the character string STRING of any character
+ in the character string ACCEPT. Return the number of bytes from the
+ beginning of the string to this occurrence, or to the end of the string
+ if none exists.
+ Unlike strcspn(), this function works correctly in multibyte locales. */
+extern size_t mbscspn (const char *string, const char *accept);
+#endif
+
+#if @GNULIB_MBSPBRK@
+/* Find the first occurrence in the character string STRING of any character
+ in the character string ACCEPT. Return the pointer to it, or NULL if none
+ exists.
+ Unlike strpbrk(), this function works correctly in multibyte locales. */
+# define mbspbrk rpl_mbspbrk /* avoid collision with HP-UX function */
+extern char * mbspbrk (const char *string, const char *accept);
+#endif
+
+#if @GNULIB_MBSSPN@
+/* Find the first occurrence in the character string STRING of any character
+ not in the character string REJECT. Return the number of bytes from the
+ beginning of the string to this occurrence, or to the end of the string
+ if none exists.
+ Unlike strspn(), this function works correctly in multibyte locales. */
+extern size_t mbsspn (const char *string, const char *reject);
+#endif
+
+#if @GNULIB_MBSSEP@
+/* Search the next delimiter (multibyte character listed in the character
+ string DELIM) starting at the character string *STRINGP.
+ If one is found, overwrite it with a NUL, and advance *STRINGP to point
+ to the next multibyte character after it. Otherwise, set *STRINGP to NULL.
+ If *STRINGP was already NULL, nothing happens.
+ Return the old value of *STRINGP.
+
+ This is a variant of mbstok_r() that supports empty fields.
+
+ Caveat: It modifies the original string.
+ Caveat: These functions cannot be used on constant strings.
+ Caveat: The identity of the delimiting character is lost.
+
+ See also mbstok_r(). */
+extern char * mbssep (char **stringp, const char *delim);
+#endif
+
+#if @GNULIB_MBSTOK_R@
+/* Parse the character string STRING into tokens separated by characters in
+ the character string DELIM.
+ If STRING is NULL, the saved pointer in SAVE_PTR is used as
+ the next starting point. For example:
+ char s[] = "-abc-=-def";
+ char *sp;
+ x = mbstok_r(s, "-", &sp); // x = "abc", sp = "=-def"
+ x = mbstok_r(NULL, "-=", &sp); // x = "def", sp = NULL
+ x = mbstok_r(NULL, "=", &sp); // x = NULL
+ // s = "abc\0-def\0"
+
+ Caveat: It modifies the original string.
+ Caveat: These functions cannot be used on constant strings.
+ Caveat: The identity of the delimiting character is lost.
+
+ See also mbssep(). */
+extern char * mbstok_r (char *string, const char *delim, char **save_ptr);
+#endif
+
+/* Map any int, typically from errno, into an error message. */
+#if @GNULIB_STRERROR@
+# if @REPLACE_STRERROR@
+# undef strerror
+# define strerror rpl_strerror
+extern char *strerror (int);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strerror
+# define strerror(e) \
+ (GL_LINK_WARNING ("strerror is unportable - " \
+ "use gnulib module strerror to guarantee non-NULL
result"), \
+ strerror (e))
+#endif
+
+#if @GNULIB_STRSIGNAL@
+# if @REPLACE_STRSIGNAL@
+# define strsignal rpl_strsignal
+# endif
+# if ! @HAVE_DECL_STRSIGNAL@ || @REPLACE_STRSIGNAL@
+extern char *strsignal (int __sig);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strsignal
+# define strsignal(a) \
+ (GL_LINK_WARNING ("strsignal is unportable - " \
+ "use gnulib module strsignal for portability"), \
+ strsignal (a))
+#endif
+
+#if @GNULIB_STRVERSCMP@
+# if address@hidden@
+extern int strverscmp (const char *, const char *);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef strverscmp
+# define strverscmp(a, b) \
+ (GL_LINK_WARNING ("strverscmp is unportable - " \
+ "use gnulib module strverscmp for portability"), \
+ strverscmp (a, b))
+#endif
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _GL_STRING_H */
+#endif /* _GL_STRING_H */
diff --git a/lib/sys_file.in.h b/lib/sys_file.in.h
new file mode 100644
index 0000000..52ef466
--- /dev/null
+++ b/lib/sys_file.in.h
@@ -0,0 +1,60 @@
+/* Provide a more complete sys/file.h.
+
+ Copyright (C) 2007-2008 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 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 Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program; if not, write to the Free Software Foundation,
+ Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */
+
+/* Written by Richard W.M. Jones. */
+#ifndef _GL_SYS_FILE_H
+
+# if __GNUC__ >= 3
address@hidden@
+# endif
+
+/* The include_next requires a split double-inclusion guard. */
+# if @HAVE_SYS_FILE_H@
+# @INCLUDE_NEXT@ @NEXT_SYS_FILE_H@
+# endif
+
+#ifndef _GL_SYS_FILE_H
+#define _GL_SYS_FILE_H
+
+
+#if @GNULIB_FLOCK@
+/* Apply or remove advisory locks on an open file.
+ Return 0 if successful, otherwise -1 and errno set. */
+# if address@hidden@
+extern int flock (int fd, int operation);
+
+/* Operations for the 'flock' call (same as Linux kernel constants). */
+#define LOCK_SH 1 /* Shared lock. */
+#define LOCK_EX 2 /* Exclusive lock. */
+#define LOCK_UN 8 /* Unlock. */
+
+/* Can be OR'd in to one of the above. */
+#define LOCK_NB 4 /* Don't block when locking. */
+
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef flock
+# define flock(fd,op) \
+ (GL_LINK_WARNING ("flock is unportable - " \
+ "use gnulib module flock for portability"), \
+ flock ((fd), (op)))
+#endif
+
+
+#endif /* _GL_SYS_FILE_H */
+#endif /* _GL_SYS_FILE_H */
diff --git a/lib/unistd.in.h b/lib/unistd.in.h
index d4b842a..2e42c0b 100644
--- a/lib/unistd.in.h
+++ b/lib/unistd.in.h
@@ -1,5 +1,5 @@
/* Substitute for and wrapper around <unistd.h>.
- Copyright (C) 2003-2008 Free Software Foundation, Inc.
+ Copyright (C) 2003-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
@@ -29,7 +29,7 @@
#ifndef _GL_UNISTD_H
#define _GL_UNISTD_H
-/* mingw doesn't define the SEEK_* macros in <unistd.h>. */
+/* mingw doesn't define the SEEK_* or *_FILENO macros in <unistd.h>. */
#if !(defined SEEK_CUR && defined SEEK_END && defined SEEK_SET)
# include <stdio.h>
#endif
@@ -87,6 +87,17 @@
/* The definition of GL_LINK_WARNING is copied here. */
+/* OS/2 EMX lacks these macros. */
+#ifndef STDIN_FILENO
+# define STDIN_FILENO 0
+#endif
+#ifndef STDOUT_FILENO
+# define STDOUT_FILENO 1
+#endif
+#ifndef STDERR_FILENO
+# define STDERR_FILENO 2
+#endif
+
/* Declare overridden functions. */
#ifdef __cplusplus
@@ -120,10 +131,6 @@ extern int chown (const char *file, uid_t uid, gid_t gid);
#if @GNULIB_CLOSE@
-# if @UNISTD_H_HAVE_WINSOCK2_H@
-/* Need a gnulib internal function. */
-# define HAVE__GL_CLOSE_FD_MAYBE_SOCKET 1
-# endif
# if @REPLACE_CLOSE@
/* Automatically included by modules that need a replacement for close. */
# undef close
@@ -475,6 +482,23 @@ extern int lchown (char const *file, uid_t owner, gid_t
group);
#endif
+#if @GNULIB_LINK@
+/* Create a new hard link for an existing file.
+ Return 0 if successful, otherwise -1 and errno set.
+ See POSIX:2001 specification
+ <http://www.opengroup.org/susv3xsh/link.html>. */
+# if address@hidden@
+extern int link (const char *path1, const char *path2);
+# endif
+#elif defined GNULIB_POSIXCHECK
+# undef link
+# define link(path1,path2) \
+ (GL_LINK_WARNING ("link is unportable - " \
+ "use gnulib module link for portability"), \
+ link (path1, path2))
+#endif
+
+
#if @GNULIB_LSEEK@
# if @REPLACE_LSEEK@
/* Set the offset of FD relative to SEEK_SET, SEEK_CUR, or SEEK_END.
diff --git a/lib/unistr.h b/lib/unistr.h
new file mode 100644
index 0000000..83ff134
--- /dev/null
+++ b/lib/unistr.h
@@ -0,0 +1,681 @@
+/* Elementary Unicode string functions.
+ Copyright (C) 2001-2002, 2005-2009 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify it
+ under the terms of the GNU Lesser General Public License as published
+ by the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ 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 program. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef _UNISTR_H
+#define _UNISTR_H
+
+#include "unitypes.h"
+
+/* Get bool. */
+#include <stdbool.h>
+
+/* Get size_t. */
+#include <stddef.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+/* Conventions:
+
+ All functions prefixed with u8_ operate on UTF-8 encoded strings.
+ Their unit is an uint8_t (1 byte).
+
+ All functions prefixed with u16_ operate on UTF-16 encoded strings.
+ Their unit is an uint16_t (a 2-byte word).
+
+ All functions prefixed with u32_ operate on UCS-4 encoded strings.
+ Their unit is an uint32_t (a 4-byte word).
+
+ All argument pairs (s, n) denote a Unicode string s[0..n-1] with exactly
+ n units.
+
+ All arguments starting with "str" and the arguments of functions starting
+ with u8_str/u16_str/u32_str denote a NUL terminated string, i.e. a string
+ which terminates at the first NUL unit. This termination unit is
+ considered part of the string for all memory allocation purposes, but
+ is not considered part of the string for all other logical purposes.
+
+ Functions returning a string result take a (resultbuf, lengthp) argument
+ pair. If resultbuf is not NULL and the result fits into *lengthp units,
+ it is put in resultbuf, and resultbuf is returned. Otherwise, a freshly
+ allocated string is returned. In both cases, *lengthp is set to the
+ length (number of units) of the returned string. In case of error,
+ NULL is returned and errno is set. */
+
+
+/* Elementary string checks. */
+
+/* Check whether an UTF-8 string is well-formed.
+ Return NULL if valid, or a pointer to the first invalid unit otherwise. */
+extern const uint8_t *
+ u8_check (const uint8_t *s, size_t n);
+
+/* Check whether an UTF-16 string is well-formed.
+ Return NULL if valid, or a pointer to the first invalid unit otherwise. */
+extern const uint16_t *
+ u16_check (const uint16_t *s, size_t n);
+
+/* Check whether an UCS-4 string is well-formed.
+ Return NULL if valid, or a pointer to the first invalid unit otherwise. */
+extern const uint32_t *
+ u32_check (const uint32_t *s, size_t n);
+
+
+/* Elementary string conversions. */
+
+/* Convert an UTF-8 string to an UTF-16 string. */
+extern uint16_t *
+ u8_to_u16 (const uint8_t *s, size_t n, uint16_t *resultbuf,
+ size_t *lengthp);
+
+/* Convert an UTF-8 string to an UCS-4 string. */
+extern uint32_t *
+ u8_to_u32 (const uint8_t *s, size_t n, uint32_t *resultbuf,
+ size_t *lengthp);
+
+/* Convert an UTF-16 string to an UTF-8 string. */
+extern uint8_t *
+ u16_to_u8 (const uint16_t *s, size_t n, uint8_t *resultbuf,
+ size_t *lengthp);
+
+/* Convert an UTF-16 string to an UCS-4 string. */
+extern uint32_t *
+ u16_to_u32 (const uint16_t *s, size_t n, uint32_t *resultbuf,
+ size_t *lengthp);
+
+/* Convert an UCS-4 string to an UTF-8 string. */
+extern uint8_t *
+ u32_to_u8 (const uint32_t *s, size_t n, uint8_t *resultbuf,
+ size_t *lengthp);
+
+/* Convert an UCS-4 string to an UTF-16 string. */
+extern uint16_t *
+ u32_to_u16 (const uint32_t *s, size_t n, uint16_t *resultbuf,
+ size_t *lengthp);
+
+
+/* Elementary string functions. */
+
+/* Return the length (number of units) of the first character in S, which is
+ no longer than N. Return 0 if it is the NUL character. Return -1 upon
+ failure. */
+/* Similar to mblen(), except that s must not be NULL. */
+extern int
+ u8_mblen (const uint8_t *s, size_t n);
+extern int
+ u16_mblen (const uint16_t *s, size_t n);
+extern int
+ u32_mblen (const uint32_t *s, size_t n);
+
+/* Return the length (number of units) of the first character in S, putting
+ its 'ucs4_t' representation in *PUC. Upon failure, *PUC is set to 0xfffd,
+ and an appropriate number of units is returned.
+ The number of available units, N, must be > 0. */
+/* Similar to mbtowc(), except that puc and s must not be NULL, n must be > 0,
+ and the NUL character is not treated specially. */
+/* The variants with _safe suffix are safe, even if the library is compiled
+ without --enable-safety. */
+
+#ifdef GNULIB_UNISTR_U8_MBTOUC_UNSAFE
+# if !HAVE_INLINE
+extern int
+ u8_mbtouc_unsafe (ucs4_t *puc, const uint8_t *s, size_t n);
+# else
+extern int
+ u8_mbtouc_unsafe_aux (ucs4_t *puc, const uint8_t *s, size_t n);
+static inline int
+u8_mbtouc_unsafe (ucs4_t *puc, const uint8_t *s, size_t n)
+{
+ uint8_t c = *s;
+
+ if (c < 0x80)
+ {
+ *puc = c;
+ return 1;
+ }
+ else
+ return u8_mbtouc_unsafe_aux (puc, s, n);
+}
+# endif
+#endif
+
+#ifdef GNULIB_UNISTR_U16_MBTOUC_UNSAFE
+# if !HAVE_INLINE
+extern int
+ u16_mbtouc_unsafe (ucs4_t *puc, const uint16_t *s, size_t n);
+# else
+extern int
+ u16_mbtouc_unsafe_aux (ucs4_t *puc, const uint16_t *s, size_t n);
+static inline int
+u16_mbtouc_unsafe (ucs4_t *puc, const uint16_t *s, size_t n)
+{
+ uint16_t c = *s;
+
+ if (c < 0xd800 || c >= 0xe000)
+ {
+ *puc = c;
+ return 1;
+ }
+ else
+ return u16_mbtouc_unsafe_aux (puc, s, n);
+}
+# endif
+#endif
+
+#ifdef GNULIB_UNISTR_U32_MBTOUC_UNSAFE
+# if !HAVE_INLINE
+extern int
+ u32_mbtouc_unsafe (ucs4_t *puc, const uint32_t *s, size_t n);
+# else
+static inline int
+u32_mbtouc_unsafe (ucs4_t *puc, const uint32_t *s, size_t n _UNUSED_PARAMETER_)
+{
+ uint32_t c = *s;
+
+# if CONFIG_UNICODE_SAFETY
+ if (c < 0xd800 || (c >= 0xe000 && c < 0x110000))
+# endif
+ *puc = c;
+# if CONFIG_UNICODE_SAFETY
+ else
+ /* invalid multibyte character */
+ *puc = 0xfffd;
+# endif
+ return 1;
+}
+# endif
+#endif
+
+#ifdef GNULIB_UNISTR_U8_MBTOUC
+# if !HAVE_INLINE
+extern int
+ u8_mbtouc (ucs4_t *puc, const uint8_t *s, size_t n);
+# else
+extern int
+ u8_mbtouc_aux (ucs4_t *puc, const uint8_t *s, size_t n);
+static inline int
+u8_mbtouc (ucs4_t *puc, const uint8_t *s, size_t n)
+{
+ uint8_t c = *s;
+
+ if (c < 0x80)
+ {
+ *puc = c;
+ return 1;
+ }
+ else
+ return u8_mbtouc_aux (puc, s, n);
+}
+# endif
+#endif
+
+#ifdef GNULIB_UNISTR_U16_MBTOUC
+# if !HAVE_INLINE
+extern int
+ u16_mbtouc (ucs4_t *puc, const uint16_t *s, size_t n);
+# else
+extern int
+ u16_mbtouc_aux (ucs4_t *puc, const uint16_t *s, size_t n);
+static inline int
+u16_mbtouc (ucs4_t *puc, const uint16_t *s, size_t n)
+{
+ uint16_t c = *s;
+
+ if (c < 0xd800 || c >= 0xe000)
+ {
+ *puc = c;
+ return 1;
+ }
+ else
+ return u16_mbtouc_aux (puc, s, n);
+}
+# endif
+#endif
+
+#ifdef GNULIB_UNISTR_U32_MBTOUC
+# if !HAVE_INLINE
+extern int
+ u32_mbtouc (ucs4_t *puc, const uint32_t *s, size_t n);
+# else
+static inline int
+u32_mbtouc (ucs4_t *puc, const uint32_t *s, size_t n _UNUSED_PARAMETER_)
+{
+ uint32_t c = *s;
+
+ if (c < 0xd800 || (c >= 0xe000 && c < 0x110000))
+ *puc = c;
+ else
+ /* invalid multibyte character */
+ *puc = 0xfffd;
+ return 1;
+}
+# endif
+#endif
+
+/* Return the length (number of units) of the first character in S, putting
+ its 'ucs4_t' representation in *PUC. Upon failure, *PUC is set to 0xfffd,
+ and -1 is returned for an invalid sequence of units, -2 is returned for an
+ incomplete sequence of units.
+ The number of available units, N, must be > 0. */
+/* Similar to u*_mbtouc(), except that the return value gives more details
+ about the failure, similar to mbrtowc(). */
+
+#ifdef GNULIB_UNISTR_U8_MBTOUCR
+extern int
+ u8_mbtoucr (ucs4_t *puc, const uint8_t *s, size_t n);
+#endif
+
+#ifdef GNULIB_UNISTR_U16_MBTOUCR
+extern int
+ u16_mbtoucr (ucs4_t *puc, const uint16_t *s, size_t n);
+#endif
+
+#ifdef GNULIB_UNISTR_U32_MBTOUCR
+extern int
+ u32_mbtoucr (ucs4_t *puc, const uint32_t *s, size_t n);
+#endif
+
+/* Put the multibyte character represented by UC in S, returning its
+ length. Return -1 upon failure, -2 if the number of available units, N,
+ is too small. The latter case cannot occur if N >= 6/2/1, respectively. */
+/* Similar to wctomb(), except that s must not be NULL, and the argument n
+ must be specified. */
+
+#ifdef GNULIB_UNISTR_U8_UCTOMB
+/* Auxiliary function, also used by u8_chr, u8_strchr, u8_strrchr. */
+extern int
+ u8_uctomb_aux (uint8_t *s, ucs4_t uc, int n);
+# if !HAVE_INLINE
+extern int
+ u8_uctomb (uint8_t *s, ucs4_t uc, int n);
+# else
+static inline int
+u8_uctomb (uint8_t *s, ucs4_t uc, int n)
+{
+ if (uc < 0x80 && n > 0)
+ {
+ s[0] = uc;
+ return 1;
+ }
+ else
+ return u8_uctomb_aux (s, uc, n);
+}
+# endif
+#endif
+
+#ifdef GNULIB_UNISTR_U16_UCTOMB
+/* Auxiliary function, also used by u16_chr, u16_strchr, u16_strrchr. */
+extern int
+ u16_uctomb_aux (uint16_t *s, ucs4_t uc, int n);
+# if !HAVE_INLINE
+extern int
+ u16_uctomb (uint16_t *s, ucs4_t uc, int n);
+# else
+static inline int
+u16_uctomb (uint16_t *s, ucs4_t uc, int n)
+{
+ if (uc < 0xd800 && n > 0)
+ {
+ s[0] = uc;
+ return 1;
+ }
+ else
+ return u16_uctomb_aux (s, uc, n);
+}
+# endif
+#endif
+
+#ifdef GNULIB_UNISTR_U32_UCTOMB
+# if !HAVE_INLINE
+extern int
+ u32_uctomb (uint32_t *s, ucs4_t uc, int n);
+# else
+static inline int
+u32_uctomb (uint32_t *s, ucs4_t uc, int n)
+{
+ if (uc < 0xd800 || (uc >= 0xe000 && uc < 0x110000))
+ {
+ if (n > 0)
+ {
+ *s = uc;
+ return 1;
+ }
+ else
+ return -2;
+ }
+ else
+ return -1;
+}
+# endif
+#endif
+
+/* Copy N units from SRC to DEST. */
+/* Similar to memcpy(). */
+extern uint8_t *
+ u8_cpy (uint8_t *dest, const uint8_t *src, size_t n);
+extern uint16_t *
+ u16_cpy (uint16_t *dest, const uint16_t *src, size_t n);
+extern uint32_t *
+ u32_cpy (uint32_t *dest, const uint32_t *src, size_t n);
+
+/* Copy N units from SRC to DEST, guaranteeing correct behavior for
+ overlapping memory areas. */
+/* Similar to memmove(). */
+extern uint8_t *
+ u8_move (uint8_t *dest, const uint8_t *src, size_t n);
+extern uint16_t *
+ u16_move (uint16_t *dest, const uint16_t *src, size_t n);
+extern uint32_t *
+ u32_move (uint32_t *dest, const uint32_t *src, size_t n);
+
+/* Set the first N characters of S to UC. UC should be a character that
+ occupies only 1 unit. */
+/* Similar to memset(). */
+extern uint8_t *
+ u8_set (uint8_t *s, ucs4_t uc, size_t n);
+extern uint16_t *
+ u16_set (uint16_t *s, ucs4_t uc, size_t n);
+extern uint32_t *
+ u32_set (uint32_t *s, ucs4_t uc, size_t n);
+
+/* Compare S1 and S2, each of length N. */
+/* Similar to memcmp(). */
+extern int
+ u8_cmp (const uint8_t *s1, const uint8_t *s2, size_t n);
+extern int
+ u16_cmp (const uint16_t *s1, const uint16_t *s2, size_t n);
+extern int
+ u32_cmp (const uint32_t *s1, const uint32_t *s2, size_t n);
+
+/* Compare S1 and S2. */
+/* Similar to the gnulib function memcmp2(). */
+extern int
+ u8_cmp2 (const uint8_t *s1, size_t n1, const uint8_t *s2, size_t n2);
+extern int
+ u16_cmp2 (const uint16_t *s1, size_t n1, const uint16_t *s2, size_t n2);
+extern int
+ u32_cmp2 (const uint32_t *s1, size_t n1, const uint32_t *s2, size_t n2);
+
+/* Search the string at S for UC. */
+/* Similar to memchr(). */
+extern uint8_t *
+ u8_chr (const uint8_t *s, size_t n, ucs4_t uc);
+extern uint16_t *
+ u16_chr (const uint16_t *s, size_t n, ucs4_t uc);
+extern uint32_t *
+ u32_chr (const uint32_t *s, size_t n, ucs4_t uc);
+
+/* Count the number of Unicode characters in the N units from S. */
+/* Similar to mbsnlen(). */
+extern size_t
+ u8_mbsnlen (const uint8_t *s, size_t n);
+extern size_t
+ u16_mbsnlen (const uint16_t *s, size_t n);
+extern size_t
+ u32_mbsnlen (const uint32_t *s, size_t n);
+
+/* Elementary string functions with memory allocation. */
+
+/* Make a freshly allocated copy of S, of length N. */
+extern uint8_t *
+ u8_cpy_alloc (const uint8_t *s, size_t n);
+extern uint16_t *
+ u16_cpy_alloc (const uint16_t *s, size_t n);
+extern uint32_t *
+ u32_cpy_alloc (const uint32_t *s, size_t n);
+
+/* Elementary string functions on NUL terminated strings. */
+
+/* Return the length (number of units) of the first character in S.
+ Return 0 if it is the NUL character. Return -1 upon failure. */
+extern int
+ u8_strmblen (const uint8_t *s);
+extern int
+ u16_strmblen (const uint16_t *s);
+extern int
+ u32_strmblen (const uint32_t *s);
+
+/* Return the length (number of units) of the first character in S, putting
+ its 'ucs4_t' representation in *PUC. Return 0 if it is the NUL
+ character. Return -1 upon failure. */
+extern int
+ u8_strmbtouc (ucs4_t *puc, const uint8_t *s);
+extern int
+ u16_strmbtouc (ucs4_t *puc, const uint16_t *s);
+extern int
+ u32_strmbtouc (ucs4_t *puc, const uint32_t *s);
+
+/* Forward iteration step. Advances the pointer past the next character,
+ or returns NULL if the end of the string has been reached. Puts the
+ character's 'ucs4_t' representation in *PUC. */
+extern const uint8_t *
+ u8_next (ucs4_t *puc, const uint8_t *s);
+extern const uint16_t *
+ u16_next (ucs4_t *puc, const uint16_t *s);
+extern const uint32_t *
+ u32_next (ucs4_t *puc, const uint32_t *s);
+
+/* Backward iteration step. Advances the pointer to point to the previous
+ character, or returns NULL if the beginning of the string had been reached.
+ Puts the character's 'ucs4_t' representation in *PUC. */
+extern const uint8_t *
+ u8_prev (ucs4_t *puc, const uint8_t *s, const uint8_t *start);
+extern const uint16_t *
+ u16_prev (ucs4_t *puc, const uint16_t *s, const uint16_t *start);
+extern const uint32_t *
+ u32_prev (ucs4_t *puc, const uint32_t *s, const uint32_t *start);
+
+/* Return the number of units in S. */
+/* Similar to strlen(), wcslen(). */
+extern size_t
+ u8_strlen (const uint8_t *s);
+extern size_t
+ u16_strlen (const uint16_t *s);
+extern size_t
+ u32_strlen (const uint32_t *s);
+
+/* Return the number of units in S, but at most MAXLEN. */
+/* Similar to strnlen(), wcsnlen(). */
+extern size_t
+ u8_strnlen (const uint8_t *s, size_t maxlen);
+extern size_t
+ u16_strnlen (const uint16_t *s, size_t maxlen);
+extern size_t
+ u32_strnlen (const uint32_t *s, size_t maxlen);
+
+/* Copy SRC to DEST. */
+/* Similar to strcpy(), wcscpy(). */
+extern uint8_t *
+ u8_strcpy (uint8_t *dest, const uint8_t *src);
+extern uint16_t *
+ u16_strcpy (uint16_t *dest, const uint16_t *src);
+extern uint32_t *
+ u32_strcpy (uint32_t *dest, const uint32_t *src);
+
+/* Copy SRC to DEST, returning the address of the terminating NUL in DEST. */
+/* Similar to stpcpy(). */
+extern uint8_t *
+ u8_stpcpy (uint8_t *dest, const uint8_t *src);
+extern uint16_t *
+ u16_stpcpy (uint16_t *dest, const uint16_t *src);
+extern uint32_t *
+ u32_stpcpy (uint32_t *dest, const uint32_t *src);
+
+/* Copy no more than N units of SRC to DEST. */
+/* Similar to strncpy(), wcsncpy(). */
+extern uint8_t *
+ u8_strncpy (uint8_t *dest, const uint8_t *src, size_t n);
+extern uint16_t *
+ u16_strncpy (uint16_t *dest, const uint16_t *src, size_t n);
+extern uint32_t *
+ u32_strncpy (uint32_t *dest, const uint32_t *src, size_t n);
+
+/* Copy no more than N units of SRC to DEST, returning the address of
+ the last unit written into DEST. */
+/* Similar to stpncpy(). */
+extern uint8_t *
+ u8_stpncpy (uint8_t *dest, const uint8_t *src, size_t n);
+extern uint16_t *
+ u16_stpncpy (uint16_t *dest, const uint16_t *src, size_t n);
+extern uint32_t *
+ u32_stpncpy (uint32_t *dest, const uint32_t *src, size_t n);
+
+/* Append SRC onto DEST. */
+/* Similar to strcat(), wcscat(). */
+extern uint8_t *
+ u8_strcat (uint8_t *dest, const uint8_t *src);
+extern uint16_t *
+ u16_strcat (uint16_t *dest, const uint16_t *src);
+extern uint32_t *
+ u32_strcat (uint32_t *dest, const uint32_t *src);
+
+/* Append no more than N units of SRC onto DEST. */
+/* Similar to strncat(), wcsncat(). */
+extern uint8_t *
+ u8_strncat (uint8_t *dest, const uint8_t *src, size_t n);
+extern uint16_t *
+ u16_strncat (uint16_t *dest, const uint16_t *src, size_t n);
+extern uint32_t *
+ u32_strncat (uint32_t *dest, const uint32_t *src, size_t n);
+
+/* Compare S1 and S2. */
+/* Similar to strcmp(), wcscmp(). */
+extern int
+ u8_strcmp (const uint8_t *s1, const uint8_t *s2);
+extern int
+ u16_strcmp (const uint16_t *s1, const uint16_t *s2);
+extern int
+ u32_strcmp (const uint32_t *s1, const uint32_t *s2);
+
+/* Compare S1 and S2 using the collation rules of the current locale.
+ Return -1 if S1 < S2, 0 if S1 = S2, 1 if S1 > S2.
+ Upon failure, set errno and return any value. */
+/* Similar to strcoll(), wcscoll(). */
+extern int
+ u8_strcoll (const uint8_t *s1, const uint8_t *s2);
+extern int
+ u16_strcoll (const uint16_t *s1, const uint16_t *s2);
+extern int
+ u32_strcoll (const uint32_t *s1, const uint32_t *s2);
+
+/* Compare no more than N units of S1 and S2. */
+/* Similar to strncmp(), wcsncmp(). */
+extern int
+ u8_strncmp (const uint8_t *s1, const uint8_t *s2, size_t n);
+extern int
+ u16_strncmp (const uint16_t *s1, const uint16_t *s2, size_t n);
+extern int
+ u32_strncmp (const uint32_t *s1, const uint32_t *s2, size_t n);
+
+/* Duplicate S, returning an identical malloc'd string. */
+/* Similar to strdup(), wcsdup(). */
+extern uint8_t *
+ u8_strdup (const uint8_t *s);
+extern uint16_t *
+ u16_strdup (const uint16_t *s);
+extern uint32_t *
+ u32_strdup (const uint32_t *s);
+
+/* Find the first occurrence of UC in STR. */
+/* Similar to strchr(), wcschr(). */
+extern uint8_t *
+ u8_strchr (const uint8_t *str, ucs4_t uc);
+extern uint16_t *
+ u16_strchr (const uint16_t *str, ucs4_t uc);
+extern uint32_t *
+ u32_strchr (const uint32_t *str, ucs4_t uc);
+
+/* Find the last occurrence of UC in STR. */
+/* Similar to strrchr(), wcsrchr(). */
+extern uint8_t *
+ u8_strrchr (const uint8_t *str, ucs4_t uc);
+extern uint16_t *
+ u16_strrchr (const uint16_t *str, ucs4_t uc);
+extern uint32_t *
+ u32_strrchr (const uint32_t *str, ucs4_t uc);
+
+/* Return the length of the initial segment of STR which consists entirely
+ of Unicode characters not in REJECT. */
+/* Similar to strcspn(), wcscspn(). */
+extern size_t
+ u8_strcspn (const uint8_t *str, const uint8_t *reject);
+extern size_t
+ u16_strcspn (const uint16_t *str, const uint16_t *reject);
+extern size_t
+ u32_strcspn (const uint32_t *str, const uint32_t *reject);
+
+/* Return the length of the initial segment of STR which consists entirely
+ of Unicode characters in ACCEPT. */
+/* Similar to strspn(), wcsspn(). */
+extern size_t
+ u8_strspn (const uint8_t *str, const uint8_t *accept);
+extern size_t
+ u16_strspn (const uint16_t *str, const uint16_t *accept);
+extern size_t
+ u32_strspn (const uint32_t *str, const uint32_t *accept);
+
+/* Find the first occurrence in STR of any character in ACCEPT. */
+/* Similar to strpbrk(), wcspbrk(). */
+extern uint8_t *
+ u8_strpbrk (const uint8_t *str, const uint8_t *accept);
+extern uint16_t *
+ u16_strpbrk (const uint16_t *str, const uint16_t *accept);
+extern uint32_t *
+ u32_strpbrk (const uint32_t *str, const uint32_t *accept);
+
+/* Find the first occurrence of NEEDLE in HAYSTACK. */
+/* Similar to strstr(), wcsstr(). */
+extern uint8_t *
+ u8_strstr (const uint8_t *haystack, const uint8_t *needle);
+extern uint16_t *
+ u16_strstr (const uint16_t *haystack, const uint16_t *needle);
+extern uint32_t *
+ u32_strstr (const uint32_t *haystack, const uint32_t *needle);
+
+/* Test whether STR starts with PREFIX. */
+extern bool
+ u8_startswith (const uint8_t *str, const uint8_t *prefix);
+extern bool
+ u16_startswith (const uint16_t *str, const uint16_t *prefix);
+extern bool
+ u32_startswith (const uint32_t *str, const uint32_t *prefix);
+
+/* Test whether STR ends with SUFFIX. */
+extern bool
+ u8_endswith (const uint8_t *str, const uint8_t *suffix);
+extern bool
+ u16_endswith (const uint16_t *str, const uint16_t *suffix);
+extern bool
+ u32_endswith (const uint32_t *str, const uint32_t *suffix);
+
+/* Divide STR into tokens separated by characters in DELIM.
+ This interface is actually more similar to wcstok than to strtok. */
+/* Similar to strtok_r(), wcstok(). */
+extern uint8_t *
+ u8_strtok (uint8_t *str, const uint8_t *delim, uint8_t **ptr);
+extern uint16_t *
+ u16_strtok (uint16_t *str, const uint16_t *delim, uint16_t **ptr);
+extern uint32_t *
+ u32_strtok (uint32_t *str, const uint32_t *delim, uint32_t **ptr);
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _UNISTR_H */
diff --git a/lib/unistr/u8-mbtouc-aux.c b/lib/unistr/u8-mbtouc-aux.c
new file mode 100644
index 0000000..53d02bf
--- /dev/null
+++ b/lib/unistr/u8-mbtouc-aux.c
@@ -0,0 +1,158 @@
+/* Conversion UTF-8 to UCS-4.
+ Copyright (C) 2001-2002, 2006-2007, 2009 Free Software Foundation, Inc.
+ Written by Bruno Haible <address@hidden>, 2001.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+/* Specification. */
+#include "unistr.h"
+
+#if defined IN_LIBUNISTRING || HAVE_INLINE
+
+int
+u8_mbtouc_aux (ucs4_t *puc, const uint8_t *s, size_t n)
+{
+ uint8_t c = *s;
+
+ if (c >= 0xc2)
+ {
+ if (c < 0xe0)
+ {
+ if (n >= 2)
+ {
+ if ((s[1] ^ 0x80) < 0x40)
+ {
+ *puc = ((unsigned int) (c & 0x1f) << 6)
+ | (unsigned int) (s[1] ^ 0x80);
+ return 2;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xf0)
+ {
+ if (n >= 3)
+ {
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (c >= 0xe1 || s[1] >= 0xa0)
+ && (c != 0xed || s[1] < 0xa0))
+ {
+ *puc = ((unsigned int) (c & 0x0f) << 12)
+ | ((unsigned int) (s[1] ^ 0x80) << 6)
+ | (unsigned int) (s[2] ^ 0x80);
+ return 3;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xf8)
+ {
+ if (n >= 4)
+ {
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40
+ && (c >= 0xf1 || s[1] >= 0x90)
+#if 1
+ && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90))
+#endif
+ )
+ {
+ *puc = ((unsigned int) (c & 0x07) << 18)
+ | ((unsigned int) (s[1] ^ 0x80) << 12)
+ | ((unsigned int) (s[2] ^ 0x80) << 6)
+ | (unsigned int) (s[3] ^ 0x80);
+ return 4;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+#if 0
+ else if (c < 0xfc)
+ {
+ if (n >= 5)
+ {
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40
+ && (c >= 0xf9 || s[1] >= 0x88))
+ {
+ *puc = ((unsigned int) (c & 0x03) << 24)
+ | ((unsigned int) (s[1] ^ 0x80) << 18)
+ | ((unsigned int) (s[2] ^ 0x80) << 12)
+ | ((unsigned int) (s[3] ^ 0x80) << 6)
+ | (unsigned int) (s[4] ^ 0x80);
+ return 5;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xfe)
+ {
+ if (n >= 6)
+ {
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40
+ && (s[5] ^ 0x80) < 0x40
+ && (c >= 0xfd || s[1] >= 0x84))
+ {
+ *puc = ((unsigned int) (c & 0x01) << 30)
+ | ((unsigned int) (s[1] ^ 0x80) << 24)
+ | ((unsigned int) (s[2] ^ 0x80) << 18)
+ | ((unsigned int) (s[3] ^ 0x80) << 12)
+ | ((unsigned int) (s[4] ^ 0x80) << 6)
+ | (unsigned int) (s[5] ^ 0x80);
+ return 6;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+#endif
+ }
+ /* invalid multibyte character */
+ *puc = 0xfffd;
+ return 1;
+}
+
+#endif
diff --git a/lib/unistr/u8-mbtouc-unsafe-aux.c
b/lib/unistr/u8-mbtouc-unsafe-aux.c
new file mode 100644
index 0000000..43e4a36
--- /dev/null
+++ b/lib/unistr/u8-mbtouc-unsafe-aux.c
@@ -0,0 +1,168 @@
+/* Conversion UTF-8 to UCS-4.
+ Copyright (C) 2001-2002, 2006-2007, 2009 Free Software Foundation, Inc.
+ Written by Bruno Haible <address@hidden>, 2001.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+/* Specification. */
+#include "unistr.h"
+
+#if defined IN_LIBUNISTRING || HAVE_INLINE
+
+int
+u8_mbtouc_unsafe_aux (ucs4_t *puc, const uint8_t *s, size_t n)
+{
+ uint8_t c = *s;
+
+ if (c >= 0xc2)
+ {
+ if (c < 0xe0)
+ {
+ if (n >= 2)
+ {
+#if CONFIG_UNICODE_SAFETY
+ if ((s[1] ^ 0x80) < 0x40)
+#endif
+ {
+ *puc = ((unsigned int) (c & 0x1f) << 6)
+ | (unsigned int) (s[1] ^ 0x80);
+ return 2;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xf0)
+ {
+ if (n >= 3)
+ {
+#if CONFIG_UNICODE_SAFETY
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (c >= 0xe1 || s[1] >= 0xa0)
+ && (c != 0xed || s[1] < 0xa0))
+#endif
+ {
+ *puc = ((unsigned int) (c & 0x0f) << 12)
+ | ((unsigned int) (s[1] ^ 0x80) << 6)
+ | (unsigned int) (s[2] ^ 0x80);
+ return 3;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xf8)
+ {
+ if (n >= 4)
+ {
+#if CONFIG_UNICODE_SAFETY
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40
+ && (c >= 0xf1 || s[1] >= 0x90)
+#if 1
+ && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90))
+#endif
+ )
+#endif
+ {
+ *puc = ((unsigned int) (c & 0x07) << 18)
+ | ((unsigned int) (s[1] ^ 0x80) << 12)
+ | ((unsigned int) (s[2] ^ 0x80) << 6)
+ | (unsigned int) (s[3] ^ 0x80);
+ return 4;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+#if 0
+ else if (c < 0xfc)
+ {
+ if (n >= 5)
+ {
+#if CONFIG_UNICODE_SAFETY
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40
+ && (c >= 0xf9 || s[1] >= 0x88))
+#endif
+ {
+ *puc = ((unsigned int) (c & 0x03) << 24)
+ | ((unsigned int) (s[1] ^ 0x80) << 18)
+ | ((unsigned int) (s[2] ^ 0x80) << 12)
+ | ((unsigned int) (s[3] ^ 0x80) << 6)
+ | (unsigned int) (s[4] ^ 0x80);
+ return 5;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xfe)
+ {
+ if (n >= 6)
+ {
+#if CONFIG_UNICODE_SAFETY
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40
+ && (s[5] ^ 0x80) < 0x40
+ && (c >= 0xfd || s[1] >= 0x84))
+#endif
+ {
+ *puc = ((unsigned int) (c & 0x01) << 30)
+ | ((unsigned int) (s[1] ^ 0x80) << 24)
+ | ((unsigned int) (s[2] ^ 0x80) << 18)
+ | ((unsigned int) (s[3] ^ 0x80) << 12)
+ | ((unsigned int) (s[4] ^ 0x80) << 6)
+ | (unsigned int) (s[5] ^ 0x80);
+ return 6;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+#endif
+ }
+ /* invalid multibyte character */
+ *puc = 0xfffd;
+ return 1;
+}
+
+#endif
diff --git a/lib/unistr/u8-mbtouc-unsafe.c b/lib/unistr/u8-mbtouc-unsafe.c
new file mode 100644
index 0000000..4661569
--- /dev/null
+++ b/lib/unistr/u8-mbtouc-unsafe.c
@@ -0,0 +1,179 @@
+/* Look at first character in UTF-8 string.
+ Copyright (C) 1999-2002, 2006-2007, 2009 Free Software Foundation, Inc.
+ Written by Bruno Haible <address@hidden>, 2001.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#if defined IN_LIBUNISTRING
+/* Tell unistr.h to declare u8_mbtouc_unsafe as 'extern', not
+ 'static inline'. */
+# include "unistring-notinline.h"
+#endif
+
+/* Specification. */
+#include "unistr.h"
+
+#if !HAVE_INLINE
+
+int
+u8_mbtouc_unsafe (ucs4_t *puc, const uint8_t *s, size_t n)
+{
+ uint8_t c = *s;
+
+ if (c < 0x80)
+ {
+ *puc = c;
+ return 1;
+ }
+ else if (c >= 0xc2)
+ {
+ if (c < 0xe0)
+ {
+ if (n >= 2)
+ {
+#if CONFIG_UNICODE_SAFETY
+ if ((s[1] ^ 0x80) < 0x40)
+#endif
+ {
+ *puc = ((unsigned int) (c & 0x1f) << 6)
+ | (unsigned int) (s[1] ^ 0x80);
+ return 2;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xf0)
+ {
+ if (n >= 3)
+ {
+#if CONFIG_UNICODE_SAFETY
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (c >= 0xe1 || s[1] >= 0xa0)
+ && (c != 0xed || s[1] < 0xa0))
+#endif
+ {
+ *puc = ((unsigned int) (c & 0x0f) << 12)
+ | ((unsigned int) (s[1] ^ 0x80) << 6)
+ | (unsigned int) (s[2] ^ 0x80);
+ return 3;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xf8)
+ {
+ if (n >= 4)
+ {
+#if CONFIG_UNICODE_SAFETY
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40
+ && (c >= 0xf1 || s[1] >= 0x90)
+#if 1
+ && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90))
+#endif
+ )
+#endif
+ {
+ *puc = ((unsigned int) (c & 0x07) << 18)
+ | ((unsigned int) (s[1] ^ 0x80) << 12)
+ | ((unsigned int) (s[2] ^ 0x80) << 6)
+ | (unsigned int) (s[3] ^ 0x80);
+ return 4;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+#if 0
+ else if (c < 0xfc)
+ {
+ if (n >= 5)
+ {
+#if CONFIG_UNICODE_SAFETY
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40
+ && (c >= 0xf9 || s[1] >= 0x88))
+#endif
+ {
+ *puc = ((unsigned int) (c & 0x03) << 24)
+ | ((unsigned int) (s[1] ^ 0x80) << 18)
+ | ((unsigned int) (s[2] ^ 0x80) << 12)
+ | ((unsigned int) (s[3] ^ 0x80) << 6)
+ | (unsigned int) (s[4] ^ 0x80);
+ return 5;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xfe)
+ {
+ if (n >= 6)
+ {
+#if CONFIG_UNICODE_SAFETY
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40
+ && (s[5] ^ 0x80) < 0x40
+ && (c >= 0xfd || s[1] >= 0x84))
+#endif
+ {
+ *puc = ((unsigned int) (c & 0x01) << 30)
+ | ((unsigned int) (s[1] ^ 0x80) << 24)
+ | ((unsigned int) (s[2] ^ 0x80) << 18)
+ | ((unsigned int) (s[3] ^ 0x80) << 12)
+ | ((unsigned int) (s[4] ^ 0x80) << 6)
+ | (unsigned int) (s[5] ^ 0x80);
+ return 6;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+#endif
+ }
+ /* invalid multibyte character */
+ *puc = 0xfffd;
+ return 1;
+}
+
+#endif
diff --git a/lib/unistr/u8-mbtouc.c b/lib/unistr/u8-mbtouc.c
new file mode 100644
index 0000000..ff624f1
--- /dev/null
+++ b/lib/unistr/u8-mbtouc.c
@@ -0,0 +1,168 @@
+/* Look at first character in UTF-8 string.
+ Copyright (C) 1999-2002, 2006-2007, 2009 Free Software Foundation, Inc.
+ Written by Bruno Haible <address@hidden>, 2001.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#if defined IN_LIBUNISTRING
+/* Tell unistr.h to declare u8_mbtouc as 'extern', not 'static inline'. */
+# include "unistring-notinline.h"
+#endif
+
+/* Specification. */
+#include "unistr.h"
+
+#if !HAVE_INLINE
+
+int
+u8_mbtouc (ucs4_t *puc, const uint8_t *s, size_t n)
+{
+ uint8_t c = *s;
+
+ if (c < 0x80)
+ {
+ *puc = c;
+ return 1;
+ }
+ else if (c >= 0xc2)
+ {
+ if (c < 0xe0)
+ {
+ if (n >= 2)
+ {
+ if ((s[1] ^ 0x80) < 0x40)
+ {
+ *puc = ((unsigned int) (c & 0x1f) << 6)
+ | (unsigned int) (s[1] ^ 0x80);
+ return 2;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xf0)
+ {
+ if (n >= 3)
+ {
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (c >= 0xe1 || s[1] >= 0xa0)
+ && (c != 0xed || s[1] < 0xa0))
+ {
+ *puc = ((unsigned int) (c & 0x0f) << 12)
+ | ((unsigned int) (s[1] ^ 0x80) << 6)
+ | (unsigned int) (s[2] ^ 0x80);
+ return 3;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xf8)
+ {
+ if (n >= 4)
+ {
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40
+ && (c >= 0xf1 || s[1] >= 0x90)
+#if 1
+ && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90))
+#endif
+ )
+ {
+ *puc = ((unsigned int) (c & 0x07) << 18)
+ | ((unsigned int) (s[1] ^ 0x80) << 12)
+ | ((unsigned int) (s[2] ^ 0x80) << 6)
+ | (unsigned int) (s[3] ^ 0x80);
+ return 4;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+#if 0
+ else if (c < 0xfc)
+ {
+ if (n >= 5)
+ {
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40
+ && (c >= 0xf9 || s[1] >= 0x88))
+ {
+ *puc = ((unsigned int) (c & 0x03) << 24)
+ | ((unsigned int) (s[1] ^ 0x80) << 18)
+ | ((unsigned int) (s[2] ^ 0x80) << 12)
+ | ((unsigned int) (s[3] ^ 0x80) << 6)
+ | (unsigned int) (s[4] ^ 0x80);
+ return 5;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+ else if (c < 0xfe)
+ {
+ if (n >= 6)
+ {
+ if ((s[1] ^ 0x80) < 0x40 && (s[2] ^ 0x80) < 0x40
+ && (s[3] ^ 0x80) < 0x40 && (s[4] ^ 0x80) < 0x40
+ && (s[5] ^ 0x80) < 0x40
+ && (c >= 0xfd || s[1] >= 0x84))
+ {
+ *puc = ((unsigned int) (c & 0x01) << 30)
+ | ((unsigned int) (s[1] ^ 0x80) << 24)
+ | ((unsigned int) (s[2] ^ 0x80) << 18)
+ | ((unsigned int) (s[3] ^ 0x80) << 12)
+ | ((unsigned int) (s[4] ^ 0x80) << 6)
+ | (unsigned int) (s[5] ^ 0x80);
+ return 6;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return n;
+ }
+ }
+#endif
+ }
+ /* invalid multibyte character */
+ *puc = 0xfffd;
+ return 1;
+}
+
+#endif
diff --git a/lib/unistr/u8-mbtoucr.c b/lib/unistr/u8-mbtoucr.c
new file mode 100644
index 0000000..dd83352
--- /dev/null
+++ b/lib/unistr/u8-mbtoucr.c
@@ -0,0 +1,285 @@
+/* Look at first character in UTF-8 string, returning an error code.
+ Copyright (C) 1999-2002, 2006-2007 Free Software Foundation, Inc.
+ Written by Bruno Haible <address@hidden>, 2001.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+/* Specification. */
+#include "unistr.h"
+
+int
+u8_mbtoucr (ucs4_t *puc, const uint8_t *s, size_t n)
+{
+ uint8_t c = *s;
+
+ if (c < 0x80)
+ {
+ *puc = c;
+ return 1;
+ }
+ else if (c >= 0xc2)
+ {
+ if (c < 0xe0)
+ {
+ if (n >= 2)
+ {
+ if ((s[1] ^ 0x80) < 0x40)
+ {
+ *puc = ((unsigned int) (c & 0x1f) << 6)
+ | (unsigned int) (s[1] ^ 0x80);
+ return 2;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ else if (c < 0xf0)
+ {
+ if (n >= 2)
+ {
+ if ((s[1] ^ 0x80) < 0x40
+ && (c >= 0xe1 || s[1] >= 0xa0)
+ && (c != 0xed || s[1] < 0xa0))
+ {
+ if (n >= 3)
+ {
+ if ((s[2] ^ 0x80) < 0x40)
+ {
+ *puc = ((unsigned int) (c & 0x0f) << 12)
+ | ((unsigned int) (s[1] ^ 0x80) << 6)
+ | (unsigned int) (s[2] ^ 0x80);
+ return 3;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ else if (c < 0xf8)
+ {
+ if (n >= 2)
+ {
+ if ((s[1] ^ 0x80) < 0x40
+ && (c >= 0xf1 || s[1] >= 0x90)
+#if 1
+ && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90))
+#endif
+ )
+ {
+ if (n >= 3)
+ {
+ if ((s[2] ^ 0x80) < 0x40)
+ {
+ if (n >= 4)
+ {
+ if ((s[3] ^ 0x80) < 0x40)
+ {
+ *puc = ((unsigned int) (c & 0x07) << 18)
+ | ((unsigned int) (s[1] ^ 0x80) << 12)
+ | ((unsigned int) (s[2] ^ 0x80) << 6)
+ | (unsigned int) (s[3] ^ 0x80);
+ return 4;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+#if 0
+ else if (c < 0xfc)
+ {
+ if (n >= 2)
+ {
+ if ((s[1] ^ 0x80) < 0x40
+ && (c >= 0xf9 || s[1] >= 0x88))
+ {
+ if (n >= 3)
+ {
+ if ((s[2] ^ 0x80) < 0x40)
+ {
+ if (n >= 4)
+ {
+ if ((s[3] ^ 0x80) < 0x40)
+ {
+ if (n >= 5)
+ {
+ if ((s[4] ^ 0x80) < 0x40)
+ {
+ *puc = ((unsigned int) (c & 0x03) <<
24)
+ | ((unsigned int) (s[1] ^
0x80) << 18)
+ | ((unsigned int) (s[2] ^
0x80) << 12)
+ | ((unsigned int) (s[3] ^
0x80) << 6)
+ | (unsigned int) (s[4] ^ 0x80);
+ return 5;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ else if (c < 0xfe)
+ {
+ if (n >= 2)
+ {
+ if ((s[1] ^ 0x80) < 0x40
+ && (c >= 0xfd || s[1] >= 0x84))
+ {
+ if (n >= 3)
+ {
+ if ((s[2] ^ 0x80) < 0x40)
+ {
+ if (n >= 4)
+ {
+ if ((s[3] ^ 0x80) < 0x40)
+ {
+ if (n >= 5)
+ {
+ if ((s[4] ^ 0x80) < 0x40)
+ {
+ if (n >= 6)
+ {
+ if ((s[5] ^ 0x80) < 0x40)
+ {
+ *puc = ((unsigned int) (c &
0x01) << 30)
+ | ((unsigned int)
(s[1] ^ 0x80) << 24)
+ | ((unsigned int)
(s[2] ^ 0x80) << 18)
+ | ((unsigned int)
(s[3] ^ 0x80) << 12)
+ | ((unsigned int)
(s[4] ^ 0x80) << 6)
+ | (unsigned int) (s[5]
^ 0x80);
+ return 6;
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character
*/
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+ /* invalid multibyte character */
+ }
+ else
+ {
+ /* incomplete multibyte character */
+ *puc = 0xfffd;
+ return -2;
+ }
+ }
+#endif
+ }
+ /* invalid multibyte character */
+ *puc = 0xfffd;
+ return -1;
+}
diff --git a/lib/unistr/u8-prev.c b/lib/unistr/u8-prev.c
new file mode 100644
index 0000000..245d22f
--- /dev/null
+++ b/lib/unistr/u8-prev.c
@@ -0,0 +1,93 @@
+/* Iterate over previous character in UTF-8 string.
+ Copyright (C) 2002, 2006-2007 Free Software Foundation, Inc.
+ Written by Bruno Haible <address@hidden>, 2002.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+/* Specification. */
+#include "unistr.h"
+
+const uint8_t *
+u8_prev (ucs4_t *puc, const uint8_t *s, const uint8_t *start)
+{
+ /* Keep in sync with unistr.h and utf8-ucs4.c. */
+ if (s != start)
+ {
+ uint8_t c_1 = s[-1];
+
+ if (c_1 < 0x80)
+ {
+ *puc = c_1;
+ return s - 1;
+ }
+#if CONFIG_UNICODE_SAFETY
+ if ((c_1 ^ 0x80) < 0x40)
+#endif
+ if (s - 1 != start)
+ {
+ uint8_t c_2 = s[-2];
+
+ if (c_2 >= 0xc2 && c_2 < 0xe0)
+ {
+ *puc = ((unsigned int) (c_2 & 0x1f) << 6)
+ | (unsigned int) (c_1 ^ 0x80);
+ return s - 2;
+ }
+#if CONFIG_UNICODE_SAFETY
+ if ((c_2 ^ 0x80) < 0x40)
+#endif
+ if (s - 2 != start)
+ {
+ uint8_t c_3 = s[-3];
+
+ if (c_3 >= 0xe0 && c_3 < 0xf0
+#if CONFIG_UNICODE_SAFETY
+ && (c_3 >= 0xe1 || c_2 >= 0xa0)
+ && (c_3 != 0xed || c_2 < 0xa0)
+#endif
+ )
+ {
+ *puc = ((unsigned int) (c_3 & 0x0f) << 12)
+ | ((unsigned int) (c_2 ^ 0x80) << 6)
+ | (unsigned int) (c_1 ^ 0x80);
+ return s - 3;
+ }
+#if CONFIG_UNICODE_SAFETY
+ if ((c_3 ^ 0x80) < 0x40)
+#endif
+ if (s - 3 != start)
+ {
+ uint8_t c_4 = s[-4];
+
+ if (c_4 >= 0xf0 && c_4 < 0xf8
+#if CONFIG_UNICODE_SAFETY
+ && (c_4 >= 0xf1 || c_3 >= 0x90)
+ && (c_4 < 0xf4 || (c_4 == 0xf4 && c_3 < 0x90))
+#endif
+ )
+ {
+ *puc = ((unsigned int) (c_4 & 0x07) << 18)
+ | ((unsigned int) (c_3 ^ 0x80) << 12)
+ | ((unsigned int) (c_2 ^ 0x80) << 6)
+ | (unsigned int) (c_1 ^ 0x80);
+ return s - 4;
+ }
+ }
+ }
+ }
+ }
+ return NULL;
+}
diff --git a/lib/unistr/u8-uctomb-aux.c b/lib/unistr/u8-uctomb-aux.c
new file mode 100644
index 0000000..c42fa50
--- /dev/null
+++ b/lib/unistr/u8-uctomb-aux.c
@@ -0,0 +1,69 @@
+/* Conversion UCS-4 to UTF-8.
+ Copyright (C) 2002, 2006-2007 Free Software Foundation, Inc.
+ Written by Bruno Haible <address@hidden>, 2002.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+/* Specification. */
+#include "unistr.h"
+
+int
+u8_uctomb_aux (uint8_t *s, ucs4_t uc, int n)
+{
+ int count;
+
+ if (uc < 0x80)
+ /* The case n >= 1 is already handled by the caller. */
+ return -2;
+ else if (uc < 0x800)
+ count = 2;
+ else if (uc < 0x10000)
+ {
+ if (uc < 0xd800 || uc >= 0xe000)
+ count = 3;
+ else
+ return -1;
+ }
+#if 0
+ else if (uc < 0x200000)
+ count = 4;
+ else if (uc < 0x4000000)
+ count = 5;
+ else if (uc <= 0x7fffffff)
+ count = 6;
+#else
+ else if (uc < 0x110000)
+ count = 4;
+#endif
+ else
+ return -1;
+
+ if (n < count)
+ return -2;
+
+ switch (count) /* note: code falls through cases! */
+ {
+#if 0
+ case 6: s[5] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x4000000;
+ case 5: s[4] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x200000;
+#endif
+ case 4: s[3] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x10000;
+ case 3: s[2] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x800;
+ case 2: s[1] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0xc0;
+ /*case 1:*/ s[0] = uc;
+ }
+ return count;
+}
diff --git a/lib/unistr/u8-uctomb.c b/lib/unistr/u8-uctomb.c
new file mode 100644
index 0000000..3392166
--- /dev/null
+++ b/lib/unistr/u8-uctomb.c
@@ -0,0 +1,88 @@
+/* Store a character in UTF-8 string.
+ Copyright (C) 2002, 2005-2006, 2009 Free Software Foundation, Inc.
+ Written by Bruno Haible <address@hidden>, 2002.
+
+ 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 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public License
+ along with this program. If not, see <http://www.gnu.org/licenses/>. */
+
+#include <config.h>
+
+#if defined IN_LIBUNISTRING
+/* Tell unistr.h to declare u8_uctomb as 'extern', not 'static inline'. */
+# include "unistring-notinline.h"
+#endif
+
+/* Specification. */
+#include "unistr.h"
+
+#if !HAVE_INLINE
+
+int
+u8_uctomb (uint8_t *s, ucs4_t uc, int n)
+{
+ if (uc < 0x80)
+ {
+ if (n > 0)
+ {
+ s[0] = uc;
+ return 1;
+ }
+ /* else return -2, below. */
+ }
+ else
+ {
+ int count;
+
+ if (uc < 0x800)
+ count = 2;
+ else if (uc < 0x10000)
+ {
+ if (uc < 0xd800 || uc >= 0xe000)
+ count = 3;
+ else
+ return -1;
+ }
+#if 0
+ else if (uc < 0x200000)
+ count = 4;
+ else if (uc < 0x4000000)
+ count = 5;
+ else if (uc <= 0x7fffffff)
+ count = 6;
+#else
+ else if (uc < 0x110000)
+ count = 4;
+#endif
+ else
+ return -1;
+
+ if (n >= count)
+ {
+ switch (count) /* note: code falls through cases! */
+ {
+#if 0
+ case 6: s[5] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x4000000;
+ case 5: s[4] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x200000;
+#endif
+ case 4: s[3] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x10000;
+ case 3: s[2] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x800;
+ case 2: s[1] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0xc0;
+ /*case 1:*/ s[0] = uc;
+ }
+ return count;
+ }
+ }
+ return -2;
+}
+
+#endif
diff --git a/lib/unitypes.h b/lib/unitypes.h
new file mode 100644
index 0000000..fe8d877
--- /dev/null
+++ b/lib/unitypes.h
@@ -0,0 +1,26 @@
+/* Elementary types for the GNU UniString library.
+ Copyright (C) 2002, 2005-2006 Free Software Foundation, Inc.
+
+ This program is free software: you can redistribute it and/or modify it
+ under the terms of the GNU Lesser General Public License as published
+ by the Free Software Foundation; either version 3 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ 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 program. If not, see <http://www.gnu.org/licenses/>. */
+
+#ifndef _UNITYPES_H
+#define _UNITYPES_H
+
+/* Get uint8_t, uint16_t, uint32_t. */
+#include <stdint.h>
+
+/* Type representing a Unicode character. */
+typedef uint32_t ucs4_t;
+
+#endif /* _UNITYPES_H */
diff --git a/lib/wchar.in.h b/lib/wchar.in.h
index 3425062..1f1f130 100644
--- a/lib/wchar.in.h
+++ b/lib/wchar.in.h
@@ -1,6 +1,6 @@
/* A substitute for ISO C99 <wchar.h>, for platforms that have issues.
- 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
@@ -30,8 +30,18 @@
@PRAGMA_SYSTEM_HEADER@
#endif
-#ifdef __need_mbstate_t
-/* Special invocation convention inside uClibc header files. */
+#if defined __need_mbstate_t || (defined __hpux && ((defined
_INTTYPES_INCLUDED && !defined strtoimax) || defined
_GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) || defined _GL_ALREADY_INCLUDING_WCHAR_H
+/* Special invocation convention:
+ - Inside uClibc header files.
+ - On HP-UX 11.00 we have a sequence of nested includes
+ <wchar.h> -> <stdlib.h> -> <stdint.h>, and the latter includes <wchar.h>,
+ once indirectly <stdint.h> -> <sys/types.h> -> <inttypes.h> -> <wchar.h>
+ and once directly. In both situations 'wint_t' is not yet defined,
+ therefore we cannot provide the function overrides; instead include only
+ the system's <wchar.h>.
+ - On IRIX 6.5, similarly, we have an include <wchar.h> -> <wctype.h>, and
+ the latter includes <wchar.h>. But here, we have no way to detect whether
+ <wctype.h> is completely included or is still being included. */
address@hidden@ @NEXT_WCHAR_H@
@@ -40,6 +50,8 @@
#ifndef _GL_WCHAR_H
+#define _GL_ALREADY_INCLUDING_WCHAR_H
+
/* Tru64 with Desktop Toolkit C has a bug: <stdio.h> must be included before
<wchar.h>.
BSD/OS 4.0.1 has a bug: <stddef.h>, <stdio.h> and <time.h> must be
@@ -55,6 +67,8 @@
# @INCLUDE_NEXT@ @NEXT_WCHAR_H@
#endif
+#undef _GL_ALREADY_INCLUDING_WCHAR_H
+
#ifndef _GL_WCHAR_H
#define _GL_WCHAR_H
@@ -250,7 +264,11 @@ extern size_t wcsrtombs (char *dest, const wchar_t **srcp,
size_t len, mbstate_t
/* Convert a wide string to a string. */
#if @GNULIB_WCSNRTOMBS@
-# if address@hidden@
+# if @REPLACE_WCSNRTOMBS@
+# undef wcsnrtombs
+# define wcsnrtombs rpl_wcsnrtombs
+# endif
+# if address@hidden@ || @REPLACE_WCSNRTOMBS@
extern size_t wcsnrtombs (char *dest, const wchar_t **srcp, size_t srclen,
size_t len, mbstate_t *ps);
# endif
#elif defined GNULIB_POSIXCHECK
diff --git a/libguile.h b/libguile.h
index 40122df..6a6d232 100644
--- a/libguile.h
+++ b/libguile.h
@@ -1,7 +1,7 @@
#ifndef SCM_LIBGUILE_H
#define SCM_LIBGUILE_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,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
@@ -32,6 +32,7 @@ extern "C" {
#include "libguile/arbiters.h"
#include "libguile/async.h"
#include "libguile/boolean.h"
+#include "libguile/bytevectors.h"
#include "libguile/chars.h"
#include "libguile/continuations.h"
#include "libguile/dynl.h"
@@ -75,6 +76,7 @@ extern "C" {
#include "libguile/procprop.h"
#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"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 369b249..fcf197a 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -32,10 +32,10 @@ DEFAULT_INCLUDES =
## 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'.
-AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \
+AM_CPPFLAGS = -DBUILDING_LIBGUILE=1 -I$(top_srcdir) -I$(top_builddir) \
-I$(top_srcdir)/lib -I$(top_builddir)/lib
-AM_CFLAGS = $(GCC_CFLAGS)
+AM_CFLAGS = $(GCC_CFLAGS) $(CFLAG_VISIBILITY)
## The Gnulib Libtool archive.
gnulib_library = $(top_builddir)/lib/libgnu.la
@@ -106,7 +106,8 @@ guile_LDFLAGS = $(GUILE_CFLAGS)
libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
- chars.c continuations.c convert.c debug.c deprecation.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
\
@@ -115,7 +116,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c
backtrace.c boolean.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 random.c rdelim.c read.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 \
@@ -134,7 +136,8 @@ address@hidden@_la_LDFLAGS = \
-module -L$(builddir) -lguile \
-version-info @LIBGUILE_I18N_INTERFACE@
-DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
+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 \
@@ -143,7 +146,8 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x
boolean.x chars.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 random.x rdelim.x read.x root.x rw.x scmsigs.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 \
@@ -155,7 +159,8 @@ 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 chars.doc continuations.doc debug.doc deprecation.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 \
@@ -165,7 +170,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc
backtrace.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 random.doc rdelim.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
\
@@ -204,7 +210,7 @@ install-exec-hook:
## working.
noinst_HEADERS = convert.i.c \
conv-integer.i.c conv-uinteger.i.c \
- eval.i.c \
+ eval.i.c ieee-754.h \
srfi-4.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
@@ -223,7 +229,8 @@ 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 chars.h continuations.h convert.h debug.h debug-malloc.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 \
@@ -232,7 +239,8 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h
backtrace.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 regex-posix.h print.h procprop.h procs.h properties.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 \
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 3672b1c..07d7b4d 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -98,13 +98,10 @@
#define SCM_UNLIKELY(_expr) SCM_EXPECT ((_expr), 0)
/* The SCM_INTERNAL macro makes it possible to explicitly declare a function
- * as having "internal" linkage. */
-#if (defined __GNUC__) && \
- ((__GNUC__ >= 4) || (__GNUC__ == 3 && __GNUC_MINOR__ == 3))
-# define SCM_INTERNAL extern __attribute__ ((__visibility__ ("internal")))
-#else
-# define SCM_INTERNAL extern
-#endif
+ * as having "internal" linkage. However our current tack on this problem is
+ * to use GCC 4's -fvisibility=hidden, making functions internal by default,
+ * and then SCM_API marks them for export. */
+#define SCM_INTERNAL extern
@@ -154,13 +151,14 @@
/* SCM_API is a macro prepended to all function and data definitions
- which should be exported or imported in the resulting dynamic link
- library (DLL) in the Win32 port. */
-
-#if defined (SCM_IMPORT)
-# define SCM_API __declspec (dllimport) extern
-#elif defined (SCM_EXPORT) || defined (DLL_EXPORT)
-# define SCM_API __declspec (dllexport) extern
+ which should be exported from libguile. */
+
+#if BUILDING_LIBGUILE && HAVE_VISIBILITY
+# define SCM_API extern __attribute__((__visibility__("default")))
+#elif BUILDING_LIBGUILE && defined _MSC_VER
+# define SCM_API __declspec(dllexport) extern
+#elif defined _MSC_VER
+# define SCM_API __declspec(dllimport) extern
#else
# define SCM_API extern
#endif
diff --git a/libguile/async.c b/libguile/async.c
index bf03c48..4dc5ea4 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -179,7 +179,7 @@ scm_async_click ()
SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
(SCM thunk),
"This function is deprecated. You can use @var{thunk} directly\n"
- "instead of explicitely creating an async object.\n")
+ "instead of explicitly creating an async object.\n")
#define FUNC_NAME s_scm_system_async
{
scm_c_issue_deprecation_warning
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
new file mode 100644
index 0000000..4c3a353
--- /dev/null
+++ b/libguile/bytevectors.c
@@ -0,0 +1,1978 @@
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+
+#include <gmp.h>
+
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/ieee-754.h"
+
+#include <byteswap.h>
+#include <striconveh.h>
+#include <uniconv.h>
+
+#ifdef HAVE_LIMITS_H
+# include <limits.h>
+#else
+/* Assuming 32-bit longs. */
+# define ULONG_MAX 4294967295UL
+#endif
+
+#include <string.h>
+
+
+
+/* Utilities. */
+
+/* Convenience macros. These are used by the various templates (macros) that
+ are parameterized by integer signedness. */
+#define INT8_T_signed scm_t_int8
+#define INT8_T_unsigned scm_t_uint8
+#define INT16_T_signed scm_t_int16
+#define INT16_T_unsigned scm_t_uint16
+#define INT32_T_signed scm_t_int32
+#define INT32_T_unsigned scm_t_uint32
+#define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
+#define is_unsigned_int8(_x) ((_x) <= 255UL)
+#define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
+#define is_unsigned_int16(_x) ((_x) <= 65535UL)
+#define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <=
2147483647L))
+#define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
+#define SIGNEDNESS_signed 1
+#define SIGNEDNESS_unsigned 0
+
+#define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
+#define INT_SWAP(_size) bswap_ ## _size
+#define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
+#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
+
+
+#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
+ unsigned c_len, c_index; \
+ _sign char *c_bv; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ c_index = scm_to_uint (index); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
+ scm_out_of_range (FUNC_NAME, index);
+
+/* Template for fixed-size integer access (only 8, 16 or 32-bit). */
+#define INTEGER_REF(_len, _sign) \
+ SCM result; \
+ \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ { \
+ INT_TYPE (_len, _sign) c_result; \
+ \
+ memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
+ if (!scm_is_eq (endianness, native_endianness)) \
+ c_result = INT_SWAP (_len) (c_result); \
+ \
+ result = SCM_I_MAKINUM (c_result); \
+ } \
+ \
+ return result;
+
+/* Template for fixed-size integer access using the native endianness. */
+#define INTEGER_NATIVE_REF(_len, _sign) \
+ SCM result; \
+ \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ { \
+ INT_TYPE (_len, _sign) c_result; \
+ \
+ memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
+ result = SCM_I_MAKINUM (c_result); \
+ } \
+ \
+ return result;
+
+/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
+#define INTEGER_SET(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ { \
+ _sign long c_value; \
+ INT_TYPE (_len, _sign) c_value_short; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ scm_wrong_type_arg (FUNC_NAME, 3, value); \
+ \
+ c_value = SCM_I_INUM (value); \
+ if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ c_value_short = (INT_TYPE (_len, _sign)) c_value; \
+ if (!scm_is_eq (endianness, native_endianness)) \
+ c_value_short = INT_SWAP (_len) (c_value_short); \
+ \
+ memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+/* Template for fixed-size integer modification using the native
+ endianness. */
+#define INTEGER_NATIVE_SET(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ { \
+ _sign long c_value; \
+ INT_TYPE (_len, _sign) c_value_short; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ scm_wrong_type_arg (FUNC_NAME, 3, value); \
+ \
+ c_value = SCM_I_INUM (value); \
+ if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ c_value_short = (INT_TYPE (_len, _sign)) c_value; \
+ \
+ memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+
+
+/* Bytevector type. */
+
+SCM_GLOBAL_SMOB (scm_tc16_bytevector, "r6rs-bytevector", 0);
+
+#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
+ SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
+#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
+ SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
+
+/* The empty bytevector. */
+SCM scm_null_bytevector = SCM_UNSPECIFIED;
+
+
+static inline SCM
+make_bytevector_from_buffer (unsigned len, signed char *contents)
+{
+ /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
+ SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents);
+}
+
+static inline SCM
+make_bytevector (unsigned len)
+{
+ SCM bv;
+
+ if (SCM_UNLIKELY (len == 0))
+ bv = scm_null_bytevector;
+ 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);
+ }
+
+ return bv;
+}
+
+/* Return a new bytevector of size LEN octets. */
+SCM
+scm_c_make_bytevector (unsigned len)
+{
+ return (make_bytevector (len));
+}
+
+/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
+ by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
+SCM
+scm_c_take_bytevector (signed char *contents, unsigned 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 bv;
+}
+
+/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
+ size) and return BV. */
+SCM
+scm_i_shrink_bytevector (SCM bv, unsigned c_new_len)
+{
+ if (!SCM_BYTEVECTOR_INLINE_P (bv))
+ {
+ unsigned c_len;
+ signed char *c_bv, *c_new_bv;
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
+
+ if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len))
+ {
+ /* Copy to the in-line buffer and free the current buffer. */
+ 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);
+ }
+ else
+ {
+ /* Resize the existing buffer. */
+ c_new_bv = scm_gc_realloc (c_bv, c_len, c_new_len,
+ SCM_GC_BYTEVECTOR);
+ SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv);
+ }
+ }
+
+ return bv;
+}
+
+SCM_SMOB_PRINT (scm_tc16_bytevector, print_bytevector,
+ bv, port, pstate)
+{
+ unsigned c_len, i;
+ unsigned char *c_bv;
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ scm_puts ("#vu8(", port);
+ for (i = 0; i < c_len; i++)
+ {
+ if (i > 0)
+ scm_putc (' ', port);
+
+ scm_uintprint (c_bv[i], 10, port);
+ }
+
+ scm_putc (')', port);
+
+ /* Make GCC think we use it. */
+ scm_remember_upto_here ((SCM) pstate);
+
+ return 1;
+}
+
+SCM_SMOB_FREE (scm_tc16_bytevector, free_bytevector, bv)
+{
+
+ if (!SCM_BYTEVECTOR_INLINE_P (bv))
+ {
+ unsigned c_len;
+ signed char *c_bv;
+
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+
+ return 0;
+}
+
+
+
+/* General operations. */
+
+SCM_SYMBOL (scm_sym_big, "big");
+SCM_SYMBOL (scm_sym_little, "little");
+
+SCM scm_endianness_big, scm_endianness_little;
+
+/* Host endianness (a symbol). */
+static SCM native_endianness = SCM_UNSPECIFIED;
+
+/* Byte-swapping. */
+#ifndef bswap_24
+# define bswap_24(_x) \
+ ((((_x) & 0xff0000) >> 16) | \
+ (((_x) & 0x00ff00)) | \
+ (((_x) & 0x0000ff) << 16))
+#endif
+
+
+SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0,
+ (void),
+ "Return a symbol denoting the machine's native endianness.")
+#define FUNC_NAME s_scm_native_endianness
+{
+ return native_endianness;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} is a bytevector.")
+#define FUNC_NAME s_scm_bytevector_p
+{
+ return (scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_bytevector,
+ obj)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
+ (SCM len, SCM fill),
+ "Return a newly allocated bytevector of @var{len} bytes, "
+ "optionally filled with @var{fill}.")
+#define FUNC_NAME s_scm_make_bytevector
+{
+ SCM bv;
+ unsigned c_len;
+ signed char c_fill = '\0';
+
+ SCM_VALIDATE_UINT_COPY (1, len, c_len);
+ if (fill != SCM_UNDEFINED)
+ {
+ int value;
+
+ value = scm_to_int (fill);
+ if (SCM_UNLIKELY ((value < -128) || (value > 255)))
+ scm_out_of_range (FUNC_NAME, fill);
+ c_fill = (signed char) value;
+ }
+
+ bv = make_bytevector (c_len);
+ if (fill != SCM_UNDEFINED)
+ {
+ unsigned i;
+ signed char *contents;
+
+ contents = SCM_BYTEVECTOR_CONTENTS (bv);
+ for (i = 0; i < c_len; i++)
+ contents[i] = c_fill;
+ }
+
+ return bv;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0,
+ (SCM bv),
+ "Return the length (in bytes) of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_length
+{
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ return (scm_from_uint (SCM_BYTEVECTOR_LENGTH (bv)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0,
+ (SCM bv1, SCM bv2),
+ "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
+ "have the same length and contents.")
+#define FUNC_NAME s_scm_bytevector_eq_p
+{
+ SCM result = SCM_BOOL_F;
+ unsigned c_len1, c_len2;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv1);
+ SCM_VALIDATE_BYTEVECTOR (2, bv2);
+
+ c_len1 = SCM_BYTEVECTOR_LENGTH (bv1);
+ c_len2 = SCM_BYTEVECTOR_LENGTH (bv2);
+
+ if (c_len1 == c_len2)
+ {
+ signed char *c_bv1, *c_bv2;
+
+ c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1);
+ c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2);
+
+ result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
+ (SCM bv, SCM fill),
+ "Fill bytevector @var{bv} with @var{fill}, a byte.")
+#define FUNC_NAME s_scm_bytevector_fill_x
+{
+ unsigned c_len, i;
+ signed char *c_bv, c_fill;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ c_fill = scm_to_int8 (fill);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ for (i = 0; i < c_len; i++)
+ c_bv[i] = c_fill;
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
+ (SCM source, SCM source_start, SCM target, SCM target_start,
+ SCM len),
+ "Copy @var{len} bytes from @var{source} into @var{target}, "
+ "starting reading from @var{source_start} (a positive index "
+ "within @var{source}) and start writing at "
+ "@var{target_start}.")
+#define FUNC_NAME s_scm_bytevector_copy_x
+{
+ unsigned c_len, c_source_len, c_target_len;
+ unsigned c_source_start, c_target_start;
+ signed char *c_source, *c_target;
+
+ SCM_VALIDATE_BYTEVECTOR (1, source);
+ SCM_VALIDATE_BYTEVECTOR (3, target);
+
+ c_len = scm_to_uint (len);
+ c_source_start = scm_to_uint (source_start);
+ c_target_start = scm_to_uint (target_start);
+
+ c_source = SCM_BYTEVECTOR_CONTENTS (source);
+ c_target = SCM_BYTEVECTOR_CONTENTS (target);
+ c_source_len = SCM_BYTEVECTOR_LENGTH (source);
+ c_target_len = SCM_BYTEVECTOR_LENGTH (target);
+
+ if (SCM_UNLIKELY (c_source_start + c_len > c_source_len))
+ scm_out_of_range (FUNC_NAME, source_start);
+ if (SCM_UNLIKELY (c_target_start + c_len > c_target_len))
+ scm_out_of_range (FUNC_NAME, target_start);
+
+ memcpy (c_target + c_target_start,
+ c_source + c_source_start,
+ c_len);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
+ (SCM bv),
+ "Return a newly allocated copy of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_copy
+{
+ SCM copy;
+ unsigned c_len;
+ signed char *c_bv, *c_copy;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ copy = make_bytevector (c_len);
+ c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
+ memcpy (c_copy, c_bv, c_len);
+
+ return copy;
+}
+#undef FUNC_NAME
+
+
+/* Operations on bytes and octets. */
+
+SCM_DEFINE (scm_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_ref
+{
+ INTEGER_NATIVE_REF (8, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the byte located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_s8_ref
+{
+ INTEGER_NATIVE_REF (8, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_set_x
+{
+ INTEGER_NATIVE_SET (8, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_set_x
+{
+ INTEGER_NATIVE_SET (8, signed);
+}
+#undef FUNC_NAME
+
+#undef OCTET_ACCESSOR_PROLOGUE
+
+
+SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
+ (SCM bv),
+ "Return a newly allocated list of octets containing the "
+ "contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_u8_list
+{
+ SCM lst, pair;
+ unsigned c_len, i;
+ unsigned char *c_bv;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED);
+ for (i = 0, pair = lst;
+ i < c_len;
+ i++, pair = SCM_CDR (pair))
+ {
+ SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
+ (SCM lst),
+ "Turn @var{lst}, a list of octets, into a bytevector.")
+#define FUNC_NAME s_scm_u8_list_to_bytevector
+{
+ SCM bv, item;
+ long c_len, i;
+ unsigned char *c_bv;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
+
+ bv = make_bytevector (c_len);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
+ {
+ item = SCM_CAR (lst);
+
+ if (SCM_LIKELY (SCM_I_INUMP (item)))
+ {
+ long c_item;
+
+ c_item = SCM_I_INUM (item);
+ if (SCM_LIKELY ((c_item >= 0) && (c_item < 256)))
+ c_bv[i] = (unsigned char) c_item;
+ else
+ goto type_error;
+ }
+ else
+ goto type_error;
+ }
+
+ return bv;
+
+ type_error:
+ scm_wrong_type_arg (FUNC_NAME, 1, item);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+/* Compute the two's complement of VALUE (a positive integer) on SIZE octets
+ using (2^(SIZE * 8) - VALUE). */
+static inline void
+twos_complement (mpz_t value, size_t size)
+{
+ unsigned long bit_count;
+
+ /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
+ checking on SIZE performed earlier. */
+ bit_count = (unsigned long) size << 3UL;
+
+ if (SCM_LIKELY (bit_count < sizeof (unsigned long)))
+ mpz_ui_sub (value, 1UL << bit_count, value);
+ else
+ {
+ mpz_t max;
+
+ mpz_init (max);
+ mpz_ui_pow_ui (max, 2, bit_count);
+ mpz_sub (value, max, value);
+ mpz_clear (max);
+ }
+}
+
+static inline SCM
+bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
+ SCM endianness)
+{
+ SCM result;
+ mpz_t c_mpz;
+ int c_endianness, negative_p = 0;
+
+ if (signed_p)
+ {
+ if (scm_is_eq (endianness, scm_sym_big))
+ negative_p = c_bv[0] & 0x80;
+ else
+ negative_p = c_bv[c_size - 1] & 0x80;
+ }
+
+ c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
+
+ mpz_init (c_mpz);
+ mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */,
+ c_size /* word is C_SIZE-byte long */,
+ c_endianness,
+ 0 /* nails */, c_bv);
+
+ if (signed_p && negative_p)
+ {
+ twos_complement (c_mpz, c_size);
+ mpz_neg (c_mpz, c_mpz);
+ }
+
+ result = scm_from_mpz (c_mpz);
+ mpz_clear (c_mpz); /* FIXME: Needed? */
+
+ return result;
+}
+
+static inline int
+bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
+ SCM value, SCM endianness)
+{
+ mpz_t c_mpz;
+ int c_endianness, c_sign, err = 0;
+
+ c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
+
+ mpz_init (c_mpz);
+ scm_to_mpz (value, c_mpz);
+
+ c_sign = mpz_sgn (c_mpz);
+ if (c_sign < 0)
+ {
+ if (SCM_LIKELY (signed_p))
+ {
+ mpz_neg (c_mpz, c_mpz);
+ twos_complement (c_mpz, c_size);
+ }
+ else
+ {
+ err = -1;
+ goto finish;
+ }
+ }
+
+ if (c_sign == 0)
+ /* Zero. */
+ memset (c_bv, 0, c_size);
+ else
+ {
+ size_t word_count, value_size;
+
+ value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size);
+ if (SCM_UNLIKELY (value_size > c_size))
+ {
+ err = -2;
+ goto finish;
+ }
+
+
+ mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */,
+ c_size, c_endianness,
+ 0 /* nails */, c_mpz);
+ if (SCM_UNLIKELY (word_count != 1))
+ /* Shouldn't happen since we already checked with VALUE_SIZE. */
+ abort ();
+ }
+
+ finish:
+ mpz_clear (c_mpz);
+
+ return err;
+}
+
+#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
+ unsigned long c_len, c_index, c_size;
\
+ char *c_bv; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ c_index = scm_to_ulong (index); \
+ c_size = scm_to_ulong (size);
\
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
\
+ \
+ /* C_SIZE must have its 3 higher bits set to zero so that \
+ multiplying it by 8 yields a number that fits in an \
+ unsigned long. */
\
+ if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
+ scm_out_of_range (FUNC_NAME, size);
\
+ if (SCM_UNLIKELY (c_index + c_size > c_len)) \
+ scm_out_of_range (FUNC_NAME, index);
+
+
+/* Template of an integer reference function. */
+#define GENERIC_INTEGER_REF(_sign) \
+ SCM result; \
+ \
+ if (c_size < 3) \
+ { \
+ int swap;
\
+ _sign int value; \
+ \
+ swap = !scm_is_eq (endianness, native_endianness); \
+ switch (c_size) \
+ { \
+ case 1: \
+ { \
+ _sign char c_value8; \
+ memcpy (&c_value8, c_bv, 1); \
+ value = c_value8; \
+ } \
+ break; \
+ case 2: \
+ { \
+ INT_TYPE (16, _sign) c_value16; \
+ memcpy (&c_value16, c_bv, 2); \
+ if (swap) \
+ value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
+ else \
+ value = c_value16; \
+ } \
+ break; \
+ default: \
+ abort (); \
+ } \
+ \
+ result = SCM_I_MAKINUM ((_sign int) value); \
+ } \
+ else \
+ result = bytevector_large_ref ((char *) c_bv, \
+ c_size, SIGNEDNESS (_sign), \
+ endianness); \
+ \
+ return result;
+
+static inline SCM
+bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness)
+{
+ GENERIC_INTEGER_REF (signed);
+}
+
+static inline SCM
+bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness)
+{
+ GENERIC_INTEGER_REF (unsigned);
+}
+
+
+/* Template of an integer assignment function. */
+#define GENERIC_INTEGER_SET(_sign) \
+ if (c_size < 3) \
+ { \
+ _sign int c_value; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ goto range_error; \
+ \
+ c_value = SCM_I_INUM (value); \
+ switch (c_size) \
+ { \
+ case 1: \
+ if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
+ { \
+ _sign char c_value8; \
+ c_value8 = (_sign char) c_value; \
+ memcpy (c_bv, &c_value8, 1); \
+ } \
+ else \
+ goto range_error; \
+ break; \
+ \
+ case 2: \
+ if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
+ { \
+ int swap; \
+ INT_TYPE (16, _sign) c_value16; \
+ \
+ swap = !scm_is_eq (endianness, native_endianness); \
+ \
+ if (swap) \
+ c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
+ else \
+ c_value16 = c_value; \
+ \
+ memcpy (c_bv, &c_value16, 2); \
+ } \
+ else \
+ goto range_error; \
+ break; \
+ \
+ default: \
+ abort (); \
+ } \
+ } \
+ else \
+ { \
+ int err; \
+ \
+ err = bytevector_large_set (c_bv, c_size,
\
+ SIGNEDNESS (_sign), \
+ value, endianness); \
+ if (err) \
+ goto range_error; \
+ } \
+ \
+ return; \
+ \
+ range_error: \
+ scm_out_of_range (FUNC_NAME, value); \
+ return;
+
+static inline void
+bytevector_signed_set (char *c_bv, size_t c_size,
+ SCM value, SCM endianness,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ GENERIC_INTEGER_SET (signed);
+}
+#undef FUNC_NAME
+
+static inline void
+bytevector_unsigned_set (char *c_bv, size_t c_size,
+ SCM value, SCM endianness,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ GENERIC_INTEGER_SET (unsigned);
+}
+#undef FUNC_NAME
+
+#undef GENERIC_INTEGER_SET
+#undef GENERIC_INTEGER_REF
+
+
+SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
+ (SCM bv, SCM index, SCM endianness, SCM size),
+ "Return the @var{size}-octet long unsigned integer at index "
+ "@var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_uint_ref
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
+
+ return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
+ (SCM bv, SCM index, SCM endianness, SCM size),
+ "Return the @var{size}-octet long unsigned integer at index "
+ "@var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_sint_ref
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
+
+ return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
+ "Set the @var{size}-octet long unsigned integer at @var{index} "
+ "to @var{value}.")
+#define FUNC_NAME s_scm_bytevector_uint_set_x
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
+
+ bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
+ FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
+ "Set the @var{size}-octet long signed integer at @var{index} "
+ "to @var{value}.")
+#define FUNC_NAME s_scm_bytevector_sint_set_x
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
+
+ bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
+ FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+/* Operations on integers of arbitrary size. */
+
+#define INTEGERS_TO_LIST(_sign)
\
+ SCM lst, pair; \
+ size_t i, c_len, c_size; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ c_size = scm_to_uint (size); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ if (SCM_UNLIKELY (c_len == 0)) \
+ lst = SCM_EOL; \
+ else if (SCM_UNLIKELY (c_len < c_size)) \
+ scm_out_of_range (FUNC_NAME, size);
\
+ else \
+ { \
+ const char *c_bv;
\
+ \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ lst = scm_make_list (scm_from_uint (c_len / c_size), \
+ SCM_UNSPECIFIED); \
+ for (i = 0, pair = lst; \
+ i <= c_len - c_size; \
+ i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
+ { \
+ SCM_SETCAR (pair, \
+ bytevector_ ## _sign ## _ref (c_bv, c_size, \
+ endianness)); \
+ } \
+ } \
+ \
+ return lst;
+
+SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list",
+ 3, 0, 0,
+ (SCM bv, SCM endianness, SCM size),
+ "Return a list of signed integers of @var{size} octets "
+ "representing the contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_sint_list
+{
+ INTEGERS_TO_LIST (signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
+ 3, 0, 0,
+ (SCM bv, SCM endianness, SCM size),
+ "Return a list of unsigned integers of @var{size} octets "
+ "representing the contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_uint_list
+{
+ INTEGERS_TO_LIST (unsigned);
+}
+#undef FUNC_NAME
+
+#undef INTEGER_TO_LIST
+
+
+#define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
+ SCM bv; \
+ long c_len; \
+ size_t c_size; \
+ char *c_bv, *c_bv_ptr; \
+ \
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ c_size = scm_to_uint (size); \
+ \
+ 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); \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
\
+ \
+ for (c_bv_ptr = c_bv;
\
+ !scm_is_null (lst); \
+ lst = SCM_CDR (lst), c_bv_ptr += c_size)
\
+ { \
+ bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
+ SCM_CAR (lst), endianness, \
+ FUNC_NAME); \
+ } \
+ \
+ return bv;
+
+
+SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector",
+ 3, 0, 0,
+ (SCM lst, SCM endianness, SCM size),
+ "Return a bytevector containing the unsigned integers "
+ "listed in @var{lst} and encoded on @var{size} octets "
+ "according to @var{endianness}.")
+#define FUNC_NAME s_scm_uint_list_to_bytevector
+{
+ INTEGER_LIST_TO_BYTEVECTOR (unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector",
+ 3, 0, 0,
+ (SCM lst, SCM endianness, SCM size),
+ "Return a bytevector containing the signed integers "
+ "listed in @var{lst} and encoded on @var{size} octets "
+ "according to @var{endianness}.")
+#define FUNC_NAME s_scm_sint_list_to_bytevector
+{
+ INTEGER_LIST_TO_BYTEVECTOR (signed);
+}
+#undef FUNC_NAME
+
+#undef INTEGER_LIST_TO_BYTEVECTOR
+
+
+
+/* Operations on 16-bit integers. */
+
+SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the unsigned 16-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_u16_ref
+{
+ INTEGER_REF (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the signed 16-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_s16_ref
+{
+ INTEGER_REF (16, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 16-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u16_native_ref
+{
+ INTEGER_NATIVE_REF (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 16-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s16_native_ref
+{
+ INTEGER_NATIVE_REF (16, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_u16_set_x
+{
+ INTEGER_SET (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_s16_set_x
+{
+ INTEGER_SET (16, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the unsigned integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u16_native_set_x
+{
+ INTEGER_NATIVE_SET (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the signed integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s16_native_set_x
+{
+ INTEGER_NATIVE_SET (16, signed);
+}
+#undef FUNC_NAME
+
+
+
+/* Operations on 32-bit integers. */
+
+/* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
+ arbitrary 32-bit integers. Thus we fall back to using the
+ `large_{ref,set}' variants on 32-bit machines. */
+
+#define LARGE_INTEGER_REF(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), endianness));
+
+#define LARGE_INTEGER_SET(_len, _sign) \
+ int err; \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (4, endianness); \
+ \
+ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), value, endianness); \
+ if (SCM_UNLIKELY (err)) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ return SCM_UNSPECIFIED;
+
+#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
+ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), native_endianness));
+
+#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
+ int err; \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), value, \
+ native_endianness); \
+ if (SCM_UNLIKELY (err)) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ return SCM_UNSPECIFIED;
+
+
+SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_u32_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_REF (32, unsigned);
+#else
+ LARGE_INTEGER_REF (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the signed 32-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_s32_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_REF (32, signed);
+#else
+ LARGE_INTEGER_REF (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u32_native_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_REF (32, unsigned);
+#else
+ LARGE_INTEGER_NATIVE_REF (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s32_native_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_REF (32, signed);
+#else
+ LARGE_INTEGER_NATIVE_REF (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_u32_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_SET (32, unsigned);
+#else
+ LARGE_INTEGER_SET (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_s32_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_SET (32, signed);
+#else
+ LARGE_INTEGER_SET (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the unsigned integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u32_native_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_SET (32, unsigned);
+#else
+ LARGE_INTEGER_NATIVE_SET (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the signed integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s32_native_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_SET (32, signed);
+#else
+ LARGE_INTEGER_NATIVE_SET (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+
+
+/* Operations on 64-bit integers. */
+
+/* For 64-bit integers, we use only the `large_{ref,set}' variant. */
+
+SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the unsigned 64-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_u64_ref
+{
+ LARGE_INTEGER_REF (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the signed 64-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_s64_ref
+{
+ LARGE_INTEGER_REF (64, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 64-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u64_native_ref
+{
+ LARGE_INTEGER_NATIVE_REF (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 64-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s64_native_ref
+{
+ LARGE_INTEGER_NATIVE_REF (64, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_u64_set_x
+{
+ LARGE_INTEGER_SET (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_s64_set_x
+{
+ LARGE_INTEGER_SET (64, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the unsigned integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u64_native_set_x
+{
+ LARGE_INTEGER_NATIVE_SET (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the signed integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s64_native_set_x
+{
+ LARGE_INTEGER_NATIVE_SET (64, signed);
+}
+#undef FUNC_NAME
+
+
+
+/* Operations on IEEE-754 numbers. */
+
+/* There are two possible word endians, visible in glibc's <ieee754.h>.
+ However, in R6RS, when the endianness is `little', little endian is
+ assumed for both the byte order and the word order. This is clear from
+ Section 2.1 of R6RS-lib (in response to
+ http://www.r6rs.org/formal-comments/comment-187.txt). */
+
+
+/* Convert to/from a floating-point number with different endianness. This
+ method is probably not the most efficient but it should be portable. */
+
+static inline void
+float_to_foreign_endianness (union scm_ieee754_float *target,
+ float source)
+{
+ union scm_ieee754_float src;
+
+ src.f = source;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ target->little_endian.negative = src.big_endian.negative;
+ target->little_endian.exponent = src.big_endian.exponent;
+ target->little_endian.mantissa = src.big_endian.mantissa;
+#else
+ target->big_endian.negative = src.little_endian.negative;
+ target->big_endian.exponent = src.little_endian.exponent;
+ target->big_endian.mantissa = src.little_endian.mantissa;
+#endif
+}
+
+static inline float
+float_from_foreign_endianness (const union scm_ieee754_float *source)
+{
+ union scm_ieee754_float result;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ result.big_endian.negative = source->little_endian.negative;
+ result.big_endian.exponent = source->little_endian.exponent;
+ result.big_endian.mantissa = source->little_endian.mantissa;
+#else
+ result.little_endian.negative = source->big_endian.negative;
+ result.little_endian.exponent = source->big_endian.exponent;
+ result.little_endian.mantissa = source->big_endian.mantissa;
+#endif
+
+ return (result.f);
+}
+
+static inline void
+double_to_foreign_endianness (union scm_ieee754_double *target,
+ double source)
+{
+ union scm_ieee754_double src;
+
+ src.d = source;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ target->little_little_endian.negative = src.big_endian.negative;
+ target->little_little_endian.exponent = src.big_endian.exponent;
+ target->little_little_endian.mantissa0 = src.big_endian.mantissa0;
+ target->little_little_endian.mantissa1 = src.big_endian.mantissa1;
+#else
+ target->big_endian.negative = src.little_little_endian.negative;
+ target->big_endian.exponent = src.little_little_endian.exponent;
+ target->big_endian.mantissa0 = src.little_little_endian.mantissa0;
+ target->big_endian.mantissa1 = src.little_little_endian.mantissa1;
+#endif
+}
+
+static inline double
+double_from_foreign_endianness (const union scm_ieee754_double *source)
+{
+ union scm_ieee754_double result;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ result.big_endian.negative = source->little_little_endian.negative;
+ result.big_endian.exponent = source->little_little_endian.exponent;
+ result.big_endian.mantissa0 = source->little_little_endian.mantissa0;
+ result.big_endian.mantissa1 = source->little_little_endian.mantissa1;
+#else
+ result.little_little_endian.negative = source->big_endian.negative;
+ result.little_little_endian.exponent = source->big_endian.exponent;
+ result.little_little_endian.mantissa0 = source->big_endian.mantissa0;
+ result.little_little_endian.mantissa1 = source->big_endian.mantissa1;
+#endif
+
+ return (result.d);
+}
+
+/* Template macros to abstract over doubles and floats.
+ XXX: Guile can only convert to/from doubles. */
+#define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
+#define IEEE754_TO_SCM(_c_type) scm_from_double
+#define IEEE754_FROM_SCM(_c_type) scm_to_double
+#define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
+ _c_type ## _from_foreign_endianness
+#define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
+ _c_type ## _to_foreign_endianness
+
+
+/* Templace getters and setters. */
+
+#define IEEE754_ACCESSOR_PROLOGUE(_type) \
+ INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
+
+#define IEEE754_REF(_type) \
+ _type c_result; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ if (scm_is_eq (endianness, native_endianness)) \
+ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
+ else \
+ { \
+ IEEE754_UNION (_type) c_raw; \
+ \
+ memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
+ c_result = \
+ IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
+ } \
+ \
+ return (IEEE754_TO_SCM (_type) (c_result));
+
+#define IEEE754_NATIVE_REF(_type) \
+ _type c_result; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ \
+ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
+ return (IEEE754_TO_SCM (_type) (c_result));
+
+#define IEEE754_SET(_type) \
+ _type c_value; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_REAL (3, value); \
+ SCM_VALIDATE_SYMBOL (4, endianness); \
+ c_value = IEEE754_FROM_SCM (_type) (value); \
+ \
+ if (scm_is_eq (endianness, native_endianness)) \
+ memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
+ else \
+ { \
+ IEEE754_UNION (_type) c_raw; \
+ \
+ IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
+ memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+#define IEEE754_NATIVE_SET(_type) \
+ _type c_value; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_REAL (3, value); \
+ c_value = IEEE754_FROM_SCM (_type) (value); \
+ \
+ memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
+ return SCM_UNSPECIFIED;
+
+
+/* Single precision. */
+
+SCM_DEFINE (scm_bytevector_ieee_single_ref,
+ "bytevector-ieee-single-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the IEEE-754 single from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_ref
+{
+ IEEE754_REF (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_native_ref,
+ "bytevector-ieee-single-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the IEEE-754 single from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
+{
+ IEEE754_NATIVE_REF (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_set_x,
+ "bytevector-ieee-single-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store real @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_set_x
+{
+ IEEE754_SET (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_native_set_x,
+ "bytevector-ieee-single-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the real @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
+{
+ IEEE754_NATIVE_SET (float);
+}
+#undef FUNC_NAME
+
+
+/* Double precision. */
+
+SCM_DEFINE (scm_bytevector_ieee_double_ref,
+ "bytevector-ieee-double-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the IEEE-754 double from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_ref
+{
+ IEEE754_REF (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_native_ref,
+ "bytevector-ieee-double-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the IEEE-754 double from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
+{
+ IEEE754_NATIVE_REF (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_set_x,
+ "bytevector-ieee-double-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store real @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_set_x
+{
+ IEEE754_SET (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_native_set_x,
+ "bytevector-ieee-double-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the real @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
+{
+ IEEE754_NATIVE_SET (double);
+}
+#undef FUNC_NAME
+
+
+#undef IEEE754_UNION
+#undef IEEE754_TO_SCM
+#undef IEEE754_FROM_SCM
+#undef IEEE754_FROM_FOREIGN_ENDIANNESS
+#undef IEEE754_TO_FOREIGN_ENDIANNESS
+#undef IEEE754_REF
+#undef IEEE754_NATIVE_REF
+#undef IEEE754_SET
+#undef IEEE754_NATIVE_SET
+
+
+/* Operations on strings. */
+
+
+/* Produce a function that returns the length of a UTF-encoded string. */
+#define UTF_STRLEN_FUNCTION(_utf_width)
\
+static inline size_t \
+utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
+{ \
+ size_t len = 0; \
+ const uint ## _utf_width ## _t *ptr; \
+ for (ptr = str; \
+ *ptr != 0; \
+ ptr++) \
+ { \
+ len++; \
+ } \
+ \
+ return (len * ((_utf_width) / 8)); \
+}
+
+UTF_STRLEN_FUNCTION (8)
+
+
+/* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
+#define UTF_STRLEN(_utf_width, _str) \
+ utf ## _utf_width ## _strlen (_str)
+
+/* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
+ ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
+ encoding name). */
+static inline void
+utf_encoding_name (char *name, size_t utf_width, SCM endianness)
+{
+ strcpy (name, "UTF-");
+ strcat (name, ((utf_width == 8)
+ ? "8"
+ : ((utf_width == 16)
+ ? "16"
+ : ((utf_width == 32)
+ ? "32"
+ : "??"))));
+ strcat (name,
+ ((scm_is_eq (endianness, scm_sym_big))
+ ? "BE"
+ : ((scm_is_eq (endianness, scm_sym_little))
+ ? "LE"
+ : "unknown")));
+}
+
+/* Maximum length of a UTF encoding name. */
+#define MAX_UTF_ENCODING_NAME_LEN 16
+
+/* Produce the body of a `string->utf' function. */
+#define STRING_TO_UTF(_utf_width) \
+ SCM utf; \
+ int err; \
+ char *c_str; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ char *c_utf = NULL, *c_locale; \
+ size_t c_strlen, c_raw_strlen, c_utf_len = 0;
\
+ \
+ SCM_VALIDATE_STRING (1, str);
\
+ if (endianness == SCM_UNDEFINED) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ c_strlen = scm_c_string_length (str);
\
+ c_raw_strlen = c_strlen * ((_utf_width) / 8);
\
+ do \
+ { \
+ c_str = (char *) alloca (c_raw_strlen + 1); \
+ c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
+ } \
+ while (c_raw_strlen > c_strlen); \
+ c_str[c_raw_strlen] = '\0'; \
+ \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
+ strcpy (c_locale, locale_charset ());
\
+ \
+ err = mem_iconveh (c_str, c_raw_strlen, \
+ c_locale, c_utf_name, \
+ iconveh_question_mark, NULL, \
+ &c_utf, &c_utf_len); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
+ scm_list_1 (str), err); \
+ else \
+ /* C_UTF is null-terminated. */ \
+ utf = scm_c_take_bytevector ((signed char *) c_utf,
\
+ c_utf_len); \
+ \
+ return (utf);
+
+
+
+SCM_DEFINE (scm_string_to_utf8, "string->utf8",
+ 1, 0, 0,
+ (SCM str),
+ "Return a newly allocated bytevector that contains the UTF-8 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf8
+{
+ SCM utf;
+ char *c_str;
+ uint8_t *c_utf;
+ size_t c_strlen, c_raw_strlen;
+
+ SCM_VALIDATE_STRING (1, str);
+
+ c_strlen = scm_c_string_length (str);
+ c_raw_strlen = c_strlen;
+ do
+ {
+ c_str = (char *) alloca (c_raw_strlen + 1);
+ c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen);
+ }
+ while (c_raw_strlen > c_strlen);
+ c_str[c_raw_strlen] = '\0';
+
+ c_utf = u8_strconv_from_locale (c_str);
+ if (SCM_UNLIKELY (c_utf == NULL))
+ scm_syserror (FUNC_NAME);
+ else
+ /* C_UTF is null-terminated. */
+ utf = scm_c_take_bytevector ((signed char *) c_utf,
+ UTF_STRLEN (8, c_utf));
+
+ return (utf);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_to_utf16, "string->utf16",
+ 1, 1, 0,
+ (SCM str, SCM endianness),
+ "Return a newly allocated bytevector that contains the UTF-16 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf16
+{
+ STRING_TO_UTF (16);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_to_utf32, "string->utf32",
+ 1, 1, 0,
+ (SCM str, SCM endianness),
+ "Return a newly allocated bytevector that contains the UTF-32 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf32
+{
+ STRING_TO_UTF (32);
+}
+#undef FUNC_NAME
+
+
+/* Produce the body of a function that converts a UTF-encoded bytevector to a
+ string. */
+#define UTF_TO_STRING(_utf_width) \
+ SCM str = SCM_BOOL_F;
\
+ int err; \
+ char *c_str = NULL, *c_locale; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ const char *c_utf; \
+ size_t c_strlen = 0, c_utf_len; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, utf); \
+ if (endianness == SCM_UNDEFINED) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
+ c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
+ strcpy (c_locale, locale_charset ());
\
+ \
+ err = mem_iconveh (c_utf, c_utf_len, \
+ c_utf_name, c_locale, \
+ iconveh_question_mark, NULL, \
+ &c_str, &c_strlen); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
+ scm_list_1 (utf), err); \
+ else \
+ /* C_STR is null-terminated. */ \
+ str = scm_take_locale_stringn (c_str, c_strlen); \
+ \
+ return (str);
+
+
+SCM_DEFINE (scm_utf8_to_string, "utf8->string",
+ 1, 0, 0,
+ (SCM utf),
+ "Return a newly allocate string that contains from the UTF-8-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf8_to_string
+{
+ SCM str;
+ int err;
+ char *c_str = NULL, *c_locale;
+ const char *c_utf;
+ size_t c_utf_len, c_strlen = 0;
+
+ SCM_VALIDATE_BYTEVECTOR (1, utf);
+
+ c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
+
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1);
+ strcpy (c_locale, locale_charset ());
+
+ c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
+ err = mem_iconveh (c_utf, c_utf_len,
+ "UTF-8", c_locale,
+ iconveh_question_mark, NULL,
+ &c_str, &c_strlen);
+ if (SCM_UNLIKELY (err))
+ scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A",
+ scm_list_1 (utf), err);
+ else
+ /* C_STR is null-terminated. */
+ str = scm_take_locale_stringn (c_str, c_strlen);
+
+ return (str);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_utf16_to_string, "utf16->string",
+ 1, 1, 0,
+ (SCM utf, SCM endianness),
+ "Return a newly allocate string that contains from the UTF-16-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf16_to_string
+{
+ UTF_TO_STRING (16);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_utf32_to_string, "utf32->string",
+ 1, 1, 0,
+ (SCM utf, SCM endianness),
+ "Return a newly allocate string that contains from the UTF-32-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf32_to_string
+{
+ UTF_TO_STRING (32);
+}
+#undef FUNC_NAME
+
+
+
+/* Initialization. */
+
+void
+scm_init_bytevectors (void)
+{
+#include "libguile/bytevectors.x"
+
+#ifdef WORDS_BIGENDIAN
+ native_endianness = scm_sym_big;
+#else
+ native_endianness = scm_sym_little;
+#endif
+
+ scm_endianness_big = scm_sym_big;
+ scm_endianness_little = scm_sym_little;
+
+ scm_null_bytevector =
+ scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
+}
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
new file mode 100644
index 0000000..98c38ac
--- /dev/null
+++ b/libguile/bytevectors.h
@@ -0,0 +1,133 @@
+#ifndef SCM_BYTEVECTORS_H
+#define SCM_BYTEVECTORS_H
+
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+
+
+/* R6RS bytevectors. */
+
+#define SCM_BYTEVECTOR_LENGTH(_bv) \
+ ((unsigned) SCM_SMOB_DATA (_bv))
+#define SCM_BYTEVECTOR_CONTENTS(_bv) \
+ (SCM_BYTEVECTOR_INLINE_P (_bv) \
+ ? (signed char *) SCM_SMOB_OBJECT_2_LOC (_bv) \
+ : (signed char *) SCM_SMOB_DATA_2 (_bv))
+
+
+SCM_API SCM scm_endianness_big;
+SCM_API SCM scm_endianness_little;
+
+SCM_API SCM scm_make_bytevector (SCM, SCM);
+SCM_API SCM scm_c_make_bytevector (unsigned);
+SCM_API SCM scm_native_endianness (void);
+SCM_API SCM scm_bytevector_p (SCM);
+SCM_API SCM scm_bytevector_length (SCM);
+SCM_API SCM scm_bytevector_eq_p (SCM, SCM);
+SCM_API SCM scm_bytevector_fill_x (SCM, SCM);
+SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_copy (SCM);
+
+SCM_API SCM scm_bytevector_to_u8_list (SCM);
+SCM_API SCM scm_u8_list_to_bytevector (SCM);
+SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_to_uint_list (SCM, SCM, SCM);
+SCM_API SCM scm_sint_list_to_bytevector (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_to_sint_list (SCM, SCM, SCM);
+
+SCM_API SCM scm_bytevector_u16_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s16_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u32_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s32_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u64_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s64_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u8_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s8_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_uint_ref (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_sint_ref (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u8_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s8_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_uint_set_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_sint_set_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_string_to_utf8 (SCM);
+SCM_API SCM scm_string_to_utf16 (SCM, SCM);
+SCM_API SCM scm_string_to_utf32 (SCM, SCM);
+SCM_API SCM scm_utf8_to_string (SCM);
+SCM_API SCM scm_utf16_to_string (SCM, SCM);
+SCM_API SCM scm_utf32_to_string (SCM, SCM);
+
+
+
+/* Internal API. */
+
+/* The threshold (in octets) under which bytevectors are stored "in-line",
+ 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_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)))
+
+/* Hint that is passed to `scm_gc_malloc ()' and friends. */
+#define SCM_GC_BYTEVECTOR "bytevector"
+
+SCM_API void scm_init_bytevectors (void);
+
+SCM_INTERNAL scm_t_bits scm_tc16_bytevector;
+SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, unsigned);
+
+#define scm_c_shrink_bytevector(_bv, _len) \
+ (SCM_BYTEVECTOR_INLINE_P (_bv) \
+ ? (_bv) \
+ : scm_i_shrink_bytevector ((_bv), (_len)))
+
+SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, unsigned);
+SCM_INTERNAL SCM scm_null_bytevector;
+
+#endif /* SCM_BYTEVECTORS_H */
diff --git a/libguile/eval.c b/libguile/eval.c
index 19ac0b1..05af5a1 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -2140,6 +2140,25 @@ unmemoize_at_call_with_values (const SCM expr, const SCM
env)
unmemoize_exprs (SCM_CDR (expr), env));
}
+SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
+SCM_GLOBAL_SYMBOL (scm_sym_eval_when, s_eval_when);
+SCM_SYMBOL (sym_eval, "eval");
+SCM_SYMBOL (sym_load, "load");
+
+
+SCM
+scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
+
+ if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr)))
+ || scm_is_true (scm_memq (sym_load, scm_cadr (expr))))
+ return scm_cons (SCM_IM_BEGIN, scm_cddr (expr));
+
+ return scm_list_1 (SCM_IM_BEGIN);
+}
+
#if 0
/* See futures.h for a comment why futures are not enabled.
diff --git a/libguile/eval.h b/libguile/eval.h
index f3ec2e1..b017f2e 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -100,6 +100,7 @@ SCM_API SCM scm_sym_atapply;
SCM_API SCM scm_sym_atcall_cc;
SCM_API SCM scm_sym_at_call_with_values;
SCM_API SCM scm_sym_delay;
+SCM_API SCM scm_sym_eval_when;
SCM_API SCM scm_sym_arrow;
SCM_API SCM scm_sym_else;
SCM_API SCM scm_sym_apply;
@@ -146,6 +147,7 @@ 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);
diff --git a/libguile/frames.c b/libguile/frames.c
index f53cade..c08fd31 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
@@ -45,6 +21,7 @@
#include <stdlib.h>
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"
diff --git a/libguile/frames.h b/libguile/frames.h
index 8367637..d74476a 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
+ * *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_FRAMES_H_
#define _SCM_FRAMES_H_
@@ -97,7 +73,7 @@
* Heap frames
*/
-extern scm_t_bits scm_tc16_vm_frame;
+SCM_API scm_t_bits scm_tc16_vm_frame;
struct scm_vm_frame
{
@@ -118,24 +94,24 @@ struct scm_vm_frame
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
/* FIXME rename scm_byte_t */
-extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
+SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_byte_t *ip, scm_t_ptrdiff offset);
-extern SCM scm_vm_frame_p (SCM obj);
-extern SCM scm_vm_frame_program (SCM frame);
-extern SCM scm_vm_frame_arguments (SCM frame);
-extern SCM scm_vm_frame_source (SCM frame);
-extern SCM scm_vm_frame_local_ref (SCM frame, SCM index);
-extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
-extern SCM scm_vm_frame_return_address (SCM frame);
-extern SCM scm_vm_frame_mv_return_address (SCM frame);
-extern SCM scm_vm_frame_dynamic_link (SCM frame);
-extern SCM scm_vm_frame_external_link (SCM frame);
-extern SCM scm_vm_frame_stack (SCM frame);
-
-extern SCM scm_c_vm_frame_prev (SCM frame);
-
-extern void scm_bootstrap_frames (void);
-extern void scm_init_frames (void);
+SCM_API SCM scm_vm_frame_p (SCM obj);
+SCM_API SCM scm_vm_frame_program (SCM frame);
+SCM_API SCM scm_vm_frame_arguments (SCM frame);
+SCM_API SCM scm_vm_frame_source (SCM frame);
+SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index);
+SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
+SCM_API SCM scm_vm_frame_return_address (SCM frame);
+SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
+SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
+SCM_API SCM scm_vm_frame_external_link (SCM frame);
+SCM_API SCM scm_vm_frame_stack (SCM frame);
+
+SCM_API SCM scm_c_vm_frame_prev (SCM frame);
+
+SCM_INTERNAL void scm_bootstrap_frames (void);
+SCM_INTERNAL void scm_init_frames (void);
#endif /* _SCM_FRAMES_H_ */
diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c
index d89f1cf..7bc9644 100644
--- a/libguile/gc_os_dep.c
+++ b/libguile/gc_os_dep.c
@@ -1127,7 +1127,7 @@ scm_get_stack_base ()
# ifdef OSF1
# define OS_TYPE "OSF1"
# define DATASTART ((ptr_t) 0x140000000)
- extern _end;
+ extern int _end;
# define DATAEND ((ptr_t) &_end)
# define HEURISTIC2
/* Normally HEURISTIC2 is too conervative, since */
@@ -1912,7 +1912,7 @@ void *scm_get_stack_base()
# if STACK_GROWS_DOWN
result = GC_find_limit((ptr_t)(&dummy), TRUE);
# ifdef HEURISTIC2_LIMIT
- if (result > HEURISTIC2_LIMIT
+ if ((ptr_t)result > HEURISTIC2_LIMIT
&& (ptr_t)(&dummy) < HEURISTIC2_LIMIT) {
result = HEURISTIC2_LIMIT;
}
diff --git a/libguile/ieee-754.h b/libguile/ieee-754.h
new file mode 100644
index 0000000..e345efa
--- /dev/null
+++ b/libguile/ieee-754.h
@@ -0,0 +1,90 @@
+/* Copyright (C) 1992, 1995, 1996, 1999 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+
+ The GNU C Library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ The GNU C 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 the GNU C Library; if not, write to the Free
+ Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307 USA. */
+
+#ifndef SCM_IEEE_754_H
+#define SCM_IEEE_754_H 1
+
+/* Based on glibc's <ieee754.h> and modified by Ludovic Courtès to include
+ all possible IEEE-754 double-precision representations. */
+
+
+/* IEEE 754 simple-precision format (32-bit). */
+
+union scm_ieee754_float
+ {
+ float f;
+
+ struct
+ {
+ unsigned int negative:1;
+ unsigned int exponent:8;
+ unsigned int mantissa:23;
+ } big_endian;
+
+ struct
+ {
+ unsigned int mantissa:23;
+ unsigned int exponent:8;
+ unsigned int negative:1;
+ } little_endian;
+ };
+
+
+
+/* IEEE 754 double-precision format (64-bit). */
+
+union scm_ieee754_double
+ {
+ double d;
+
+ struct
+ {
+ /* Big endian. */
+
+ unsigned int negative:1;
+ unsigned int exponent:11;
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa0:20;
+ unsigned int mantissa1:32;
+ } big_endian;
+
+ struct
+ {
+ /* Both byte order and word order are little endian. */
+
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+ } little_little_endian;
+
+ struct
+ {
+ /* Byte order is little endian but word order is big endian. Not
+ sure this is very wide spread. */
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+ unsigned int mantissa1:32;
+ } little_big_endian;
+
+ };
+
+
+#endif /* SCM_IEEE_754_H */
diff --git a/libguile/instructions.c b/libguile/instructions.c
index 4f504f0..f0f52e4 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -1,49 +1,27 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
+
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "instructions.h"
diff --git a/libguile/instructions.h b/libguile/instructions.h
index 4968671..f4f45b3 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_INSTRUCTIONS_H_
#define _SCM_INSTRUCTIONS_H_
@@ -57,16 +33,16 @@ enum scm_opcode {
scm_op_last = SCM_VM_NUM_INSTRUCTIONS
};
-extern SCM scm_instruction_list (void);
-extern SCM scm_instruction_p (SCM obj);
-extern SCM scm_instruction_length (SCM inst);
-extern SCM scm_instruction_pops (SCM inst);
-extern SCM scm_instruction_pushes (SCM inst);
-extern SCM scm_instruction_to_opcode (SCM inst);
-extern SCM scm_opcode_to_instruction (SCM op);
+SCM_API SCM scm_instruction_list (void);
+SCM_API SCM scm_instruction_p (SCM obj);
+SCM_API SCM scm_instruction_length (SCM inst);
+SCM_API SCM scm_instruction_pops (SCM inst);
+SCM_API SCM scm_instruction_pushes (SCM inst);
+SCM_API SCM scm_instruction_to_opcode (SCM inst);
+SCM_API SCM scm_opcode_to_instruction (SCM op);
-extern void scm_bootstrap_instructions (void);
-extern void scm_init_instructions (void);
+SCM_INTERNAL void scm_bootstrap_instructions (void);
+SCM_INTERNAL void scm_init_instructions (void);
#endif /* _SCM_INSTRUCTIONS_H_ */
diff --git a/libguile/macros.c b/libguile/macros.c
index d132c01..ca3e83e 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -48,10 +48,13 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
|| scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
macro, port, pstate)))
{
+ scm_puts ("#<", port);
+
+ if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
+ scm_puts ("extended-", port);
+
if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code))
- scm_puts ("#<primitive-", port);
- else
- scm_puts ("#<", port);
+ scm_puts ("primitive-", port);
if (SCM_MACRO_TYPE (macro) == 0)
scm_puts ("syntax", port);
@@ -63,6 +66,8 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
scm_puts ("macro!", port);
if (SCM_MACRO_TYPE (macro) == 3)
scm_puts ("builtin-macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 4)
+ scm_puts ("syncase-macro", port);
scm_putc (' ', port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
@@ -77,6 +82,14 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
scm_iprin1 (src, port, pstate);
}
+ if (SCM_MACRO_IS_EXTENDED (macro))
+ {
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_2 (macro), port);
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_3 (macro), port);
+ }
+
scm_putc ('>', port);
}
@@ -84,6 +97,16 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
}
static SCM
+macro_mark (SCM macro)
+{
+ if (SCM_MACRO_IS_EXTENDED (macro))
+ { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro));
+ scm_gc_mark (SCM_SMOB_OBJECT_3 (macro));
+ }
+ return SCM_SMOB_OBJECT (macro);
+}
+
+static SCM
makmac (SCM code, scm_t_bits flags)
{
SCM z;
@@ -164,11 +187,45 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0,
#endif
+SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0,
+ (SCM type, SCM binding),
+ "Return a @dfn{macro} that requires expansion by syntax-case.\n"
+ "While users should not call this function, it is useful to know\n"
+ "that syntax-case macros are represented as Guile primitive
macros.")
+#define FUNC_NAME s_scm_make_syncase_macro
+{
+ SCM z;
+ SCM_VALIDATE_SYMBOL (1, type);
+
+ SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type),
+ SCM_UNPACK (binding));
+ SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED);
+ return z;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3,
0, 0,
+ (SCM m, SCM type, SCM binding),
+ "Extend a core macro @var{m} with a syntax-case binding.")
+#define FUNC_NAME s_scm_make_extended_syncase_macro
+{
+ SCM z;
+ SCM_VALIDATE_SMOB (1, m, macro);
+ SCM_VALIDATE_SYMBOL (2, type);
+
+ SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type),
+ SCM_UNPACK (binding));
+ SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED);
+ return z;
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0,
(SCM obj),
- "Return @code{#t} if @var{obj} is a regular macro, a memoizing
macro or a\n"
- "syntax transformer.")
+ "Return @code{#t} if @var{obj} is a regular macro, a memoizing
macro, a\n"
+ "syntax transformer, or a syntax-case macro.")
#define FUNC_NAME s_scm_macro_p
{
return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj));
@@ -182,14 +239,15 @@ SCM_SYMBOL (scm_sym_macro, "macro");
#endif
SCM_SYMBOL (scm_sym_mmacro, "macro!");
SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!");
+SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro");
SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
(SCM m),
- "Return one of the symbols @code{syntax}, @code{macro} or\n"
- "@code{macro!}, depending on whether @var{m} is a syntax\n"
- "transformer, a regular macro, or a memoizing macro,\n"
- "respectively. If @var{m} is not a macro, @code{#f} is\n"
- "returned.")
+ "Return one of the symbols @code{syntax}, @code{macro},\n"
+ "@code{macro!}, or @code{syntax-case}, depending on whether\n"
+ "@var{m} is a syntax transformer, a regular macro, a memoizing\n"
+ "macro, or a syntax-case macro, respectively. If @var{m} is\n"
+ "not a macro, @code{#f} is returned.")
#define FUNC_NAME s_scm_macro_type
{
if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m))
@@ -202,6 +260,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
#endif
case 2: return scm_sym_mmacro;
case 3: return scm_sym_bimacro;
+ case 4: return scm_sym_syncase_macro;
default: scm_wrong_type_arg (FUNC_NAME, 1, m);
}
}
@@ -214,7 +273,9 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
#define FUNC_NAME s_scm_macro_name
{
SCM_VALIDATE_SMOB (1, m, macro);
- return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m)));
+ if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m))))
+ return scm_procedure_name (SCM_SMOB_OBJECT (m));
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -236,6 +297,34 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1,
0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0,
+ (SCM m),
+ "Return the type of the macro @var{m}.")
+#define FUNC_NAME s_scm_syncase_macro_type
+{
+ SCM_VALIDATE_SMOB (1, m, macro);
+
+ if (SCM_MACRO_IS_EXTENDED (m))
+ return SCM_SMOB_OBJECT_2 (m);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0,
+ (SCM m),
+ "Return the binding of the macro @var{m}.")
+#define FUNC_NAME s_scm_syncase_macro_binding
+{
+ SCM_VALIDATE_SMOB (1, m, macro);
+
+ if (SCM_MACRO_IS_EXTENDED (m))
+ return SCM_SMOB_OBJECT_3 (m);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
SCM
scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
{
@@ -249,7 +338,7 @@ void
scm_init_macros ()
{
scm_tc16_macro = scm_make_smob_type ("macro", 0);
- scm_set_smob_mark (scm_tc16_macro, scm_markcdr);
+ scm_set_smob_mark (scm_tc16_macro, macro_mark);
scm_set_smob_print (scm_tc16_macro, macro_print);
#include "libguile/macros.x"
}
diff --git a/libguile/macros.h b/libguile/macros.h
index e1de77f..5e3d64a 100644
--- a/libguile/macros.h
+++ b/libguile/macros.h
@@ -29,9 +29,15 @@
#define SCM_ASSYNT(_cond, _msg, _subr) \
if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL);
+#define SCM_MACRO_TYPE_BITS (3)
+#define SCM_MACRO_TYPE_MASK ((1<<SCM_MACRO_TYPE_BITS)-1)
+#define SCM_F_MACRO_EXTENDED (1<<SCM_MACRO_TYPE_BITS)
+
#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
-#define SCM_MACRO_TYPE(m) SCM_SMOB_FLAGS (m)
+#define SCM_MACRO_TYPE(m) (SCM_SMOB_FLAGS (m) & SCM_MACRO_TYPE_MASK)
+#define SCM_MACRO_IS_EXTENDED(m) (SCM_SMOB_FLAGS (m) & SCM_F_MACRO_EXTENDED)
#define SCM_BUILTIN_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 3)
+#define SCM_SYNCASE_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 4)
#define SCM_MACRO_CODE(m) SCM_SMOB_OBJECT (m)
SCM_API scm_t_bits scm_tc16_macro;
@@ -39,10 +45,15 @@ SCM_API scm_t_bits scm_tc16_macro;
SCM_INTERNAL SCM scm_i_makbimacro (SCM code);
SCM_API SCM scm_makmmacro (SCM code);
SCM_API SCM scm_makacro (SCM code);
+SCM_API SCM scm_make_syncase_macro (SCM type, SCM binding);
+SCM_API SCM scm_make_extended_syncase_macro (SCM builtin, SCM type,
+ SCM binding);
SCM_API SCM scm_macro_p (SCM obj);
SCM_API SCM scm_macro_type (SCM m);
SCM_API SCM scm_macro_name (SCM m);
SCM_API SCM scm_macro_transformer (SCM m);
+SCM_API SCM scm_syncase_macro_type (SCM m);
+SCM_API SCM scm_syncase_macro_binding (SCM m);
SCM_API SCM scm_make_synt (const char *name,
SCM (*macroizer) (SCM),
SCM (*fcn) ());
diff --git a/libguile/modules.c b/libguile/modules.c
index 2cb8a76..689510c 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -412,13 +412,13 @@ SCM_DEFINE (scm_module_local_variable,
"module-local-variable", 2, 0, 0,
register SCM b;
- /* SCM_MODULE_TAG is not initialized yet when `boot-9.scm' is being
- evaluated. */
if (scm_module_system_booted_p)
SCM_VALIDATE_MODULE (1, module);
SCM_VALIDATE_SYMBOL (2, sym);
+ if (scm_is_false (module))
+ return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
/* 1. Check module obarray */
b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
diff --git a/libguile/net_db.c b/libguile/net_db.c
index deb8d38..af6e3d5 100644
--- a/libguile/net_db.c
+++ b/libguile/net_db.c
@@ -1,5 +1,5 @@
/* "net_db.c" network database support
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006 Free Software
Foundation, Inc.
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,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
@@ -64,6 +64,12 @@
extern int h_errno;
#endif
+#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR \
+ && !defined __MINGW32__ && !defined __CYGWIN__
+/* Some OSes, such as Tru64 5.1b, lack a declaration for hstrerror(3). */
+extern const char *hstrerror (int);
+#endif
+
SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 52dfb73..37435b5 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006,
2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006,
2007, 2008, 2009 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
@@ -5352,7 +5352,12 @@ SCM
scm_c_make_polar (double mag, double ang)
{
double s, c;
-#if HAVE_SINCOS
+
+ /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
+ use it on Glibc-based systems that have it (it's a GNU extension). See
+ http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
+ details. */
+#if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
sincos (ang, &s, &c);
#else
s = sin (ang);
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 8bc203d..6a0a11b 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
@@ -51,6 +27,7 @@
#include <sys/types.h>
#include <assert.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "programs.h"
#include "objcodes.h"
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 2226916..acd43a6 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
+ * *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_OBJCODES_H_
#define _SCM_OBJCODES_H_
@@ -60,7 +36,7 @@ struct scm_objcode {
#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1)
#define SCM_F_OBJCODE_IS_SLICE (1<<2)
-extern scm_t_bits scm_tc16_objcode;
+SCM_API scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
@@ -80,15 +56,15 @@ extern scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr);
-extern SCM scm_load_objcode (SCM file);
-extern SCM scm_objcode_p (SCM obj);
-extern SCM scm_objcode_meta (SCM objcode);
-extern SCM scm_bytecode_to_objcode (SCM bytecode);
-extern SCM scm_objcode_to_bytecode (SCM objcode);
-extern SCM scm_write_objcode (SCM objcode, SCM port);
+SCM_API SCM scm_load_objcode (SCM file);
+SCM_API SCM scm_objcode_p (SCM obj);
+SCM_API SCM scm_objcode_meta (SCM objcode);
+SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
+SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
+SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
-extern void scm_bootstrap_objcodes (void);
-extern void scm_init_objcodes (void);
+SCM_INTERNAL void scm_bootstrap_objcodes (void);
+SCM_INTERNAL void scm_init_objcodes (void);
#endif /* _SCM_OBJCODES_H_ */
diff --git a/libguile/posix.c b/libguile/posix.c
index 78fd295..5e6f05f 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -21,6 +21,7 @@
# include <config.h>
#endif
+#include <stdlib.h>
#include <stdio.h>
#include <errno.h>
@@ -100,8 +101,6 @@ extern char *ttyname();
#include <signal.h>
-extern char ** environ;
-
#ifdef HAVE_GRP_H
#include <grp.h>
#endif
@@ -137,13 +136,7 @@ extern char ** environ;
# include <sys/resource.h>
#endif
-#if HAVE_SYS_FILE_H
-# include <sys/file.h>
-#endif
-
-#if HAVE_CRT_EXTERNS_H
-#include <crt_externs.h> /* for Darwin _NSGetEnviron */
-#endif
+#include <sys/file.h> /* from Gnulib */
/* Some Unix systems don't define these. CPP hair is dangerous, but
this seems safe enough... */
@@ -197,13 +190,6 @@ int sethostname (char *name, size_t namelen);
-/* On Apple Darwin in a shared library there's no "environ" to access
- directly, instead the address of that variable must be obtained with
- _NSGetEnviron(). */
-#if HAVE__NSGETENVIRON && defined (PIC)
-#define environ (*_NSGetEnviron())
-#endif
-
/* Two often used patterns
@@ -1512,98 +1498,13 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
int rv;
char *c_str = scm_to_locale_string (str);
- if (strchr (c_str, '=') == NULL)
- {
- /* We want no "=" in the argument to mean remove the variable from the
- environment, but not all putenv()s understand this, for example
- FreeBSD 4.8 doesn't. Getting it happening everywhere is a bit
- painful. What unsetenv() exists, we use that, of course.
-
- Traditionally putenv("NAME") removes a variable, for example that's
- what we have to do on Solaris 9 (it doesn't have an unsetenv).
-
- But on DOS and on that DOS overlay manager thing called W-whatever,
- putenv("NAME=") must be used (it too doesn't have an unsetenv).
-
- Supposedly on AIX a putenv("NAME") could cause a segfault, but also
- supposedly AIX 5.3 and up has unsetenv() available so should be ok
- with the latter there.
-
- For the moment we hard code the DOS putenv("NAME=") style under
- __MINGW32__ and do the traditional everywhere else. Such
- system-name tests are bad, of course. It'd be possible to use a
- configure test when doing a a native build. For example GNU R has
- such a test (see R_PUTENV_AS_UNSETENV in
- https://svn.r-project.org/R/trunk/m4/R.m4). But when cross
- compiling there'd want to be a guess, one probably based on the
- system name (ie. mingw or not), thus landing back in basically the
- present hard-coded situation. Another possibility for a cross
- build would be to try "NAME" then "NAME=" at runtime, if that's not
- too much like overkill. */
-
-#if HAVE_UNSETENV
- /* when unsetenv() exists then we use it */
- unsetenv (c_str);
- free (c_str);
-#elif defined (__MINGW32__)
- /* otherwise putenv("NAME=") on DOS */
- int e;
- size_t len = strlen (c_str);
- char *ptr = scm_malloc (len + 2);
- strcpy (ptr, c_str);
- strcpy (ptr+len, "=");
- rv = putenv (ptr);
- e = errno; free (ptr); free (c_str); errno = e;
- if (rv < 0)
- SCM_SYSERROR;
-#else
- /* otherwise traditional putenv("NAME") */
- rv = putenv (c_str);
- if (rv < 0)
- SCM_SYSERROR;
-#endif
- }
- else
- {
-#ifdef __MINGW32__
- /* If str is "FOO=", ie. attempting to set an empty string, then
- we need to see if it's been successful. On MINGW, "FOO="
- means remove FOO from the environment. As a workaround, we
- set "FOO= ", ie. a space, and then modify the string returned
- by getenv. It's not enough just to modify the string we set,
- because MINGW putenv copies it. */
-
- {
- size_t len = strlen (c_str);
- if (c_str[len-1] == '=')
- {
- char *ptr = scm_malloc (len+2);
- strcpy (ptr, c_str);
- strcpy (ptr+len, " ");
- rv = putenv (ptr);
- if (rv < 0)
- {
- int eno = errno;
- free (c_str);
- errno = eno;
- SCM_SYSERROR;
- }
- /* truncate to just the name */
- c_str[len-1] = '\0';
- ptr = getenv (c_str);
- if (ptr)
- ptr[0] = '\0';
- return SCM_UNSPECIFIED;
- }
- }
-#endif /* __MINGW32__ */
+ /* Leave C_STR in the environment. */
- /* Leave c_str in the environment. */
+ /* Gnulib's `putenv' module honors the semantics described above. */
+ rv = putenv (c_str);
+ if (rv < 0)
+ SCM_SYSERROR;
- rv = putenv (c_str);
- if (rv < 0)
- SCM_SYSERROR;
- }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1869,6 +1770,11 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
#endif /* HAVE_GETLOGIN */
#if HAVE_CUSERID
+
+# if !HAVE_DECL_CUSERID
+extern char *cuserid (char *);
+# endif
+
SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
(void),
"Return a string containing a user name associated with the\n"
@@ -1978,73 +1884,6 @@ SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_GETPASS */
-/* Wrapper function for flock() support under M$-Windows. */
-#ifdef __MINGW32__
-# include <io.h>
-# include <sys/locking.h>
-# include <errno.h>
-# ifndef _LK_UNLCK
- /* Current MinGW package fails to define this. *sigh* */
-# define _LK_UNLCK 0
-# endif
-# define LOCK_EX 1
-# define LOCK_UN 2
-# define LOCK_SH 4
-# define LOCK_NB 8
-
-static int flock (int fd, int operation)
-{
- long pos, len;
- int ret, err;
-
- /* Disable invalid arguments. */
- if (((operation & (LOCK_EX | LOCK_SH)) == (LOCK_EX | LOCK_SH)) ||
- ((operation & (LOCK_EX | LOCK_UN)) == (LOCK_EX | LOCK_UN)) ||
- ((operation & (LOCK_SH | LOCK_UN)) == (LOCK_SH | LOCK_UN)))
- {
- errno = EINVAL;
- return -1;
- }
-
- /* Determine mode of operation and discard unsupported ones. */
- if (operation == (LOCK_NB | LOCK_EX))
- operation = _LK_NBLCK;
- else if (operation & LOCK_UN)
- operation = _LK_UNLCK;
- else if (operation == LOCK_EX)
- operation = _LK_LOCK;
- else
- {
- errno = EINVAL;
- return -1;
- }
-
- /* Save current file pointer and seek to beginning. */
- if ((pos = lseek (fd, 0, SEEK_CUR)) == -1 || (len = filelength (fd)) == -1)
- return -1;
- lseek (fd, 0L, SEEK_SET);
-
- /* Deadlock if necessary. */
- do
- {
- ret = _locking (fd, operation, len);
- }
- while (ret == -1 && errno == EDEADLOCK);
-
- /* Produce meaningful error message. */
- if (errno == EACCES && operation == _LK_NBLCK)
- err = EDEADLOCK;
- else
- err = errno;
-
- /* Return to saved file position pointer. */
- lseek (fd, pos, SEEK_SET);
- errno = err;
- return ret;
-}
-#endif /* __MINGW32__ */
-
-#if HAVE_FLOCK || defined (__MINGW32__)
SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
(SCM file, SCM operation),
"Apply or remove an advisory lock on an open file.\n"
@@ -2088,7 +1927,6 @@ SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-#endif /* HAVE_FLOCK */
#if HAVE_SETHOSTNAME
SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0,
diff --git a/libguile/programs.c b/libguile/programs.c
index 8e89829..68e0b85 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -1,49 +1,26 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "instructions.h"
#include "modules.h"
diff --git a/libguile/programs.h b/libguile/programs.h
index 68a6936..ae819ef 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_PROGRAMS_H_
#define _SCM_PROGRAMS_H_
@@ -51,7 +27,7 @@
typedef unsigned char scm_byte_t;
-extern scm_t_bits scm_tc16_program;
+SCM_API scm_t_bits scm_tc16_program;
#define SCM_F_PROGRAM_IS_BOOT (1<<0)
@@ -63,27 +39,27 @@ extern scm_t_bits scm_tc16_program;
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
-extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
+SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
-extern SCM scm_program_p (SCM obj);
-extern SCM scm_program_base (SCM program);
-extern SCM scm_program_arity (SCM program);
-extern SCM scm_program_meta (SCM program);
-extern SCM scm_program_bindings (SCM program);
-extern SCM scm_program_sources (SCM program);
-extern SCM scm_program_source (SCM program, SCM ip);
-extern SCM scm_program_properties (SCM program);
-extern SCM scm_program_name (SCM program);
-extern SCM scm_program_objects (SCM program);
-extern SCM scm_program_module (SCM program);
-extern SCM scm_program_external (SCM program);
-extern SCM scm_program_external_set_x (SCM program, SCM external);
-extern SCM scm_program_objcode (SCM program);
+SCM_API SCM scm_program_p (SCM obj);
+SCM_API SCM scm_program_base (SCM program);
+SCM_API SCM scm_program_arity (SCM program);
+SCM_API SCM scm_program_meta (SCM program);
+SCM_API SCM scm_program_bindings (SCM program);
+SCM_API SCM scm_program_sources (SCM program);
+SCM_API SCM scm_program_source (SCM program, SCM ip);
+SCM_API SCM scm_program_properties (SCM program);
+SCM_API SCM scm_program_name (SCM program);
+SCM_API SCM scm_program_objects (SCM program);
+SCM_API SCM scm_program_module (SCM program);
+SCM_API SCM scm_program_external (SCM program);
+SCM_API SCM scm_program_external_set_x (SCM program, SCM external);
+SCM_API SCM scm_program_objcode (SCM program);
-extern SCM scm_c_program_source (SCM program, size_t ip);
+SCM_API SCM scm_c_program_source (SCM program, size_t ip);
-extern void scm_bootstrap_programs (void);
-extern void scm_init_programs (void);
+SCM_INTERNAL void scm_bootstrap_programs (void);
+SCM_INTERNAL void scm_init_programs (void);
#endif /* _SCM_PROGRAMS_H_ */
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
new file mode 100644
index 0000000..a07636f
--- /dev/null
+++ b/libguile/r6rs-ports.c
@@ -0,0 +1,1118 @@
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif
+
+#include <string.h>
+#include <stdio.h>
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/r6rs-ports.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/values.h"
+#include "libguile/vectors.h"
+
+
+
+/* Unimplemented features. */
+
+
+/* Transoders are currently not implemented since Guile 1.8 is not
+ Unicode-capable. Thus, most of the code here assumes the use of the
+ binary transcoder. */
+static inline void
+transcoders_not_implemented (void)
+{
+ fprintf (stderr, "%s: warning: transcoders not implemented\n",
+ PACKAGE_NAME);
+}
+
+
+/* End-of-file object. */
+
+SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0,
+ (void),
+ "Return the end-of-file object.")
+#define FUNC_NAME s_scm_eof_object
+{
+ return (SCM_EOF_VAL);
+}
+#undef FUNC_NAME
+
+
+/* Input ports. */
+
+#ifndef MIN
+# define MIN(a,b) ((a) < (b) ? (a) : (b))
+#endif
+
+/* Bytevector input ports or "bip" for short. */
+static scm_t_bits bytevector_input_port_type = 0;
+
+static inline SCM
+make_bip (SCM bv)
+{
+ SCM port;
+ char *c_bv;
+ unsigned c_len;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+
+ port = scm_new_port_table_entry (bytevector_input_port_type);
+
+ /* Prevent BV from being GC'd. */
+ SCM_SETSTREAM (port, SCM_UNPACK (bv));
+
+ /* Have the port directly access the bytevector. */
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
+ c_port->read_end = (unsigned char *) c_bv + c_len;
+ c_port->read_buf_size = c_len;
+
+ /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
+
+ return port;
+}
+
+static SCM
+bip_mark (SCM port)
+{
+ /* Mark the underlying bytevector. */
+ return (SCM_PACK (SCM_STREAM (port)));
+}
+
+static int
+bip_fill_input (SCM port)
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ if (c_port->read_pos >= c_port->read_end)
+ result = EOF;
+ else
+ result = (int) *c_port->read_pos;
+
+ return result;
+}
+
+static off_t
+bip_seek (SCM port, off_t offset, int whence)
+#define FUNC_NAME "bip_seek"
+{
+ off_t c_result = 0;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ offset += c_port->read_pos - c_port->read_buf;
+ /* Fall through. */
+
+ case SEEK_SET:
+ if (c_port->read_buf + offset < c_port->read_end)
+ {
+ c_port->read_pos = c_port->read_buf + offset;
+ c_result = offset;
+ }
+ else
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ break;
+
+ case SEEK_END:
+ if (c_port->read_end - offset >= c_port->read_buf)
+ {
+ c_port->read_pos = c_port->read_end - offset;
+ c_result = c_port->read_pos - c_port->read_buf;
+ }
+ else
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "invalid `seek' parameter");
+ }
+
+ return c_result;
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the bytevector input port type. */
+static inline void
+initialize_bytevector_input_ports (void)
+{
+ bytevector_input_port_type =
+ scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input,
+ NULL);
+
+ scm_set_port_mark (bytevector_input_port_type, bip_mark);
+ scm_set_port_seek (bytevector_input_port_type, bip_seek);
+}
+
+
+SCM_DEFINE (scm_open_bytevector_input_port,
+ "open-bytevector-input-port", 1, 1, 0,
+ (SCM bv, SCM transcoder),
+ "Return an input port whose contents are drawn from "
+ "bytevector @var{bv}.")
+#define FUNC_NAME s_scm_open_bytevector_input_port
+{
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
+ transcoders_not_implemented ();
+
+ return (make_bip (bv));
+}
+#undef FUNC_NAME
+
+
+/* Custom binary ports. The following routines are shared by input and
+ output custom binary ports. */
+
+#define SCM_CBP_GET_POSITION_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
+#define SCM_CBP_SET_POSITION_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
+#define SCM_CBP_CLOSE_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
+
+static SCM
+cbp_mark (SCM port)
+{
+ /* Mark the underlying method and object vector. */
+ return (SCM_PACK (SCM_STREAM (port)));
+}
+
+static off_t
+cbp_seek (SCM port, off_t offset, int whence)
+#define FUNC_NAME "cbp_seek"
+{
+ SCM result;
+ off_t c_result = 0;
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ {
+ SCM get_position_proc;
+
+ get_position_proc = SCM_CBP_GET_POSITION_PROC (port);
+ if (SCM_LIKELY (scm_is_true (get_position_proc)))
+ result = scm_call_0 (get_position_proc);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary port does not "
+ "support `port-position'");
+
+ offset += scm_to_int (result);
+ /* Fall through. */
+ }
+
+ case SEEK_SET:
+ {
+ SCM set_position_proc;
+
+ set_position_proc = SCM_CBP_SET_POSITION_PROC (port);
+ if (SCM_LIKELY (scm_is_true (set_position_proc)))
+ result = scm_call_1 (set_position_proc, scm_from_int (offset));
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary port does not "
+ "support `set-port-position!'");
+
+ /* Assuming setting the position succeeded. */
+ c_result = offset;
+ break;
+ }
+
+ default:
+ /* `SEEK_END' cannot be supported. */
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary ports do not "
+ "support `SEEK_END'");
+ }
+
+ return c_result;
+}
+#undef FUNC_NAME
+
+static int
+cbp_close (SCM port)
+{
+ SCM close_proc;
+
+ close_proc = SCM_CBP_CLOSE_PROC (port);
+ if (scm_is_true (close_proc))
+ /* Invoke the `close' thunk. */
+ scm_call_0 (close_proc);
+
+ return 1;
+}
+
+
+/* Custom binary input port ("cbip" for short). */
+
+static scm_t_bits custom_binary_input_port_type = 0;
+
+/* Size of the buffer embedded in custom binary input ports. */
+#define CBIP_BUFFER_SIZE 4096
+
+/* Return the bytevector associated with PORT. */
+#define SCM_CBIP_BYTEVECTOR(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
+
+/* Return the various procedures of PORT. */
+#define SCM_CBIP_READ_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
+
+
+static inline SCM
+make_cbip (SCM read_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc)
+{
+ SCM port, bv, method_vector;
+ char *c_bv;
+ unsigned c_len;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+
+ /* Use a bytevector as the underlying buffer. */
+ c_len = CBIP_BUFFER_SIZE;
+ bv = scm_c_make_bytevector (c_len);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ /* Store the various methods and bytevector in a vector. */
+ method_vector = scm_c_make_vector (5, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+
+ port = scm_new_port_table_entry (custom_binary_input_port_type);
+
+ /* Attach it the method vector. */
+ SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
+
+ /* Have the port directly access the buffer (bytevector). */
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
+ c_port->read_end = (unsigned char *) c_bv;
+ c_port->read_buf_size = c_len;
+
+ /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
+
+ return port;
+}
+
+static int
+cbip_fill_input (SCM port)
+#define FUNC_NAME "cbip_fill_input"
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ again:
+ if (c_port->read_pos >= c_port->read_end)
+ {
+ /* Invoke the user's `read!' procedure. */
+ unsigned c_octets;
+ SCM bv, read_proc, octets;
+
+ /* Use the bytevector associated with PORT as the buffer passed to the
+ `read!' procedure, thereby avoiding additional allocations. */
+ bv = SCM_CBIP_BYTEVECTOR (port);
+ read_proc = SCM_CBIP_READ_PROC (port);
+
+ /* The assumption here is that C_PORT's internal buffer wasn't changed
+ behind our back. */
+ assert (c_port->read_buf ==
+ (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
+ assert ((unsigned) c_port->read_buf_size
+ == SCM_BYTEVECTOR_LENGTH (bv));
+
+ octets = scm_call_3 (read_proc, bv, SCM_INUM0,
+ SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
+ c_octets = scm_to_uint (octets);
+
+ c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
+
+ if (c_octets > 0)
+ goto again;
+ else
+ result = EOF;
+ }
+ else
+ result = (int) *c_port->read_pos;
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_custom_binary_input_port,
+ "make-custom-binary-input-port", 5, 0, 0,
+ (SCM id, SCM read_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc),
+ "Return a new custom binary input port whose input is drained "
+ "by invoking @var{read_proc} and passing it a bytevector, an "
+ "index where octets should be written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_input_port
+{
+ SCM_VALIDATE_STRING (1, id);
+ SCM_VALIDATE_PROC (2, read_proc);
+
+ if (!scm_is_false (get_position_proc))
+ SCM_VALIDATE_PROC (3, get_position_proc);
+
+ if (!scm_is_false (set_position_proc))
+ SCM_VALIDATE_PROC (4, set_position_proc);
+
+ if (!scm_is_false (close_proc))
+ SCM_VALIDATE_PROC (5, close_proc);
+
+ return (make_cbip (read_proc, get_position_proc, set_position_proc,
+ close_proc));
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the custom binary input port type. */
+static inline void
+initialize_custom_binary_input_ports (void)
+{
+ custom_binary_input_port_type =
+ scm_make_port_type ("r6rs-custom-binary-input-port",
+ cbip_fill_input, NULL);
+
+ scm_set_port_mark (custom_binary_input_port_type, cbp_mark);
+ scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
+ scm_set_port_close (custom_binary_input_port_type, cbp_close);
+}
+
+
+
+/* Binary input. */
+
+/* We currently don't support specific binary input ports. */
+#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
+
+SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0,
+ (SCM port),
+ "Read an octet from @var{port}, a binary input port, "
+ "blocking as necessary.")
+#define FUNC_NAME s_scm_get_u8
+{
+ SCM result;
+ int c_result;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_result = scm_getc (port);
+ if (c_result == EOF)
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM ((unsigned char) c_result);
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0,
+ (SCM port),
+ "Like @code{get-u8} but does not update @var{port} to "
+ "point past the octet.")
+#define FUNC_NAME s_scm_lookahead_u8
+{
+ SCM result;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ result = scm_peek_char (port);
+ if (SCM_CHARP (result))
+ result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result));
+ else
+ result = SCM_EOF_VAL;
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
+ (SCM port, SCM count),
+ "Read @var{count} octets from @var{port}, blocking as "
+ "necessary and return a bytevector containing the octets "
+ "read. If fewer bytes are available, a bytevector smaller "
+ "than @var{count} is returned.")
+#define FUNC_NAME s_scm_get_bytevector_n
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_count;
+ size_t c_read;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ c_count = scm_to_uint (count);
+
+ result = scm_c_make_bytevector (c_count);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result);
+
+ if (SCM_LIKELY (c_count > 0))
+ /* XXX: `scm_c_read ()' does not update the port position. */
+ c_read = scm_c_read (port, c_bv, c_count);
+ else
+ /* Don't invoke `scm_c_read ()' since it may block. */
+ c_read = 0;
+
+ if ((c_read == 0) && (c_count > 0))
+ {
+ if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
+ result = SCM_EOF_VAL;
+ else
+ result = scm_null_bytevector;
+ }
+ else
+ {
+ if (c_read < c_count)
+ result = scm_c_shrink_bytevector (result, c_read);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Read @var{count} bytes from @var{port} and store them "
+ "in @var{bv} starting at index @var{start}. Return either "
+ "the number of bytes actually read or the end-of-file "
+ "object.")
+#define FUNC_NAME s_scm_get_bytevector_n_x
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_start, c_count, c_len;
+ size_t c_read;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+ c_start = scm_to_uint (start);
+ c_count = scm_to_uint (count);
+
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+
+ if (SCM_LIKELY (c_count > 0))
+ c_read = scm_c_read (port, c_bv + c_start, c_count);
+ else
+ /* Don't invoke `scm_c_read ()' since it may block. */
+ c_read = 0;
+
+ if ((c_read == 0) && (c_count > 0))
+ {
+ if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM (0);
+ }
+ else
+ result = scm_from_size_t (c_read);
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
+ (SCM port),
+ "Read from @var{port}, blocking as necessary, until data "
+ "are available or and end-of-file is reached. Return either "
+ "a new bytevector containing the data read or the "
+ "end-of-file object.")
+#define FUNC_NAME s_scm_get_bytevector_some
+{
+ /* Read at least one byte, unless the end-of-file is already reached, and
+ read while characters are available (buffered). */
+
+ SCM result;
+ char *c_bv;
+ unsigned c_len;
+ size_t c_total;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_len = 4096;
+ c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ c_total = 0;
+
+ do
+ {
+ int c_chr;
+
+ if (c_total + 1 > c_len)
+ {
+ /* Grow the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
+ SCM_GC_BYTEVECTOR);
+ c_len *= 2;
+ }
+
+ /* We can't use `scm_c_read ()' since it blocks. */
+ c_chr = scm_getc (port);
+ if (c_chr != EOF)
+ {
+ c_bv[c_total] = (char) c_chr;
+ c_total++;
+ }
+ }
+ while ((scm_is_true (scm_char_ready_p (port)))
+ && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
+
+ if (c_total == 0)
+ {
+ result = SCM_EOF_VAL;
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ if (c_len > c_total)
+ {
+ /* Shrink the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
+ SCM_GC_BYTEVECTOR);
+ c_len = (unsigned) c_total;
+ }
+
+ result = scm_c_take_bytevector ((signed char *) c_bv, c_len);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
+ (SCM port),
+ "Read from @var{port}, blocking as necessary, until "
+ "the end-of-file is reached. Return either "
+ "a new bytevector containing the data read or the "
+ "end-of-file object (if no data were available).")
+#define FUNC_NAME s_scm_get_bytevector_all
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_len, c_count;
+ size_t c_read, c_total;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_len = c_count = 4096;
+ c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ c_total = c_read = 0;
+
+ do
+ {
+ if (c_total + c_read > c_len)
+ {
+ /* Grow the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
+ SCM_GC_BYTEVECTOR);
+ c_count = c_len;
+ c_len *= 2;
+ }
+
+ /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
+ reached. */
+ c_read = scm_c_read (port, c_bv + c_total, c_count);
+ c_total += c_read, c_count -= c_read;
+ }
+ while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
+
+ if (c_total == 0)
+ {
+ result = SCM_EOF_VAL;
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ if (c_len > c_total)
+ {
+ /* Shrink the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
+ SCM_GC_BYTEVECTOR);
+ c_len = (unsigned) c_total;
+ }
+
+ result = scm_c_take_bytevector ((signed char *) c_bv, c_len);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+
+/* Binary output. */
+
+/* We currently don't support specific binary input ports. */
+#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
+
+
+SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0,
+ (SCM port, SCM octet),
+ "Write @var{octet} to binary port @var{port}.")
+#define FUNC_NAME s_scm_put_u8
+{
+ scm_t_uint8 c_octet;
+
+ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
+ c_octet = scm_to_uint8 (octet);
+
+ scm_putc ((char) c_octet, port);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Write the contents of @var{bv} to @var{port}, optionally "
+ "starting at index @var{start} and limiting to @var{count} "
+ "octets.")
+#define FUNC_NAME s_scm_put_bytevector
+{
+ char *c_bv;
+ unsigned c_start, c_count, c_len;
+
+ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ if (start != SCM_UNDEFINED)
+ {
+ c_start = scm_to_uint (start);
+
+ if (count != SCM_UNDEFINED)
+ {
+ c_count = scm_to_uint (count);
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+ }
+ else
+ {
+ if (SCM_UNLIKELY (c_start >= c_len))
+ scm_out_of_range (FUNC_NAME, start);
+ else
+ c_count = c_len - c_start;
+ }
+ }
+ else
+ c_start = 0, c_count = c_len;
+
+ scm_c_write (port, c_bv + c_start, c_count);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+/* Bytevector output port ("bop" for short). */
+
+/* Implementation of "bops".
+
+ Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
+ it. The procedure returned along with the output port is actually an
+ applicable SMOB. The SMOB holds a reference to the port. When applied,
+ the SMOB swallows the port's internal buffer, turning it into a
+ bytevector, and resets it.
+
+ XXX: Access to a bop's internal buffer is not thread-safe. */
+
+static scm_t_bits bytevector_output_port_type = 0;
+
+SCM_SMOB (bytevector_output_port_procedure,
+ "r6rs-bytevector-output-port-procedure",
+ 0);
+
+#define SCM_GC_BOP "r6rs-bytevector-output-port"
+#define SCM_BOP_BUFFER_INITIAL_SIZE 4096
+
+/* Representation of a bop's internal buffer. */
+typedef struct
+{
+ size_t total_len;
+ size_t len;
+ size_t pos;
+ char *buffer;
+} scm_t_bop_buffer;
+
+
+/* Accessing a bop's buffer. */
+#define SCM_BOP_BUFFER(_port) \
+ ((scm_t_bop_buffer *) SCM_STREAM (_port))
+#define SCM_SET_BOP_BUFFER(_port, _buf) \
+ (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
+
+
+static inline void
+bop_buffer_init (scm_t_bop_buffer *buf)
+{
+ buf->total_len = buf->len = buf->pos = 0;
+ buf->buffer = NULL;
+}
+
+static inline void
+bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size)
+{
+ char *new_buf;
+ size_t new_size;
+
+ for (new_size = buf->total_len
+ ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE;
+ new_size < min_size;
+ new_size *= 2);
+
+ if (buf->buffer)
+ new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len,
+ new_size, SCM_GC_BOP);
+ else
+ new_buf = scm_gc_malloc (new_size, SCM_GC_BOP);
+
+ buf->buffer = new_buf;
+ buf->total_len = new_size;
+}
+
+static inline SCM
+make_bop (void)
+{
+ SCM port, bop_proc;
+ scm_t_port *c_port;
+ scm_t_bop_buffer *buf;
+ const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+
+ port = scm_new_port_table_entry (bytevector_output_port_type);
+
+ buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
+ bop_buffer_init (buf);
+
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = 0;
+
+ SCM_SET_BOP_BUFFER (port, buf);
+
+ /* Mark PORT as open and writable. */
+ SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+
+ /* Make the bop procedure. */
+ SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure,
+ SCM_PACK (port));
+
+ return (scm_values (scm_list_2 (port, bop_proc)));
+}
+
+static size_t
+bop_free (SCM port)
+{
+ /* The port itself is necessarily freed _after_ the bop proc, since the bop
+ proc holds a reference to it. Thus we can safely free the internal
+ buffer when the bop becomes unreferenced. */
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+ if (buf->buffer)
+ scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP);
+
+ scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP);
+
+ return 0;
+}
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+bop_write (SCM port, const void *data, size_t size)
+{
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+
+ if (buf->pos + size > buf->total_len)
+ bop_buffer_grow (buf, buf->pos + size);
+
+ memcpy (buf->buffer + buf->pos, data, size);
+ buf->pos += size;
+ buf->len = (buf->len > buf->pos) ? buf->len : buf->pos;
+}
+
+static off_t
+bop_seek (SCM port, off_t offset, int whence)
+#define FUNC_NAME "bop_seek"
+{
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+ switch (whence)
+ {
+ case SEEK_CUR:
+ offset += (off_t) buf->pos;
+ /* Fall through. */
+
+ case SEEK_SET:
+ if (offset < 0 || (unsigned) offset > buf->len)
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ else
+ buf->pos = offset;
+ break;
+
+ case SEEK_END:
+ if (offset < 0 || (unsigned) offset >= buf->len)
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ else
+ buf->pos = buf->len - (offset + 1);
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "invalid `seek' parameter");
+ }
+
+ return buf->pos;
+}
+#undef FUNC_NAME
+
+/* Fetch data from a bop. */
+SCM_SMOB_APPLY (bytevector_output_port_procedure,
+ bop_proc_apply, 0, 0, 0, (SCM bop_proc))
+{
+ SCM port, bv;
+ scm_t_bop_buffer *buf, result_buf;
+
+ port = SCM_PACK (SCM_SMOB_DATA (bop_proc));
+ buf = SCM_BOP_BUFFER (port);
+
+ result_buf = *buf;
+ bop_buffer_init (buf);
+
+ if (result_buf.len == 0)
+ bv = scm_c_take_bytevector (NULL, 0);
+ else
+ {
+ if (result_buf.total_len > result_buf.len)
+ /* Shrink the buffer. */
+ result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer,
+ result_buf.total_len,
+ result_buf.len,
+ SCM_GC_BOP);
+
+ bv = scm_c_take_bytevector ((signed char *) result_buf.buffer,
+ result_buf.len);
+ }
+
+ return bv;
+}
+
+SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark,
+ bop_proc)
+{
+ /* Mark the port associated with BOP_PROC. */
+ return (SCM_PACK (SCM_SMOB_DATA (bop_proc)));
+}
+
+
+SCM_DEFINE (scm_open_bytevector_output_port,
+ "open-bytevector-output-port", 0, 1, 0,
+ (SCM transcoder),
+ "Return two values: an output port and a procedure. The latter "
+ "should be called with zero arguments to obtain a bytevector "
+ "containing the data accumulated by the port.")
+#define FUNC_NAME s_scm_open_bytevector_output_port
+{
+ if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
+ transcoders_not_implemented ();
+
+ return (make_bop ());
+}
+#undef FUNC_NAME
+
+static inline void
+initialize_bytevector_output_ports (void)
+{
+ bytevector_output_port_type =
+ scm_make_port_type ("r6rs-bytevector-output-port",
+ NULL, bop_write);
+
+ scm_set_port_seek (bytevector_output_port_type, bop_seek);
+ scm_set_port_free (bytevector_output_port_type, bop_free);
+}
+
+
+/* Custom binary output port ("cbop" for short). */
+
+static scm_t_bits custom_binary_output_port_type;
+
+/* Return the various procedures of PORT. */
+#define SCM_CBOP_WRITE_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
+
+
+static inline SCM
+make_cbop (SCM write_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc)
+{
+ SCM port, method_vector;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+
+ /* Store the various methods and bytevector in a vector. */
+ method_vector = scm_c_make_vector (4, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+
+ port = scm_new_port_table_entry (custom_binary_output_port_type);
+
+ /* Attach it the method vector. */
+ SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
+
+ /* Have the port directly access the buffer (bytevector). */
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = c_port->read_buf_size = 0;
+
+ /* Mark PORT as open, writable and unbuffered. */
+ SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
+
+ return port;
+}
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+cbop_write (SCM port, const void *data, size_t size)
+#define FUNC_NAME "cbop_write"
+{
+ long int c_result;
+ size_t c_written;
+ SCM bv, write_proc, result;
+
+ /* XXX: Allocating a new bytevector at each `write' call is inefficient,
+ but necessary since (1) we don't control the lifetime of the buffer
+ pointed to by DATA, and (2) the `write!' procedure could capture the
+ bytevector it is passed. */
+ bv = scm_c_make_bytevector (size);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size);
+
+ write_proc = SCM_CBOP_WRITE_PROC (port);
+
+ /* Since the `write' procedure of Guile's ports has type `void', it must
+ try hard to write exactly SIZE bytes, regardless of how many bytes the
+ sink can handle. */
+ for (c_written = 0;
+ c_written < size;
+ c_written += c_result)
+ {
+ result = scm_call_3 (write_proc, bv,
+ scm_from_size_t (c_written),
+ scm_from_size_t (size - c_written));
+
+ c_result = scm_to_long (result);
+ if (SCM_UNLIKELY (c_result < 0
+ || (size_t) c_result > (size - c_written)))
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, result,
+ "R6RS custom binary output port `write!' "
+ "returned a incorrect integer");
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_custom_binary_output_port,
+ "make-custom-binary-output-port", 5, 0, 0,
+ (SCM id, SCM write_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc),
+ "Return a new custom binary output port whose output is drained "
+ "by invoking @var{write_proc} and passing it a bytevector, an "
+ "index where octets should be written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_output_port
+{
+ SCM_VALIDATE_STRING (1, id);
+ SCM_VALIDATE_PROC (2, write_proc);
+
+ if (!scm_is_false (get_position_proc))
+ SCM_VALIDATE_PROC (3, get_position_proc);
+
+ if (!scm_is_false (set_position_proc))
+ SCM_VALIDATE_PROC (4, set_position_proc);
+
+ if (!scm_is_false (close_proc))
+ SCM_VALIDATE_PROC (5, close_proc);
+
+ return (make_cbop (write_proc, get_position_proc, set_position_proc,
+ close_proc));
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the custom binary output port type. */
+static inline void
+initialize_custom_binary_output_ports (void)
+{
+ custom_binary_output_port_type =
+ scm_make_port_type ("r6rs-custom-binary-output-port",
+ NULL, cbop_write);
+
+ scm_set_port_mark (custom_binary_output_port_type, cbp_mark);
+ scm_set_port_seek (custom_binary_output_port_type, cbp_seek);
+ scm_set_port_close (custom_binary_output_port_type, cbp_close);
+}
+
+
+/* Initialization. */
+
+void
+scm_init_r6rs_ports (void)
+{
+#include "r6rs-ports.x"
+
+ initialize_bytevector_input_ports ();
+ initialize_custom_binary_input_ports ();
+ initialize_bytevector_output_ports ();
+ initialize_custom_binary_output_ports ();
+}
diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h
new file mode 100644
index 0000000..e29d962
--- /dev/null
+++ b/libguile/r6rs-ports.h
@@ -0,0 +1,43 @@
+#ifndef SCM_R6RS_PORTS_H
+#define SCM_R6RS_PORTS_H
+
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+
+/* R6RS I/O Ports. */
+
+SCM_API SCM scm_eof_object (void);
+SCM_API SCM scm_open_bytevector_input_port (SCM, SCM);
+SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_u8 (SCM);
+SCM_API SCM scm_lookahead_u8 (SCM);
+SCM_API SCM scm_get_bytevector_n (SCM, SCM);
+SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_bytevector_some (SCM);
+SCM_API SCM scm_get_bytevector_all (SCM);
+SCM_API SCM scm_put_u8 (SCM, SCM);
+SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_open_bytevector_output_port (SCM);
+SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM);
+
+SCM_API void scm_init_r6rs_ports (void);
+
+#endif /* SCM_R6RS_PORTS_H */
diff --git a/libguile/read.c b/libguile/read.c
index 47b8004..3493ba0 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -182,6 +182,7 @@ static SCM *scm_read_hash_procedures;
/* Read an SCSH block comment. */
static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
+static SCM scm_read_commented_expression (int chr, SCM port);
/* Read from PORT until a delimiter (e.g., a whitespace) is read. Return
zero if the whole token fits in BUF, non-zero otherwise. */
@@ -257,6 +258,9 @@ flush_ws (SCM port, const char *eoferr)
case '!':
scm_read_scsh_block_comment (c, port);
break;
+ case ';':
+ scm_read_commented_expression (c, port);
+ break;
default:
scm_ungetc (c, port);
return '#';
@@ -552,12 +556,21 @@ scm_read_mixed_case_symbol (int chr, SCM port)
if (scm_is_pair (str))
{
+ size_t len;
+
str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
- result = scm_string_to_symbol (str);
+ len = scm_c_string_length (str);
/* Per SRFI-88, `:' alone is an identifier, not a keyword. */
- if (postfix && ends_with_colon && (scm_c_string_length (result) > 1))
- result = scm_symbol_to_keyword (result);
+ 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);
}
else
{
@@ -691,6 +704,65 @@ scm_read_quote (int chr, SCM port)
return p;
}
+SCM_SYMBOL (sym_syntax, "syntax");
+SCM_SYMBOL (sym_quasisyntax, "quasisyntax");
+SCM_SYMBOL (sym_unsyntax, "unsyntax");
+SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing");
+
+static SCM
+scm_read_syntax (int chr, SCM port)
+{
+ SCM p;
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+
+ switch (chr)
+ {
+ case '`':
+ p = sym_quasisyntax;
+ break;
+
+ case '\'':
+ p = sym_syntax;
+ break;
+
+ case ',':
+ {
+ int c;
+
+ c = scm_getc (port);
+ if ('@' == c)
+ p = sym_unsyntax_splicing;
+ else
+ {
+ scm_ungetc (c, port);
+ p = sym_unsyntax;
+ }
+ break;
+ }
+
+ default:
+ fprintf (stderr, "%s: unhandled syntax character (%i)\n",
+ "scm_read_syntax", chr);
+ abort ();
+ }
+
+ p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
+ if (SCM_RECORD_POSITIONS_P)
+ scm_whash_insert (scm_source_whash, p,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
+
+
+ return p;
+}
+
static inline SCM
scm_read_semicolon_comment (int chr, SCM port)
{
@@ -854,6 +926,20 @@ scm_read_scsh_block_comment (int chr, SCM port)
}
static SCM
+scm_read_commented_expression (int chr, SCM port)
+{
+ int c;
+
+ c = flush_ws (port, (char *) NULL);
+ if (EOF == c)
+ scm_i_input_error ("read_commented_expression", port,
+ "no expression after #; comment", SCM_EOL);
+ scm_ungetc (c, port);
+ scm_read_expression (port);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
scm_read_extended_symbol (int chr, SCM port)
{
/* Guile's extended symbol read syntax looks like this:
@@ -1014,6 +1100,12 @@ scm_read_sharp (int chr, SCM port)
return (scm_read_extended_symbol (chr, port));
case '!':
return (scm_read_scsh_block_comment (chr, port));
+ case ';':
+ return (scm_read_commented_expression (chr, port));
+ case '`':
+ case '\'':
+ case ',':
+ return (scm_read_syntax (chr, port));
default:
result = scm_read_sharp_extension (chr, port);
if (scm_is_eq (result, SCM_UNSPECIFIED))
diff --git a/libguile/stime.c b/libguile/stime.c
index 34c8a98..5384783 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -77,10 +77,6 @@
# include <sys/timeb.h>
#endif
-#if HAVE_CRT_EXTERNS_H
-#include <crt_externs.h> /* for Darwin _NSGetEnviron */
-#endif
-
#ifndef tzname /* For SGI. */
extern char *tzname[]; /* RS6000 and others reject char **tzname. */
#endif
@@ -98,15 +94,6 @@ extern char *strptime ();
# define timet long
#endif
-extern char ** environ;
-
-/* On Apple Darwin in a shared library there's no "environ" to access
- directly, instead the address of that variable must be obtained with
- _NSGetEnviron(). */
-#if HAVE__NSGETENVIRON && defined (PIC)
-#define environ (*_NSGetEnviron())
-#endif
-
#ifdef HAVE_TIMES
static
diff --git a/libguile/strings.c b/libguile/strings.c
index c138026..012e08b 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1069,7 +1069,7 @@ scm_i_deprecated_string_chars (SCM str)
"SCM_STRING_CHARS does not work with shared substrings.",
SCM_EOL);
- /* We explicitely test for read-only strings to produce a better
+ /* We explicitly test for read-only strings to produce a better
error message.
*/
diff --git a/libguile/threads.c b/libguile/threads.c
index bb874e2..d63c619 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -1161,6 +1161,16 @@ SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2,
0,
scm_i_pthread_mutex_unlock (&t->admin_mutex);
SCM_TICK;
scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
+
+ /* Check for exit again, since we just released and
+ reacquired the admin mutex, before the next block_self
+ call (which would block forever if t has already
+ exited). */
+ if (t->exited)
+ {
+ res = t->result;
+ break;
+ }
}
}
@@ -1491,6 +1501,7 @@ fat_mutex_unlock (SCM mutex, SCM cond,
{
if (relock)
scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner);
+ t->block_asyncs--;
break;
}
diff --git a/libguile/validate.h b/libguile/validate.h
index e05b7dd..c362c02 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -3,7 +3,7 @@
#ifndef SCM_VALIDATE_H
#define SCM_VALIDATE_H
-/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007 Free Software
Foundation, Inc.
+/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 Free Software
Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -150,6 +150,9 @@
cvar = scm_to_bool (flag); \
} while (0)
+#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj) \
+ SCM_VALIDATE_SMOB ((_pos), (_obj), bytevector)
+
#define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP,
"character")
#define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \
diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h
index beecf0f..587766a 100644
--- a/libguile/vm-bootstrap.h
+++ b/libguile/vm-bootstrap.h
@@ -1,48 +1,24 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_VM_BOOTSTRAP_H_
#define _SCM_VM_BOOTSTRAP_H_
-extern void scm_bootstrap_vm (void);
+SCM_INTERNAL void scm_bootstrap_vm (void);
#endif /* _SCM_VM_BOOTSTRAP_H_ */
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 45251fd..f43f8c7 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
/* This file is included in vm.c multiple times */
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 6bb2354..8c919f6 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
/* This file is included in vm_engine.c */
@@ -147,8 +123,12 @@
#ifdef VM_ENABLE_PARANOID_ASSERTIONS
#define CHECK_IP() \
do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
+#define ASSERT_BOUND(x) \
+ do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \
+ } while (0)
#else
#define CHECK_IP()
+#define ASSERT_BOUND(x)
#endif
/* Get a local copy of the program's "object table" (i.e. the vector of
diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h
index 7ad2b9d..02dfbc4 100644
--- a/libguile/vm-expand.h
+++ b/libguile/vm-expand.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef VM_LABEL
#define VM_LABEL(tag) l_##tag
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 4af6026..38dea32 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
/* This file is included in vm_engine.c */
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 5468604..42f2b19 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -230,6 +230,7 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0,
1)
VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
{
PUSH (LOCAL_REF (FETCH ()));
+ ASSERT_BOUND (*sp);
NEXT;
}
@@ -244,6 +245,7 @@ VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1,
0, 1)
}
CHECK_EXTERNAL(e);
PUSH (SCM_CAR (e));
+ ASSERT_BOUND (*sp);
NEXT;
}
@@ -408,12 +410,6 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set",
1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1)
-{
- PUSH (external);
- NEXT;
-}
-
/*
* branch and jump
diff --git a/libguile/vm.c b/libguile/vm.c
index 38d085c..081a691 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
@@ -46,6 +22,7 @@
#include <stdlib.h>
#include <alloca.h>
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"
#include "instructions.h"
diff --git a/libguile/vm.h b/libguile/vm.h
index 5c38f9f..2f2b617 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,43 +1,19 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
+ * This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
#ifndef _SCM_VM_H_
#define _SCM_VM_H_
@@ -78,37 +54,37 @@ struct scm_vm {
SCM trace_frame; /* a frame being traced */
};
-extern SCM scm_the_vm_fluid;
+SCM_API SCM scm_the_vm_fluid;
#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x)
#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm))
#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
-extern SCM scm_the_vm ();
-extern SCM scm_make_vm (void);
-extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
-extern SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
-extern SCM scm_vm_option_ref (SCM vm, SCM key);
-extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
-
-extern SCM scm_vm_version (void);
-extern SCM scm_the_vm (void);
-extern SCM scm_vm_p (SCM obj);
-extern SCM scm_vm_ip (SCM vm);
-extern SCM scm_vm_sp (SCM vm);
-extern SCM scm_vm_fp (SCM vm);
-extern SCM scm_vm_boot_hook (SCM vm);
-extern SCM scm_vm_halt_hook (SCM vm);
-extern SCM scm_vm_next_hook (SCM vm);
-extern SCM scm_vm_break_hook (SCM vm);
-extern SCM scm_vm_enter_hook (SCM vm);
-extern SCM scm_vm_apply_hook (SCM vm);
-extern SCM scm_vm_exit_hook (SCM vm);
-extern SCM scm_vm_return_hook (SCM vm);
-extern SCM scm_vm_option (SCM vm, SCM key);
-extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
-extern SCM scm_vm_stats (SCM vm);
-extern SCM scm_vm_trace_frame (SCM vm);
+SCM_API SCM scm_the_vm ();
+SCM_API SCM scm_make_vm (void);
+SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
+SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
+SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
+SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
+
+SCM_API SCM scm_vm_version (void);
+SCM_API SCM scm_the_vm (void);
+SCM_API SCM scm_vm_p (SCM obj);
+SCM_API SCM scm_vm_ip (SCM vm);
+SCM_API SCM scm_vm_sp (SCM vm);
+SCM_API SCM scm_vm_fp (SCM vm);
+SCM_API SCM scm_vm_boot_hook (SCM vm);
+SCM_API SCM scm_vm_halt_hook (SCM vm);
+SCM_API SCM scm_vm_next_hook (SCM vm);
+SCM_API SCM scm_vm_break_hook (SCM vm);
+SCM_API SCM scm_vm_enter_hook (SCM vm);
+SCM_API SCM scm_vm_apply_hook (SCM vm);
+SCM_API SCM scm_vm_exit_hook (SCM vm);
+SCM_API SCM scm_vm_return_hook (SCM vm);
+SCM_API SCM scm_vm_option (SCM vm, SCM key);
+SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
+SCM_API SCM scm_vm_stats (SCM vm);
+SCM_API SCM scm_vm_trace_frame (SCM vm);
struct scm_vm_cont {
scm_byte_t *ip;
@@ -119,16 +95,16 @@ struct scm_vm_cont {
scm_t_ptrdiff reloc;
};
-extern scm_t_bits scm_tc16_vm_cont;
+SCM_API scm_t_bits scm_tc16_vm_cont;
#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
-extern SCM scm_vm_capture_continuations (void);
-extern void scm_vm_reinstate_continuations (SCM conts);
+SCM_API SCM scm_vm_capture_continuations (void);
+SCM_API void scm_vm_reinstate_continuations (SCM conts);
-extern SCM scm_load_compiled_with_vm (SCM file);
+SCM_API SCM scm_load_compiled_with_vm (SCM file);
-extern void scm_init_vm (void);
+SCM_INTERNAL void scm_init_vm (void);
#endif /* _SCM_VM_H_ */
diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4
new file mode 100644
index 0000000..d4d04d1
--- /dev/null
+++ b/m4/00gnulib.m4
@@ -0,0 +1,30 @@
+# 00gnulib.m4 serial 2
+dnl Copyright (C) 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 This file must be named something that sorts before all other
+dnl gnulib-provided .m4 files. It is needed until such time as we can
+dnl assume Autoconf 2.64, with its improved AC_DEFUN_ONCE semantics.
+
+# AC_DEFUN_ONCE([NAME], VALUE)
+# ----------------------------
+# Define NAME to expand to VALUE on the first use (whether by direct
+# expansion, or by AC_REQUIRE), and to nothing on all subsequent uses.
+# Avoid bugs in AC_REQUIRE in Autoconf 2.63 and earlier. This
+# definition is slower than the version in Autoconf 2.64, because it
+# can only use interfaces that existed since 2.59; but it achieves the
+# same effect. Quoting is necessary to avoid confusing Automake.
+m4_version_prereq([2.63.263], [],
+[m4_define([AC][_DEFUN_ONCE],
+ [AC][_DEFUN([$1],
+ [AC_REQUIRE([_gl_DEFUN_ONCE([$1])],
+ [m4_indir([_gl_DEFUN_ONCE([$1])])])])]dnl
+[AC][_DEFUN([_gl_DEFUN_ONCE([$1])], [$2])])])
+
+# gl_00GNULIB
+# -----------
+# Witness macro that this file has been included. Needed to force
+# Automake to include this file prior to all other gnulib .m4 files.
+AC_DEFUN([gl_00GNULIB])
diff --git a/m4/alloca.m4 b/m4/alloca.m4
index 95f54a6..4b978e1 100644
--- a/m4/alloca.m4
+++ b/m4/alloca.m4
@@ -1,5 +1,5 @@
-# alloca.m4 serial 8
-dnl Copyright (C) 2002-2004, 2006, 2007 Free Software Foundation, Inc.
+# alloca.m4 serial 9
+dnl Copyright (C) 2002-2004, 2006, 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,
dnl with or without modifications, as long as this notice is preserved.
@@ -26,7 +26,7 @@ AC_DEFUN([gl_FUNC_ALLOCA],
])
if test $gl_cv_rpl_alloca = yes; then
dnl OK, alloca can be implemented through a compiler built-in.
- AC_DEFINE([HAVE_ALLOCA], 1,
+ AC_DEFINE([HAVE_ALLOCA], [1],
[Define to 1 if you have 'alloca' after including <alloca.h>,
a header that may be supplied by this distribution.])
ALLOCA_H=alloca.h
diff --git a/m4/byteswap.m4 b/m4/byteswap.m4
new file mode 100644
index 0000000..ad13f22
--- /dev/null
+++ b/m4/byteswap.m4
@@ -0,0 +1,18 @@
+# byteswap.m4 serial 3
+dnl Copyright (C) 2005, 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,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl Written by Oskar Liljeblad.
+
+AC_DEFUN([gl_BYTESWAP],
+[
+ dnl Prerequisites of lib/byteswap.in.h.
+ AC_CHECK_HEADERS([byteswap.h], [
+ BYTESWAP_H=''
+ ], [
+ BYTESWAP_H='byteswap.h'
+ ])
+ AC_SUBST([BYTESWAP_H])
+])
diff --git a/m4/codeset.m4 b/m4/codeset.m4
index de4181d..413217b 100644
--- a/m4/codeset.m4
+++ b/m4/codeset.m4
@@ -1,5 +1,5 @@
-# codeset.m4 serial 3 (gettext-0.18)
-dnl Copyright (C) 2000-2002, 2006, 2008 Free Software Foundation, Inc.
+# codeset.m4 serial 4 (gettext-0.18)
+dnl Copyright (C) 2000-2002, 2006, 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.
@@ -15,7 +15,7 @@ AC_DEFUN([AM_LANGINFO_CODESET],
[am_cv_langinfo_codeset=no])
])
if test $am_cv_langinfo_codeset = yes; then
- AC_DEFINE([HAVE_LANGINFO_CODESET], 1,
+ AC_DEFINE([HAVE_LANGINFO_CODESET], [1],
[Define if you have <langinfo.h> and nl_langinfo(CODESET).])
fi
])
diff --git a/m4/environ.m4 b/m4/environ.m4
new file mode 100644
index 0000000..b17bb60
--- /dev/null
+++ b/m4/environ.m4
@@ -0,0 +1,36 @@
+# environ.m4 serial 2
+dnl Copyright (C) 2001-2004, 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,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_ENVIRON],
+[
+ AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
+ dnl Persuade glibc <unistd.h> to declare environ.
+ AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+ gt_CHECK_VAR_DECL([#include <unistd.h>], environ)
+ if test $gt_cv_var_environ_declaration != yes; then
+ HAVE_DECL_ENVIRON=0
+ fi
+])
+
+# Check if a variable is properly declared.
+# gt_CHECK_VAR_DECL(includes,variable)
+AC_DEFUN([gt_CHECK_VAR_DECL],
+[
+ define([gt_cv_var], [gt_cv_var_]$2[_declaration])
+ AC_MSG_CHECKING([if $2 is properly declared])
+ AC_CACHE_VAL([gt_cv_var], [
+ AC_TRY_COMPILE([$1
+ extern struct { int foo; } $2;],
+ [$2.foo = 1;],
+ gt_cv_var=no,
+ gt_cv_var=yes)])
+ AC_MSG_RESULT([$gt_cv_var])
+ if test $gt_cv_var = yes; then
+ AC_DEFINE([HAVE_]translit($2, [a-z], [A-Z])[_DECL], 1,
+ [Define if you have the declaration of $2.])
+ fi
+ undefine([gt_cv_var])
+])
diff --git a/m4/extensions.m4 b/m4/extensions.m4
index 611fcfd..ba6d5e1 100644
--- a/m4/extensions.m4
+++ b/m4/extensions.m4
@@ -1,7 +1,7 @@
-# serial 6 -*- Autoconf -*-
+# serial 8 -*- Autoconf -*-
# Enable extensions on systems that normally disable them.
-# Copyright (C) 2003, 2006-2008 Free Software Foundation, Inc.
+# Copyright (C) 2003, 2006-2009 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
@@ -20,7 +20,7 @@
# AC_DEFINE. The goal here is to define all known feature-enabling
# macros, then, if reports of conflicts are made, disable macros that
# cause problems on some platforms (such as __EXTENSIONS__).
-AC_DEFUN([AC_USE_SYSTEM_EXTENSIONS],
+AC_DEFUN_ONCE([AC_USE_SYSTEM_EXTENSIONS],
[AC_BEFORE([$0], [AC_COMPILE_IFELSE])dnl
AC_BEFORE([$0], [AC_RUN_IFELSE])dnl
@@ -90,5 +90,15 @@ AC_BEFORE([$0], [AC_RUN_IFELSE])dnl
# ------------------------
# Enable extensions on systems that normally disable them,
# typically due to standards-conformance issues.
-AC_DEFUN([gl_USE_SYSTEM_EXTENSIONS],
- [AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])])
+AC_DEFUN_ONCE([gl_USE_SYSTEM_EXTENSIONS],
+[
+ dnl Require this macro before AC_USE_SYSTEM_EXTENSIONS.
+ dnl gnulib does not need it. But if it gets required by third-party macros
+ dnl after AC_USE_SYSTEM_EXTENSIONS is required, autoconf 2.62..2.63 emit a
+ dnl warning: "AC_COMPILE_IFELSE was called before AC_USE_SYSTEM_EXTENSIONS".
+ dnl Note: We can do this only for one of the macros AC_AIX, AC_GNU_SOURCE,
+ dnl AC_MINIX. If people still use AC_AIX or AC_MINIX, they are out of luck.
+ AC_REQUIRE([AC_GNU_SOURCE])
+
+ AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS])
+])
diff --git a/m4/flock.m4 b/m4/flock.m4
new file mode 100644
index 0000000..96475fc
--- /dev/null
+++ b/m4/flock.m4
@@ -0,0 +1,26 @@
+# flock.m4 serial 1
+dnl Copyright (C) 2008 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.
+
+AC_DEFUN([gl_FUNC_FLOCK],
+[
+ AC_REQUIRE([gl_HEADER_SYS_FILE_H_DEFAULTS])
+ AC_CHECK_FUNCS_ONCE([flock])
+ if test $ac_cv_func_flock = no; then
+ HAVE_FLOCK=0
+ AC_LIBOBJ([flock])
+ gl_PREREQ_FLOCK
+ fi
+])
+
+dnl Prerequisites of lib/flock.c.
+AC_DEFUN([gl_PREREQ_FLOCK],
+[
+ AC_CHECK_FUNCS_ONCE([fcntl])
+ AC_CHECK_HEADERS_ONCE([unistd.h fcntl.h])
+
+ dnl Do we have a POSIX fcntl lock implementation?
+ AC_CHECK_MEMBERS([struct flock.l_type],[],[],[[#include <fcntl.h>]])
+])
diff --git a/m4/fpieee.m4 b/m4/fpieee.m4
new file mode 100644
index 0000000..9f4a92c
--- /dev/null
+++ b/m4/fpieee.m4
@@ -0,0 +1,52 @@
+# fpieee.m4 serial 1
+dnl Copyright (C) 2007 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 IEEE 754 standardized three items:
+dnl - The formats of single-float and double-float - nowadays commonly
+dnl available as 'float' and 'double' in C and C++.
+dnl No autoconf test needed.
+dnl - The overflow and division by zero behaviour: The result are values
+dnl '±Inf' and 'NaN', rather than exceptions as it was before.
+dnl This file provides an autoconf macro for ensuring this behaviour of
+dnl floating-point operations.
+dnl - A set of conditions (overflow, underflow, inexact, etc.) which can
+dnl be configured to trigger an exception.
+dnl This cannot be done in a portable way: it depends on the compiler,
+dnl libc, kernel, and CPU. No autoconf macro is provided for this.
+
+dnl Ensure non-trapping behaviour of floating-point overflow and
+dnl floating-point division by zero.
+dnl (For integer overflow, see gcc's -ftrapv option; for integer division by
+dnl zero, see the autoconf macro in intdiv0.m4.)
+
+AC_DEFUN([gl_FP_IEEE],
+[
+ AC_REQUIRE([AC_PROG_CC])
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ # IEEE behaviour is the default on all CPUs except Alpha and SH
+ # (according to the test results of Bruno Haible's ieeefp/fenv_default.m4
+ # and the GCC 4.1.2 manual).
+ case "$host_cpu" in
+ alpha*)
+ # On Alpha systems, a compiler option provides the behaviour.
+ # See the ieee(3) manual page, also available at
+ #
<http://h30097.www3.hp.com/docs/base_doc/DOCUMENTATION/V51B_HTML/MAN/MAN3/0600____.HTM>
+ if test -n "$GCC"; then
+ # GCC has the option -mieee.
+ CPPFLAGS="$CPPFLAGS -mieee"
+ else
+ # Compaq (ex-DEC) C has the option -ieee.
+ CPPFLAGS="$CPPFLAGS -ieee"
+ fi
+ ;;
+ sh*)
+ if test -n "$GCC"; then
+ # GCC has the option -mieee.
+ CPPFLAGS="$CPPFLAGS -mieee"
+ fi
+ ;;
+ esac
+])
diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4
index 5781d1d..0fbe119 100644
--- a/m4/gnulib-cache.m4
+++ b/m4/gnulib-cache.m4
@@ -15,19 +15,30 @@
# 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 count-one-bits extensions
full-read full-write strcase strftime
+# 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 count-one-bits
environ extensions flock fpieee full-read full-write iconv_open-utf
lib-symbol-visibility libunistring putenv stdlib strcase strftime striconveh
string
# Specification in the form of a few gnulib-tool.m4 macro invocations:
gl_LOCAL_DIR([])
gl_MODULES([
alloca-opt
autobuild
+ byteswap
count-one-bits
+ environ
extensions
+ flock
+ fpieee
full-read
full-write
+ iconv_open-utf
+ lib-symbol-visibility
+ libunistring
+ putenv
+ stdlib
strcase
strftime
+ striconveh
+ string
])
gl_AVOID([])
gl_SOURCE_BASE([lib])
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4
index c73db14..c8fda20 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -1,5 +1,5 @@
-# gnulib-common.m4 serial 6
-dnl Copyright (C) 2007-2008 Free Software Foundation, Inc.
+# gnulib-common.m4 serial 11
+dnl Copyright (C) 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,
dnl with or without modifications, as long as this notice is preserved.
@@ -8,6 +8,7 @@ dnl with or without modifications, as long as this notice is
preserved.
# is expanded unconditionally through gnulib-tool magic.
AC_DEFUN([gl_COMMON], [
dnl Use AC_REQUIRE here, so that the code is expanded once only.
+ AC_REQUIRE([gl_00GNULIB])
AC_REQUIRE([gl_COMMON_BODY])
])
AC_DEFUN([gl_COMMON_BODY], [
@@ -52,7 +53,7 @@ m4_ifndef([m4_foreach_w],
# is a backport of autoconf-2.60's AC_PROG_MKDIR_P.
# Remove this macro when we can assume autoconf >= 2.60.
m4_ifdef([AC_PROG_MKDIR_P], [], [
- AC_DEFUN([AC_PROG_MKDIR_P],
+ AC_DEFUN_ONCE([AC_PROG_MKDIR_P],
[AC_REQUIRE([AM_PROG_MKDIR_P])dnl defined by automake
MKDIR_P='$(mkdir_p)'
AC_SUBST([MKDIR_P])])])
@@ -63,7 +64,7 @@ m4_ifdef([AC_PROG_MKDIR_P], [], [
# works.
# This definition can be removed once autoconf >= 2.62 can be assumed.
AC_DEFUN([AC_C_RESTRICT],
-[AC_CACHE_CHECK([for C/C++ restrict keyword], ac_cv_c_restrict,
+[AC_CACHE_CHECK([for C/C++ restrict keyword], [ac_cv_c_restrict],
[ac_cv_c_restrict=no
# The order here caters to the fact that C++ does not require restrict.
for ac_kw in __restrict __restrict__ _Restrict restrict; do
@@ -99,3 +100,25 @@ AC_DEFUN([AC_C_RESTRICT],
*) AC_DEFINE_UNQUOTED([restrict], [$ac_cv_c_restrict]) ;;
esac
])
+
+# gl_BIGENDIAN
+# is like AC_C_BIGENDIAN, except that it can be AC_REQUIREd.
+# Note that AC_REQUIRE([AC_C_BIGENDIAN]) does not work reliably because some
+# macros invoke AC_C_BIGENDIAN with arguments.
+AC_DEFUN([gl_BIGENDIAN],
+[
+ AC_C_BIGENDIAN
+])
+
+# gl_CACHE_VAL_SILENT(cache-id, command-to-set-it)
+# is like AC_CACHE_VAL(cache-id, command-to-set-it), except that it does not
+# output a spurious "(cached)" mark in the midst of other configure output.
+# This macro should be used instead of AC_CACHE_VAL when it is not surrounded
+# by an AC_MSG_CHECKING/AC_MSG_RESULT pair.
+AC_DEFUN([gl_CACHE_VAL_SILENT],
+[
+ saved_as_echo_n="$as_echo_n"
+ as_echo_n=':'
+ AC_CACHE_VAL([$1], [$2])
+ as_echo_n="$saved_as_echo_n"
+])
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index 5e9ce99..8f77510 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -25,8 +25,10 @@ AC_DEFUN([gl_EARLY],
m4_pattern_allow([^gl_LIBOBJS$])dnl a variable
m4_pattern_allow([^gl_LTLIBOBJS$])dnl a variable
AC_REQUIRE([AC_PROG_RANLIB])
+ AC_REQUIRE([AM_PROG_CC_C_O])
AB_INIT
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+ AC_REQUIRE([gl_FP_IEEE])
])
# This macro should be invoked from ./configure.in, in the section
@@ -43,27 +45,56 @@ AC_DEFUN([gl_INIT],
gl_COMMON
gl_source_base='lib'
gl_FUNC_ALLOCA
+ gl_BYTESWAP
gl_COUNT_ONE_BITS
+ gl_ENVIRON
+ gl_UNISTD_MODULE_INDICATOR([environ])
+ gl_FUNC_FLOCK
+ gl_HEADER_SYS_FILE_MODULE_INDICATOR([flock])
+ AM_ICONV
+ gl_ICONV_H
+ gl_FUNC_ICONV_OPEN
+ gl_FUNC_ICONV_OPEN_UTF
gl_INLINE
+ gl_VISIBILITY
+ gl_LIBUNISTRING
gl_LOCALCHARSET
LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(top_builddir)/$gl_source_base\""
AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT])
+ gl_FUNC_MALLOC_POSIX
+ gl_STDLIB_MODULE_INDICATOR([malloc-posix])
gl_FUNC_MBRLEN
gl_WCHAR_MODULE_INDICATOR([mbrlen])
gl_FUNC_MBRTOWC
gl_WCHAR_MODULE_INDICATOR([mbrtowc])
gl_FUNC_MBSINIT
gl_WCHAR_MODULE_INDICATOR([mbsinit])
+ gl_MULTIARCH
+ gl_FUNC_PUTENV
+ gl_STDLIB_MODULE_INDICATOR([putenv])
gl_SAFE_READ
gl_SAFE_WRITE
gt_TYPE_SSIZE_T
AM_STDBOOL_H
+ gl_STDINT_H
+ gl_STDLIB_H
gl_STRCASE
gl_FUNC_GNU_STRFTIME
+ if test $gl_cond_libtool = false; then
+ gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV"
+ gl_libdeps="$gl_libdeps $LIBICONV"
+ fi
+ gl_HEADER_STRING_H
gl_HEADER_STRINGS_H
+ gl_HEADER_SYS_FILE_H
+ AC_PROG_MKDIR_P
gl_HEADER_TIME_H
gl_TIME_R
gl_UNISTD_H
+ gl_MODULE_INDICATOR([unistr/u8-mbtouc])
+ gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe])
+ gl_MODULE_INDICATOR([unistr/u8-mbtoucr])
+ gl_MODULE_INDICATOR([unistr/u8-uctomb])
gl_WCHAR_H
gl_FUNC_WRITE
gl_UNISTD_MODULE_INDICATOR([write])
@@ -195,19 +226,39 @@ AC_DEFUN([gltests_LIBSOURCES], [
# This macro records the list of files which have been installed by
# gnulib-tool and may be removed by future gnulib-tool invocations.
AC_DEFUN([gl_FILE_LIST], [
+ build-aux/config.rpath
build-aux/link-warning.h
lib/alloca.in.h
+ lib/byteswap.in.h
+ lib/c-ctype.c
+ lib/c-ctype.h
+ lib/c-strcase.h
+ lib/c-strcasecmp.c
+ lib/c-strcaseeq.h
+ lib/c-strncasecmp.c
lib/config.charset
lib/count-one-bits.h
+ lib/flock.c
lib/full-read.c
lib/full-read.h
lib/full-write.c
lib/full-write.h
+ lib/iconv.c
+ lib/iconv.in.h
+ lib/iconv_close.c
+ lib/iconv_open-aix.gperf
+ lib/iconv_open-hpux.gperf
+ lib/iconv_open-irix.gperf
+ lib/iconv_open-osf.gperf
+ lib/iconv_open.c
+ lib/iconveh.h
lib/localcharset.c
lib/localcharset.h
+ lib/malloc.c
lib/mbrlen.c
lib/mbrtowc.c
lib/mbsinit.c
+ lib/putenv.c
lib/ref-add.sin
lib/ref-del.sin
lib/safe-read.c
@@ -215,46 +266,83 @@ AC_DEFUN([gl_FILE_LIST], [
lib/safe-write.c
lib/safe-write.h
lib/stdbool.in.h
+ lib/stdint.in.h
+ lib/stdlib.in.h
lib/strcasecmp.c
lib/streq.h
lib/strftime.c
lib/strftime.h
+ lib/striconveh.c
+ lib/striconveh.h
+ lib/string.in.h
lib/strings.in.h
lib/strncasecmp.c
+ lib/sys_file.in.h
lib/time.in.h
lib/time_r.c
lib/unistd.in.h
+ lib/unistr.h
+ lib/unistr/u8-mbtouc-aux.c
+ lib/unistr/u8-mbtouc-unsafe-aux.c
+ lib/unistr/u8-mbtouc-unsafe.c
+ lib/unistr/u8-mbtouc.c
+ lib/unistr/u8-mbtoucr.c
+ lib/unistr/u8-prev.c
+ lib/unistr/u8-uctomb-aux.c
+ lib/unistr/u8-uctomb.c
+ lib/unitypes.h
lib/verify.h
lib/wchar.in.h
lib/write.c
+ m4/00gnulib.m4
m4/alloca.m4
m4/autobuild.m4
+ m4/byteswap.m4
m4/codeset.m4
m4/count-one-bits.m4
+ m4/environ.m4
m4/extensions.m4
+ m4/flock.m4
+ m4/fpieee.m4
m4/glibc21.m4
m4/gnulib-common.m4
+ m4/iconv.m4
+ m4/iconv_h.m4
+ m4/iconv_open.m4
m4/include_next.m4
m4/inline.m4
+ m4/lib-ld.m4
+ m4/lib-link.m4
+ m4/lib-prefix.m4
+ m4/libunistring.m4
m4/localcharset.m4
m4/locale-fr.m4
m4/locale-ja.m4
m4/locale-zh.m4
+ m4/longlong.m4
+ m4/malloc.m4
m4/mbrlen.m4
m4/mbrtowc.m4
m4/mbsinit.m4
m4/mbstate_t.m4
+ m4/multiarch.m4
+ m4/putenv.m4
m4/safe-read.m4
m4/safe-write.m4
m4/ssize_t.m4
m4/stdbool.m4
+ m4/stdint.m4
+ m4/stdlib_h.m4
m4/strcase.m4
m4/strftime.m4
+ m4/string_h.m4
m4/strings_h.m4
+ m4/sys_file_h.m4
m4/time_h.m4
m4/time_r.m4
m4/tm_gmtoff.m4
m4/unistd_h.m4
+ m4/visibility.m4
m4/wchar.m4
m4/wint_t.m4
m4/write.m4
diff --git a/m4/iconv.m4 b/m4/iconv.m4
new file mode 100644
index 0000000..3cc6268
--- /dev/null
+++ b/m4/iconv.m4
@@ -0,0 +1,180 @@
+# iconv.m4 serial AM7 (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,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl From Bruno Haible.
+
+AC_DEFUN([AM_ICONV_LINKFLAGS_BODY],
+[
+ dnl Prerequisites of AC_LIB_LINKFLAGS_BODY.
+ AC_REQUIRE([AC_LIB_PREPARE_PREFIX])
+ AC_REQUIRE([AC_LIB_RPATH])
+
+ dnl Search for libiconv and define LIBICONV, LTLIBICONV and INCICONV
+ dnl accordingly.
+ AC_LIB_LINKFLAGS_BODY([iconv])
+])
+
+AC_DEFUN([AM_ICONV_LINK],
+[
+ dnl Some systems have iconv in libc, some have it in libiconv (OSF/1 and
+ dnl those with the standalone portable GNU libiconv installed).
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+
+ dnl Search for libiconv and define LIBICONV, LTLIBICONV and INCICONV
+ dnl accordingly.
+ AC_REQUIRE([AM_ICONV_LINKFLAGS_BODY])
+
+ dnl Add $INCICONV to CPPFLAGS before performing the following checks,
+ dnl because if the user has installed libiconv and not disabled its use
+ dnl via --without-libiconv-prefix, he wants to use it. The first
+ dnl AC_TRY_LINK will then fail, the second AC_TRY_LINK will succeed.
+ am_save_CPPFLAGS="$CPPFLAGS"
+ AC_LIB_APPENDTOVAR([CPPFLAGS], [$INCICONV])
+
+ AC_CACHE_CHECK([for iconv], [am_cv_func_iconv], [
+ am_cv_func_iconv="no, consider installing GNU libiconv"
+ am_cv_lib_iconv=no
+ AC_TRY_LINK([#include <stdlib.h>
+#include <iconv.h>],
+ [iconv_t cd = iconv_open("","");
+ iconv(cd,NULL,NULL,NULL,NULL);
+ iconv_close(cd);],
+ [am_cv_func_iconv=yes])
+ if test "$am_cv_func_iconv" != yes; then
+ am_save_LIBS="$LIBS"
+ LIBS="$LIBS $LIBICONV"
+ AC_TRY_LINK([#include <stdlib.h>
+#include <iconv.h>],
+ [iconv_t cd = iconv_open("","");
+ iconv(cd,NULL,NULL,NULL,NULL);
+ iconv_close(cd);],
+ [am_cv_lib_iconv=yes]
+ [am_cv_func_iconv=yes])
+ LIBS="$am_save_LIBS"
+ fi
+ ])
+ if test "$am_cv_func_iconv" = yes; then
+ AC_CACHE_CHECK([for working iconv], [am_cv_func_iconv_works], [
+ dnl This tests against bugs in AIX 5.1 and HP-UX 11.11.
+ am_save_LIBS="$LIBS"
+ if test $am_cv_lib_iconv = yes; then
+ LIBS="$LIBS $LIBICONV"
+ fi
+ AC_TRY_RUN([
+#include <iconv.h>
+#include <string.h>
+int main ()
+{
+ /* Test against AIX 5.1 bug: Failures are not distinguishable from successful
+ returns. */
+ {
+ iconv_t cd_utf8_to_88591 = iconv_open ("ISO8859-1", "UTF-8");
+ if (cd_utf8_to_88591 != (iconv_t)(-1))
+ {
+ static const char input[] = "\342\202\254"; /* EURO SIGN */
+ char buf[10];
+ const char *inptr = input;
+ size_t inbytesleft = strlen (input);
+ char *outptr = buf;
+ size_t outbytesleft = sizeof (buf);
+ size_t res = iconv (cd_utf8_to_88591,
+ (char **) &inptr, &inbytesleft,
+ &outptr, &outbytesleft);
+ if (res == 0)
+ return 1;
+ }
+ }
+#if 0 /* This bug could be worked around by the caller. */
+ /* Test against HP-UX 11.11 bug: Positive return value instead of 0. */
+ {
+ iconv_t cd_88591_to_utf8 = iconv_open ("utf8", "iso88591");
+ if (cd_88591_to_utf8 != (iconv_t)(-1))
+ {
+ static const char input[] = "\304rger mit b\366sen B\374bchen ohne
Augenma\337";
+ char buf[50];
+ const char *inptr = input;
+ size_t inbytesleft = strlen (input);
+ char *outptr = buf;
+ size_t outbytesleft = sizeof (buf);
+ size_t res = iconv (cd_88591_to_utf8,
+ (char **) &inptr, &inbytesleft,
+ &outptr, &outbytesleft);
+ if ((int)res > 0)
+ return 1;
+ }
+ }
+#endif
+ /* Test against HP-UX 11.11 bug: No converter from EUC-JP to UTF-8 is
+ provided. */
+ if (/* Try standardized names. */
+ iconv_open ("UTF-8", "EUC-JP") == (iconv_t)(-1)
+ /* Try IRIX, OSF/1 names. */
+ && iconv_open ("UTF-8", "eucJP") == (iconv_t)(-1)
+ /* Try AIX names. */
+ && iconv_open ("UTF-8", "IBM-eucJP") == (iconv_t)(-1)
+ /* Try HP-UX names. */
+ && iconv_open ("utf8", "eucJP") == (iconv_t)(-1))
+ return 1;
+ return 0;
+}], [am_cv_func_iconv_works=yes], [am_cv_func_iconv_works=no],
+ [case "$host_os" in
+ aix* | hpux*) am_cv_func_iconv_works="guessing no" ;;
+ *) am_cv_func_iconv_works="guessing yes" ;;
+ esac])
+ LIBS="$am_save_LIBS"
+ ])
+ case "$am_cv_func_iconv_works" in
+ *no) am_func_iconv=no am_cv_lib_iconv=no ;;
+ *) am_func_iconv=yes ;;
+ esac
+ else
+ am_func_iconv=no am_cv_lib_iconv=no
+ fi
+ if test "$am_func_iconv" = yes; then
+ AC_DEFINE([HAVE_ICONV], [1],
+ [Define if you have the iconv() function and it works.])
+ fi
+ if test "$am_cv_lib_iconv" = yes; then
+ AC_MSG_CHECKING([how to link with libiconv])
+ AC_MSG_RESULT([$LIBICONV])
+ else
+ dnl If $LIBICONV didn't lead to a usable library, we don't need $INCICONV
+ dnl either.
+ CPPFLAGS="$am_save_CPPFLAGS"
+ LIBICONV=
+ LTLIBICONV=
+ fi
+ AC_SUBST([LIBICONV])
+ AC_SUBST([LTLIBICONV])
+])
+
+AC_DEFUN([AM_ICONV],
+[
+ AM_ICONV_LINK
+ if test "$am_cv_func_iconv" = yes; then
+ AC_MSG_CHECKING([for iconv declaration])
+ AC_CACHE_VAL([am_cv_proto_iconv], [
+ AC_TRY_COMPILE([
+#include <stdlib.h>
+#include <iconv.h>
+extern
+#ifdef __cplusplus
+"C"
+#endif
+#if defined(__STDC__) || defined(__cplusplus)
+size_t iconv (iconv_t cd, char * *inbuf, size_t *inbytesleft, char * *outbuf,
size_t *outbytesleft);
+#else
+size_t iconv();
+#endif
+], [], [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_DEFINE_UNQUOTED([ICONV_CONST], [$am_cv_proto_iconv_arg1],
+ [Define as const if the declaration of iconv() needs const.])
+ fi
+])
diff --git a/m4/iconv_h.m4 b/m4/iconv_h.m4
new file mode 100644
index 0000000..bc05b05
--- /dev/null
+++ b/m4/iconv_h.m4
@@ -0,0 +1,34 @@
+# iconv_h.m4 serial 4
+dnl Copyright (C) 2007-2008 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.
+
+AC_DEFUN([gl_ICONV_H],
+[
+ AC_REQUIRE([gl_ICONV_H_DEFAULTS])
+ gl_CHECK_NEXT_HEADERS([iconv.h])
+])
+
+dnl Unconditionally enables the replacement of <iconv.h>.
+AC_DEFUN([gl_REPLACE_ICONV_H],
+[
+ AC_REQUIRE([gl_ICONV_H_DEFAULTS])
+ ICONV_H='iconv.h'
+])
+
+AC_DEFUN([gl_ICONV_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_ICONV_H_DEFAULTS])
+
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_ICONV_H_DEFAULTS],
+[
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ REPLACE_ICONV=0; AC_SUBST([REPLACE_ICONV])
+ REPLACE_ICONV_OPEN=0; AC_SUBST([REPLACE_ICONV_OPEN])
+ REPLACE_ICONV_UTF=0; AC_SUBST([REPLACE_ICONV_UTF])
+ ICONV_H=''; AC_SUBST([ICONV_H])
+])
diff --git a/m4/iconv_open.m4 b/m4/iconv_open.m4
new file mode 100644
index 0000000..c7b948e
--- /dev/null
+++ b/m4/iconv_open.m4
@@ -0,0 +1,237 @@
+# iconv_open.m4 serial 5
+dnl Copyright (C) 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,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_FUNC_ICONV_OPEN],
+[
+ AC_REQUIRE([AM_ICONV])
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ AC_REQUIRE([gl_ICONV_H_DEFAULTS])
+ if test "$am_cv_func_iconv" = yes; then
+ dnl Test whether iconv_open accepts standardized encoding names.
+ dnl We know that GNU libiconv and GNU libc do.
+ AC_EGREP_CPP([gnu_iconv], [
+ #include <iconv.h>
+ #if defined _LIBICONV_VERSION || defined __GLIBC__
+ gnu_iconv
+ #endif
+ ], [gl_func_iconv_gnu=yes], [gl_func_iconv_gnu=no])
+ if test $gl_func_iconv_gnu = no; then
+ iconv_flavor=
+ case "$host_os" in
+ aix*) iconv_flavor=ICONV_FLAVOR_AIX ;;
+ irix*) iconv_flavor=ICONV_FLAVOR_IRIX ;;
+ hpux*) iconv_flavor=ICONV_FLAVOR_HPUX ;;
+ osf*) iconv_flavor=ICONV_FLAVOR_OSF ;;
+ esac
+ if test -n "$iconv_flavor"; then
+ AC_DEFINE_UNQUOTED([ICONV_FLAVOR], [$iconv_flavor],
+ [Define to a symbolic name denoting the flavor of iconv_open()
+ implementation.])
+ gl_REPLACE_ICONV_OPEN
+ fi
+ fi
+ fi
+])
+
+AC_DEFUN([gl_REPLACE_ICONV_OPEN],
+[
+ gl_REPLACE_ICONV_H
+ REPLACE_ICONV_OPEN=1
+ AC_LIBOBJ([iconv_open])
+])
+
+AC_DEFUN([gl_FUNC_ICONV_OPEN_UTF],
+[
+ AC_REQUIRE([gl_FUNC_ICONV_OPEN])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_REQUIRE([gl_ICONV_H_DEFAULTS])
+ if test "$am_cv_func_iconv" = yes; then
+ if test -n "$am_cv_proto_iconv_arg1"; then
+ ICONV_CONST="const"
+ else
+ ICONV_CONST=
+ fi
+ AC_SUBST([ICONV_CONST])
+ AC_CACHE_CHECK([whether iconv supports conversion between UTF-8 and
UTF-{16,32}{BE,LE}],
+ [gl_cv_func_iconv_supports_utf],
+ [
+ save_LIBS="$LIBS"
+ LIBS="$LIBS $LIBICONV"
+ AC_TRY_RUN([
+#include <iconv.h>
+#include <errno.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#define ASSERT(expr) if (!(expr)) return 1;
+int main ()
+{
+ /* Test conversion from UTF-8 to UTF-16BE with no errors. */
+ {
+ static const char input[] =
+ "Japanese (\346\227\245\346\234\254\350\252\236)
[\360\235\224\215\360\235\224\236\360\235\224\255]";
+ static const char expected[] =
+ "\000J\000a\000p\000a\000n\000e\000s\000e\000
\000(\145\345\147\054\212\236\000)\000
\000[\330\065\335\015\330\065\335\036\330\065\335\055\000]";
+ iconv_t cd;
+ char buf[100];
+ const char *inptr;
+ size_t inbytesleft;
+ char *outptr;
+ size_t outbytesleft;
+ size_t res;
+ cd = iconv_open ("UTF-16BE", "UTF-8");
+ ASSERT (cd != (iconv_t)(-1));
+ inptr = input;
+ inbytesleft = sizeof (input) - 1;
+ outptr = buf;
+ outbytesleft = sizeof (buf);
+ res = iconv (cd,
+ (ICONV_CONST char **) &inptr, &inbytesleft,
+ &outptr, &outbytesleft);
+ ASSERT (res == 0 && inbytesleft == 0);
+ ASSERT (outptr == buf + (sizeof (expected) - 1));
+ ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0);
+ ASSERT (iconv_close (cd) == 0);
+ }
+ /* Test conversion from UTF-8 to UTF-16LE with no errors. */
+ {
+ static const char input[] =
+ "Japanese (\346\227\245\346\234\254\350\252\236)
[\360\235\224\215\360\235\224\236\360\235\224\255]";
+ static const char expected[] =
+ "J\000a\000p\000a\000n\000e\000s\000e\000
\000(\000\345\145\054\147\236\212)\000
\000[\000\065\330\015\335\065\330\036\335\065\330\055\335]\000";
+ iconv_t cd;
+ char buf[100];
+ const char *inptr;
+ size_t inbytesleft;
+ char *outptr;
+ size_t outbytesleft;
+ size_t res;
+ cd = iconv_open ("UTF-16LE", "UTF-8");
+ ASSERT (cd != (iconv_t)(-1));
+ inptr = input;
+ inbytesleft = sizeof (input) - 1;
+ outptr = buf;
+ outbytesleft = sizeof (buf);
+ res = iconv (cd,
+ (ICONV_CONST char **) &inptr, &inbytesleft,
+ &outptr, &outbytesleft);
+ ASSERT (res == 0 && inbytesleft == 0);
+ ASSERT (outptr == buf + (sizeof (expected) - 1));
+ ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0);
+ ASSERT (iconv_close (cd) == 0);
+ }
+ /* Test conversion from UTF-8 to UTF-32BE with no errors. */
+ {
+ static const char input[] =
+ "Japanese (\346\227\245\346\234\254\350\252\236)
[\360\235\224\215\360\235\224\236\360\235\224\255]";
+ static const char expected[] =
+
"\000\000\000J\000\000\000a\000\000\000p\000\000\000a\000\000\000n\000\000\000e\000\000\000s\000\000\000e\000\000\000
\000\000\000(\000\000\145\345\000\000\147\054\000\000\212\236\000\000\000)\000\000\000
\000\000\000[\000\001\325\015\000\001\325\036\000\001\325\055\000\000\000]";
+ iconv_t cd;
+ char buf[100];
+ const char *inptr;
+ size_t inbytesleft;
+ char *outptr;
+ size_t outbytesleft;
+ size_t res;
+ cd = iconv_open ("UTF-32BE", "UTF-8");
+ ASSERT (cd != (iconv_t)(-1));
+ inptr = input;
+ inbytesleft = sizeof (input) - 1;
+ outptr = buf;
+ outbytesleft = sizeof (buf);
+ res = iconv (cd,
+ (ICONV_CONST char **) &inptr, &inbytesleft,
+ &outptr, &outbytesleft);
+ ASSERT (res == 0 && inbytesleft == 0);
+ ASSERT (outptr == buf + (sizeof (expected) - 1));
+ ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0);
+ ASSERT (iconv_close (cd) == 0);
+ }
+ /* Test conversion from UTF-8 to UTF-32LE with no errors. */
+ {
+ static const char input[] =
+ "Japanese (\346\227\245\346\234\254\350\252\236)
[\360\235\224\215\360\235\224\236\360\235\224\255]";
+ static const char expected[] =
+
"J\000\000\000a\000\000\000p\000\000\000a\000\000\000n\000\000\000e\000\000\000s\000\000\000e\000\000\000
\000\000\000(\000\000\000\345\145\000\000\054\147\000\000\236\212\000\000)\000\000\000
\000\000\000[\000\000\000\015\325\001\000\036\325\001\000\055\325\001\000]\000\000\000";
+ iconv_t cd;
+ char buf[100];
+ const char *inptr;
+ size_t inbytesleft;
+ char *outptr;
+ size_t outbytesleft;
+ size_t res;
+ cd = iconv_open ("UTF-32LE", "UTF-8");
+ ASSERT (cd != (iconv_t)(-1));
+ inptr = input;
+ inbytesleft = sizeof (input) - 1;
+ outptr = buf;
+ outbytesleft = sizeof (buf);
+ res = iconv (cd,
+ (ICONV_CONST char **) &inptr, &inbytesleft,
+ &outptr, &outbytesleft);
+ ASSERT (res == 0 && inbytesleft == 0);
+ ASSERT (outptr == buf + (sizeof (expected) - 1));
+ ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0);
+ ASSERT (iconv_close (cd) == 0);
+ }
+ /* Test conversion from UTF-16BE to UTF-8 with no errors.
+ This test fails on NetBSD 3.0. */
+ {
+ static const char input[] =
+ "\000J\000a\000p\000a\000n\000e\000s\000e\000
\000(\145\345\147\054\212\236\000)\000
\000[\330\065\335\015\330\065\335\036\330\065\335\055\000]";
+ static const char expected[] =
+ "Japanese (\346\227\245\346\234\254\350\252\236)
[\360\235\224\215\360\235\224\236\360\235\224\255]";
+ iconv_t cd;
+ char buf[100];
+ const char *inptr;
+ size_t inbytesleft;
+ char *outptr;
+ size_t outbytesleft;
+ size_t res;
+ cd = iconv_open ("UTF-8", "UTF-16BE");
+ ASSERT (cd != (iconv_t)(-1));
+ inptr = input;
+ inbytesleft = sizeof (input) - 1;
+ outptr = buf;
+ outbytesleft = sizeof (buf);
+ res = iconv (cd,
+ (ICONV_CONST char **) &inptr, &inbytesleft,
+ &outptr, &outbytesleft);
+ ASSERT (res == 0 && inbytesleft == 0);
+ ASSERT (outptr == buf + (sizeof (expected) - 1));
+ ASSERT (memcmp (buf, expected, sizeof (expected) - 1) == 0);
+ ASSERT (iconv_close (cd) == 0);
+ }
+ return 0;
+}], [gl_cv_func_iconv_supports_utf=yes], [gl_cv_func_iconv_supports_utf=no],
+ [
+ dnl We know that GNU libiconv, GNU libc, and Solaris >= 9 do.
+ dnl OSF/1 5.1 has these encodings, but inserts a BOM in the "to"
+ dnl direction.
+ gl_cv_func_iconv_supports_utf=no
+ if test $gl_func_iconv_gnu = yes; then
+ gl_cv_func_iconv_supports_utf=yes
+ else
+changequote(,)dnl
+ case "$host_os" in
+ solaris2.9 | solaris2.1[0-9]) gl_cv_func_iconv_supports_utf=yes
;;
+ esac
+changequote([,])dnl
+ fi
+ ])
+ LIBS="$save_LIBS"
+ ])
+ if test $gl_cv_func_iconv_supports_utf = no; then
+ REPLACE_ICONV_UTF=1
+ AC_DEFINE([REPLACE_ICONV_UTF], [1],
+ [Define if the iconv() functions are enhanced to handle the
UTF-{16,32}{BE,LE} encodings.])
+ REPLACE_ICONV=1
+ gl_REPLACE_ICONV_OPEN
+ AC_LIBOBJ([iconv])
+ AC_LIBOBJ([iconv_close])
+ fi
+ fi
+])
diff --git a/m4/include_next.m4 b/m4/include_next.m4
index 062753c..5e22ded 100644
--- a/m4/include_next.m4
+++ b/m4/include_next.m4
@@ -1,5 +1,5 @@
-# include_next.m4 serial 10
-dnl Copyright (C) 2006-2008 Free Software Foundation, Inc.
+# include_next.m4 serial 14
+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,
dnl with or without modifications, as long as this notice is preserved.
@@ -32,14 +32,15 @@ AC_DEFUN([gl_INCLUDE_NEXT],
[gl_cv_have_include_next],
[rm -rf conftestd1a conftestd1b conftestd2
mkdir conftestd1a conftestd1b conftestd2
- dnl The include of <stdio.h> is because IBM C 9.0 on AIX 6.1 supports
- dnl include_next when used as first preprocessor directive in a file,
- dnl but not when preceded by another include directive. Additionally,
- dnl with this same compiler, include_next is a no-op when used in a
- dnl header file that was included by specifying its absolute file name.
- dnl Despite these two bugs, include_next is used in the compiler's
- dnl <math.h>. By virtue of the second bug, we need to use include_next
- dnl as well in this case.
+ dnl IBM C 9.0, 10.1 (original versions, prior to the 2009-01 updates) on
+ dnl AIX 6.1 support include_next when used as first preprocessor directive
+ dnl in a file, but not when preceded by another include directive. Check
+ dnl for this bug by including <stdio.h>.
+ dnl Additionally, with this same compiler, include_next is a no-op when
+ dnl used in a header file that was included by specifying its absolute
+ dnl file name. Despite these two bugs, include_next is used in the
+ dnl compiler's <math.h>. By virtue of the second bug, we need to use
+ dnl include_next as well in this case.
cat <<EOF > conftestd1a/conftest.h
#define DEFINED_IN_CONFTESTD1
#include_next <conftest.h>
@@ -103,8 +104,14 @@ EOF
# For each arg foo.h, if #include_next works, define NEXT_FOO_H to be
# '<foo.h>'; otherwise define it to be
# '"///usr/include/foo.h"', or whatever other absolute file name is suitable.
+# Also, if #include_next works as first preprocessing directive in a file,
+# define NEXT_AS_FIRST_DIRECTIVE_FOO_H to be '<foo.h>'; otherwise define it to
+# be
+# '"///usr/include/foo.h"', or whatever other absolute file name is suitable.
# That way, a header file with the following line:
# address@hidden@ @NEXT_FOO_H@
+# or
+# address@hidden@ @NEXT_AS_FIRST_DIRECTIVE_FOO_H@
# behaves (after sed substitution) as if it contained
# #include_next <foo.h>
# even if the compiler does not support include_next.
@@ -122,15 +129,15 @@ AC_DEFUN([gl_CHECK_NEXT_HEADERS],
m4_foreach_w([gl_HEADER_NAME], [$1],
[AS_VAR_PUSHDEF([gl_next_header],
- [gl_cv_next_]m4_quote(m4_defn([gl_HEADER_NAME])))
+ [gl_cv_next_]m4_defn([gl_HEADER_NAME]))
if test $gl_cv_have_include_next = yes; then
AS_VAR_SET([gl_next_header], ['<'gl_HEADER_NAME'>'])
else
AC_CACHE_CHECK(
- [absolute name of <]m4_quote(m4_defn([gl_HEADER_NAME]))[>],
- m4_quote(m4_defn([gl_next_header])),
+ [absolute name of <]m4_defn([gl_HEADER_NAME])[>],
+ m4_defn([gl_next_header]),
[AS_VAR_PUSHDEF([gl_header_exists],
- [ac_cv_header_]m4_quote(m4_defn([gl_HEADER_NAME])))
+ [ac_cv_header_]m4_defn([gl_HEADER_NAME]))
if test AS_VAR_GET(gl_header_exists) = yes; then
AC_LANG_CONFTEST(
[AC_LANG_SOURCE(
@@ -152,8 +159,8 @@ AC_DEFUN([gl_CHECK_NEXT_HEADERS],
dnl so use subshell.
AS_VAR_SET([gl_next_header],
['"'`(eval "$gl_absname_cpp conftest.$ac_ext")
2>&AS_MESSAGE_LOG_FD |
- sed -n '\#/]m4_quote(m4_defn([gl_HEADER_NAME]))[#{
- s#.*"\(.*/]m4_quote(m4_defn([gl_HEADER_NAME]))[\)".*#\1#
+ sed -n '\#/]m4_defn([gl_HEADER_NAME])[#{
+ s#.*"\(.*/]m4_defn([gl_HEADER_NAME])[\)".*#\1#
s#^/[^/]#//&#
p
q
@@ -164,7 +171,17 @@ AC_DEFUN([gl_CHECK_NEXT_HEADERS],
AS_VAR_POPDEF([gl_header_exists])])
fi
AC_SUBST(
- AS_TR_CPP([NEXT_]m4_quote(m4_defn([gl_HEADER_NAME]))),
+ AS_TR_CPP([NEXT_]m4_defn([gl_HEADER_NAME])),
[AS_VAR_GET([gl_next_header])])
+ if test $gl_cv_have_include_next = yes || test $gl_cv_have_include_next =
buggy; then
+ # INCLUDE_NEXT_AS_FIRST_DIRECTIVE='include_next'
+ gl_next_as_first_directive='<'gl_HEADER_NAME'>'
+ else
+ # INCLUDE_NEXT_AS_FIRST_DIRECTIVE='include'
+ gl_next_as_first_directive=AS_VAR_GET([gl_next_header])
+ fi
+ AC_SUBST(
+ AS_TR_CPP([NEXT_AS_FIRST_DIRECTIVE_]m4_defn([gl_HEADER_NAME])),
+ [$gl_next_as_first_directive])
AS_VAR_POPDEF([gl_next_header])])
])
diff --git a/m4/inline.m4 b/m4/inline.m4
index a07076c..cee5109 100644
--- a/m4/inline.m4
+++ b/m4/inline.m4
@@ -1,5 +1,5 @@
-# inline.m4 serial 3
-dnl Copyright (C) 2006 Free Software Foundation, Inc.
+# inline.m4 serial 4
+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,
dnl with or without modifications, as long as this notice is preserved.
@@ -32,7 +32,7 @@ AC_DEFUN([gl_INLINE],
fi
])
if test $gl_cv_c_inline_effective = yes; then
- AC_DEFINE([HAVE_INLINE], 1,
+ AC_DEFINE([HAVE_INLINE], [1],
[Define to 1 if the compiler supports one of the keywords
'inline', '__inline__', '__inline' and effectively inlines
functions marked as such.])
diff --git a/m4/lib-ld.m4 b/m4/lib-ld.m4
new file mode 100644
index 0000000..e4863f2
--- /dev/null
+++ b/m4/lib-ld.m4
@@ -0,0 +1,110 @@
+# lib-ld.m4 serial 4 (gettext-0.18)
+dnl Copyright (C) 1996-2003, 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 Subroutines of libtool.m4,
+dnl with replacements s/AC_/AC_LIB/ and s/lt_cv/acl_cv/ to avoid collision
+dnl with libtool.m4.
+
+dnl From libtool-1.4. Sets the variable with_gnu_ld to yes or no.
+AC_DEFUN([AC_LIB_PROG_LD_GNU],
+[AC_CACHE_CHECK([if the linker ($LD) is GNU ld], [acl_cv_prog_gnu_ld],
+[# I'd rather use --version here, but apparently some GNU ld's only accept -v.
+case `$LD -v 2>&1 </dev/null` in
+*GNU* | *'with BFD'*)
+ acl_cv_prog_gnu_ld=yes ;;
+*)
+ acl_cv_prog_gnu_ld=no ;;
+esac])
+with_gnu_ld=$acl_cv_prog_gnu_ld
+])
+
+dnl From libtool-1.4. Sets the variable LD.
+AC_DEFUN([AC_LIB_PROG_LD],
+[AC_ARG_WITH([gnu-ld],
+[ --with-gnu-ld assume the C compiler uses GNU ld [default=no]],
+test "$withval" = no || with_gnu_ld=yes, with_gnu_ld=no)
+AC_REQUIRE([AC_PROG_CC])dnl
+AC_REQUIRE([AC_CANONICAL_HOST])dnl
+# Prepare PATH_SEPARATOR.
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; then
+ echo "#! /bin/sh" >conf$$.sh
+ echo "exit 0" >>conf$$.sh
+ chmod +x conf$$.sh
+ if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
+ PATH_SEPARATOR=';'
+ else
+ PATH_SEPARATOR=:
+ fi
+ rm -f conf$$.sh
+fi
+ac_prog=ld
+if test "$GCC" = yes; then
+ # Check if gcc -print-prog-name=ld gives a path.
+ AC_MSG_CHECKING([for ld used by GCC])
+ case $host in
+ *-*-mingw*)
+ # gcc leaves a trailing carriage return which upsets mingw
+ ac_prog=`($CC -print-prog-name=ld) 2>&5 | tr -d '\015'` ;;
+ *)
+ ac_prog=`($CC -print-prog-name=ld) 2>&5` ;;
+ esac
+ case $ac_prog in
+ # Accept absolute paths.
+ [[\\/]* | [A-Za-z]:[\\/]*)]
+ [re_direlt='/[^/][^/]*/\.\./']
+ # Canonicalize the path of ld
+ ac_prog=`echo $ac_prog| sed 's%\\\\%/%g'`
+ while echo $ac_prog | grep "$re_direlt" > /dev/null 2>&1; do
+ ac_prog=`echo $ac_prog| sed "s%$re_direlt%/%"`
+ done
+ test -z "$LD" && LD="$ac_prog"
+ ;;
+ "")
+ # If it fails, then pretend we aren't using GCC.
+ ac_prog=ld
+ ;;
+ *)
+ # If it is relative, then search for the first ld in PATH.
+ with_gnu_ld=unknown
+ ;;
+ esac
+elif test "$with_gnu_ld" = yes; then
+ AC_MSG_CHECKING([for GNU ld])
+else
+ AC_MSG_CHECKING([for non-GNU ld])
+fi
+AC_CACHE_VAL([acl_cv_path_LD],
+[if test -z "$LD"; then
+ IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}${PATH_SEPARATOR-:}"
+ for ac_dir in $PATH; do
+ test -z "$ac_dir" && ac_dir=.
+ if test -f "$ac_dir/$ac_prog" || test -f "$ac_dir/$ac_prog$ac_exeext"; then
+ acl_cv_path_LD="$ac_dir/$ac_prog"
+ # Check to see if the program is GNU ld. I'd rather use --version,
+ # but apparently some GNU ld's only accept -v.
+ # Break only if it was the GNU/non-GNU ld that we prefer.
+ case `"$acl_cv_path_LD" -v 2>&1 < /dev/null` in
+ *GNU* | *'with BFD'*)
+ test "$with_gnu_ld" != no && break ;;
+ *)
+ test "$with_gnu_ld" != yes && break ;;
+ esac
+ fi
+ done
+ IFS="$ac_save_ifs"
+else
+ acl_cv_path_LD="$LD" # Let the user override the test with a path.
+fi])
+LD="$acl_cv_path_LD"
+if test -n "$LD"; then
+ AC_MSG_RESULT([$LD])
+else
+ AC_MSG_RESULT([no])
+fi
+test -z "$LD" && AC_MSG_ERROR([no acceptable ld found in \$PATH])
+AC_LIB_PROG_LD_GNU
+])
diff --git a/m4/lib-link.m4 b/m4/lib-link.m4
new file mode 100644
index 0000000..2144203
--- /dev/null
+++ b/m4/lib-link.m4
@@ -0,0 +1,761 @@
+# lib-link.m4 serial 19 (gettext-0.18)
+dnl Copyright (C) 2001-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 Bruno Haible.
+
+AC_PREREQ([2.54])
+
+dnl AC_LIB_LINKFLAGS(name [, dependencies]) searches for libname and
+dnl the libraries corresponding to explicit and implicit dependencies.
+dnl Sets and AC_SUBSTs the LIB${NAME} and LTLIB${NAME} variables and
+dnl augments the CPPFLAGS variable.
+dnl Sets and AC_SUBSTs the LIB${NAME}_PREFIX variable to nonempty if libname
+dnl was found in ${LIB${NAME}_PREFIX}/$acl_libdirstem.
+AC_DEFUN([AC_LIB_LINKFLAGS],
+[
+ AC_REQUIRE([AC_LIB_PREPARE_PREFIX])
+ AC_REQUIRE([AC_LIB_RPATH])
+ pushdef([Name],[translit([$1],[./-], [___])])
+ pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-],
+ [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])])
+ AC_CACHE_CHECK([how to link with lib[]$1], [ac_cv_lib[]Name[]_libs], [
+ AC_LIB_LINKFLAGS_BODY([$1], [$2])
+ ac_cv_lib[]Name[]_libs="$LIB[]NAME"
+ ac_cv_lib[]Name[]_ltlibs="$LTLIB[]NAME"
+ ac_cv_lib[]Name[]_cppflags="$INC[]NAME"
+ ac_cv_lib[]Name[]_prefix="$LIB[]NAME[]_PREFIX"
+ ])
+ LIB[]NAME="$ac_cv_lib[]Name[]_libs"
+ LTLIB[]NAME="$ac_cv_lib[]Name[]_ltlibs"
+ INC[]NAME="$ac_cv_lib[]Name[]_cppflags"
+ LIB[]NAME[]_PREFIX="$ac_cv_lib[]Name[]_prefix"
+ AC_LIB_APPENDTOVAR([CPPFLAGS], [$INC]NAME)
+ AC_SUBST([LIB]NAME)
+ AC_SUBST([LTLIB]NAME)
+ AC_SUBST([LIB]NAME[_PREFIX])
+ dnl Also set HAVE_LIB[]NAME so that AC_LIB_HAVE_LINKFLAGS can reuse the
+ dnl results of this search when this library appears as a dependency.
+ HAVE_LIB[]NAME=yes
+ popdef([NAME])
+ popdef([Name])
+])
+
+dnl AC_LIB_HAVE_LINKFLAGS(name, dependencies, includes, testcode,
[missing-message])
+dnl searches for libname and the libraries corresponding to explicit and
+dnl implicit dependencies, together with the specified include files and
+dnl the ability to compile and link the specified testcode. The missing-message
+dnl defaults to 'no' and may contain additional hints for the user.
+dnl If found, it sets and AC_SUBSTs HAVE_LIB${NAME}=yes and the LIB${NAME}
+dnl and LTLIB${NAME} variables and augments the CPPFLAGS variable, and
+dnl #defines HAVE_LIB${NAME} to 1. Otherwise, it sets and AC_SUBSTs
+dnl HAVE_LIB${NAME}=no and LIB${NAME} and LTLIB${NAME} to empty.
+dnl Sets and AC_SUBSTs the LIB${NAME}_PREFIX variable to nonempty if libname
+dnl was found in ${LIB${NAME}_PREFIX}/$acl_libdirstem.
+AC_DEFUN([AC_LIB_HAVE_LINKFLAGS],
+[
+ AC_REQUIRE([AC_LIB_PREPARE_PREFIX])
+ AC_REQUIRE([AC_LIB_RPATH])
+ pushdef([Name],[translit([$1],[./-], [___])])
+ pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-],
+ [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])])
+
+ dnl Search for lib[]Name and define LIB[]NAME, LTLIB[]NAME and INC[]NAME
+ dnl accordingly.
+ AC_LIB_LINKFLAGS_BODY([$1], [$2])
+
+ dnl Add $INC[]NAME to CPPFLAGS before performing the following checks,
+ dnl because if the user has installed lib[]Name and not disabled its use
+ dnl via --without-lib[]Name-prefix, he wants to use it.
+ ac_save_CPPFLAGS="$CPPFLAGS"
+ AC_LIB_APPENDTOVAR([CPPFLAGS], [$INC]NAME)
+
+ AC_CACHE_CHECK([for lib[]$1], [ac_cv_lib[]Name], [
+ ac_save_LIBS="$LIBS"
+ LIBS="$LIBS $LIB[]NAME"
+ AC_TRY_LINK([$3], [$4],
+ [ac_cv_lib[]Name=yes],
+ [ac_cv_lib[]Name='m4_if([$5], [], [no], [[$5]])'])
+ LIBS="$ac_save_LIBS"
+ ])
+ if test "$ac_cv_lib[]Name" = yes; then
+ HAVE_LIB[]NAME=yes
+ AC_DEFINE([HAVE_LIB]NAME, 1, [Define if you have the lib[]$1 library.])
+ AC_MSG_CHECKING([how to link with lib[]$1])
+ AC_MSG_RESULT([$LIB[]NAME])
+ else
+ HAVE_LIB[]NAME=no
+ dnl If $LIB[]NAME didn't lead to a usable library, we don't need
+ dnl $INC[]NAME either.
+ CPPFLAGS="$ac_save_CPPFLAGS"
+ LIB[]NAME=
+ LTLIB[]NAME=
+ LIB[]NAME[]_PREFIX=
+ fi
+ AC_SUBST([HAVE_LIB]NAME)
+ AC_SUBST([LIB]NAME)
+ AC_SUBST([LTLIB]NAME)
+ AC_SUBST([LIB]NAME[_PREFIX])
+ popdef([NAME])
+ popdef([Name])
+])
+
+dnl Determine the platform dependent parameters needed to use rpath:
+dnl acl_libext,
+dnl acl_shlibext,
+dnl acl_hardcode_libdir_flag_spec,
+dnl acl_hardcode_libdir_separator,
+dnl acl_hardcode_direct,
+dnl acl_hardcode_minus_L.
+AC_DEFUN([AC_LIB_RPATH],
+[
+ dnl Tell automake >= 1.10 to complain if config.rpath is missing.
+ m4_ifdef([AC_REQUIRE_AUX_FILE], [AC_REQUIRE_AUX_FILE([config.rpath])])
+ AC_REQUIRE([AC_PROG_CC]) dnl we use $CC, $GCC, $LDFLAGS
+ AC_REQUIRE([AC_LIB_PROG_LD]) dnl we use $LD, $with_gnu_ld
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl we use $host
+ AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT]) dnl we use $ac_aux_dir
+ AC_CACHE_CHECK([for shared library run path origin], [acl_cv_rpath], [
+ CC="$CC" GCC="$GCC" LDFLAGS="$LDFLAGS" LD="$LD" with_gnu_ld="$with_gnu_ld"
\
+ ${CONFIG_SHELL-/bin/sh} "$ac_aux_dir/config.rpath" "$host" > conftest.sh
+ . ./conftest.sh
+ rm -f ./conftest.sh
+ acl_cv_rpath=done
+ ])
+ wl="$acl_cv_wl"
+ acl_libext="$acl_cv_libext"
+ acl_shlibext="$acl_cv_shlibext"
+ acl_libname_spec="$acl_cv_libname_spec"
+ acl_library_names_spec="$acl_cv_library_names_spec"
+ acl_hardcode_libdir_flag_spec="$acl_cv_hardcode_libdir_flag_spec"
+ acl_hardcode_libdir_separator="$acl_cv_hardcode_libdir_separator"
+ acl_hardcode_direct="$acl_cv_hardcode_direct"
+ acl_hardcode_minus_L="$acl_cv_hardcode_minus_L"
+ dnl Determine whether the user wants rpath handling at all.
+ AC_ARG_ENABLE([rpath],
+ [ --disable-rpath do not hardcode runtime library paths],
+ :, enable_rpath=yes)
+])
+
+dnl AC_LIB_FROMPACKAGE(name, package)
+dnl declares that libname comes from the given package. The configure file
+dnl will then not have a --with-libname-prefix option but a
+dnl --with-package-prefix option. Several libraries can come from the same
+dnl package. This declaration must occur before an AC_LIB_LINKFLAGS or similar
+dnl macro call that searches for libname.
+AC_DEFUN([AC_LIB_FROMPACKAGE],
+[
+ pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-],
+ [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])])
+ define([acl_frompackage_]NAME, [$2])
+ popdef([NAME])
+ pushdef([PACK],[$2])
+ pushdef([PACKUP],[translit(PACK,[abcdefghijklmnopqrstuvwxyz./-],
+ [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])])
+ define([acl_libsinpackage_]PACKUP,
+ m4_ifdef([acl_libsinpackage_]PACKUP, [acl_libsinpackage_]PACKUP[[,
]],)[lib$1])
+ popdef([PACKUP])
+ popdef([PACK])
+])
+
+dnl AC_LIB_LINKFLAGS_BODY(name [, dependencies]) searches for libname and
+dnl the libraries corresponding to explicit and implicit dependencies.
+dnl Sets the LIB${NAME}, LTLIB${NAME} and INC${NAME} variables.
+dnl Also, sets the LIB${NAME}_PREFIX variable to nonempty if libname was found
+dnl in ${LIB${NAME}_PREFIX}/$acl_libdirstem.
+AC_DEFUN([AC_LIB_LINKFLAGS_BODY],
+[
+ AC_REQUIRE([AC_LIB_PREPARE_MULTILIB])
+ pushdef([NAME],[translit([$1],[abcdefghijklmnopqrstuvwxyz./-],
+ [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])])
+ pushdef([PACK],[m4_ifdef([acl_frompackage_]NAME, [acl_frompackage_]NAME,
lib[$1])])
+ pushdef([PACKUP],[translit(PACK,[abcdefghijklmnopqrstuvwxyz./-],
+ [ABCDEFGHIJKLMNOPQRSTUVWXYZ___])])
+ pushdef([PACKLIBS],[m4_ifdef([acl_frompackage_]NAME,
[acl_libsinpackage_]PACKUP, lib[$1])])
+ dnl Autoconf >= 2.61 supports dots in --with options.
+
pushdef([P_A_C_K],[m4_if(m4_version_compare(m4_defn([m4_PACKAGE_VERSION]),[2.61]),[-1],[translit(PACK,[.],[_])],PACK)])
+ dnl By default, look in $includedir and $libdir.
+ use_additional=yes
+ AC_LIB_WITH_FINAL_PREFIX([
+ eval additional_includedir=\"$includedir\"
+ eval additional_libdir=\"$libdir\"
+ ])
+ AC_ARG_WITH(P_A_C_K[-prefix],
+[[ --with-]]P_A_C_K[[-prefix[=DIR] search for ]PACKLIBS[ in DIR/include and
DIR/lib
+ --without-]]P_A_C_K[[-prefix don't search for ]PACKLIBS[ in includedir
and libdir]],
+[
+ if test "X$withval" = "Xno"; then
+ use_additional=no
+ else
+ if test "X$withval" = "X"; then
+ AC_LIB_WITH_FINAL_PREFIX([
+ eval additional_includedir=\"$includedir\"
+ eval additional_libdir=\"$libdir\"
+ ])
+ else
+ additional_includedir="$withval/include"
+ additional_libdir="$withval/$acl_libdirstem"
+ if test "$acl_libdirstem2" != "$acl_libdirstem" \
+ && ! test -d "$withval/$acl_libdirstem"; then
+ additional_libdir="$withval/$acl_libdirstem2"
+ fi
+ fi
+ fi
+])
+ dnl Search the library and its dependencies in $additional_libdir and
+ dnl $LDFLAGS. Using breadth-first-seach.
+ LIB[]NAME=
+ LTLIB[]NAME=
+ INC[]NAME=
+ LIB[]NAME[]_PREFIX=
+ rpathdirs=
+ ltrpathdirs=
+ names_already_handled=
+ names_next_round='$1 $2'
+ while test -n "$names_next_round"; do
+ names_this_round="$names_next_round"
+ names_next_round=
+ for name in $names_this_round; do
+ already_handled=
+ for n in $names_already_handled; do
+ if test "$n" = "$name"; then
+ already_handled=yes
+ break
+ fi
+ done
+ if test -z "$already_handled"; then
+ names_already_handled="$names_already_handled $name"
+ dnl See if it was already located by an earlier AC_LIB_LINKFLAGS
+ dnl or AC_LIB_HAVE_LINKFLAGS call.
+ uppername=`echo "$name" | sed -e
'y|abcdefghijklmnopqrstuvwxyz./-|ABCDEFGHIJKLMNOPQRSTUVWXYZ___|'`
+ eval value=\"\$HAVE_LIB$uppername\"
+ if test -n "$value"; then
+ if test "$value" = yes; then
+ eval value=\"\$LIB$uppername\"
+ test -z "$value" || LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$value"
+ eval value=\"\$LTLIB$uppername\"
+ test -z "$value" || LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+
}$value"
+ else
+ dnl An earlier call to AC_LIB_HAVE_LINKFLAGS has determined
+ dnl that this library doesn't exist. So just drop it.
+ :
+ fi
+ else
+ dnl Search the library lib$name in $additional_libdir and $LDFLAGS
+ dnl and the already constructed $LIBNAME/$LTLIBNAME.
+ found_dir=
+ found_la=
+ found_so=
+ found_a=
+ eval libname=\"$acl_libname_spec\" # typically: libname=lib$name
+ if test -n "$acl_shlibext"; then
+ shrext=".$acl_shlibext" # typically: shrext=.so
+ else
+ shrext=
+ fi
+ if test $use_additional = yes; then
+ dir="$additional_libdir"
+ dnl The same code as in the loop below:
+ dnl First look for a shared library.
+ if test -n "$acl_shlibext"; then
+ if test -f "$dir/$libname$shrext"; then
+ found_dir="$dir"
+ found_so="$dir/$libname$shrext"
+ else
+ if test "$acl_library_names_spec" =
'$libname$shrext$versuffix'; then
+ ver=`(cd "$dir" && \
+ for f in "$libname$shrext".*; do echo "$f"; done \
+ | sed -e "s,^$libname$shrext\\\\.,," \
+ | sort -t '.' -n -r -k1,1 -k2,2 -k3,3 -k4,4 -k5,5 \
+ | sed 1q ) 2>/dev/null`
+ if test -n "$ver" && test -f "$dir/$libname$shrext.$ver";
then
+ found_dir="$dir"
+ found_so="$dir/$libname$shrext.$ver"
+ fi
+ else
+ eval library_names=\"$acl_library_names_spec\"
+ for f in $library_names; do
+ if test -f "$dir/$f"; then
+ found_dir="$dir"
+ found_so="$dir/$f"
+ break
+ fi
+ done
+ fi
+ fi
+ fi
+ dnl Then look for a static library.
+ if test "X$found_dir" = "X"; then
+ if test -f "$dir/$libname.$acl_libext"; then
+ found_dir="$dir"
+ found_a="$dir/$libname.$acl_libext"
+ fi
+ fi
+ if test "X$found_dir" != "X"; then
+ if test -f "$dir/$libname.la"; then
+ found_la="$dir/$libname.la"
+ fi
+ fi
+ fi
+ if test "X$found_dir" = "X"; then
+ for x in $LDFLAGS $LTLIB[]NAME; do
+ AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
+ case "$x" in
+ -L*)
+ dir=`echo "X$x" | sed -e 's/^X-L//'`
+ dnl First look for a shared library.
+ if test -n "$acl_shlibext"; then
+ if test -f "$dir/$libname$shrext"; then
+ found_dir="$dir"
+ found_so="$dir/$libname$shrext"
+ else
+ if test "$acl_library_names_spec" =
'$libname$shrext$versuffix'; then
+ ver=`(cd "$dir" && \
+ for f in "$libname$shrext".*; do echo "$f"; done
\
+ | sed -e "s,^$libname$shrext\\\\.,," \
+ | sort -t '.' -n -r -k1,1 -k2,2 -k3,3 -k4,4
-k5,5 \
+ | sed 1q ) 2>/dev/null`
+ if test -n "$ver" && test -f
"$dir/$libname$shrext.$ver"; then
+ found_dir="$dir"
+ found_so="$dir/$libname$shrext.$ver"
+ fi
+ else
+ eval library_names=\"$acl_library_names_spec\"
+ for f in $library_names; do
+ if test -f "$dir/$f"; then
+ found_dir="$dir"
+ found_so="$dir/$f"
+ break
+ fi
+ done
+ fi
+ fi
+ fi
+ dnl Then look for a static library.
+ if test "X$found_dir" = "X"; then
+ if test -f "$dir/$libname.$acl_libext"; then
+ found_dir="$dir"
+ found_a="$dir/$libname.$acl_libext"
+ fi
+ fi
+ if test "X$found_dir" != "X"; then
+ if test -f "$dir/$libname.la"; then
+ found_la="$dir/$libname.la"
+ fi
+ fi
+ ;;
+ esac
+ if test "X$found_dir" != "X"; then
+ break
+ fi
+ done
+ fi
+ if test "X$found_dir" != "X"; then
+ dnl Found the library.
+ LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-L$found_dir -l$name"
+ if test "X$found_so" != "X"; then
+ dnl Linking with a shared library. We attempt to hardcode its
+ dnl directory into the executable's runpath, unless it's the
+ dnl standard /usr/lib.
+ if test "$enable_rpath" = no \
+ || test "X$found_dir" = "X/usr/$acl_libdirstem" \
+ || test "X$found_dir" = "X/usr/$acl_libdirstem2"; then
+ dnl No hardcoding is needed.
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so"
+ else
+ dnl Use an explicit option to hardcode DIR into the resulting
+ dnl binary.
+ dnl Potentially add DIR to ltrpathdirs.
+ dnl The ltrpathdirs will be appended to $LTLIBNAME at the end.
+ haveit=
+ for x in $ltrpathdirs; do
+ if test "X$x" = "X$found_dir"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ ltrpathdirs="$ltrpathdirs $found_dir"
+ fi
+ dnl The hardcoding into $LIBNAME is system dependent.
+ if test "$acl_hardcode_direct" = yes; then
+ dnl Using DIR/libNAME.so during linking hardcodes DIR into
the
+ dnl resulting binary.
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so"
+ else
+ if test -n "$acl_hardcode_libdir_flag_spec" && test
"$acl_hardcode_minus_L" = no; then
+ dnl Use an explicit option to hardcode DIR into the
resulting
+ dnl binary.
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so"
+ dnl Potentially add DIR to rpathdirs.
+ dnl The rpathdirs will be appended to $LIBNAME at the end.
+ haveit=
+ for x in $rpathdirs; do
+ if test "X$x" = "X$found_dir"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ rpathdirs="$rpathdirs $found_dir"
+ fi
+ else
+ dnl Rely on "-L$found_dir".
+ dnl But don't add it if it's already contained in the
LDFLAGS
+ dnl or the already constructed $LIBNAME
+ haveit=
+ for x in $LDFLAGS $LIB[]NAME; do
+ AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
+ if test "X$x" = "X-L$found_dir"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$found_dir"
+ fi
+ if test "$acl_hardcode_minus_L" != no; then
+ dnl FIXME: Not sure whether we should use
+ dnl "-L$found_dir -l$name" or "-L$found_dir $found_so"
+ dnl here.
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_so"
+ else
+ dnl We cannot use $acl_hardcode_runpath_var and
LD_RUN_PATH
+ dnl here, because this doesn't fit in flags passed to the
+ dnl compiler. So give up. No hardcoding. This affects
only
+ dnl very old systems.
+ dnl FIXME: Not sure whether we should use
+ dnl "-L$found_dir -l$name" or "-L$found_dir $found_so"
+ dnl here.
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-l$name"
+ fi
+ fi
+ fi
+ fi
+ else
+ if test "X$found_a" != "X"; then
+ dnl Linking with a static library.
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$found_a"
+ else
+ dnl We shouldn't come here, but anyway it's good to have a
+ dnl fallback.
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-L$found_dir -l$name"
+ fi
+ fi
+ dnl Assume the include files are nearby.
+ additional_includedir=
+ case "$found_dir" in
+ */$acl_libdirstem | */$acl_libdirstem/)
+ basedir=`echo "X$found_dir" | sed -e 's,^X,,' -e
"s,/$acl_libdirstem/"'*$,,'`
+ if test "$name" = '$1'; then
+ LIB[]NAME[]_PREFIX="$basedir"
+ fi
+ additional_includedir="$basedir/include"
+ ;;
+ */$acl_libdirstem2 | */$acl_libdirstem2/)
+ basedir=`echo "X$found_dir" | sed -e 's,^X,,' -e
"s,/$acl_libdirstem2/"'*$,,'`
+ if test "$name" = '$1'; then
+ LIB[]NAME[]_PREFIX="$basedir"
+ fi
+ additional_includedir="$basedir/include"
+ ;;
+ esac
+ if test "X$additional_includedir" != "X"; then
+ dnl Potentially add $additional_includedir to $INCNAME.
+ dnl But don't add it
+ dnl 1. if it's the standard /usr/include,
+ dnl 2. if it's /usr/local/include and we are using GCC on
Linux,
+ dnl 3. if it's already present in $CPPFLAGS or the already
+ dnl constructed $INCNAME,
+ dnl 4. if it doesn't exist as a directory.
+ if test "X$additional_includedir" != "X/usr/include"; then
+ haveit=
+ if test "X$additional_includedir" = "X/usr/local/include"; then
+ if test -n "$GCC"; then
+ case $host_os in
+ linux* | gnu* | k*bsd*-gnu) haveit=yes;;
+ esac
+ fi
+ fi
+ if test -z "$haveit"; then
+ for x in $CPPFLAGS $INC[]NAME; do
+ AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
+ if test "X$x" = "X-I$additional_includedir"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ if test -d "$additional_includedir"; then
+ dnl Really add $additional_includedir to $INCNAME.
+ INC[]NAME="${INC[]NAME}${INC[]NAME:+
}-I$additional_includedir"
+ fi
+ fi
+ fi
+ fi
+ fi
+ dnl Look for dependencies.
+ if test -n "$found_la"; then
+ dnl Read the .la file. It defines the variables
+ dnl dlname, library_names, old_library, dependency_libs, current,
+ dnl age, revision, installed, dlopen, dlpreopen, libdir.
+ save_libdir="$libdir"
+ case "$found_la" in
+ */* | *\\*) . "$found_la" ;;
+ *) . "./$found_la" ;;
+ esac
+ libdir="$save_libdir"
+ dnl We use only dependency_libs.
+ for dep in $dependency_libs; do
+ case "$dep" in
+ -L*)
+ additional_libdir=`echo "X$dep" | sed -e 's/^X-L//'`
+ dnl Potentially add $additional_libdir to $LIBNAME and
$LTLIBNAME.
+ dnl But don't add it
+ dnl 1. if it's the standard /usr/lib,
+ dnl 2. if it's /usr/local/lib and we are using GCC on
Linux,
+ dnl 3. if it's already present in $LDFLAGS or the already
+ dnl constructed $LIBNAME,
+ dnl 4. if it doesn't exist as a directory.
+ if test "X$additional_libdir" != "X/usr/$acl_libdirstem" \
+ && test "X$additional_libdir" !=
"X/usr/$acl_libdirstem2"; then
+ haveit=
+ if test "X$additional_libdir" =
"X/usr/local/$acl_libdirstem" \
+ || test "X$additional_libdir" =
"X/usr/local/$acl_libdirstem2"; then
+ if test -n "$GCC"; then
+ case $host_os in
+ linux* | gnu* | k*bsd*-gnu) haveit=yes;;
+ esac
+ fi
+ fi
+ if test -z "$haveit"; then
+ haveit=
+ for x in $LDFLAGS $LIB[]NAME; do
+ AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
+ if test "X$x" = "X-L$additional_libdir"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ if test -d "$additional_libdir"; then
+ dnl Really add $additional_libdir to $LIBNAME.
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+
}-L$additional_libdir"
+ fi
+ fi
+ haveit=
+ for x in $LDFLAGS $LTLIB[]NAME; do
+ AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
+ if test "X$x" = "X-L$additional_libdir"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ if test -d "$additional_libdir"; then
+ dnl Really add $additional_libdir to $LTLIBNAME.
+ LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+
}-L$additional_libdir"
+ fi
+ fi
+ fi
+ fi
+ ;;
+ -R*)
+ dir=`echo "X$dep" | sed -e 's/^X-R//'`
+ if test "$enable_rpath" != no; then
+ dnl Potentially add DIR to rpathdirs.
+ dnl The rpathdirs will be appended to $LIBNAME at the
end.
+ haveit=
+ for x in $rpathdirs; do
+ if test "X$x" = "X$dir"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ rpathdirs="$rpathdirs $dir"
+ fi
+ dnl Potentially add DIR to ltrpathdirs.
+ dnl The ltrpathdirs will be appended to $LTLIBNAME at
the end.
+ haveit=
+ for x in $ltrpathdirs; do
+ if test "X$x" = "X$dir"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ ltrpathdirs="$ltrpathdirs $dir"
+ fi
+ fi
+ ;;
+ -l*)
+ dnl Handle this in the next round.
+ names_next_round="$names_next_round "`echo "X$dep" | sed
-e 's/^X-l//'`
+ ;;
+ *.la)
+ dnl Handle this in the next round. Throw away the .la's
+ dnl directory; it is already contained in a preceding -L
+ dnl option.
+ names_next_round="$names_next_round "`echo "X$dep" | sed
-e 's,^X.*/,,' -e 's,^lib,,' -e 's,\.la$,,'`
+ ;;
+ *)
+ dnl Most likely an immediate library name.
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$dep"
+ LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }$dep"
+ ;;
+ esac
+ done
+ fi
+ else
+ dnl Didn't find the library; assume it is in the system directories
+ dnl known to the linker and runtime loader. (All the system
+ dnl directories known to the linker should also be known to the
+ dnl runtime loader, otherwise the system is severely
misconfigured.)
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }-l$name"
+ LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-l$name"
+ fi
+ fi
+ fi
+ done
+ done
+ if test "X$rpathdirs" != "X"; then
+ if test -n "$acl_hardcode_libdir_separator"; then
+ dnl Weird platform: only the last -rpath option counts, the user must
+ dnl pass all path elements in one option. We can arrange that for a
+ dnl single library, but not when more than one $LIBNAMEs are used.
+ alldirs=
+ for found_dir in $rpathdirs; do
+
alldirs="${alldirs}${alldirs:+$acl_hardcode_libdir_separator}$found_dir"
+ done
+ dnl Note: acl_hardcode_libdir_flag_spec uses $libdir and $wl.
+ acl_save_libdir="$libdir"
+ libdir="$alldirs"
+ eval flag=\"$acl_hardcode_libdir_flag_spec\"
+ libdir="$acl_save_libdir"
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$flag"
+ else
+ dnl The -rpath options are cumulative.
+ for found_dir in $rpathdirs; do
+ acl_save_libdir="$libdir"
+ libdir="$found_dir"
+ eval flag=\"$acl_hardcode_libdir_flag_spec\"
+ libdir="$acl_save_libdir"
+ LIB[]NAME="${LIB[]NAME}${LIB[]NAME:+ }$flag"
+ done
+ fi
+ fi
+ if test "X$ltrpathdirs" != "X"; then
+ dnl When using libtool, the option that works for both libraries and
+ dnl executables is -R. The -R options are cumulative.
+ for found_dir in $ltrpathdirs; do
+ LTLIB[]NAME="${LTLIB[]NAME}${LTLIB[]NAME:+ }-R$found_dir"
+ done
+ fi
+ popdef([P_A_C_K])
+ popdef([PACKLIBS])
+ popdef([PACKUP])
+ popdef([PACK])
+ popdef([NAME])
+])
+
+dnl AC_LIB_APPENDTOVAR(VAR, CONTENTS) appends the elements of CONTENTS to VAR,
+dnl unless already present in VAR.
+dnl Works only for CPPFLAGS, not for LIB* variables because that sometimes
+dnl contains two or three consecutive elements that belong together.
+AC_DEFUN([AC_LIB_APPENDTOVAR],
+[
+ for element in [$2]; do
+ haveit=
+ for x in $[$1]; do
+ AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
+ if test "X$x" = "X$element"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ [$1]="${[$1]}${[$1]:+ }$element"
+ fi
+ done
+])
+
+dnl For those cases where a variable contains several -L and -l options
+dnl referring to unknown libraries and directories, this macro determines the
+dnl necessary additional linker options for the runtime path.
+dnl AC_LIB_LINKFLAGS_FROM_LIBS([LDADDVAR], [LIBSVALUE], [USE-LIBTOOL])
+dnl sets LDADDVAR to linker options needed together with LIBSVALUE.
+dnl If USE-LIBTOOL evaluates to non-empty, linking with libtool is assumed,
+dnl otherwise linking without libtool is assumed.
+AC_DEFUN([AC_LIB_LINKFLAGS_FROM_LIBS],
+[
+ AC_REQUIRE([AC_LIB_RPATH])
+ AC_REQUIRE([AC_LIB_PREPARE_MULTILIB])
+ $1=
+ if test "$enable_rpath" != no; then
+ if test -n "$acl_hardcode_libdir_flag_spec" && test
"$acl_hardcode_minus_L" = no; then
+ dnl Use an explicit option to hardcode directories into the resulting
+ dnl binary.
+ rpathdirs=
+ next=
+ for opt in $2; do
+ if test -n "$next"; then
+ dir="$next"
+ dnl No need to hardcode the standard /usr/lib.
+ if test "X$dir" != "X/usr/$acl_libdirstem" \
+ && test "X$dir" != "X/usr/$acl_libdirstem2"; then
+ rpathdirs="$rpathdirs $dir"
+ fi
+ next=
+ else
+ case $opt in
+ -L) next=yes ;;
+ -L*) dir=`echo "X$opt" | sed -e 's,^X-L,,'`
+ dnl No need to hardcode the standard /usr/lib.
+ if test "X$dir" != "X/usr/$acl_libdirstem" \
+ && test "X$dir" != "X/usr/$acl_libdirstem2"; then
+ rpathdirs="$rpathdirs $dir"
+ fi
+ next= ;;
+ *) next= ;;
+ esac
+ fi
+ done
+ if test "X$rpathdirs" != "X"; then
+ if test -n ""$3""; then
+ dnl libtool is used for linking. Use -R options.
+ for dir in $rpathdirs; do
+ $1="${$1}${$1:+ }-R$dir"
+ done
+ else
+ dnl The linker is used for linking directly.
+ if test -n "$acl_hardcode_libdir_separator"; then
+ dnl Weird platform: only the last -rpath option counts, the user
+ dnl must pass all path elements in one option.
+ alldirs=
+ for dir in $rpathdirs; do
+
alldirs="${alldirs}${alldirs:+$acl_hardcode_libdir_separator}$dir"
+ done
+ acl_save_libdir="$libdir"
+ libdir="$alldirs"
+ eval flag=\"$acl_hardcode_libdir_flag_spec\"
+ libdir="$acl_save_libdir"
+ $1="$flag"
+ else
+ dnl The -rpath options are cumulative.
+ for dir in $rpathdirs; do
+ acl_save_libdir="$libdir"
+ libdir="$dir"
+ eval flag=\"$acl_hardcode_libdir_flag_spec\"
+ libdir="$acl_save_libdir"
+ $1="${$1}${$1:+ }$flag"
+ done
+ fi
+ fi
+ fi
+ fi
+ fi
+ AC_SUBST([$1])
+])
diff --git a/m4/lib-prefix.m4 b/m4/lib-prefix.m4
new file mode 100644
index 0000000..4b7ee33
--- /dev/null
+++ b/m4/lib-prefix.m4
@@ -0,0 +1,224 @@
+# lib-prefix.m4 serial 7 (gettext-0.18)
+dnl Copyright (C) 2001-2005, 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 Bruno Haible.
+
+dnl AC_LIB_ARG_WITH is synonymous to AC_ARG_WITH in autoconf-2.13, and
+dnl similar to AC_ARG_WITH in autoconf 2.52...2.57 except that is doesn't
+dnl require excessive bracketing.
+ifdef([AC_HELP_STRING],
+[AC_DEFUN([AC_LIB_ARG_WITH], [AC_ARG_WITH([$1],[[$2]],[$3],[$4])])],
+[AC_DEFUN([AC_][LIB_ARG_WITH], [AC_ARG_WITH([$1],[$2],[$3],[$4])])])
+
+dnl AC_LIB_PREFIX adds to the CPPFLAGS and LDFLAGS the flags that are needed
+dnl to access previously installed libraries. The basic assumption is that
+dnl a user will want packages to use other packages he previously installed
+dnl with the same --prefix option.
+dnl This macro is not needed if only AC_LIB_LINKFLAGS is used to locate
+dnl libraries, but is otherwise very convenient.
+AC_DEFUN([AC_LIB_PREFIX],
+[
+ AC_BEFORE([$0], [AC_LIB_LINKFLAGS])
+ AC_REQUIRE([AC_PROG_CC])
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ AC_REQUIRE([AC_LIB_PREPARE_MULTILIB])
+ AC_REQUIRE([AC_LIB_PREPARE_PREFIX])
+ dnl By default, look in $includedir and $libdir.
+ use_additional=yes
+ AC_LIB_WITH_FINAL_PREFIX([
+ eval additional_includedir=\"$includedir\"
+ eval additional_libdir=\"$libdir\"
+ ])
+ AC_LIB_ARG_WITH([lib-prefix],
+[ --with-lib-prefix[=DIR] search for libraries in DIR/include and DIR/lib
+ --without-lib-prefix don't search for libraries in includedir and libdir],
+[
+ if test "X$withval" = "Xno"; then
+ use_additional=no
+ else
+ if test "X$withval" = "X"; then
+ AC_LIB_WITH_FINAL_PREFIX([
+ eval additional_includedir=\"$includedir\"
+ eval additional_libdir=\"$libdir\"
+ ])
+ else
+ additional_includedir="$withval/include"
+ additional_libdir="$withval/$acl_libdirstem"
+ fi
+ fi
+])
+ if test $use_additional = yes; then
+ dnl Potentially add $additional_includedir to $CPPFLAGS.
+ dnl But don't add it
+ dnl 1. if it's the standard /usr/include,
+ dnl 2. if it's already present in $CPPFLAGS,
+ dnl 3. if it's /usr/local/include and we are using GCC on Linux,
+ dnl 4. if it doesn't exist as a directory.
+ if test "X$additional_includedir" != "X/usr/include"; then
+ haveit=
+ for x in $CPPFLAGS; do
+ AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
+ if test "X$x" = "X-I$additional_includedir"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ if test "X$additional_includedir" = "X/usr/local/include"; then
+ if test -n "$GCC"; then
+ case $host_os in
+ linux* | gnu* | k*bsd*-gnu) haveit=yes;;
+ esac
+ fi
+ fi
+ if test -z "$haveit"; then
+ if test -d "$additional_includedir"; then
+ dnl Really add $additional_includedir to $CPPFLAGS.
+ CPPFLAGS="${CPPFLAGS}${CPPFLAGS:+ }-I$additional_includedir"
+ fi
+ fi
+ fi
+ fi
+ dnl Potentially add $additional_libdir to $LDFLAGS.
+ dnl But don't add it
+ dnl 1. if it's the standard /usr/lib,
+ dnl 2. if it's already present in $LDFLAGS,
+ dnl 3. if it's /usr/local/lib and we are using GCC on Linux,
+ dnl 4. if it doesn't exist as a directory.
+ if test "X$additional_libdir" != "X/usr/$acl_libdirstem"; then
+ haveit=
+ for x in $LDFLAGS; do
+ AC_LIB_WITH_FINAL_PREFIX([eval x=\"$x\"])
+ if test "X$x" = "X-L$additional_libdir"; then
+ haveit=yes
+ break
+ fi
+ done
+ if test -z "$haveit"; then
+ if test "X$additional_libdir" = "X/usr/local/$acl_libdirstem"; then
+ if test -n "$GCC"; then
+ case $host_os in
+ linux*) haveit=yes;;
+ esac
+ fi
+ fi
+ if test -z "$haveit"; then
+ if test -d "$additional_libdir"; then
+ dnl Really add $additional_libdir to $LDFLAGS.
+ LDFLAGS="${LDFLAGS}${LDFLAGS:+ }-L$additional_libdir"
+ fi
+ fi
+ fi
+ fi
+ fi
+])
+
+dnl AC_LIB_PREPARE_PREFIX creates variables acl_final_prefix,
+dnl acl_final_exec_prefix, containing the values to which $prefix and
+dnl $exec_prefix will expand at the end of the configure script.
+AC_DEFUN([AC_LIB_PREPARE_PREFIX],
+[
+ dnl Unfortunately, prefix and exec_prefix get only finally determined
+ dnl at the end of configure.
+ if test "X$prefix" = "XNONE"; then
+ acl_final_prefix="$ac_default_prefix"
+ else
+ acl_final_prefix="$prefix"
+ fi
+ if test "X$exec_prefix" = "XNONE"; then
+ acl_final_exec_prefix='${prefix}'
+ else
+ acl_final_exec_prefix="$exec_prefix"
+ fi
+ acl_save_prefix="$prefix"
+ prefix="$acl_final_prefix"
+ eval acl_final_exec_prefix=\"$acl_final_exec_prefix\"
+ prefix="$acl_save_prefix"
+])
+
+dnl AC_LIB_WITH_FINAL_PREFIX([statement]) evaluates statement, with the
+dnl variables prefix and exec_prefix bound to the values they will have
+dnl at the end of the configure script.
+AC_DEFUN([AC_LIB_WITH_FINAL_PREFIX],
+[
+ acl_save_prefix="$prefix"
+ prefix="$acl_final_prefix"
+ acl_save_exec_prefix="$exec_prefix"
+ exec_prefix="$acl_final_exec_prefix"
+ $1
+ exec_prefix="$acl_save_exec_prefix"
+ prefix="$acl_save_prefix"
+])
+
+dnl AC_LIB_PREPARE_MULTILIB creates
+dnl - a variable acl_libdirstem, containing the basename of the libdir, either
+dnl "lib" or "lib64" or "lib/64",
+dnl - a variable acl_libdirstem2, as a secondary possible value for
+dnl acl_libdirstem, either the same as acl_libdirstem or "lib/sparcv9" or
+dnl "lib/amd64".
+AC_DEFUN([AC_LIB_PREPARE_MULTILIB],
+[
+ dnl There is no formal standard regarding lib and lib64.
+ dnl On glibc systems, the current practice is that on a system supporting
+ dnl 32-bit and 64-bit instruction sets or ABIs, 64-bit libraries go under
+ dnl $prefix/lib64 and 32-bit libraries go under $prefix/lib. We determine
+ dnl the compiler's default mode by looking at the compiler's library search
+ dnl path. If at least one of its elements ends in /lib64 or points to a
+ dnl directory whose absolute pathname ends in /lib64, we assume a 64-bit ABI.
+ dnl Otherwise we use the default, namely "lib".
+ dnl On Solaris systems, the current practice is that on a system supporting
+ dnl 32-bit and 64-bit instruction sets or ABIs, 64-bit libraries go under
+ dnl $prefix/lib/64 (which is a symlink to either $prefix/lib/sparcv9 or
+ dnl $prefix/lib/amd64) and 32-bit libraries go under $prefix/lib.
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ acl_libdirstem=lib
+ acl_libdirstem2=
+ case "$host_os" in
+ solaris*)
+ dnl See Solaris 10 Software Developer Collection > Solaris 64-bit
Developer's Guide > The Development Environment
+ dnl <http://docs.sun.com/app/docs/doc/816-5138/dev-env?l=en&a=view>.
+ dnl "Portable Makefiles should refer to any library directories using
the 64 symbolic link."
+ dnl But we want to recognize the sparcv9 or amd64 subdirectory also if
the
+ dnl symlink is missing, so we set acl_libdirstem2 too.
+ AC_CACHE_CHECK([for 64-bit host], [gl_cv_solaris_64bit],
+ [AC_EGREP_CPP([sixtyfour bits], [
+#ifdef _LP64
+sixtyfour bits
+#endif
+ ], [gl_cv_solaris_64bit=yes], [gl_cv_solaris_64bit=no])
+ ])
+ if test $gl_cv_solaris_64bit = yes; then
+ acl_libdirstem=lib/64
+ case "$host_cpu" in
+ sparc*) acl_libdirstem2=lib/sparcv9 ;;
+ i*86 | x86_64) acl_libdirstem2=lib/amd64 ;;
+ esac
+ fi
+ ;;
+ *)
+ searchpath=`(LC_ALL=C $CC -print-search-dirs) 2>/dev/null | sed -n -e
's,^libraries: ,,p' | sed -e 's,^=,,'`
+ if test -n "$searchpath"; then
+ acl_save_IFS="${IFS= }"; IFS=":"
+ for searchdir in $searchpath; do
+ if test -d "$searchdir"; then
+ case "$searchdir" in
+ */lib64/ | */lib64 ) acl_libdirstem=lib64 ;;
+ */../ | */.. )
+ # Better ignore directories of this form. They are misleading.
+ ;;
+ *) searchdir=`cd "$searchdir" && pwd`
+ case "$searchdir" in
+ */lib64 ) acl_libdirstem=lib64 ;;
+ esac ;;
+ esac
+ fi
+ done
+ IFS="$acl_save_IFS"
+ fi
+ ;;
+ esac
+ test -n "$acl_libdirstem2" || acl_libdirstem2="$acl_libdirstem"
+])
diff --git a/m4/libunistring.m4 b/m4/libunistring.m4
new file mode 100644
index 0000000..52ff06b
--- /dev/null
+++ b/m4/libunistring.m4
@@ -0,0 +1,37 @@
+# libunistring.m4 serial 1
+dnl Copyright (C) 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 gl_LIBUNISTRING
+dnl Searches for an installed libunistring.
+dnl If found, it sets and AC_SUBSTs HAVE_LIBUNISTRING=yes and the LIBUNISTRING
+dnl and LTLIBUNISTRING variables and augments the CPPFLAGS variable, and
+dnl #defines HAVE_LIBUNISTRING to 1. Otherwise, it sets and AC_SUBSTs
+dnl HAVE_LIBUNISTRING=no and LIBUNINSTRING and LTLIBUNISTRING to empty.
+
+AC_DEFUN([gl_LIBUNISTRING],
+[
+ dnl First, try to link without -liconv. libunistring often depends on
+ dnl libiconv, but we don't know (and often don't need to know) where
+ dnl libiconv is installed.
+ AC_LIB_HAVE_LINKFLAGS([unistring], [],
+ [#include <uniconv.h>], [u8_strconv_from_locale((char*)0);],
+ [no, consider installing GNU libunistring])
+ if test "$ac_cv_libunistring" != yes; then
+ dnl Second try, with -liconv.
+ AC_REQUIRE([AM_ICONV])
+ if test -n "$LIBICONV"; then
+ glus_save_LIBS="$LIBS"
+ LIBS="$LIBS $LIBICONV"
+ AC_LIB_HAVE_LINKFLAGS([unistring], [],
+ [#include <uniconv.h>], [u8_strconv_from_locale((char*)0);],
+ [no, consider installing GNU libunistring])
+ if test -n "$LIBUNISTRING"; then
+ LIBUNISTRING="$LIBUNISTRING $LIBICONV"
+ fi
+ LIBS="$glus_save_LIBS"
+ fi
+ fi
+])
diff --git a/m4/localcharset.m4 b/m4/localcharset.m4
index b2b7733..e960104 100644
--- a/m4/localcharset.m4
+++ b/m4/localcharset.m4
@@ -1,5 +1,5 @@
-# localcharset.m4 serial 5
-dnl Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
+# localcharset.m4 serial 6
+dnl Copyright (C) 2002, 2004, 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,
dnl with or without modifications, as long as this notice is preserved.
@@ -8,7 +8,7 @@ AC_DEFUN([gl_LOCALCHARSET],
[
dnl Prerequisites of lib/localcharset.c.
AC_REQUIRE([AM_LANGINFO_CODESET])
- AC_CHECK_DECLS_ONCE(getc_unlocked)
+ AC_CHECK_DECLS_ONCE([getc_unlocked])
dnl Prerequisites of the lib/Makefile.am snippet.
AC_REQUIRE([AC_CANONICAL_HOST])
diff --git a/m4/locale-fr.m4 b/m4/locale-fr.m4
index ac8a78d..653a5bc 100644
--- a/m4/locale-fr.m4
+++ b/m4/locale-fr.m4
@@ -1,5 +1,5 @@
-# locale-fr.m4 serial 9
-dnl Copyright (C) 2003, 2005-2008 Free Software Foundation, Inc.
+# locale-fr.m4 serial 11
+dnl Copyright (C) 2003, 2005-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.
@@ -11,26 +11,8 @@ AC_DEFUN([gt_LOCALE_FR],
[
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([AM_LANGINFO_CODESET])
- AC_CACHE_CHECK([for a traditional french locale], gt_cv_locale_fr, [
- macosx=
-changequote(,)dnl
- case "$host_os" in
- darwin[56]*) ;;
- darwin*) macosx=yes;;
- esac
-changequote([,])dnl
- if test -n "$macosx"; then
- # On Darwin 7 (MacOS X), the libc supports some locales in non-UTF-8
- # encodings, but the kernel does not support them. The documentation
- # says:
- # "... all code that calls BSD system routines should ensure
- # that the const *char parameters of these routines are in UTF-8
- # encoding. All BSD system functions expect their string
- # parameters to be in UTF-8 encoding and nothing else."
- # See the comments in config.charset. Therefore we bypass the test.
- gt_cv_locale_fr=none
- else
- AC_LANG_CONFTEST([AC_LANG_SOURCE([
+ AC_CACHE_CHECK([for a traditional french locale], [gt_cv_locale_fr], [
+ AC_LANG_CONFTEST([AC_LANG_SOURCE([
changequote(,)dnl
#include <locale.h>
#include <time.h>
@@ -75,42 +57,41 @@ int main () {
return 0;
}
changequote([,])dnl
- ])])
- if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
- # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because
- # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the
- # configure script would override the LC_ALL setting. Likewise for
- # LC_CTYPE, which is also set at the beginning of the configure script.
- # Test for the usual locale name.
- if (LC_ALL=fr_FR LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
- gt_cv_locale_fr=fr_FR
+ ])])
+ if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
+ # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because
+ # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the
+ # configure script would override the LC_ALL setting. Likewise for
+ # LC_CTYPE, which is also set at the beginning of the configure script.
+ # Test for the usual locale name.
+ if (LC_ALL=fr_FR LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
+ gt_cv_locale_fr=fr_FR
+ else
+ # Test for the locale name with explicit encoding suffix.
+ if (LC_ALL=fr_FR.ISO-8859-1 LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
+ gt_cv_locale_fr=fr_FR.ISO-8859-1
else
- # Test for the locale name with explicit encoding suffix.
- if (LC_ALL=fr_FR.ISO-8859-1 LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
- gt_cv_locale_fr=fr_FR.ISO-8859-1
+ # Test for the AIX, OSF/1, FreeBSD, NetBSD, OpenBSD locale name.
+ if (LC_ALL=fr_FR.ISO8859-1 LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
+ gt_cv_locale_fr=fr_FR.ISO8859-1
else
- # Test for the AIX, OSF/1, FreeBSD, NetBSD, OpenBSD locale name.
- if (LC_ALL=fr_FR.ISO8859-1 LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
- gt_cv_locale_fr=fr_FR.ISO8859-1
+ # Test for the HP-UX locale name.
+ if (LC_ALL=fr_FR.iso88591 LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
+ gt_cv_locale_fr=fr_FR.iso88591
else
- # Test for the HP-UX locale name.
- if (LC_ALL=fr_FR.iso88591 LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
- gt_cv_locale_fr=fr_FR.iso88591
+ # Test for the Solaris 7 locale name.
+ if (LC_ALL=fr LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null;
then
+ gt_cv_locale_fr=fr
else
- # Test for the Solaris 7 locale name.
- if (LC_ALL=fr LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
- gt_cv_locale_fr=fr
- else
- # None found.
- gt_cv_locale_fr=none
- fi
+ # None found.
+ gt_cv_locale_fr=none
fi
fi
fi
fi
fi
- rm -fr conftest*
fi
+ rm -fr conftest*
])
LOCALE_FR=$gt_cv_locale_fr
AC_SUBST([LOCALE_FR])
@@ -120,7 +101,7 @@ dnl Determine the name of a french locale with UTF-8
encoding.
AC_DEFUN([gt_LOCALE_FR_UTF8],
[
AC_REQUIRE([AM_LANGINFO_CODESET])
- AC_CACHE_CHECK([for a french Unicode locale], gt_cv_locale_fr_utf8, [
+ AC_CACHE_CHECK([for a french Unicode locale], [gt_cv_locale_fr_utf8], [
AC_LANG_CONFTEST([AC_LANG_SOURCE([
changequote(,)dnl
#include <locale.h>
diff --git a/m4/locale-ja.m4 b/m4/locale-ja.m4
index c42064f..9360576 100644
--- a/m4/locale-ja.m4
+++ b/m4/locale-ja.m4
@@ -1,5 +1,5 @@
-# locale-ja.m4 serial 5
-dnl Copyright (C) 2003, 2005-2008 Free Software Foundation, Inc.
+# locale-ja.m4 serial 7
+dnl Copyright (C) 2003, 2005-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.
@@ -11,26 +11,8 @@ AC_DEFUN([gt_LOCALE_JA],
[
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([AM_LANGINFO_CODESET])
- AC_CACHE_CHECK([for a traditional japanese locale], gt_cv_locale_ja, [
- macosx=
-changequote(,)dnl
- case "$host_os" in
- darwin[56]*) ;;
- darwin*) macosx=yes;;
- esac
-changequote([,])dnl
- if test -n "$macosx"; then
- # On Darwin 7 (MacOS X), the libc supports some locales in non-UTF-8
- # encodings, but the kernel does not support them. The documentation
- # says:
- # "... all code that calls BSD system routines should ensure
- # that the const *char parameters of these routines are in UTF-8
- # encoding. All BSD system functions expect their string
- # parameters to be in UTF-8 encoding and nothing else."
- # See the comments in config.charset. Therefore we bypass the test.
- gt_cv_locale_ja=none
- else
- AC_LANG_CONFTEST([AC_LANG_SOURCE([
+ AC_CACHE_CHECK([for a traditional japanese locale], [gt_cv_locale_ja], [
+ AC_LANG_CONFTEST([AC_LANG_SOURCE([
changequote(,)dnl
#include <locale.h>
#include <time.h>
@@ -79,47 +61,46 @@ int main ()
return 0;
}
changequote([,])dnl
- ])])
- if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
- # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because
- # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the
- # configure script would override the LC_ALL setting. Likewise for
- # LC_CTYPE, which is also set at the beginning of the configure script.
- # Test for the AIX locale name.
- if (LC_ALL=ja_JP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
- gt_cv_locale_ja=ja_JP
+ ])])
+ if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
+ # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because
+ # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the
+ # configure script would override the LC_ALL setting. Likewise for
+ # LC_CTYPE, which is also set at the beginning of the configure script.
+ # Test for the AIX locale name.
+ if (LC_ALL=ja_JP LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
+ gt_cv_locale_ja=ja_JP
+ else
+ # Test for the locale name with explicit encoding suffix.
+ if (LC_ALL=ja_JP.EUC-JP LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
+ gt_cv_locale_ja=ja_JP.EUC-JP
else
- # Test for the locale name with explicit encoding suffix.
- if (LC_ALL=ja_JP.EUC-JP LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
- gt_cv_locale_ja=ja_JP.EUC-JP
+ # Test for the HP-UX, OSF/1, NetBSD locale name.
+ if (LC_ALL=ja_JP.eucJP LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
+ gt_cv_locale_ja=ja_JP.eucJP
else
- # Test for the HP-UX, OSF/1, NetBSD locale name.
- if (LC_ALL=ja_JP.eucJP LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
- gt_cv_locale_ja=ja_JP.eucJP
+ # Test for the IRIX, FreeBSD locale name.
+ if (LC_ALL=ja_JP.EUC LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
+ gt_cv_locale_ja=ja_JP.EUC
else
- # Test for the IRIX, FreeBSD locale name.
- if (LC_ALL=ja_JP.EUC LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
- gt_cv_locale_ja=ja_JP.EUC
+ # Test for the Solaris 7 locale name.
+ if (LC_ALL=ja LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null;
then
+ gt_cv_locale_ja=ja
else
- # Test for the Solaris 7 locale name.
- if (LC_ALL=ja LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
- gt_cv_locale_ja=ja
+ # Special test for NetBSD 1.6.
+ if test -f /usr/share/locale/ja_JP.eucJP/LC_CTYPE; then
+ gt_cv_locale_ja=ja_JP.eucJP
else
- # Special test for NetBSD 1.6.
- if test -f /usr/share/locale/ja_JP.eucJP/LC_CTYPE; then
- gt_cv_locale_ja=ja_JP.eucJP
- else
- # None found.
- gt_cv_locale_ja=none
- fi
+ # None found.
+ gt_cv_locale_ja=none
fi
fi
fi
fi
fi
fi
- rm -fr conftest*
fi
+ rm -fr conftest*
])
LOCALE_JA=$gt_cv_locale_ja
AC_SUBST([LOCALE_JA])
diff --git a/m4/locale-zh.m4 b/m4/locale-zh.m4
index 594f62a..36a5f1d 100644
--- a/m4/locale-zh.m4
+++ b/m4/locale-zh.m4
@@ -1,5 +1,5 @@
-# locale-zh.m4 serial 4
-dnl Copyright (C) 2003, 2005-2008 Free Software Foundation, Inc.
+# locale-zh.m4 serial 6
+dnl Copyright (C) 2003, 2005-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.
@@ -11,26 +11,8 @@ AC_DEFUN([gt_LOCALE_ZH_CN],
[
AC_REQUIRE([AC_CANONICAL_HOST])
AC_REQUIRE([AM_LANGINFO_CODESET])
- AC_CACHE_CHECK([for a transitional chinese locale], gt_cv_locale_zh_CN, [
- macosx=
-changequote(,)dnl
- case "$host_os" in
- darwin[56]*) ;;
- darwin*) macosx=yes;;
- esac
-changequote([,])dnl
- if test -n "$macosx"; then
- # On Darwin 7 (MacOS X), the libc supports some locales in non-UTF-8
- # encodings, but the kernel does not support them. The documentation
- # says:
- # "... all code that calls BSD system routines should ensure
- # that the const *char parameters of these routines are in UTF-8
- # encoding. All BSD system functions expect their string
- # parameters to be in UTF-8 encoding and nothing else."
- # See the comments in config.charset. Therefore we bypass the test.
- gt_cv_locale_zh_CN=none
- else
- AC_LANG_CONFTEST([AC_LANG_SOURCE([
+ AC_CACHE_CHECK([for a transitional chinese locale], [gt_cv_locale_zh_CN], [
+ AC_LANG_CONFTEST([AC_LANG_SOURCE([
changequote(,)dnl
#include <locale.h>
#include <stdlib.h>
@@ -80,31 +62,30 @@ int main ()
return 0;
}
changequote([,])dnl
- ])])
- if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
- # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because
- # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the
- # configure script would override the LC_ALL setting. Likewise for
- # LC_CTYPE, which is also set at the beginning of the configure script.
- # Test for the locale name without encoding suffix.
- if (LC_ALL=zh_CN LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
- gt_cv_locale_zh_CN=zh_CN
+ ])])
+ if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
+ # Setting LC_ALL is not enough. Need to set LC_TIME to empty, because
+ # otherwise on MacOS X 10.3.5 the LC_TIME=C from the beginning of the
+ # configure script would override the LC_ALL setting. Likewise for
+ # LC_CTYPE, which is also set at the beginning of the configure script.
+ # Test for the locale name without encoding suffix.
+ if (LC_ALL=zh_CN LC_TIME= LC_CTYPE= ./conftest; exit) 2>/dev/null; then
+ gt_cv_locale_zh_CN=zh_CN
+ else
+ # Test for the locale name with explicit encoding suffix.
+ if (LC_ALL=zh_CN.GB18030 LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
+ gt_cv_locale_zh_CN=zh_CN.GB18030
else
- # Test for the locale name with explicit encoding suffix.
- if (LC_ALL=zh_CN.GB18030 LC_TIME= LC_CTYPE= ./conftest; exit)
2>/dev/null; then
- gt_cv_locale_zh_CN=zh_CN.GB18030
- else
- # None found.
- gt_cv_locale_zh_CN=none
- fi
+ # None found.
+ gt_cv_locale_zh_CN=none
fi
- else
- # If there was a link error, due to mblen(), the system is so old that
- # it certainly doesn't have a chinese locale.
- gt_cv_locale_zh_CN=none
fi
- rm -fr conftest*
+ else
+ # If there was a link error, due to mblen(), the system is so old that
+ # it certainly doesn't have a chinese locale.
+ gt_cv_locale_zh_CN=none
fi
+ rm -fr conftest*
])
LOCALE_ZH_CN=$gt_cv_locale_zh_CN
AC_SUBST([LOCALE_ZH_CN])
diff --git a/m4/longlong.m4 b/m4/longlong.m4
new file mode 100644
index 0000000..eedc8d5
--- /dev/null
+++ b/m4/longlong.m4
@@ -0,0 +1,106 @@
+# longlong.m4 serial 14
+dnl Copyright (C) 1999-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,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl From Paul Eggert.
+
+# Define HAVE_LONG_LONG_INT if 'long long int' works.
+# This fixes a bug in Autoconf 2.61, but can be removed once we
+# assume 2.62 everywhere.
+
+# Note: If the type 'long long int' exists but is only 32 bits large
+# (as on some very old compilers), HAVE_LONG_LONG_INT will not be
+# defined. In this case you can treat 'long long int' like 'long int'.
+
+AC_DEFUN([AC_TYPE_LONG_LONG_INT],
+[
+ AC_CACHE_CHECK([for long long int], [ac_cv_type_long_long_int],
+ [AC_LINK_IFELSE(
+ [_AC_TYPE_LONG_LONG_SNIPPET],
+ [dnl This catches a bug in Tandem NonStop Kernel (OSS) cc -O circa 2004.
+ dnl If cross compiling, assume the bug isn't important, since
+ dnl nobody cross compiles for this platform as far as we know.
+ AC_RUN_IFELSE(
+ [AC_LANG_PROGRAM(
+ address@hidden:@include <limits.h>
+ @%:@ifndef LLONG_MAX
+ @%:@ define HALF \
+ (1LL << (sizeof (long long int) * CHAR_BIT - 2))
+ @%:@ define LLONG_MAX (HALF - 1 + HALF)
+ @%:@endif]],
+ [[long long int n = 1;
+ int i;
+ for (i = 0; ; i++)
+ {
+ long long int m = n << i;
+ if (m >> i != n)
+ return 1;
+ if (LLONG_MAX / 2 < m)
+ break;
+ }
+ return 0;]])],
+ [ac_cv_type_long_long_int=yes],
+ [ac_cv_type_long_long_int=no],
+ [ac_cv_type_long_long_int=yes])],
+ [ac_cv_type_long_long_int=no])])
+ if test $ac_cv_type_long_long_int = yes; then
+ AC_DEFINE([HAVE_LONG_LONG_INT], [1],
+ [Define to 1 if the system has the type `long long int'.])
+ fi
+])
+
+# Define HAVE_UNSIGNED_LONG_LONG_INT if 'unsigned long long int' works.
+# This fixes a bug in Autoconf 2.61, but can be removed once we
+# assume 2.62 everywhere.
+
+# Note: If the type 'unsigned long long int' exists but is only 32 bits
+# large (as on some very old compilers), AC_TYPE_UNSIGNED_LONG_LONG_INT
+# will not be defined. In this case you can treat 'unsigned long long int'
+# like 'unsigned long int'.
+
+AC_DEFUN([AC_TYPE_UNSIGNED_LONG_LONG_INT],
+[
+ AC_CACHE_CHECK([for unsigned long long int],
+ [ac_cv_type_unsigned_long_long_int],
+ [AC_LINK_IFELSE(
+ [_AC_TYPE_LONG_LONG_SNIPPET],
+ [ac_cv_type_unsigned_long_long_int=yes],
+ [ac_cv_type_unsigned_long_long_int=no])])
+ if test $ac_cv_type_unsigned_long_long_int = yes; then
+ AC_DEFINE([HAVE_UNSIGNED_LONG_LONG_INT], [1],
+ [Define to 1 if the system has the type `unsigned long long int'.])
+ fi
+])
+
+# Expands to a C program that can be used to test for simultaneous support
+# of 'long long' and 'unsigned long long'. We don't want to say that
+# 'long long' is available if 'unsigned long long' is not, or vice versa,
+# because too many programs rely on the symmetry between signed and unsigned
+# integer types (excluding 'bool').
+AC_DEFUN([_AC_TYPE_LONG_LONG_SNIPPET],
+[
+ AC_LANG_PROGRAM(
+ [[/* For now, do not test the preprocessor; as of 2007 there are too many
+ implementations with broken preprocessors. Perhaps this can
+ be revisited in 2012. In the meantime, code should not expect
+ #if to work with literals wider than 32 bits. */
+ /* Test literals. */
+ long long int ll = 9223372036854775807ll;
+ long long int nll = -9223372036854775807LL;
+ unsigned long long int ull = 18446744073709551615ULL;
+ /* Test constant expressions. */
+ typedef int a[((-9223372036854775807LL < 0 && 0 < 9223372036854775807ll)
+ ? 1 : -1)];
+ typedef int b[(18446744073709551615ULL <= (unsigned long long int) -1
+ ? 1 : -1)];
+ int i = 63;]],
+ [[/* Test availability of runtime routines for shift and division. */
+ long long int llmax = 9223372036854775807ll;
+ unsigned long long int ullmax = 18446744073709551615ull;
+ return ((ll << 63) | (ll >> 63) | (ll < i) | (ll > i)
+ | (llmax / ll) | (llmax % ll)
+ | (ull << 63) | (ull >> 63) | (ull << i) | (ull >> i)
+ | (ullmax / ull) | (ullmax % ull));]])
+])
diff --git a/m4/malloc.m4 b/m4/malloc.m4
new file mode 100644
index 0000000..8070171
--- /dev/null
+++ b/m4/malloc.m4
@@ -0,0 +1,41 @@
+# malloc.m4 serial 9
+dnl Copyright (C) 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,
+dnl with or without modifications, as long as this notice is preserved.
+
+# gl_FUNC_MALLOC_POSIX
+# --------------------
+# Test whether 'malloc' is POSIX compliant (sets errno to ENOMEM when it
+# fails), and replace malloc if it is not.
+AC_DEFUN([gl_FUNC_MALLOC_POSIX],
+[
+ AC_REQUIRE([gl_CHECK_MALLOC_POSIX])
+ if test $gl_cv_func_malloc_posix = yes; then
+ HAVE_MALLOC_POSIX=1
+ AC_DEFINE([HAVE_MALLOC_POSIX], [1],
+ [Define if the 'malloc' function is POSIX compliant.])
+ else
+ AC_LIBOBJ([malloc])
+ HAVE_MALLOC_POSIX=0
+ fi
+ AC_SUBST([HAVE_MALLOC_POSIX])
+])
+
+# Test whether malloc, realloc, calloc are POSIX compliant,
+# Set gl_cv_func_malloc_posix to yes or no accordingly.
+AC_DEFUN([gl_CHECK_MALLOC_POSIX],
+[
+ AC_CACHE_CHECK([whether malloc, realloc, calloc are POSIX compliant],
+ [gl_cv_func_malloc_posix],
+ [
+ dnl It is too dangerous to try to allocate a large amount of memory:
+ dnl some systems go to their knees when you do that. So assume that
+ dnl all Unix implementations of the function are POSIX compliant.
+ AC_TRY_COMPILE([],
+ [#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+ choke me
+ #endif
+ ], [gl_cv_func_malloc_posix=yes], [gl_cv_func_malloc_posix=no])
+ ])
+])
diff --git a/m4/mbrtowc.m4 b/m4/mbrtowc.m4
index da0d426..11d7d23 100644
--- a/m4/mbrtowc.m4
+++ b/m4/mbrtowc.m4
@@ -1,5 +1,5 @@
-# mbrtowc.m4 serial 12
-dnl Copyright (C) 2001-2002, 2004-2005, 2008 Free Software Foundation, Inc.
+# mbrtowc.m4 serial 15
+dnl Copyright (C) 2001-2002, 2004-2005, 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.
@@ -65,9 +65,15 @@ AC_DEFUN([gl_MBSTATE_T_BROKEN],
AC_CHECK_FUNCS_ONCE([mbrtowc])
if test $ac_cv_func_mbsinit = yes && test $ac_cv_func_mbrtowc = yes; then
gl_MBRTOWC_INCOMPLETE_STATE
+ gl_MBRTOWC_SANITYCHECK
+ REPLACE_MBSTATE_T=0
case "$gl_cv_func_mbrtowc_incomplete_state" in
- *yes) REPLACE_MBSTATE_T=0 ;;
- *) REPLACE_MBSTATE_T=1 ;;
+ *yes) ;;
+ *) REPLACE_MBSTATE_T=1 ;;
+ esac
+ case "$gl_cv_func_mbrtowc_sanitycheck" in
+ *yes) ;;
+ *) REPLACE_MBSTATE_T=1 ;;
esac
else
REPLACE_MBSTATE_T=1
@@ -121,7 +127,58 @@ int main ()
}],
[gl_cv_func_mbrtowc_incomplete_state=yes],
[gl_cv_func_mbrtowc_incomplete_state=no],
- [])
+ [:])
+ fi
+ ])
+])
+
+dnl Test whether mbrtowc works not worse than mbtowc.
+dnl Result is gl_cv_func_mbrtowc_sanitycheck.
+
+AC_DEFUN([gl_MBRTOWC_SANITYCHECK],
+[
+ AC_REQUIRE([AC_PROG_CC])
+ AC_REQUIRE([gt_LOCALE_ZH_CN])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_CACHE_CHECK([whether mbrtowc works as well as mbtowc],
+ [gl_cv_func_mbrtowc_sanitycheck],
+ [
+ dnl Initial guess, used when cross-compiling or when no suitable locale
+ dnl is present.
+changequote(,)dnl
+ case "$host_os" in
+ # Guess no on Solaris 8.
+ solaris2.8) gl_cv_func_mbrtowc_sanitycheck="guessing no" ;;
+ # Guess yes otherwise.
+ *) gl_cv_func_mbrtowc_sanitycheck="guessing yes" ;;
+ esac
+changequote([,])dnl
+ if test $LOCALE_ZH_CN != none; then
+ AC_TRY_RUN([
+#include <locale.h>
+#include <string.h>
+#include <wchar.h>
+int main ()
+{
+ /* This fails on Solaris 8:
+ mbrtowc returns 2, and sets wc to 0x00F0.
+ mbtowc returns 4 (correct) and sets wc to 0x5EDC. */
+ if (setlocale (LC_ALL, "$LOCALE_ZH_CN") != NULL)
+ {
+ char input[] = "B\250\271\201\060\211\070er"; /* "BüÃer" */
+ mbstate_t state;
+ wchar_t wc;
+
+ memset (&state, '\0', sizeof (mbstate_t));
+ if (mbrtowc (&wc, input + 3, 6, &state) != 4
+ && mbtowc (&wc, input + 3, 6) == 4)
+ return 1;
+ }
+ return 0;
+}],
+ [gl_cv_func_mbrtowc_sanitycheck=yes],
+ [gl_cv_func_mbrtowc_sanitycheck=no],
+ [:])
fi
])
])
@@ -168,7 +225,7 @@ int main ()
return 1;
}
return 0;
-}], [gl_cv_func_mbrtowc_null_arg=yes], [gl_cv_func_mbrtowc_null_arg=no], [])
+}], [gl_cv_func_mbrtowc_null_arg=yes], [gl_cv_func_mbrtowc_null_arg=no], [:])
fi
])
])
@@ -238,7 +295,7 @@ int main ()
}],
[gl_cv_func_mbrtowc_retval=yes],
[gl_cv_func_mbrtowc_retval=no],
- [])
+ [:])
fi
])
])
@@ -258,10 +315,10 @@ AC_DEFUN([gl_MBRTOWC_NUL_RETVAL],
dnl is present.
changequote(,)dnl
case "$host_os" in
- # Guess no on Solaris 9.
- solaris2.9) gl_cv_func_mbrtowc_nul_retval="guessing no" ;;
- # Guess yes otherwise.
- *) gl_cv_func_mbrtowc_nul_retval="guessing yes" ;;
+ # Guess no on Solaris 8 and 9.
+ solaris2.[89]) gl_cv_func_mbrtowc_nul_retval="guessing no" ;;
+ # Guess yes otherwise.
+ *) gl_cv_func_mbrtowc_nul_retval="guessing yes" ;;
esac
changequote([,])dnl
if test $LOCALE_ZH_CN != none; then
@@ -271,7 +328,7 @@ changequote([,])dnl
#include <wchar.h>
int main ()
{
- /* This fails on Solaris 9. */
+ /* This fails on Solaris 8 and 9. */
if (setlocale (LC_ALL, "$LOCALE_ZH_CN") != NULL)
{
mbstate_t state;
@@ -285,7 +342,7 @@ int main ()
}],
[gl_cv_func_mbrtowc_nul_retval=yes],
[gl_cv_func_mbrtowc_nul_retval=no],
- [])
+ [:])
fi
])
])
@@ -318,7 +375,7 @@ AC_DEFUN([AC_FUNC_MBRTOWC],
gl_cv_func_mbrtowc=yes,
gl_cv_func_mbrtowc=no)])
if test $gl_cv_func_mbrtowc = yes; then
- AC_DEFINE([HAVE_MBRTOWC], 1,
+ AC_DEFINE([HAVE_MBRTOWC], [1],
[Define to 1 if mbrtowc and mbstate_t are properly declared.])
fi
])
diff --git a/m4/mbstate_t.m4 b/m4/mbstate_t.m4
index d2153d9..d4ec6f0 100644
--- a/m4/mbstate_t.m4
+++ b/m4/mbstate_t.m4
@@ -1,5 +1,5 @@
-# mbstate_t.m4 serial 11
-dnl Copyright (C) 2000-2002, 2008 Free Software Foundation, Inc.
+# mbstate_t.m4 serial 12
+dnl Copyright (C) 2000-2002, 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.
@@ -16,7 +16,7 @@ AC_DEFUN([AC_TYPE_MBSTATE_T],
[
AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) dnl for HP-UX 11.11
- AC_CACHE_CHECK([for mbstate_t], ac_cv_type_mbstate_t,
+ AC_CACHE_CHECK([for mbstate_t], [ac_cv_type_mbstate_t],
[AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
[AC_INCLUDES_DEFAULT[
@@ -25,10 +25,10 @@ AC_DEFUN([AC_TYPE_MBSTATE_T],
[ac_cv_type_mbstate_t=yes],
[ac_cv_type_mbstate_t=no])])
if test $ac_cv_type_mbstate_t = yes; then
- AC_DEFINE([HAVE_MBSTATE_T], 1,
+ AC_DEFINE([HAVE_MBSTATE_T], [1],
[Define to 1 if <wchar.h> declares mbstate_t.])
else
- AC_DEFINE([mbstate_t], int,
+ AC_DEFINE([mbstate_t], [int],
[Define to a type if <wchar.h> does not define.])
fi
])
diff --git a/m4/multiarch.m4 b/m4/multiarch.m4
new file mode 100644
index 0000000..ec377ba
--- /dev/null
+++ b/m4/multiarch.m4
@@ -0,0 +1,65 @@
+# multiarch.m4 serial 5
+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.
+
+# Determine whether the compiler is or may be producing universal binaries.
+#
+# On MacOS X 10.5 and later systems, the user can create libraries and
+# executables that work on multiple system types--known as "fat" or
+# "universal" binaries--by specifying multiple '-arch' options to the
+# compiler but only a single '-arch' option to the preprocessor. Like
+# this:
+#
+# ./configure CC="gcc -arch i386 -arch x86_64 -arch ppc -arch ppc64" \
+# CXX="g++ -arch i386 -arch x86_64 -arch ppc -arch ppc64" \
+# CPP="gcc -E" CXXCPP="g++ -E"
+#
+# Detect this situation and set the macro AA_APPLE_UNIVERSAL_BUILD at the
+# beginning of config.h and set APPLE_UNIVERSAL_BUILD accordingly.
+
+AC_DEFUN_ONCE([gl_MULTIARCH],
+[
+ dnl Code similar to autoconf-2.63 AC_C_BIGENDIAN.
+ gl_cv_c_multiarch=no
+ AC_COMPILE_IFELSE(
+ [AC_LANG_SOURCE(
+ [[#ifndef __APPLE_CC__
+ not a universal capable compiler
+ #endif
+ typedef int dummy;
+ ]])],
+ [
+ dnl Check for potential -arch flags. It is not universal unless
+ dnl there are at least two -arch flags with different values.
+ arch=
+ prev=
+ for word in ${CC} ${CFLAGS} ${CPPFLAGS} ${LDFLAGS}; do
+ if test -n "$prev"; then
+ case $word in
+ i?86 | x86_64 | ppc | ppc64)
+ if test -z "$arch" || test "$arch" = "$word"; then
+ arch="$word"
+ else
+ gl_cv_c_multiarch=yes
+ fi
+ ;;
+ esac
+ prev=
+ else
+ if test "x$word" = "x-arch"; then
+ prev=arch
+ fi
+ fi
+ done
+ ])
+ if test $gl_cv_c_multiarch = yes; then
+ AC_DEFINE([AA_APPLE_UNIVERSAL_BUILD], [1],
+ [Define if the compiler is building for multiple architectures of Apple
platforms at once.])
+ APPLE_UNIVERSAL_BUILD=1
+ else
+ APPLE_UNIVERSAL_BUILD=0
+ fi
+ AC_SUBST([APPLE_UNIVERSAL_BUILD])
+])
diff --git a/m4/putenv.m4 b/m4/putenv.m4
new file mode 100644
index 0000000..120f5a4
--- /dev/null
+++ b/m4/putenv.m4
@@ -0,0 +1,41 @@
+# putenv.m4 serial 16
+dnl Copyright (C) 2002-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 Jim Meyering.
+dnl
+dnl Check whether putenv ("FOO") removes FOO from the environment.
+dnl The putenv in libc on at least SunOS 4.1.4 does *not* do that.
+
+AC_DEFUN([gl_FUNC_PUTENV],
+[
+ AC_REQUIRE([gl_STDLIB_H_DEFAULTS])
+ AC_CACHE_CHECK([for putenv compatible with GNU and SVID],
+ [gl_cv_func_svid_putenv],
+ [AC_RUN_IFELSE([AC_LANG_PROGRAM([AC_INCLUDES_DEFAULT],[[
+ /* Put it in env. */
+ if (putenv ("CONFTEST_putenv=val"))
+ return 1;
+
+ /* Try to remove it. */
+ if (putenv ("CONFTEST_putenv"))
+ return 1;
+
+ /* Make sure it was deleted. */
+ if (getenv ("CONFTEST_putenv") != 0)
+ return 1;
+
+ return 0;
+ ]])],
+ gl_cv_func_svid_putenv=yes,
+ gl_cv_func_svid_putenv=no,
+ dnl When crosscompiling, assume putenv is broken.
+ gl_cv_func_svid_putenv=no)
+ ])
+ if test $gl_cv_func_svid_putenv = no; then
+ REPLACE_PUTENV=1
+ AC_LIBOBJ([putenv])
+ fi
+])
diff --git a/m4/stdbool.m4 b/m4/stdbool.m4
index 2204ecd..57c804a 100644
--- a/m4/stdbool.m4
+++ b/m4/stdbool.m4
@@ -1,6 +1,6 @@
# Check for stdbool.h that conforms to C99.
-dnl Copyright (C) 2002-2006 Free Software Foundation, Inc.
+dnl Copyright (C) 2002-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,
dnl with or without modifications, as long as this notice is preserved.
@@ -111,5 +111,5 @@ AC_DEFUN([AC_HEADER_STDBOOL],
[ac_cv_header_stdbool_h=no])])
AC_CHECK_TYPES([_Bool])
if test $ac_cv_header_stdbool_h = yes; then
- AC_DEFINE(HAVE_STDBOOL_H, 1, [Define to 1 if stdbool.h conforms to C99.])
+ AC_DEFINE([HAVE_STDBOOL_H], [1], [Define to 1 if stdbool.h conforms to
C99.])
fi])
diff --git a/m4/stdint.m4 b/m4/stdint.m4
new file mode 100644
index 0000000..a2e8bdd
--- /dev/null
+++ b/m4/stdint.m4
@@ -0,0 +1,472 @@
+# stdint.m4 serial 34
+dnl Copyright (C) 2001-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 Paul Eggert and Bruno Haible.
+dnl Test whether <stdint.h> is supported or must be substituted.
+
+AC_DEFUN([gl_STDINT_H],
+[
+ AC_PREREQ([2.59])dnl
+
+ dnl Check for long long int and unsigned long long int.
+ AC_REQUIRE([AC_TYPE_LONG_LONG_INT])
+ if test $ac_cv_type_long_long_int = yes; then
+ HAVE_LONG_LONG_INT=1
+ else
+ HAVE_LONG_LONG_INT=0
+ fi
+ AC_SUBST([HAVE_LONG_LONG_INT])
+ AC_REQUIRE([AC_TYPE_UNSIGNED_LONG_LONG_INT])
+ if test $ac_cv_type_unsigned_long_long_int = yes; then
+ HAVE_UNSIGNED_LONG_LONG_INT=1
+ else
+ HAVE_UNSIGNED_LONG_LONG_INT=0
+ fi
+ AC_SUBST([HAVE_UNSIGNED_LONG_LONG_INT])
+
+ dnl Check for <inttypes.h>.
+ dnl AC_INCLUDES_DEFAULT defines $ac_cv_header_inttypes_h.
+ if test $ac_cv_header_inttypes_h = yes; then
+ HAVE_INTTYPES_H=1
+ else
+ HAVE_INTTYPES_H=0
+ fi
+ AC_SUBST([HAVE_INTTYPES_H])
+
+ dnl Check for <sys/types.h>.
+ dnl AC_INCLUDES_DEFAULT defines $ac_cv_header_sys_types_h.
+ if test $ac_cv_header_sys_types_h = yes; then
+ HAVE_SYS_TYPES_H=1
+ else
+ HAVE_SYS_TYPES_H=0
+ fi
+ AC_SUBST([HAVE_SYS_TYPES_H])
+
+ gl_CHECK_NEXT_HEADERS([stdint.h])
+ if test $ac_cv_header_stdint_h = yes; then
+ HAVE_STDINT_H=1
+ else
+ HAVE_STDINT_H=0
+ fi
+ AC_SUBST([HAVE_STDINT_H])
+
+ dnl Now see whether we need a substitute <stdint.h>.
+ if test $ac_cv_header_stdint_h = yes; then
+ AC_CACHE_CHECK([whether stdint.h conforms to C99],
+ [gl_cv_header_working_stdint_h],
+ [gl_cv_header_working_stdint_h=no
+ AC_COMPILE_IFELSE([
+ AC_LANG_PROGRAM([[
+#define __STDC_LIMIT_MACROS 1 /* to make it work also in C++ mode */
+#define __STDC_CONSTANT_MACROS 1 /* to make it work also in C++ mode */
+#define _GL_JUST_INCLUDE_SYSTEM_STDINT_H 1 /* work if build isn't clean */
+#include <stdint.h>
+/* Dragonfly defines WCHAR_MIN, WCHAR_MAX only in <wchar.h>. */
+#if !(defined WCHAR_MIN && defined WCHAR_MAX)
+#error "WCHAR_MIN, WCHAR_MAX not defined in <stdint.h>"
+#endif
+]
+gl_STDINT_INCLUDES
+[
+#ifdef INT8_MAX
+int8_t a1 = INT8_MAX;
+int8_t a1min = INT8_MIN;
+#endif
+#ifdef INT16_MAX
+int16_t a2 = INT16_MAX;
+int16_t a2min = INT16_MIN;
+#endif
+#ifdef INT32_MAX
+int32_t a3 = INT32_MAX;
+int32_t a3min = INT32_MIN;
+#endif
+#ifdef INT64_MAX
+int64_t a4 = INT64_MAX;
+int64_t a4min = INT64_MIN;
+#endif
+#ifdef UINT8_MAX
+uint8_t b1 = UINT8_MAX;
+#else
+typedef int b1[(unsigned char) -1 != 255 ? 1 : -1];
+#endif
+#ifdef UINT16_MAX
+uint16_t b2 = UINT16_MAX;
+#endif
+#ifdef UINT32_MAX
+uint32_t b3 = UINT32_MAX;
+#endif
+#ifdef UINT64_MAX
+uint64_t b4 = UINT64_MAX;
+#endif
+int_least8_t c1 = INT8_C (0x7f);
+int_least8_t c1max = INT_LEAST8_MAX;
+int_least8_t c1min = INT_LEAST8_MIN;
+int_least16_t c2 = INT16_C (0x7fff);
+int_least16_t c2max = INT_LEAST16_MAX;
+int_least16_t c2min = INT_LEAST16_MIN;
+int_least32_t c3 = INT32_C (0x7fffffff);
+int_least32_t c3max = INT_LEAST32_MAX;
+int_least32_t c3min = INT_LEAST32_MIN;
+int_least64_t c4 = INT64_C (0x7fffffffffffffff);
+int_least64_t c4max = INT_LEAST64_MAX;
+int_least64_t c4min = INT_LEAST64_MIN;
+uint_least8_t d1 = UINT8_C (0xff);
+uint_least8_t d1max = UINT_LEAST8_MAX;
+uint_least16_t d2 = UINT16_C (0xffff);
+uint_least16_t d2max = UINT_LEAST16_MAX;
+uint_least32_t d3 = UINT32_C (0xffffffff);
+uint_least32_t d3max = UINT_LEAST32_MAX;
+uint_least64_t d4 = UINT64_C (0xffffffffffffffff);
+uint_least64_t d4max = UINT_LEAST64_MAX;
+int_fast8_t e1 = INT_FAST8_MAX;
+int_fast8_t e1min = INT_FAST8_MIN;
+int_fast16_t e2 = INT_FAST16_MAX;
+int_fast16_t e2min = INT_FAST16_MIN;
+int_fast32_t e3 = INT_FAST32_MAX;
+int_fast32_t e3min = INT_FAST32_MIN;
+int_fast64_t e4 = INT_FAST64_MAX;
+int_fast64_t e4min = INT_FAST64_MIN;
+uint_fast8_t f1 = UINT_FAST8_MAX;
+uint_fast16_t f2 = UINT_FAST16_MAX;
+uint_fast32_t f3 = UINT_FAST32_MAX;
+uint_fast64_t f4 = UINT_FAST64_MAX;
+#ifdef INTPTR_MAX
+intptr_t g = INTPTR_MAX;
+intptr_t gmin = INTPTR_MIN;
+#endif
+#ifdef UINTPTR_MAX
+uintptr_t h = UINTPTR_MAX;
+#endif
+intmax_t i = INTMAX_MAX;
+uintmax_t j = UINTMAX_MAX;
+
+#include <limits.h> /* for CHAR_BIT */
+#define TYPE_MINIMUM(t) \
+ ((t) ((t) 0 < (t) -1 ? (t) 0 : ~ (t) 0 << (sizeof (t) * CHAR_BIT - 1)))
+#define TYPE_MAXIMUM(t) \
+ ((t) ((t) 0 < (t) -1 ? (t) -1 : ~ (~ (t) 0 << (sizeof (t) * CHAR_BIT - 1))))
+struct s {
+ int check_PTRDIFF:
+ PTRDIFF_MIN == TYPE_MINIMUM (ptrdiff_t)
+ && PTRDIFF_MAX == TYPE_MAXIMUM (ptrdiff_t)
+ ? 1 : -1;
+ /* Detect bug in FreeBSD 6.0 / ia64. */
+ int check_SIG_ATOMIC:
+ SIG_ATOMIC_MIN == TYPE_MINIMUM (sig_atomic_t)
+ && SIG_ATOMIC_MAX == TYPE_MAXIMUM (sig_atomic_t)
+ ? 1 : -1;
+ int check_SIZE: SIZE_MAX == TYPE_MAXIMUM (size_t) ? 1 : -1;
+ int check_WCHAR:
+ WCHAR_MIN == TYPE_MINIMUM (wchar_t)
+ && WCHAR_MAX == TYPE_MAXIMUM (wchar_t)
+ ? 1 : -1;
+ /* Detect bug in mingw. */
+ int check_WINT:
+ WINT_MIN == TYPE_MINIMUM (wint_t)
+ && WINT_MAX == TYPE_MAXIMUM (wint_t)
+ ? 1 : -1;
+
+ /* Detect bugs in glibc 2.4 and Solaris 10 stdint.h, among others. */
+ int check_UINT8_C:
+ (-1 < UINT8_C (0)) == (-1 < (uint_least8_t) 0) ? 1 : -1;
+ int check_UINT16_C:
+ (-1 < UINT16_C (0)) == (-1 < (uint_least16_t) 0) ? 1 : -1;
+
+ /* Detect bugs in OpenBSD 3.9 stdint.h. */
+#ifdef UINT8_MAX
+ int check_uint8: (uint8_t) -1 == UINT8_MAX ? 1 : -1;
+#endif
+#ifdef UINT16_MAX
+ int check_uint16: (uint16_t) -1 == UINT16_MAX ? 1 : -1;
+#endif
+#ifdef UINT32_MAX
+ int check_uint32: (uint32_t) -1 == UINT32_MAX ? 1 : -1;
+#endif
+#ifdef UINT64_MAX
+ int check_uint64: (uint64_t) -1 == UINT64_MAX ? 1 : -1;
+#endif
+ int check_uint_least8: (uint_least8_t) -1 == UINT_LEAST8_MAX ? 1 : -1;
+ int check_uint_least16: (uint_least16_t) -1 == UINT_LEAST16_MAX ? 1 : -1;
+ int check_uint_least32: (uint_least32_t) -1 == UINT_LEAST32_MAX ? 1 : -1;
+ int check_uint_least64: (uint_least64_t) -1 == UINT_LEAST64_MAX ? 1 : -1;
+ int check_uint_fast8: (uint_fast8_t) -1 == UINT_FAST8_MAX ? 1 : -1;
+ int check_uint_fast16: (uint_fast16_t) -1 == UINT_FAST16_MAX ? 1 : -1;
+ int check_uint_fast32: (uint_fast32_t) -1 == UINT_FAST32_MAX ? 1 : -1;
+ int check_uint_fast64: (uint_fast64_t) -1 == UINT_FAST64_MAX ? 1 : -1;
+ int check_uintptr: (uintptr_t) -1 == UINTPTR_MAX ? 1 : -1;
+ int check_uintmax: (uintmax_t) -1 == UINTMAX_MAX ? 1 : -1;
+ int check_size: (size_t) -1 == SIZE_MAX ? 1 : -1;
+};
+ ]])],
+ [dnl Determine whether the various *_MIN, *_MAX macros are usable
+ dnl in preprocessor expression. We could do it by compiling a test
+ dnl program for each of these macros. It is faster to run a program
+ dnl that inspects the macro expansion.
+ dnl This detects a bug on HP-UX 11.23/ia64.
+ AC_RUN_IFELSE([
+ AC_LANG_PROGRAM([[
+#define __STDC_LIMIT_MACROS 1 /* to make it work also in C++ mode */
+#define __STDC_CONSTANT_MACROS 1 /* to make it work also in C++ mode */
+#define _GL_JUST_INCLUDE_SYSTEM_STDINT_H 1 /* work if build isn't clean */
+#include <stdint.h>
+]
+gl_STDINT_INCLUDES
+[
+#include <stdio.h>
+#include <string.h>
+#define MVAL(macro) MVAL1(macro)
+#define MVAL1(expression) #expression
+static const char *macro_values[] =
+ {
+#ifdef INT8_MAX
+ MVAL (INT8_MAX),
+#endif
+#ifdef INT16_MAX
+ MVAL (INT16_MAX),
+#endif
+#ifdef INT32_MAX
+ MVAL (INT32_MAX),
+#endif
+#ifdef INT64_MAX
+ MVAL (INT64_MAX),
+#endif
+#ifdef UINT8_MAX
+ MVAL (UINT8_MAX),
+#endif
+#ifdef UINT16_MAX
+ MVAL (UINT16_MAX),
+#endif
+#ifdef UINT32_MAX
+ MVAL (UINT32_MAX),
+#endif
+#ifdef UINT64_MAX
+ MVAL (UINT64_MAX),
+#endif
+ NULL
+ };
+]], [[
+ const char **mv;
+ for (mv = macro_values; *mv != NULL; mv++)
+ {
+ const char *value = *mv;
+ /* Test whether it looks like a cast expression. */
+ if (strncmp (value, "((unsigned int)"/*)*/, 15) == 0
+ || strncmp (value, "((unsigned short)"/*)*/, 17) == 0
+ || strncmp (value, "((unsigned char)"/*)*/, 16) == 0
+ || strncmp (value, "((int)"/*)*/, 6) == 0
+ || strncmp (value, "((signed short)"/*)*/, 15) == 0
+ || strncmp (value, "((signed char)"/*)*/, 14) == 0)
+ return 1;
+ }
+ return 0;
+]])],
+ [gl_cv_header_working_stdint_h=yes],
+ [],
+ [dnl When cross-compiling, assume it works.
+ gl_cv_header_working_stdint_h=yes
+ ])
+ ])
+ ])
+ fi
+ if test "$gl_cv_header_working_stdint_h" = yes; then
+ STDINT_H=
+ else
+ dnl Check for <sys/inttypes.h>, and for
+ dnl <sys/bitypes.h> (used in Linux libc4 >= 4.6.7 and libc5).
+ AC_CHECK_HEADERS([sys/inttypes.h sys/bitypes.h])
+ if test $ac_cv_header_sys_inttypes_h = yes; then
+ HAVE_SYS_INTTYPES_H=1
+ else
+ HAVE_SYS_INTTYPES_H=0
+ fi
+ AC_SUBST([HAVE_SYS_INTTYPES_H])
+ if test $ac_cv_header_sys_bitypes_h = yes; then
+ HAVE_SYS_BITYPES_H=1
+ else
+ HAVE_SYS_BITYPES_H=0
+ fi
+ AC_SUBST([HAVE_SYS_BITYPES_H])
+
+ dnl Check for <wchar.h> (missing in Linux uClibc when built without wide
+ dnl character support).
+ AC_CHECK_HEADERS_ONCE([wchar.h])
+
+ gl_STDINT_TYPE_PROPERTIES
+ STDINT_H=stdint.h
+ fi
+ AC_SUBST([STDINT_H])
+])
+
+dnl gl_STDINT_BITSIZEOF(TYPES, INCLUDES)
+dnl Determine the size of each of the given types in bits.
+AC_DEFUN([gl_STDINT_BITSIZEOF],
+[
+ dnl Use a shell loop, to avoid bloating configure, and
+ dnl - extra AH_TEMPLATE calls, so that autoheader knows what to put into
+ dnl config.h.in,
+ dnl - extra AC_SUBST calls, so that the right substitutions are made.
+ m4_foreach_w([gltype], [$1],
+ [AH_TEMPLATE([BITSIZEOF_]translit(gltype,[abcdefghijklmnopqrstuvwxyz
],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_]),
+ [Define to the number of bits in type ']gltype['.])])
+ for gltype in $1 ; do
+ AC_CACHE_CHECK([for bit size of $gltype], [gl_cv_bitsizeof_${gltype}],
+ [AC_COMPUTE_INT([result], [sizeof ($gltype) * CHAR_BIT],
+ [$2
+#include <limits.h>], [result=unknown])
+ eval gl_cv_bitsizeof_${gltype}=\$result
+ ])
+ eval result=\$gl_cv_bitsizeof_${gltype}
+ if test $result = unknown; then
+ dnl Use a nonempty default, because some compilers, such as IRIX 5 cc,
+ dnl do a syntax check even on unused #if conditions and give an error
+ dnl on valid C code like this:
+ dnl #if 0
+ dnl # if > 32
+ dnl # endif
+ dnl #endif
+ result=0
+ fi
+ GLTYPE=`echo "$gltype" | tr 'abcdefghijklmnopqrstuvwxyz '
'ABCDEFGHIJKLMNOPQRSTUVWXYZ_'`
+ AC_DEFINE_UNQUOTED([BITSIZEOF_${GLTYPE}], [$result])
+ eval BITSIZEOF_${GLTYPE}=\$result
+ done
+ m4_foreach_w([gltype], [$1],
+ [AC_SUBST([BITSIZEOF_]translit(gltype,[abcdefghijklmnopqrstuvwxyz
],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_]))])
+])
+
+dnl gl_CHECK_TYPES_SIGNED(TYPES, INCLUDES)
+dnl Determine the signedness of each of the given types.
+dnl Define HAVE_SIGNED_TYPE if type is signed.
+AC_DEFUN([gl_CHECK_TYPES_SIGNED],
+[
+ dnl Use a shell loop, to avoid bloating configure, and
+ dnl - extra AH_TEMPLATE calls, so that autoheader knows what to put into
+ dnl config.h.in,
+ dnl - extra AC_SUBST calls, so that the right substitutions are made.
+ m4_foreach_w([gltype], [$1],
+ [AH_TEMPLATE([HAVE_SIGNED_]translit(gltype,[abcdefghijklmnopqrstuvwxyz
],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_]),
+ [Define to 1 if ']gltype[' is a signed integer type.])])
+ for gltype in $1 ; do
+ AC_CACHE_CHECK([whether $gltype is signed], [gl_cv_type_${gltype}_signed],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([$2[
+ int verify[2 * (($gltype) -1 < ($gltype) 0) - 1];]])],
+ result=yes, result=no)
+ eval gl_cv_type_${gltype}_signed=\$result
+ ])
+ eval result=\$gl_cv_type_${gltype}_signed
+ GLTYPE=`echo $gltype | tr 'abcdefghijklmnopqrstuvwxyz '
'ABCDEFGHIJKLMNOPQRSTUVWXYZ_'`
+ if test "$result" = yes; then
+ AC_DEFINE_UNQUOTED([HAVE_SIGNED_${GLTYPE}], [1])
+ eval HAVE_SIGNED_${GLTYPE}=1
+ else
+ eval HAVE_SIGNED_${GLTYPE}=0
+ fi
+ done
+ m4_foreach_w([gltype], [$1],
+ [AC_SUBST([HAVE_SIGNED_]translit(gltype,[abcdefghijklmnopqrstuvwxyz
],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_]))])
+])
+
+dnl gl_INTEGER_TYPE_SUFFIX(TYPES, INCLUDES)
+dnl Determine the suffix to use for integer constants of the given types.
+dnl Define t_SUFFIX for each such type.
+AC_DEFUN([gl_INTEGER_TYPE_SUFFIX],
+[
+ dnl Use a shell loop, to avoid bloating configure, and
+ dnl - extra AH_TEMPLATE calls, so that autoheader knows what to put into
+ dnl config.h.in,
+ dnl - extra AC_SUBST calls, so that the right substitutions are made.
+ m4_foreach_w([gltype], [$1],
+ [AH_TEMPLATE(translit(gltype,[abcdefghijklmnopqrstuvwxyz
],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_])[_SUFFIX],
+ [Define to l, ll, u, ul, ull, etc., as suitable for
+ constants of type ']gltype['.])])
+ for gltype in $1 ; do
+ AC_CACHE_CHECK([for $gltype integer literal suffix],
+ [gl_cv_type_${gltype}_suffix],
+ [eval gl_cv_type_${gltype}_suffix=no
+ eval result=\$gl_cv_type_${gltype}_signed
+ if test "$result" = yes; then
+ glsufu=
+ else
+ glsufu=u
+ fi
+ for glsuf in "$glsufu" ${glsufu}l ${glsufu}ll ${glsufu}i64; do
+ case $glsuf in
+ '') gltype1='int';;
+ l) gltype1='long int';;
+ ll) gltype1='long long int';;
+ i64) gltype1='__int64';;
+ u) gltype1='unsigned int';;
+ ul) gltype1='unsigned long int';;
+ ull) gltype1='unsigned long long int';;
+ ui64)gltype1='unsigned __int64';;
+ esac
+ AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM([$2[
+ extern $gltype foo;
+ extern $gltype1 foo;]])],
+ [eval gl_cv_type_${gltype}_suffix=\$glsuf])
+ eval result=\$gl_cv_type_${gltype}_suffix
+ test "$result" != no && break
+ done])
+ GLTYPE=`echo $gltype | tr 'abcdefghijklmnopqrstuvwxyz '
'ABCDEFGHIJKLMNOPQRSTUVWXYZ_'`
+ eval result=\$gl_cv_type_${gltype}_suffix
+ test "$result" = no && result=
+ eval ${GLTYPE}_SUFFIX=\$result
+ AC_DEFINE_UNQUOTED([${GLTYPE}_SUFFIX], [$result])
+ done
+ m4_foreach_w([gltype], [$1],
+ [AC_SUBST(translit(gltype,[abcdefghijklmnopqrstuvwxyz
],[ABCDEFGHIJKLMNOPQRSTUVWXYZ_])[_SUFFIX])])
+])
+
+dnl gl_STDINT_INCLUDES
+AC_DEFUN([gl_STDINT_INCLUDES],
+[[
+ /* BSD/OS 4.0.1 has a bug: <stddef.h>, <stdio.h> and <time.h> must be
+ included before <wchar.h>. */
+ #include <stddef.h>
+ #include <signal.h>
+ #if HAVE_WCHAR_H
+ # include <stdio.h>
+ # include <time.h>
+ # include <wchar.h>
+ #endif
+]])
+
+dnl gl_STDINT_TYPE_PROPERTIES
+dnl Compute HAVE_SIGNED_t, BITSIZEOF_t and t_SUFFIX, for all the types t
+dnl of interest to stdint.in.h.
+AC_DEFUN([gl_STDINT_TYPE_PROPERTIES],
+[
+ AC_REQUIRE([gl_MULTIARCH])
+ if test $APPLE_UNIVERSAL_BUILD = 0; then
+ gl_STDINT_BITSIZEOF([ptrdiff_t size_t],
+ [gl_STDINT_INCLUDES])
+ fi
+ gl_STDINT_BITSIZEOF([sig_atomic_t wchar_t wint_t],
+ [gl_STDINT_INCLUDES])
+ gl_CHECK_TYPES_SIGNED([sig_atomic_t wchar_t wint_t],
+ [gl_STDINT_INCLUDES])
+ gl_cv_type_ptrdiff_t_signed=yes
+ gl_cv_type_size_t_signed=no
+ if test $APPLE_UNIVERSAL_BUILD = 0; then
+ gl_INTEGER_TYPE_SUFFIX([ptrdiff_t size_t],
+ [gl_STDINT_INCLUDES])
+ fi
+ gl_INTEGER_TYPE_SUFFIX([sig_atomic_t wchar_t wint_t],
+ [gl_STDINT_INCLUDES])
+])
+
+dnl Autoconf >= 2.61 has AC_COMPUTE_INT built-in.
+dnl Remove this when we can assume autoconf >= 2.61.
+m4_ifdef([AC_COMPUTE_INT], [], [
+ AC_DEFUN([AC_COMPUTE_INT], [_AC_COMPUTE_INT([$2],[$1],[$3],[$4])])
+])
+
+# Hey Emacs!
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4
new file mode 100644
index 0000000..b295f16
--- /dev/null
+++ b/m4/stdlib_h.m4
@@ -0,0 +1,73 @@
+# stdlib_h.m4 serial 15
+dnl Copyright (C) 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,
+dnl with or without modifications, as long as this notice is preserved.
+
+AC_DEFUN([gl_STDLIB_H],
+[
+ AC_REQUIRE([gl_STDLIB_H_DEFAULTS])
+ gl_CHECK_NEXT_HEADERS([stdlib.h])
+ AC_CHECK_HEADERS([random.h], [], [], [AC_INCLUDES_DEFAULT])
+ if test $ac_cv_header_random_h = yes; then
+ HAVE_RANDOM_H=1
+ else
+ HAVE_RANDOM_H=0
+ fi
+ AC_SUBST([HAVE_RANDOM_H])
+ AC_CHECK_TYPES([struct random_data],
+ [], [HAVE_STRUCT_RANDOM_DATA=0],
+ [[#include <stdlib.h>
+ #if HAVE_RANDOM_H
+ # include <random.h>
+ #endif
+ ]])
+])
+
+AC_DEFUN([gl_STDLIB_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_STDLIB_H_DEFAULTS])
+
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_STDLIB_H_DEFAULTS],
+[
+ GNULIB_MALLOC_POSIX=0; AC_SUBST([GNULIB_MALLOC_POSIX])
+ GNULIB_REALLOC_POSIX=0; AC_SUBST([GNULIB_REALLOC_POSIX])
+ GNULIB_CALLOC_POSIX=0; AC_SUBST([GNULIB_CALLOC_POSIX])
+ GNULIB_ATOLL=0; AC_SUBST([GNULIB_ATOLL])
+ GNULIB_GETLOADAVG=0; AC_SUBST([GNULIB_GETLOADAVG])
+ GNULIB_GETSUBOPT=0; AC_SUBST([GNULIB_GETSUBOPT])
+ GNULIB_MKDTEMP=0; AC_SUBST([GNULIB_MKDTEMP])
+ GNULIB_MKSTEMP=0; AC_SUBST([GNULIB_MKSTEMP])
+ GNULIB_PUTENV=0; AC_SUBST([GNULIB_PUTENV])
+ GNULIB_RANDOM_R=0; AC_SUBST([GNULIB_RANDOM_R])
+ GNULIB_RPMATCH=0; AC_SUBST([GNULIB_RPMATCH])
+ GNULIB_SETENV=0; AC_SUBST([GNULIB_SETENV])
+ GNULIB_STRTOD=0; AC_SUBST([GNULIB_STRTOD])
+ GNULIB_STRTOLL=0; AC_SUBST([GNULIB_STRTOLL])
+ GNULIB_STRTOULL=0; AC_SUBST([GNULIB_STRTOULL])
+ GNULIB_UNSETENV=0; AC_SUBST([GNULIB_UNSETENV])
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ HAVE_ATOLL=1; AC_SUBST([HAVE_ATOLL])
+ HAVE_CALLOC_POSIX=1; AC_SUBST([HAVE_CALLOC_POSIX])
+ HAVE_GETSUBOPT=1; AC_SUBST([HAVE_GETSUBOPT])
+ HAVE_MALLOC_POSIX=1; AC_SUBST([HAVE_MALLOC_POSIX])
+ HAVE_MKDTEMP=1; AC_SUBST([HAVE_MKDTEMP])
+ HAVE_REALLOC_POSIX=1; AC_SUBST([HAVE_REALLOC_POSIX])
+ HAVE_RANDOM_R=1; AC_SUBST([HAVE_RANDOM_R])
+ HAVE_RPMATCH=1; AC_SUBST([HAVE_RPMATCH])
+ HAVE_SETENV=1; AC_SUBST([HAVE_SETENV])
+ HAVE_STRTOD=1; AC_SUBST([HAVE_STRTOD])
+ HAVE_STRTOLL=1; AC_SUBST([HAVE_STRTOLL])
+ HAVE_STRTOULL=1; AC_SUBST([HAVE_STRTOULL])
+ HAVE_STRUCT_RANDOM_DATA=1; AC_SUBST([HAVE_STRUCT_RANDOM_DATA])
+ HAVE_SYS_LOADAVG_H=0; AC_SUBST([HAVE_SYS_LOADAVG_H])
+ HAVE_UNSETENV=1; AC_SUBST([HAVE_UNSETENV])
+ HAVE_DECL_GETLOADAVG=1; AC_SUBST([HAVE_DECL_GETLOADAVG])
+ REPLACE_MKSTEMP=0; AC_SUBST([REPLACE_MKSTEMP])
+ REPLACE_PUTENV=0; AC_SUBST([REPLACE_PUTENV])
+ REPLACE_STRTOD=0; AC_SUBST([REPLACE_STRTOD])
+ VOID_UNSETENV=0; AC_SUBST([VOID_UNSETENV])
+])
diff --git a/m4/strcase.m4 b/m4/strcase.m4
index 79c525c..0dfdb1a 100644
--- a/m4/strcase.m4
+++ b/m4/strcase.m4
@@ -1,5 +1,5 @@
-# strcase.m4 serial 9
-dnl Copyright (C) 2002, 2005-2008 Free Software Foundation, Inc.
+# strcase.m4 serial 10
+dnl Copyright (C) 2002, 2005-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.
@@ -13,7 +13,7 @@ AC_DEFUN([gl_STRCASE],
AC_DEFUN([gl_FUNC_STRCASECMP],
[
AC_REQUIRE([gl_HEADER_STRINGS_H_DEFAULTS])
- AC_REPLACE_FUNCS(strcasecmp)
+ AC_REPLACE_FUNCS([strcasecmp])
if test $ac_cv_func_strcasecmp = no; then
HAVE_STRCASECMP=0
gl_PREREQ_STRCASECMP
@@ -23,11 +23,11 @@ AC_DEFUN([gl_FUNC_STRCASECMP],
AC_DEFUN([gl_FUNC_STRNCASECMP],
[
AC_REQUIRE([gl_HEADER_STRINGS_H_DEFAULTS])
- AC_REPLACE_FUNCS(strncasecmp)
+ AC_REPLACE_FUNCS([strncasecmp])
if test $ac_cv_func_strncasecmp = no; then
gl_PREREQ_STRNCASECMP
fi
- AC_CHECK_DECLS(strncasecmp)
+ AC_CHECK_DECLS([strncasecmp])
if test $ac_cv_have_decl_strncasecmp = no; then
HAVE_DECL_STRNCASECMP=0
fi
diff --git a/m4/strftime.m4 b/m4/strftime.m4
index 70b5378..15a8770 100644
--- a/m4/strftime.m4
+++ b/m4/strftime.m4
@@ -1,7 +1,7 @@
-#serial 29
+# serial 32
# Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-# 2006, 2007 Free Software Foundation, Inc.
+# 2006, 2007, 2009 Free Software Foundation, Inc.
#
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -25,8 +25,8 @@ AC_DEFUN([gl_FUNC_STRFTIME],
AC_REQUIRE([AC_TYPE_MBSTATE_T])
AC_REQUIRE([gl_TM_GMTOFF])
- AC_CHECK_FUNCS_ONCE(mblen mbrlen mempcpy tzset)
- AC_CHECK_HEADERS_ONCE(wchar.h)
+ AC_CHECK_FUNCS_ONCE([tzset])
+ AC_CHECK_HEADERS_ONCE([wchar.h])
AC_DEFINE([my_strftime], [nstrftime],
[Define to the name of the strftime replacement function.])
diff --git a/m4/string_h.m4 b/m4/string_h.m4
new file mode 100644
index 0000000..2d5553c
--- /dev/null
+++ b/m4/string_h.m4
@@ -0,0 +1,92 @@
+# Configure a GNU-like replacement for <string.h>.
+
+# Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# serial 6
+
+# Written by Paul Eggert.
+
+AC_DEFUN([gl_HEADER_STRING_H],
+[
+ dnl Use AC_REQUIRE here, so that the default behavior below is expanded
+ dnl once only, before all statements that occur in other macros.
+ AC_REQUIRE([gl_HEADER_STRING_H_BODY])
+])
+
+AC_DEFUN([gl_HEADER_STRING_H_BODY],
+[
+ AC_REQUIRE([AC_C_RESTRICT])
+ AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS])
+ gl_CHECK_NEXT_HEADERS([string.h])
+])
+
+AC_DEFUN([gl_STRING_MODULE_INDICATOR],
+[
+ dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
+ AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS])
+
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS],
+[
+ GNULIB_MEMMEM=0; AC_SUBST([GNULIB_MEMMEM])
+ GNULIB_MEMPCPY=0; AC_SUBST([GNULIB_MEMPCPY])
+ GNULIB_MEMRCHR=0; AC_SUBST([GNULIB_MEMRCHR])
+ GNULIB_RAWMEMCHR=0; AC_SUBST([GNULIB_RAWMEMCHR])
+ GNULIB_STPCPY=0; AC_SUBST([GNULIB_STPCPY])
+ GNULIB_STPNCPY=0; AC_SUBST([GNULIB_STPNCPY])
+ GNULIB_STRCHRNUL=0; AC_SUBST([GNULIB_STRCHRNUL])
+ GNULIB_STRDUP=0; AC_SUBST([GNULIB_STRDUP])
+ GNULIB_STRNDUP=0; AC_SUBST([GNULIB_STRNDUP])
+ GNULIB_STRNLEN=0; AC_SUBST([GNULIB_STRNLEN])
+ GNULIB_STRPBRK=0; AC_SUBST([GNULIB_STRPBRK])
+ GNULIB_STRSEP=0; AC_SUBST([GNULIB_STRSEP])
+ GNULIB_STRSTR=0; AC_SUBST([GNULIB_STRSTR])
+ GNULIB_STRCASESTR=0; AC_SUBST([GNULIB_STRCASESTR])
+ GNULIB_STRTOK_R=0; AC_SUBST([GNULIB_STRTOK_R])
+ GNULIB_MBSLEN=0; AC_SUBST([GNULIB_MBSLEN])
+ GNULIB_MBSNLEN=0; AC_SUBST([GNULIB_MBSNLEN])
+ GNULIB_MBSCHR=0; AC_SUBST([GNULIB_MBSCHR])
+ GNULIB_MBSRCHR=0; AC_SUBST([GNULIB_MBSRCHR])
+ GNULIB_MBSSTR=0; AC_SUBST([GNULIB_MBSSTR])
+ GNULIB_MBSCASECMP=0; AC_SUBST([GNULIB_MBSCASECMP])
+ GNULIB_MBSNCASECMP=0; AC_SUBST([GNULIB_MBSNCASECMP])
+ GNULIB_MBSPCASECMP=0; AC_SUBST([GNULIB_MBSPCASECMP])
+ GNULIB_MBSCASESTR=0; AC_SUBST([GNULIB_MBSCASESTR])
+ GNULIB_MBSCSPN=0; AC_SUBST([GNULIB_MBSCSPN])
+ GNULIB_MBSPBRK=0; AC_SUBST([GNULIB_MBSPBRK])
+ GNULIB_MBSSPN=0; AC_SUBST([GNULIB_MBSSPN])
+ GNULIB_MBSSEP=0; AC_SUBST([GNULIB_MBSSEP])
+ GNULIB_MBSTOK_R=0; AC_SUBST([GNULIB_MBSTOK_R])
+ GNULIB_STRERROR=0; AC_SUBST([GNULIB_STRERROR])
+ GNULIB_STRSIGNAL=0; AC_SUBST([GNULIB_STRSIGNAL])
+ GNULIB_STRVERSCMP=0; AC_SUBST([GNULIB_STRVERSCMP])
+ dnl Assume proper GNU behavior unless another module says otherwise.
+ HAVE_DECL_MEMMEM=1; AC_SUBST([HAVE_DECL_MEMMEM])
+ HAVE_MEMPCPY=1; AC_SUBST([HAVE_MEMPCPY])
+ HAVE_DECL_MEMRCHR=1; AC_SUBST([HAVE_DECL_MEMRCHR])
+ HAVE_RAWMEMCHR=1; AC_SUBST([HAVE_RAWMEMCHR])
+ HAVE_STPCPY=1; AC_SUBST([HAVE_STPCPY])
+ HAVE_STPNCPY=1; AC_SUBST([HAVE_STPNCPY])
+ HAVE_STRCHRNUL=1; AC_SUBST([HAVE_STRCHRNUL])
+ HAVE_DECL_STRDUP=1; AC_SUBST([HAVE_DECL_STRDUP])
+ HAVE_STRNDUP=1; AC_SUBST([HAVE_STRNDUP])
+ HAVE_DECL_STRNDUP=1; AC_SUBST([HAVE_DECL_STRNDUP])
+ HAVE_DECL_STRNLEN=1; AC_SUBST([HAVE_DECL_STRNLEN])
+ HAVE_STRPBRK=1; AC_SUBST([HAVE_STRPBRK])
+ HAVE_STRSEP=1; AC_SUBST([HAVE_STRSEP])
+ HAVE_STRCASESTR=1; AC_SUBST([HAVE_STRCASESTR])
+ HAVE_DECL_STRTOK_R=1; AC_SUBST([HAVE_DECL_STRTOK_R])
+ HAVE_DECL_STRERROR=1; AC_SUBST([HAVE_DECL_STRERROR])
+ HAVE_DECL_STRSIGNAL=1; AC_SUBST([HAVE_DECL_STRSIGNAL])
+ HAVE_STRVERSCMP=1; AC_SUBST([HAVE_STRVERSCMP])
+ REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM])
+ REPLACE_STRDUP=0; AC_SUBST([REPLACE_STRDUP])
+ REPLACE_STRSTR=0; AC_SUBST([REPLACE_STRSTR])
+ REPLACE_STRCASESTR=0; AC_SUBST([REPLACE_STRCASESTR])
+ REPLACE_STRERROR=0; AC_SUBST([REPLACE_STRERROR])
+ REPLACE_STRSIGNAL=0; AC_SUBST([REPLACE_STRSIGNAL])
+])
diff --git a/m4/sys_file_h.m4 b/m4/sys_file_h.m4
new file mode 100644
index 0000000..436c6fe
--- /dev/null
+++ b/m4/sys_file_h.m4
@@ -0,0 +1,41 @@
+# Configure a replacement for <sys/file.h>.
+
+# Copyright (C) 2008 Free Software Foundation, Inc.
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# Written by Richard W.M. Jones.
+
+AC_DEFUN([gl_HEADER_SYS_FILE_H],
+[
+ AC_REQUIRE([gl_HEADER_SYS_FILE_H_DEFAULTS])
+
+ dnl Only flock is defined in a working <sys/file.h>. If that
+ dnl function is already there, we don't want to do any substitution.
+ AC_CHECK_FUNCS_ONCE([flock])
+
+ gl_CHECK_NEXT_HEADERS([sys/file.h])
+ SYS_FILE_H='sys/file.h'
+ AC_SUBST([SYS_FILE_H])
+
+ AC_CHECK_HEADERS_ONCE([sys/file.h])
+ if test $ac_cv_header_sys_file_h = yes; then
+ HAVE_SYS_FILE_H=1
+ else
+ HAVE_SYS_FILE_H=0
+ fi
+ AC_SUBST([HAVE_SYS_FILE_H])
+])
+
+AC_DEFUN([gl_HEADER_SYS_FILE_MODULE_INDICATOR],
+[
+ AC_REQUIRE([gl_HEADER_SYS_FILE_H_DEFAULTS])
+
GNULIB_[]m4_translit([$1],[abcdefghijklmnopqrstuvwxyz./-],[ABCDEFGHIJKLMNOPQRSTUVWXYZ___])=1
+])
+
+AC_DEFUN([gl_HEADER_SYS_FILE_H_DEFAULTS],
+[
+ GNULIB_FLOCK=0; AC_SUBST([GNULIB_FLOCK])
+ HAVE_FLOCK=1; AC_SUBST([HAVE_FLOCK])
+])
diff --git a/m4/tm_gmtoff.m4 b/m4/tm_gmtoff.m4
index cb0b3c8..911af0a 100644
--- a/m4/tm_gmtoff.m4
+++ b/m4/tm_gmtoff.m4
@@ -1,5 +1,5 @@
-# tm_gmtoff.m4 serial 2
-dnl Copyright (C) 2002 Free Software Foundation, Inc.
+# tm_gmtoff.m4 serial 3
+dnl Copyright (C) 2002, 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.
@@ -7,7 +7,7 @@ dnl with or without modifications, as long as this notice is
preserved.
AC_DEFUN([gl_TM_GMTOFF],
[
AC_CHECK_MEMBER([struct tm.tm_gmtoff],
- [AC_DEFINE(HAVE_TM_GMTOFF, 1,
+ [AC_DEFINE([HAVE_TM_GMTOFF], [1],
[Define if struct tm has the tm_gmtoff member.])],
,
[#include <time.h>])
diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4
index 5685273..ff9a4ea 100644
--- a/m4/unistd_h.m4
+++ b/m4/unistd_h.m4
@@ -1,5 +1,5 @@
-# unistd_h.m4 serial 16
-dnl Copyright (C) 2006-2008 Free Software Foundation, Inc.
+# unistd_h.m4 serial 17
+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,
dnl with or without modifications, as long as this notice is preserved.
@@ -48,6 +48,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
GNULIB_GETPAGESIZE=0; AC_SUBST([GNULIB_GETPAGESIZE])
GNULIB_GETUSERSHELL=0; AC_SUBST([GNULIB_GETUSERSHELL])
GNULIB_LCHOWN=0; AC_SUBST([GNULIB_LCHOWN])
+ GNULIB_LINK=0; AC_SUBST([GNULIB_LINK])
GNULIB_LSEEK=0; AC_SUBST([GNULIB_LSEEK])
GNULIB_READLINK=0; AC_SUBST([GNULIB_READLINK])
GNULIB_SLEEP=0; AC_SUBST([GNULIB_SLEEP])
@@ -63,6 +64,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
HAVE_GETHOSTNAME=1; AC_SUBST([HAVE_GETHOSTNAME])
HAVE_GETPAGESIZE=1; AC_SUBST([HAVE_GETPAGESIZE])
HAVE_GETUSERSHELL=1; AC_SUBST([HAVE_GETUSERSHELL])
+ HAVE_LINK=1; AC_SUBST([HAVE_LINK])
HAVE_READLINK=1; AC_SUBST([HAVE_READLINK])
HAVE_SLEEP=1; AC_SUBST([HAVE_SLEEP])
HAVE_DECL_ENVIRON=1; AC_SUBST([HAVE_DECL_ENVIRON])
diff --git a/m4/visibility.m4 b/m4/visibility.m4
new file mode 100644
index 0000000..70bca56
--- /dev/null
+++ b/m4/visibility.m4
@@ -0,0 +1,52 @@
+# visibility.m4 serial 2 (gettext-0.18)
+dnl Copyright (C) 2005, 2008 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 Bruno Haible.
+
+dnl Tests whether the compiler supports the command-line option
+dnl -fvisibility=hidden and the function and variable attributes
+dnl __attribute__((__visibility__("hidden"))) and
+dnl __attribute__((__visibility__("default"))).
+dnl Does *not* test for __visibility__("protected") - which has tricky
+dnl semantics (see the 'vismain' test in glibc) and does not exist e.g. on
+dnl MacOS X.
+dnl Does *not* test for __visibility__("internal") - which has processor
+dnl dependent semantics.
+dnl Does *not* test for #pragma GCC visibility push(hidden) - which is
+dnl "really only recommended for legacy code".
+dnl Set the variable CFLAG_VISIBILITY.
+dnl Defines and sets the variable HAVE_VISIBILITY.
+
+AC_DEFUN([gl_VISIBILITY],
+[
+ AC_REQUIRE([AC_PROG_CC])
+ CFLAG_VISIBILITY=
+ HAVE_VISIBILITY=0
+ if test -n "$GCC"; then
+ AC_MSG_CHECKING([for simple visibility declarations])
+ AC_CACHE_VAL([gl_cv_cc_visibility], [
+ gl_save_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS -fvisibility=hidden"
+ AC_TRY_COMPILE(
+ [extern __attribute__((__visibility__("hidden"))) int hiddenvar;
+ extern __attribute__((__visibility__("default"))) int exportedvar;
+ extern __attribute__((__visibility__("hidden"))) int hiddenfunc
(void);
+ extern __attribute__((__visibility__("default"))) int exportedfunc
(void);],
+ [],
+ [gl_cv_cc_visibility=yes],
+ [gl_cv_cc_visibility=no])
+ CFLAGS="$gl_save_CFLAGS"])
+ AC_MSG_RESULT([$gl_cv_cc_visibility])
+ if test $gl_cv_cc_visibility = yes; then
+ CFLAG_VISIBILITY="-fvisibility=hidden"
+ HAVE_VISIBILITY=1
+ fi
+ fi
+ AC_SUBST([CFLAG_VISIBILITY])
+ AC_SUBST([HAVE_VISIBILITY])
+ AC_DEFINE_UNQUOTED([HAVE_VISIBILITY], [$HAVE_VISIBILITY],
+ [Define to 1 or 0, depending whether the compiler supports simple
visibility declarations.])
+])
diff --git a/m4/wchar.m4 b/m4/wchar.m4
index ba8ee6a..2e52a82 100644
--- a/m4/wchar.m4
+++ b/m4/wchar.m4
@@ -1,13 +1,13 @@
dnl A placeholder for ISO C99 <wchar.h>, for platforms that have issues.
-dnl Copyright (C) 2007-2008 Free Software Foundation, Inc.
+dnl Copyright (C) 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,
dnl with or without modifications, as long as this notice is preserved.
dnl Written by Eric Blake.
-# wchar.m4 serial 22
+# wchar.m4 serial 23
AC_DEFUN([gl_WCHAR_H],
[
@@ -73,27 +73,28 @@ AC_DEFUN([gl_WCHAR_H_DEFAULTS],
GNULIB_WCSNRTOMBS=0; AC_SUBST([GNULIB_WCSNRTOMBS])
GNULIB_WCWIDTH=0; AC_SUBST([GNULIB_WCWIDTH])
dnl Assume proper GNU behavior unless another module says otherwise.
- HAVE_BTOWC=1; AC_SUBST([HAVE_BTOWC])
- HAVE_MBSINIT=1; AC_SUBST([HAVE_MBSINIT])
- HAVE_MBRTOWC=1; AC_SUBST([HAVE_MBRTOWC])
- HAVE_MBRLEN=1; AC_SUBST([HAVE_MBRLEN])
- HAVE_MBSRTOWCS=1; AC_SUBST([HAVE_MBSRTOWCS])
- HAVE_MBSNRTOWCS=1; AC_SUBST([HAVE_MBSNRTOWCS])
- HAVE_WCRTOMB=1; AC_SUBST([HAVE_WCRTOMB])
- HAVE_WCSRTOMBS=1; AC_SUBST([HAVE_WCSRTOMBS])
- HAVE_WCSNRTOMBS=1; AC_SUBST([HAVE_WCSNRTOMBS])
- HAVE_DECL_WCTOB=1; AC_SUBST([HAVE_DECL_WCTOB])
- HAVE_DECL_WCWIDTH=1; AC_SUBST([HAVE_DECL_WCWIDTH])
- REPLACE_MBSTATE_T=0; AC_SUBST([REPLACE_MBSTATE_T])
- REPLACE_BTOWC=0; AC_SUBST([REPLACE_BTOWC])
- REPLACE_WCTOB=0; AC_SUBST([REPLACE_WCTOB])
- REPLACE_MBSINIT=0; AC_SUBST([REPLACE_MBSINIT])
- REPLACE_MBRTOWC=0; AC_SUBST([REPLACE_MBRTOWC])
- REPLACE_MBRLEN=0; AC_SUBST([REPLACE_MBRLEN])
- REPLACE_MBSRTOWCS=0; AC_SUBST([REPLACE_MBSRTOWCS])
- REPLACE_MBSNRTOWCS=0;AC_SUBST([REPLACE_MBSNRTOWCS])
- REPLACE_WCRTOMB=0; AC_SUBST([REPLACE_WCRTOMB])
- REPLACE_WCSRTOMBS=0; AC_SUBST([REPLACE_WCSRTOMBS])
- REPLACE_WCWIDTH=0; AC_SUBST([REPLACE_WCWIDTH])
- WCHAR_H=''; AC_SUBST([WCHAR_H])
+ HAVE_BTOWC=1; AC_SUBST([HAVE_BTOWC])
+ HAVE_MBSINIT=1; AC_SUBST([HAVE_MBSINIT])
+ HAVE_MBRTOWC=1; AC_SUBST([HAVE_MBRTOWC])
+ HAVE_MBRLEN=1; AC_SUBST([HAVE_MBRLEN])
+ HAVE_MBSRTOWCS=1; AC_SUBST([HAVE_MBSRTOWCS])
+ HAVE_MBSNRTOWCS=1; AC_SUBST([HAVE_MBSNRTOWCS])
+ HAVE_WCRTOMB=1; AC_SUBST([HAVE_WCRTOMB])
+ HAVE_WCSRTOMBS=1; AC_SUBST([HAVE_WCSRTOMBS])
+ HAVE_WCSNRTOMBS=1; AC_SUBST([HAVE_WCSNRTOMBS])
+ HAVE_DECL_WCTOB=1; AC_SUBST([HAVE_DECL_WCTOB])
+ HAVE_DECL_WCWIDTH=1; AC_SUBST([HAVE_DECL_WCWIDTH])
+ REPLACE_MBSTATE_T=0; AC_SUBST([REPLACE_MBSTATE_T])
+ REPLACE_BTOWC=0; AC_SUBST([REPLACE_BTOWC])
+ REPLACE_WCTOB=0; AC_SUBST([REPLACE_WCTOB])
+ REPLACE_MBSINIT=0; AC_SUBST([REPLACE_MBSINIT])
+ REPLACE_MBRTOWC=0; AC_SUBST([REPLACE_MBRTOWC])
+ REPLACE_MBRLEN=0; AC_SUBST([REPLACE_MBRLEN])
+ REPLACE_MBSRTOWCS=0; AC_SUBST([REPLACE_MBSRTOWCS])
+ REPLACE_MBSNRTOWCS=0; AC_SUBST([REPLACE_MBSNRTOWCS])
+ REPLACE_WCRTOMB=0; AC_SUBST([REPLACE_WCRTOMB])
+ REPLACE_WCSRTOMBS=0; AC_SUBST([REPLACE_WCSRTOMBS])
+ REPLACE_WCSNRTOMBS=0; AC_SUBST([REPLACE_WCSNRTOMBS])
+ REPLACE_WCWIDTH=0; AC_SUBST([REPLACE_WCWIDTH])
+ WCHAR_H=''; AC_SUBST([WCHAR_H])
])
diff --git a/m4/wint_t.m4 b/m4/wint_t.m4
index 0026a13..47a4363 100644
--- a/m4/wint_t.m4
+++ b/m4/wint_t.m4
@@ -1,5 +1,5 @@
-# wint_t.m4 serial 3 (gettext-0.18)
-dnl Copyright (C) 2003, 2007-2008 Free Software Foundation, Inc.
+# wint_t.m4 serial 4 (gettext-0.18)
+dnl Copyright (C) 2003, 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,
dnl with or without modifications, as long as this notice is preserved.
@@ -23,6 +23,6 @@ AC_DEFUN([gt_TYPE_WINT_T],
wint_t foo = (wchar_t)'\0';], ,
[gt_cv_c_wint_t=yes], [gt_cv_c_wint_t=no])])
if test $gt_cv_c_wint_t = yes; then
- AC_DEFINE([HAVE_WINT_T], 1, [Define if you have the 'wint_t' type.])
+ AC_DEFINE([HAVE_WINT_T], [1], [Define if you have the 'wint_t' type.])
fi
])
diff --git a/module/Makefile.am b/module/Makefile.am
index 95dc75a..9d9a839 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -31,30 +31,25 @@ modpath =
# putting these core modules first.
SOURCES = \
- ice-9/psyntax-pp.scm \
+ ice-9/psyntax-pp.scm
\
system/base/pmatch.scm system/base/syntax.scm
\
system/base/compile.scm system/base/language.scm \
\
- system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \
- system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \
- system/vm/trace.scm system/vm/vm.scm \
- \
- system/xref.scm \
- \
- system/repl/repl.scm system/repl/common.scm \
- system/repl/command.scm \
- \
+ language/tree-il.scm \
language/ghil.scm language/glil.scm language/assembly.scm \
\
- $(SCHEME_LANG_SOURCES) $(ECMASCRIPT_LANG_SOURCES) \
+ $(SCHEME_LANG_SOURCES) \
+ $(TREE_IL_LANG_SOURCES) \
$(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)
\
\
$(ICE_9_SOURCES) \
$(SRFI_SOURCES) \
+ $(RNRS_SOURCES) \
$(OOP_SOURCES) \
- \
+ $(SYSTEM_SOURCES) \
+ $(ECMASCRIPT_LANG_SOURCES) \
$(SCRIPTS_SOURCES)
## test.scm is not currently installed.
@@ -71,10 +66,19 @@ ice-9/psyntax-pp.scm: ice-9/psyntax.scm
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
SCHEME_LANG_SOURCES = \
- language/scheme/amatch.scm language/scheme/expand.scm \
- language/scheme/compile-ghil.scm language/scheme/spec.scm \
+ language/scheme/compile-ghil.scm \
+ language/scheme/spec.scm \
+ language/scheme/compile-tree-il.scm \
+ language/scheme/decompile-tree-il.scm \
language/scheme/inline.scm
+TREE_IL_LANG_SOURCES = \
+ language/tree-il/primitives.scm \
+ language/tree-il/optimize.scm \
+ language/tree-il/analyze.scm \
+ language/tree-il/compile-glil.scm \
+ language/tree-il/spec.scm
+
GHIL_LANG_SOURCES = \
language/ghil/spec.scm language/ghil/compile-glil.scm
@@ -140,7 +144,6 @@ ICE_9_SOURCES = \
ice-9/debugger.scm \
ice-9/documentation.scm \
ice-9/emacs.scm \
- ice-9/expand-support.scm \
ice-9/expect.scm \
ice-9/format.scm \
ice-9/getopt-long.scm \
@@ -198,6 +201,7 @@ SRFI_SOURCES = \
srfi/srfi-14.scm \
srfi/srfi-16.scm \
srfi/srfi-17.scm \
+ srfi/srfi-18.scm \
srfi/srfi-19.scm \
srfi/srfi-26.scm \
srfi/srfi-31.scm \
@@ -209,6 +213,10 @@ SRFI_SOURCES = \
srfi/srfi-69.scm \
srfi/srfi-88.scm
+RNRS_SOURCES = \
+ rnrs/bytevector.scm \
+ rnrs/io/ports.scm
+
EXTRA_DIST += scripts/ChangeLog-2008
EXTRA_DIST += scripts/README
@@ -226,6 +234,16 @@ OOP_SOURCES = \
oop/goops/accessors.scm \
oop/goops/simple.scm
+SYSTEM_SOURCES = \
+ system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \
+ system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \
+ system/vm/trace.scm system/vm/vm.scm \
+ \
+ system/xref.scm \
+ \
+ system/repl/repl.scm system/repl/common.scm \
+ system/repl/command.scm
+
EXTRA_DIST += oop/ChangeLog-2008
NOCOMP_SOURCES = \
@@ -242,5 +260,4 @@ NOCOMP_SOURCES = \
ice-9/debugging/steps.scm \
ice-9/debugging/trace.scm \
ice-9/debugging/traps.scm \
- ice-9/debugging/trc.scm \
- srfi/srfi-18.scm
+ ice-9/debugging/trc.scm
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 48d822b..4406631 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -33,6 +33,13 @@
+;; Before compiling, make sure any symbols are resolved in the (guile)
+;; module, the primary location of those symbols, rather than in
+;; (guile-user), the default module that we compile in.
+
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
;;; {R4RS compliance}
;;;
@@ -86,6 +93,42 @@
(define (provided? feature)
(and (memq feature *features*) #t))
+
+
+;;; {and-map and or-map}
+;;;
+;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;;
+
+;; and-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or f returns #f.
+;; If returning early, return #f. Otherwise, return the last value returned
+;; by f. If f has never been called because l is empty, return #t.
+;;
+(define (and-map f lst)
+ (let loop ((result #t)
+ (l lst))
+ (and result
+ (or (and (null? l)
+ result)
+ (loop (f (car l)) (cdr l))))))
+
+;; or-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or while f returns #f.
+;; If returning early, return the return value of f.
+;;
+(define (or-map f lst)
+ (let loop ((result #f)
+ (l lst))
+ (or result
+ (and (not (null? l))
+ (loop (f (car l)) (cdr l))))))
+
+
+
;; let format alias simple-format until the more complete version is loaded
(define format simple-format)
@@ -125,97 +168,181 @@
-;; Before the module system boots, there are no module names. But
-;; psyntax does want a module-name definition, so give it one.
+;; Define a minimal stub of the module API for psyntax, before modules
+;; have booted.
(define (module-name x)
+ '(guile))
+(define (module-define! module sym val)
+ (let ((v (hashq-ref (%get-pre-modules-obarray) sym)))
+ (if v
+ (variable-set! v val)
+ (hashq-set! (%get-pre-modules-obarray) sym
+ (make-variable val)))))
+(define (module-ref module sym)
+ (let ((v (module-variable module sym)))
+ (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
+(define (resolve-module . args)
#f)
-;; (eval-when (situation...) form...)
-;;
-;; Evaluate certain code based on the situation that eval-when is used
-;; in. There are three situations defined.
-;;
-;; `load' triggers when a file is loaded via `load', or when a compiled
-;; file is loaded.
-;;
-;; `compile' triggers when an expression is compiled.
-;;
-;; `eval' triggers when code is evaluated interactively, as at the REPL
-;; or via the `compile' or `eval' procedures.
-
-;; NB: this macro is only ever expanded by the interpreter. The compiler
-;; notices it and interprets the situations differently.
-(define eval-when
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((situations (cadr exp))
- (body (cddr exp)))
- (if (or (memq 'load situations)
- (memq 'eval situations))
- `(begin . ,body))))))
+;; Input hook to syncase -- so that we might be able to pass annotated
+;; expressions in. Currently disabled. Maybe we should just use
+;; source-properties directly.
+(define (annotation? x) #f)
+
+;; API provided by psyntax
+(define syntax-violation #f)
+(define datum->syntax #f)
+(define syntax->datum #f)
+(define identifier? #f)
+(define generate-temporaries #f)
+(define bound-identifier=? #f)
+(define free-identifier=? #f)
+(define sc-expand #f)
+
+;; $sc-expand is an implementation detail of psyntax. It is used by
+;; expanded macros, to dispatch an input against a set of patterns.
+(define $sc-dispatch #f)
+
+;; Load it up!
+(primitive-load-path "ice-9/psyntax-pp")
+
+;; %pre-modules-transformer is the Scheme expander from now until the
+;; module system has booted up.
+(define %pre-modules-transformer sc-expand)
+
+(define-syntax and
+ (syntax-rules ()
+ ((_) #t)
+ ((_ x) x)
+ ((_ x y ...) (if x (and y ...) #f))))
+
+(define-syntax or
+ (syntax-rules ()
+ ((_) #f)
+ ((_ x) x)
+ ((_ x y ...) (let ((t x)) (if t t (or y ...))))))
+
+;; The "maybe-more" bits are something of a hack, so that we can support
+;; SRFI-61. Rewrites into a standalone syntax-case macro would be
+;; appreciated.
+(define-syntax cond
+ (syntax-rules (=> else)
+ ((_ "maybe-more" test consequent)
+ (if test consequent))
+
+ ((_ "maybe-more" test consequent clause ...)
+ (if test consequent (cond clause ...)))
+
+ ((_ (else else1 else2 ...))
+ (begin else1 else2 ...))
+
+ ((_ (test => receiver) more-clause ...)
+ (let ((t test))
+ (cond "maybe-more" t (receiver t) more-clause ...)))
+
+ ((_ (generator guard => receiver) more-clause ...)
+ (call-with-values (lambda () generator)
+ (lambda t
+ (cond "maybe-more"
+ (apply guard t) (apply receiver t) more-clause ...))))
+
+ ((_ (test => receiver ...) more-clause ...)
+ (syntax-violation 'cond "wrong number of receiver expressions"
+ '(test => receiver ...)))
+ ((_ (generator guard => receiver ...) more-clause ...)
+ (syntax-violation 'cond "wrong number of receiver expressions"
+ '(generator guard => receiver ...)))
+
+ ((_ (test) more-clause ...)
+ (let ((t test))
+ (cond "maybe-more" t t more-clause ...)))
+
+ ((_ (test body1 body2 ...) more-clause ...)
+ (cond "maybe-more"
+ test (begin body1 body2 ...) more-clause ...))))
+
+(define-syntax case
+ (syntax-rules (else)
+ ((case (key ...)
+ clauses ...)
+ (let ((atom-key (key ...)))
+ (case atom-key clauses ...)))
+ ((case key
+ (else result1 result2 ...))
+ (begin result1 result2 ...))
+ ((case key
+ ((atoms ...) result1 result2 ...))
+ (if (memv key '(atoms ...))
+ (begin result1 result2 ...)))
+ ((case key
+ ((atoms ...) result1 result2 ...)
+ clause clauses ...)
+ (if (memv key '(atoms ...))
+ (begin result1 result2 ...)
+ (case key clause clauses ...)))))
+
+(define-syntax do
+ (syntax-rules ()
+ ((do ((var init step ...) ...)
+ (test expr ...)
+ command ...)
+ (letrec
+ ((loop
+ (lambda (var ...)
+ (if test
+ (begin
+ (if #f #f)
+ expr ...)
+ (begin
+ command
+ ...
+ (loop (do "step" var step ...)
+ ...))))))
+ (loop init ...)))
+ ((do "step" x)
+ x)
+ ((do "step" x y)
+ y)))
+
+(define-syntax delay
+ (syntax-rules ()
+ ((_ exp) (make-promise (lambda () exp)))))
-;; Before compiling, make sure any symbols are resolved in the (guile)
-;; module, the primary location of those symbols, rather than in
-;; (guile-user), the default module that we compile in.
-
-(eval-when (compile)
- (set-current-module (resolve-module '(guile))))
-
;;; {Defmacros}
;;;
-;;; Depends on: features, eval-case
-;;;
-
-(define macro-table (make-weak-key-hash-table 61))
-(define xformer-table (make-weak-key-hash-table 61))
-
-(define (defmacro? m) (hashq-ref macro-table m))
-(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
-(define (defmacro-transformer m) (hashq-ref xformer-table m))
-(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
-
-(define defmacro:transformer
- (lambda (f)
- (let* ((xform (lambda (exp env)
- (copy-tree (apply f (cdr exp)))))
- (a (procedure->memoizing-macro xform)))
- (assert-defmacro?! a)
- (set-defmacro-transformer! a f)
- a)))
-
-(define defmacro
- (let ((defmacro-transformer
- (lambda (name parms . body)
- (let ((transformer `(lambda ,parms ,@body)))
- `(eval-when
- (eval load compile)
- (define ,name (defmacro:transformer ,transformer)))))))
- (defmacro:transformer defmacro-transformer)))
-
-
-;; XXX - should the definition of the car really be looked up in the
-;; current module?
-
-(define (macroexpand-1 e)
- (cond
- ((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (local-ref (list a)))))
- (if (defmacro? val)
- (apply (defmacro-transformer val) (cdr e))
- e)))
- (#t e)))
-
-(define (macroexpand e)
- (cond
- ((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (local-ref (list a)))))
- (if (defmacro? val)
- (macroexpand (apply (defmacro-transformer val) (cdr e)))
- e)))
- (#t e)))
+(define-syntax define-macro
+ (lambda (x)
+ "Define a defmacro."
+ (syntax-case x ()
+ ((_ (macro . args) doc body1 body ...)
+ (string? (syntax->datum (syntax doc)))
+ (syntax (define-macro macro doc (lambda args body1 body ...))))
+ ((_ (macro . args) body ...)
+ (syntax (define-macro macro #f (lambda args body ...))))
+ ((_ macro doc transformer)
+ (or (string? (syntax->datum (syntax doc)))
+ (not (syntax->datum (syntax doc))))
+ (syntax
+ (define-syntax macro
+ (lambda (y)
+ doc
+ (syntax-case y ()
+ ((_ . args)
+ (let ((v (syntax->datum (syntax args))))
+ (datum->syntax y (apply transformer v))))))))))))
+
+(define-syntax defmacro
+ (lambda (x)
+ "Define a defmacro, with the old lispy defun syntax."
+ (syntax-case x ()
+ ((_ macro args doc body1 body ...)
+ (string? (syntax->datum (syntax doc)))
+ (syntax (define-macro macro doc (lambda args body1 body ...))))
+ ((_ macro args body ...)
+ (syntax (define-macro macro #f (lambda args body ...)))))))
(provide 'defmacro)
@@ -477,40 +604,6 @@
-;;; {and-map and or-map}
-;;;
-;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
-;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
-;;;
-
-;; and-map f l
-;;
-;; Apply f to successive elements of l until exhaustion or f returns #f.
-;; If returning early, return #f. Otherwise, return the last value returned
-;; by f. If f has never been called because l is empty, return #t.
-;;
-(define (and-map f lst)
- (let loop ((result #t)
- (l lst))
- (and result
- (or (and (null? l)
- result)
- (loop (f (car l)) (cdr l))))))
-
-;; or-map f l
-;;
-;; Apply f to successive elements of l until exhaustion or while f returns #f.
-;; If returning early, return the return value of f.
-;;
-(define (or-map f lst)
- (let loop ((result #f)
- (l lst))
- (or result
- (and (not (null? l))
- (loop (f (car l)) (cdr l))))))
-
-
-
(if (provided? 'posix)
(primitive-load-path "ice-9/posix"))
@@ -757,6 +850,26 @@
(start-stack 'load-stack
(primitive-load-path name)))
+(define %load-verbosely #f)
+(define (assert-load-verbosity v) (set! %load-verbosely v))
+
+(define (%load-announce file)
+ (if %load-verbosely
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (display ";;; ")
+ (display "loading ")
+ (display file)
+ (newline)
+ (force-output)))))
+
+(set! %load-hook %load-announce)
+
+(define (load name . reader)
+ (with-fluid* current-reader (and (pair? reader) (car reader))
+ (lambda ()
+ (start-stack 'load-stack
+ (primitive-load name)))))
@@ -848,9 +961,6 @@
;;; Reader code for various "#c" forms.
;;;
-(read-hash-extend #\' (lambda (c port)
- (read port)))
-
(define read-eval? (make-fluid))
(fluid-set! read-eval? #f)
(read-hash-extend #\.
@@ -1133,11 +1243,8 @@
(define (%print-module mod port) ; unused args: depth length style table)
(display "#<" port)
(display (or (module-kind mod) "module") port)
- (let ((name (module-name mod)))
- (if name
- (begin
- (display " " port)
- (display name port))))
+ (display " " port)
+ (display (module-name mod) port)
(display " " port)
(display (number->string (object-address mod) 16) port)
(display ">" port))
@@ -1194,7 +1301,8 @@
"Lazy-binder expected to be a procedure or #f." binder))
(let ((module (module-constructor (make-hash-table size)
- uses binder #f #f #f #f #f
+ uses binder #f
%pre-modules-transformer
+ #f #f #f
(make-hash-table %default-import-size)
'()
(make-weak-key-hash-table 31))))
@@ -1219,7 +1327,7 @@
(define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
-(define module-name (record-accessor module-type 'name))
+;; (define module-name (record-accessor module-type 'name)) wait until mods
are booted
(define set-module-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
(define set-module-kind! (record-modifier module-type 'kind))
@@ -1363,7 +1471,9 @@
;; or its uses?
;;
(define (module-bound? m v)
- (module-search module-locally-bound? m v))
+ (let ((var (module-variable m v)))
+ (and var
+ (variable-bound? var))))
;;; {Is a symbol interned in a module?}
;;;
@@ -1799,7 +1909,7 @@
val
(let ((m (make-module 31)))
(set-module-kind! m 'directory)
- (set-module-name! m (append (or (module-name module) '())
+ (set-module-name! m (append (module-name module)
(list (car name))))
(module-define! module (car name) m)
m)))
@@ -1853,22 +1963,31 @@
(define default-duplicate-binding-procedures #f)
(define %app (make-module 31))
+(set-module-name! %app '(%app))
(define app %app) ;; for backwards compatability
-(local-define '(%app modules) (make-module 31))
+(let ((m (make-module 31)))
+ (set-module-name! m '())
+ (local-define '(%app modules) m))
(local-define '(%app modules guile) the-root-module)
;; This boots the module system. All bindings needed by modules.c
;; must have been defined by now.
;;
(set-current-module the-root-module)
+;; definition deferred for syncase's benefit.
+(define module-name
+ (let ((accessor (record-accessor module-type 'name)))
+ (lambda (mod)
+ (or (accessor mod)
+ (begin
+ (set-module-name! mod (list (gensym)))
+ (accessor mod))))))
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
(define (try-load-module name)
- (or (begin-deprecated (try-module-linked name))
- (try-module-autoload name)
- (begin-deprecated (try-module-dynamic-link name))))
+ (try-module-autoload name))
(define (purify-module! module)
"Removes bindings in MODULE which are inherited from the (guile) module."
@@ -2002,23 +2121,34 @@
((#:use-module #:use-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
- (let* ((interface-args (cadr kws))
- (interface (apply resolve-interface interface-args)))
- (and (eq? (car kws) #:use-syntax)
- (or (symbol? (caar interface-args))
- (error "invalid module name for use-syntax"
- (car interface-args)))
- (set-module-transformer!
- module
- (module-ref interface
- (car (last-pair (car interface-args)))
- #f)))
+ (cond
+ ((equal? (caadr kws) '(ice-9 syncase))
+ (issue-deprecation-warning
+ "(ice-9 syncase) is deprecated. Support for syntax-case is now
in Guile core.")
(loop (cddr kws)
- (cons interface reversed-interfaces)
+ reversed-interfaces
exports
re-exports
replacements
- autoloads)))
+ autoloads))
+ (else
+ (let* ((interface-args (cadr kws))
+ (interface (apply resolve-interface interface-args)))
+ (and (eq? (car kws) #:use-syntax)
+ (or (symbol? (caar interface-args))
+ (error "invalid module name for use-syntax"
+ (car interface-args)))
+ (set-module-transformer!
+ module
+ (module-ref interface
+ (car (last-pair (car interface-args)))
+ #f)))
+ (loop (cddr kws)
+ (cons interface reversed-interfaces)
+ exports
+ re-exports
+ replacements
+ autoloads)))))
((#:autoload)
(or (and (pair? (cdr kws)) (pair? (cddr kws)))
(unrecognized kws))
@@ -2310,11 +2440,12 @@ module '(ice-9 q) '(make-q q-length))}."
(define (set-repl-prompt! v) (set! scm-repl-prompt v))
(define (default-pre-unwind-handler key . args)
- (save-stack pre-unwind-handler-dispatch)
+ (save-stack 1)
(apply throw key args))
-(define (pre-unwind-handler-dispatch key . args)
- (apply default-pre-unwind-handler key args))
+(begin-deprecated
+ (define (pre-unwind-handler-dispatch key . args)
+ (apply default-pre-unwind-handler key args)))
(define abort-hook (make-hook))
@@ -2391,15 +2522,7 @@ module '(ice-9 q) '(make-q q-length))}."
(else
(apply bad-throw key args)))))))
- ;; Note that having just `pre-unwind-handler-dispatch'
- ;; here is connected with the mechanism that
- ;; produces a nice backtrace upon error. If, for
- ;; example, this is replaced with (lambda args
- ;; (apply pre-unwind-handler-dispatch args)), the stack
- ;; cutting (in save-stack) goes wrong and ends up
- ;; saving no stack at all, so there is no
- ;; backtrace.
- pre-unwind-handler-dispatch)))
+ default-pre-unwind-handler)))
(if next (loop next) status)))
(set! set-batch-mode?! (lambda (arg)
@@ -2674,32 +2797,6 @@ module '(ice-9 q) '(make-q q-length))}."
`(with-fluids* (list ,@fluids) (list ,@values)
(lambda () ,@body)))))
-
-
-;;; {Macros}
-;;;
-
-;; actually....hobbit might be able to hack these with a little
-;; coaxing
-;;
-
-(define (primitive-macro? m)
- (and (macro? m)
- (not (macro-transformer m))))
-
-(defmacro define-macro (first . rest)
- (let ((name (if (symbol? first) first (car first)))
- (transformer
- (if (symbol? first)
- (car rest)
- `(lambda ,(cdr first) ,@rest))))
- `(eval-when
- (eval load compile)
- (define ,name (defmacro:transformer ,transformer)))))
-
-
-
-
;;; {While}
;;;
;;; with `continue' and `break'.
@@ -2839,50 +2936,33 @@ module '(ice-9 q) '(make-q q-length))}."
(defmacro use-syntax (spec)
`(eval-when
(eval load compile)
- ,@(if (pair? spec)
- `((process-use-modules (list
- (list ,@(compile-interface-spec spec))))
- (set-module-transformer! (current-module)
- ,(car (last-pair spec))))
- `((set-module-transformer! (current-module) ,spec)))
- *unspecified*))
+ (issue-deprecation-warning
+ "`use-syntax' is deprecated. Please contact guile-devel for more info.")
+ (process-use-modules (list (list ,@(compile-interface-spec spec))))
+ *unspecified*))
;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
;; as soon as guile supports hygienic macros.
-(define define-private define)
-
-(defmacro define-public args
- (define (syntax)
- (error "bad syntax" (list 'define-public args)))
- (define (defined-name n)
- (cond
- ((symbol? n) n)
- ((pair? n) (defined-name (car n)))
- (else (syntax))))
- (cond
- ((null? args)
- (syntax))
- (#t
- (let ((name (defined-name (car args))))
- `(begin
- (define-private ,@args)
- (export ,name))))))
-
-(defmacro defmacro-public args
- (define (syntax)
- (error "bad syntax" (list 'defmacro-public args)))
- (define (defined-name n)
- (cond
- ((symbol? n) n)
- (else (syntax))))
- (cond
- ((null? args)
- (syntax))
- (#t
- (let ((name (defined-name (car args))))
- `(begin
- (export-syntax ,name)
- (defmacro ,@args))))))
+(define-syntax define-private
+ (syntax-rules ()
+ ((_ foo bar)
+ (define foo bar))))
+
+(define-syntax define-public
+ (syntax-rules ()
+ ((_ (name . args) . body)
+ (define-public name (lambda args . body)))
+ ((_ name val)
+ (begin
+ (define name val)
+ (export name)))))
+
+(define-syntax defmacro-public
+ (syntax-rules ()
+ ((_ name args . body)
+ (begin
+ (defmacro name args . body)
+ (export-syntax name)))))
;; Export a local variable
@@ -2938,19 +3018,6 @@ module '(ice-9 q) '(make-q q-length))}."
-;;; {Compiler interface}
-;;;
-;;; The full compiler interface can be found in (system). Here we put a
-;;; few useful procedures into the global namespace.
-
-(module-autoload! the-scm-module
- '(system base compile)
- '(compile
- compile-time-environment))
-
-
-
-
;;; {Parameters}
;;;
@@ -3371,6 +3438,13 @@ module '(ice-9 q) '(make-q q-length))}."
;;; Place the user in the guile-user module.
;;;
-(define-module (guile-user))
+;;; FIXME: annotate ?
+;; (define (syncase exp)
+;; (with-fluids ((expansion-eval-closure
+;; (module-eval-closure (current-module))))
+;; (deannotate/source-properties (sc-expand (annotate exp)))))
+
+(define-module (guile-user)
+ #:autoload (system base compile) (compile))
;;; boot-9.scm ends here
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 10a307b..2b8eec0 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -1,27 +1,20 @@
-(use-modules (ice-9 syncase))
-
-;; XXX - We need to be inside (ice-9 syncase) since psyntax.ss calls
-;; `eval' int he `interaction-environment' aka the current module and
-;; it expects to have `andmap' there. The reason for this escapes me
-;; at the moment.
-;;
-(define-module (ice-9 syncase))
-
-(define source (list-ref (command-line) 1))
-(define target (list-ref (command-line) 2))
-
-(let ((in (open-input-file source))
- (out (open-output-file (string-append target ".tmp"))))
- (let loop ((x (read in)))
- (if (eof-object? x)
- (begin
- (close-port out)
- (close-port in))
- (begin
- (write (strip-expansion-structures
- (sc-expand3 x 'c '(compile load eval)))
- out)
- (newline out)
- (loop (read in))))))
-
-(system (format #f "mv -f ~s.tmp ~s" target target))
+(use-modules (language tree-il))
+(let ((source (list-ref (command-line) 1))
+ (target (list-ref (command-line) 2)))
+ (let ((in (open-input-file source))
+ (out (open-output-file (string-append target ".tmp"))))
+ (write '(eval-when (compile) (set-current-module (resolve-module
'(guile))))
+ out)
+ (newline out)
+ (let loop ((x (read in)))
+ (if (eof-object? x)
+ (begin
+ (close-port out)
+ (close-port in))
+ (begin
+ (write (tree-il->scheme
+ (sc-expand x 'c '(compile load eval)))
+ out)
+ (newline out)
+ (loop (read in))))))
+ (system (format #f "mv -f ~s.tmp ~s" target target)))
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index f3b7caf..6f2c225 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -21,7 +21,7 @@
(define substring-move-right! substring-move!)
;; This method of dynamically linking Guile Extensions is deprecated.
-;; Use `load-extension' explicitely from Scheme code instead.
+;; Use `load-extension' explicitly from Scheme code instead.
(define (split-c-module-name str)
(let loop ((rev '())
diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm
index c5f447e..92d31ca 100644
--- a/module/ice-9/documentation.scm
+++ b/module/ice-9/documentation.scm
@@ -195,15 +195,11 @@ OBJECT can be a procedure, macro or any object that has
its
`documentation' property set."
(or (and (procedure? object)
(proc-doc object))
- (and (defmacro? object)
- (proc-doc (defmacro-transformer object)))
- (and (macro? object)
- (let ((transformer (macro-transformer object)))
- (and transformer
- (proc-doc transformer))))
(object-property object 'documentation)
(and (program? object)
(program-documentation object))
+ (and (macro? object)
+ (object-documentation (macro-transformer object)))
(and (procedure? object)
(not (closure? object))
(procedure-name object)
diff --git a/module/ice-9/expand-support.scm b/module/ice-9/expand-support.scm
deleted file mode 100644
index 372d959..0000000
--- a/module/ice-9/expand-support.scm
+++ /dev/null
@@ -1,169 +0,0 @@
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-;;;;
-
-
-(define-module (ice-9 expand-support)
- :export (<annotation> annotation? annotate deannotate make-annotation
- annotation-expression annotation-source annotation-stripped
- set-annotation-stripped!
- deannotate/source-properties
-
- <module-ref> make-module-ref
- module-ref-symbol module-ref-modname module-ref-public?
-
- <lexical> make-lexical
- lexical-name lexical-gensym
-
- strip-expansion-structures))
-
-(define <annotation>
- (make-vtable "prprpw"
- (lambda (struct port)
- (display "#<annotated " port)
- (display (struct-ref struct 0) port)
- (display ">" port))))
-
-(define (annotation? x)
- (and (struct? x) (eq? (struct-vtable x) <annotation>)))
-
-(define (make-annotation e s . stripped?)
- (if (null? stripped?)
- (make-struct <annotation> 0 e s #f)
- (apply make-struct <annotation> 0 e s stripped?)))
-
-(define (annotation-expression a)
- (struct-ref a 0))
-(define (annotation-source a)
- (struct-ref a 1))
-(define (annotation-stripped a)
- (struct-ref a 2))
-(define (set-annotation-stripped! a stripped?)
- (struct-set! a 2 stripped?))
-
-(define (annotate e)
- (let ((p (if (pair? e) (source-properties e) #f))
- (out (cond ((and (list? e) (not (null? e)))
- (map annotate e))
- ((pair? e)
- (cons (annotate (car e)) (annotate (cdr e))))
- (else e))))
- (if (pair? p)
- (make-annotation out p #f)
- out)))
-
-(define (deannotate e)
- (cond ((list? e)
- (map deannotate e))
- ((pair? e)
- (cons (deannotate (car e)) (deannotate (cdr e))))
- ((annotation? e) (deannotate (annotation-expression e)))
- (else e)))
-
-(define (deannotate/source-properties e)
- (cond ((list? e)
- (map deannotate/source-properties e))
- ((pair? e)
- (cons (deannotate/source-properties (car e))
- (deannotate/source-properties (cdr e))))
- ((annotation? e)
- (let ((e (deannotate/source-properties (annotation-expression e)))
- (source (annotation-source e)))
- (if (pair? e)
- (set-source-properties! e source))
- e))
- (else e)))
-
-
-
-(define <module-ref>
- (make-vtable "prprpr"
- (lambda (struct port)
- (display "#<" port)
- (display (if (module-ref-public? struct) "@ " "@@ ") port)
- (display (module-ref-modname struct) port)
- (display " " port)
- (display (module-ref-symbol struct) port)
- (display ">" port))))
-
-(define (module-ref? x)
- (and (struct? x) (eq? (struct-vtable x) <module-ref>)))
-
-(define (make-module-ref modname symbol public?)
- (make-struct <module-ref> 0 modname symbol public?))
-
-(define (module-ref-modname a)
- (struct-ref a 0))
-(define (module-ref-symbol a)
- (struct-ref a 1))
-(define (module-ref-public? a)
- (struct-ref a 2))
-
-
-
-(define <lexical>
- (make-vtable "prpr"
- (lambda (struct port)
- (display "#<lexical " port)
- (display (lexical-name struct) port)
- (display "/" port)
- (display (lexical-gensym struct) port)
- (display ">" port))))
-
-(define (lexical? x)
- (and (struct? x) (eq? (struct-vtable x) <lexical>)))
-
-(define (make-lexical name gensym)
- (make-struct <lexical> 0 name gensym))
-
-(define (lexical-name a)
- (struct-ref a 0))
-(define (lexical-gensym a)
- (struct-ref a 1))
-
-
-
-(define (strip-expansion-structures e)
- (cond ((list? e)
- (map strip-expansion-structures e))
- ((pair? e)
- (cons (strip-expansion-structures (car e))
- (strip-expansion-structures (cdr e))))
- ((annotation? e)
- (let ((e (strip-expansion-structures (annotation-expression e)))
- (source (annotation-source e)))
- (if (pair? e)
- (set-source-properties! e source))
- e))
- ((module-ref? e)
- (cond
- ((or (not (module-ref-modname e))
- (eq? (module-ref-modname e)
- (module-name (current-module)))
- (and (not (module-ref-public? e))
- (not (module-variable
- (resolve-module (module-ref-modname e))
- (module-ref-symbol e)))))
- (module-ref-symbol e))
- (else
- `(,(if (module-ref-public? e) '@ '@@)
- ,(module-ref-modname e)
- ,(module-ref-symbol e)))))
- ((lexical? e)
- (lexical-gensym e))
- ((record? e)
- (error "unexpected record in expansion" e))
- (else e)))
diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index e6fe560..baa4d5a 100644
--- a/module/ice-9/match.scm
+++ b/module/ice-9/match.scm
@@ -194,6 +194,6 @@
(define match:runtime-structures #f)
(define match:set-runtime-structures (lambda (v) (set!
match:runtime-structures v)))
(define match:primitive-vector? vector?)
-(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda ()
#t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x))
(null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda
(x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair?
(cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x)))))
(mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x)
(pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x))
(match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda
(l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi
(cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let
((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct)
(unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol?
(car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args))
(symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args))
(g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate
fields) (let* ((selectors (map selector-name fields)) (mutators (map
mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote
(quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq?
match:structure-control (quote disjoint)) (quote match:primitive-vector?))
((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq?
match:structure-control (quote disjoint)) (if (eq? vector?
match:primitive-vector?) (set! vector? (lambda (v) (and
(match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol?
(vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not
(memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates
(cons predicate match:disjoint-predicates)))) ((eq? match:structure-control
(quote vector)) (if (not (memq predicate match:vector-structures)) (set!
match:vector-structures (cons predicate match:vector-structures)))) (else
(match:syntax-err (quote (vector disjoint)) "invalid value for
match:structure-control, legal values are"))) (quasiquote (begin
(unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote
tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define
(unquote constructor) (lambda (unquote selectors) (vector (unquote tag)
(unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and
((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length
selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing
(filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda
(obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing
(filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n)
(lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators))))))
(car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299))
(g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
+(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda ()
#t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x))
(null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda
(x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair?
(cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x)))))
(mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x)
(pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x))
(match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda
(l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi
(cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let
((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing
args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair?
(cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args))
(list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if
(null? g299) ((lambda (name constructor predicate fields) (let* ((selectors
(map selector-name fields)) (mutators (map mutator-name fields)) (tag (if
match:runtime-structures (gensym) (quasiquote (quote (unquote
(match:make-structure-tag name)))))) (vectorP (cond ((eq?
match:structure-control (quote disjoint)) (quote match:primitive-vector?))
((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq?
match:structure-control (quote disjoint)) (if (eq? vector?
match:primitive-vector?) (set! vector? (lambda (v) (and
(match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol?
(vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not
(memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates
(cons predicate match:disjoint-predicates)))) ((eq? match:structure-control
(quote vector)) (if (not (memq predicate match:vector-structures)) (set!
match:vector-structures (cons predicate match:vector-structures)))) (else
(match:syntax-err (quote (vector disjoint)) "invalid value for
match:structure-control, legal values are"))) (quasiquote (begin
(unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote
tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define
(unquote constructor) (lambda (unquote selectors) (vector (unquote tag)
(unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and
((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length
selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing
(filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda
(obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing
(filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n)
(lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators))))))
(car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299))
(g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
(defmacro define-structure args (let ((g311 (lambda () (match:syntax-err
(quasiquote (define-structure (unquote-splicing args))) "syntax error in"))))
(if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr
args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name)
(unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr
args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ()))
(g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1
id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote
@)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x)
(cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote
(define-const-structure ((unquote name) (unquote-splicing (map mk-id id1)))
(unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v))))
id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311))
(if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308
(cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311)))
(g311))))
-(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol?
id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair?
(cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda ()
#f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator?
(lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec
((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x)
(cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l
1)))) (symbol-append (lambda l (string->symbol (apply string-append (map
(lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string
x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote
(define-const-structure (unquote-splicing args))) "syntax error in")))) (if
(and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr
args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name)
(unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar
args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if
(and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args))
(g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args))
((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor
(symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote
make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin
((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote
predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if
(has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i))
(unquote (symbol-append (quote set-) name (quote -) i (quote !)))))
(symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2)
(quasiquote (define (unquote constructor) (unquote raw-constructor))) (let*
((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map
make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name
id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1)
(let* (unquote (map list names2 val)) ((unquote raw-constructor)
(unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing
(filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _))
#f (quasiquote (define (unquote (symbol-append name (quote -) (field-name
field))) (unquote (symbol-append name (quote -) i)))))) id1id2))
(unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq?
(field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote
(define (unquote (symbol-append (quote set-) name (quote -) (field-name field)
(quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote
!))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331))
(g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333))
(null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar
g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons
(car g329) g327)) (g335)))) (g335))) (g335)))))
+(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol?
id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair?
(cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda ()
#f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator?
(lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec
((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x)
(cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l
1)))) (symbol-append (lambda l (string->symbol (apply string-append (map
(lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string
x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote
(define-const-structure (unquote-splicing args))) "syntax error in")))) (if
(and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr
args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name)
(unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar
args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if
(and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args))
(g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args))
((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor
(symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote
make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin
(defstruct (unquote name) (unquote raw-constructor) (unquote predicate)
(unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg)
(quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append
(quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i)))
id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor)
(unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _)
x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map
make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor)
(lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote
raw-constructor) (unquote-splicing names1) (unquote-splicing names2)))))))))
(unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name
field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -)
(field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2))
(unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq?
(field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote
(define (unquote (symbol-append (quote set-) name (quote -) (field-name field)
(quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote
!))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331))
(g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333))
(null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar
g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons
(car g329) g327)) (g335)))) (g335))) (g335)))))
diff --git a/module/ice-9/networking.scm b/module/ice-9/networking.scm
index c021882..9a30fc5 100644
--- a/module/ice-9/networking.scm
+++ b/module/ice-9/networking.scm
@@ -17,6 +17,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
;;;;
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
(define (gethostbyaddr addr) (gethost addr))
(define (gethostbyname name) (gethost name))
diff --git a/module/ice-9/null.scm b/module/ice-9/null.scm
index b9212e6..3f9f5b0 100644
--- a/module/ice-9/null.scm
+++ b/module/ice-9/null.scm
@@ -18,7 +18,6 @@
;;;; The null environment - only syntactic bindings
(define-module (ice-9 null)
- :use-module (ice-9 syncase)
:re-export-syntax (define quote lambda if set!
cond case and or
diff --git a/module/ice-9/occam-channel.scm b/module/ice-9/occam-channel.scm
index e28f73d..e04ecac 100644
--- a/module/ice-9/occam-channel.scm
+++ b/module/ice-9/occam-channel.scm
@@ -17,7 +17,6 @@
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 occam-channel)
- #:use-syntax (ice-9 syncase)
#:use-module (oop goops)
#:use-module (ice-9 threads)
#:export-syntax (alt
diff --git a/module/ice-9/posix.scm b/module/ice-9/posix.scm
index 53d01a0..dd1a126 100644
--- a/module/ice-9/posix.scm
+++ b/module/ice-9/posix.scm
@@ -17,6 +17,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
;;;;
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
(define (stat:dev f) (vector-ref f 0))
(define (stat:ino f) (vector-ref f 1))
(define (stat:mode f) (vector-ref f 2))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 02d9e99..f33f492 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1,11 +1,13 @@
-(letrec ((syntmp-lambda-var-list-153 (lambda (syntmp-vars-544) (let
syntmp-lvl-545 ((syntmp-vars-546 syntmp-vars-544) (syntmp-ls-547 (quote ()))
(syntmp-w-548 (quote (())))) (cond ((pair? syntmp-vars-546) (syntmp-lvl-545
(cdr syntmp-vars-546) (cons (syntmp-wrap-132 (car syntmp-vars-546) syntmp-w-548
#f) syntmp-ls-547) syntmp-w-548)) ((syntmp-id?-104 syntmp-vars-546) (cons
(syntmp-wrap-132 syntmp-vars-546 syntmp-w-548 #f) syntmp-ls-547)) ((null?
syntmp-vars-546) syntmp-ls-547) ((syntmp-syntax-object?-88 syntmp-vars-546)
(syntmp-lvl-545 (syntmp-syntax-object-expression-89 syntmp-vars-546)
syntmp-ls-547 (syntmp-join-wraps-123 syntmp-w-548 (syntmp-syntax-object-wrap-90
syntmp-vars-546)))) ((annotation? syntmp-vars-546) (syntmp-lvl-545
(annotation-expression syntmp-vars-546) syntmp-ls-547 syntmp-w-548)) (else
(cons syntmp-vars-546 syntmp-ls-547)))))) (syntmp-gen-var-152 (lambda
(syntmp-id-549) (let ((syntmp-id-550 (if (syntmp-syntax-object?-88
syntmp-id-549) (syntmp-syntax-object-expression-89 syntmp-id-549)
syntmp-id-549))) (if (annotation? syntmp-id-550) (syntmp-build-annotated-81
(annotation-source syntmp-id-550) (gensym (symbol->string
(annotation-expression syntmp-id-550)))) (syntmp-build-annotated-81 #f (gensym
(symbol->string syntmp-id-550))))))) (syntmp-strip-151 (lambda (syntmp-x-551
syntmp-w-552) (if (memq (quote top) (syntmp-wrap-marks-107 syntmp-w-552)) (if
(or (annotation? syntmp-x-551) (and (pair? syntmp-x-551) (annotation? (car
syntmp-x-551)))) (syntmp-strip-annotation-150 syntmp-x-551 #f) syntmp-x-551)
(let syntmp-f-553 ((syntmp-x-554 syntmp-x-551)) (cond
((syntmp-syntax-object?-88 syntmp-x-554) (syntmp-strip-151
(syntmp-syntax-object-expression-89 syntmp-x-554) (syntmp-syntax-object-wrap-90
syntmp-x-554))) ((pair? syntmp-x-554) (let ((syntmp-a-555 (syntmp-f-553 (car
syntmp-x-554))) (syntmp-d-556 (syntmp-f-553 (cdr syntmp-x-554)))) (if (and (eq?
syntmp-a-555 (car syntmp-x-554)) (eq? syntmp-d-556 (cdr syntmp-x-554)))
syntmp-x-554 (cons syntmp-a-555 syntmp-d-556)))) ((vector? syntmp-x-554) (let
((syntmp-old-557 (vector->list syntmp-x-554))) (let ((syntmp-new-558 (map
syntmp-f-553 syntmp-old-557))) (if (andmap eq? syntmp-old-557 syntmp-new-558)
syntmp-x-554 (list->vector syntmp-new-558))))) (else syntmp-x-554))))))
(syntmp-strip-annotation-150 (lambda (syntmp-x-559 syntmp-parent-560) (cond
((pair? syntmp-x-559) (let ((syntmp-new-561 (cons #f #f))) (begin (if
syntmp-parent-560 (set-annotation-stripped! syntmp-parent-560 syntmp-new-561))
(set-car! syntmp-new-561 (syntmp-strip-annotation-150 (car syntmp-x-559) #f))
(set-cdr! syntmp-new-561 (syntmp-strip-annotation-150 (cdr syntmp-x-559) #f))
syntmp-new-561))) ((annotation? syntmp-x-559) (or (annotation-stripped
syntmp-x-559) (syntmp-strip-annotation-150 (annotation-expression syntmp-x-559)
syntmp-x-559))) ((vector? syntmp-x-559) (let ((syntmp-new-562 (make-vector
(vector-length syntmp-x-559)))) (begin (if syntmp-parent-560
(set-annotation-stripped! syntmp-parent-560 syntmp-new-562)) (let
syntmp-loop-563 ((syntmp-i-564 (- (vector-length syntmp-x-559) 1))) (unless
(syntmp-fx<-75 syntmp-i-564 0) (vector-set! syntmp-new-562 syntmp-i-564
(syntmp-strip-annotation-150 (vector-ref syntmp-x-559 syntmp-i-564) #f))
(syntmp-loop-563 (syntmp-fx--73 syntmp-i-564 1)))) syntmp-new-562))) (else
syntmp-x-559)))) (syntmp-ellipsis?-149 (lambda (syntmp-x-565) (and
(syntmp-nonsymbol-id?-103 syntmp-x-565) (syntmp-free-id=?-127 syntmp-x-565
(quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis?
chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body
chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"))
#(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))
(syntmp-chi-void-148 (lambda () (syntmp-build-annotated-81 #f (list
(syntmp-build-annotated-81 #f (quote void))))))
(syntmp-eval-local-transformer-147 (lambda (syntmp-expanded-566 syntmp-mod-567)
(let ((syntmp-p-568 (syntmp-local-eval-hook-77 syntmp-expanded-566
syntmp-mod-567))) (if (procedure? syntmp-p-568) syntmp-p-568 (syntax-error
syntmp-p-568 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-146
(lambda (syntmp-rec?-569 syntmp-e-570 syntmp-r-571 syntmp-w-572 syntmp-s-573
syntmp-mod-574 syntmp-k-575) ((lambda (syntmp-tmp-576) ((lambda
(syntmp-tmp-577) (if syntmp-tmp-577 (apply (lambda (syntmp-_-578 syntmp-id-579
syntmp-val-580 syntmp-e1-581 syntmp-e2-582) (let ((syntmp-ids-583
syntmp-id-579)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-583))
(syntax-error syntmp-e-570 "duplicate bound keyword in") (let
((syntmp-labels-585 (syntmp-gen-labels-110 syntmp-ids-583))) (let
((syntmp-new-w-586 (syntmp-make-binding-wrap-121 syntmp-ids-583
syntmp-labels-585 syntmp-w-572))) (syntmp-k-575 (cons syntmp-e1-581
syntmp-e2-582) (syntmp-extend-env-98 syntmp-labels-585 (let ((syntmp-w-588 (if
syntmp-rec?-569 syntmp-new-w-586 syntmp-w-572)) (syntmp-trans-r-589
(syntmp-macros-only-env-100 syntmp-r-571))) (map (lambda (syntmp-x-590) (cons
(quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-590
syntmp-trans-r-589 syntmp-w-588 syntmp-mod-574) syntmp-mod-574)))
syntmp-val-580)) syntmp-r-571) syntmp-new-w-586 syntmp-s-573
syntmp-mod-574)))))) syntmp-tmp-577) ((lambda (syntmp-_-592) (syntax-error
(syntmp-source-wrap-133 syntmp-e-570 syntmp-w-572 syntmp-s-573
syntmp-mod-574))) syntmp-tmp-576))) (syntax-dispatch syntmp-tmp-576 (quote (any
#(each (any any)) any . each-any))))) syntmp-e-570)))
(syntmp-chi-lambda-clause-145 (lambda (syntmp-e-593 syntmp-c-594 syntmp-r-595
syntmp-w-596 syntmp-mod-597 syntmp-k-598) ((lambda (syntmp-tmp-599) ((lambda
(syntmp-tmp-600) (if syntmp-tmp-600 (apply (lambda (syntmp-id-601 syntmp-e1-602
syntmp-e2-603) (let ((syntmp-ids-604 syntmp-id-601)) (if (not
(syntmp-valid-bound-ids?-129 syntmp-ids-604)) (syntax-error syntmp-e-593
"invalid parameter list in") (let ((syntmp-labels-606 (syntmp-gen-labels-110
syntmp-ids-604)) (syntmp-new-vars-607 (map syntmp-gen-var-152 syntmp-ids-604)))
(syntmp-k-598 syntmp-new-vars-607 (syntmp-chi-body-144 (cons syntmp-e1-602
syntmp-e2-603) syntmp-e-593 (syntmp-extend-var-env-99 syntmp-labels-606
syntmp-new-vars-607 syntmp-r-595) (syntmp-make-binding-wrap-121 syntmp-ids-604
syntmp-labels-606 syntmp-w-596) syntmp-mod-597)))))) syntmp-tmp-600) ((lambda
(syntmp-tmp-609) (if syntmp-tmp-609 (apply (lambda (syntmp-ids-610
syntmp-e1-611 syntmp-e2-612) (let ((syntmp-old-ids-613
(syntmp-lambda-var-list-153 syntmp-ids-610))) (if (not
(syntmp-valid-bound-ids?-129 syntmp-old-ids-613)) (syntax-error syntmp-e-593
"invalid parameter list in") (let ((syntmp-labels-614 (syntmp-gen-labels-110
syntmp-old-ids-613)) (syntmp-new-vars-615 (map syntmp-gen-var-152
syntmp-old-ids-613))) (syntmp-k-598 (let syntmp-f-616 ((syntmp-ls1-617 (cdr
syntmp-new-vars-615)) (syntmp-ls2-618 (car syntmp-new-vars-615))) (if (null?
syntmp-ls1-617) syntmp-ls2-618 (syntmp-f-616 (cdr syntmp-ls1-617) (cons (car
syntmp-ls1-617) syntmp-ls2-618)))) (syntmp-chi-body-144 (cons syntmp-e1-611
syntmp-e2-612) syntmp-e-593 (syntmp-extend-var-env-99 syntmp-labels-614
syntmp-new-vars-615 syntmp-r-595) (syntmp-make-binding-wrap-121
syntmp-old-ids-613 syntmp-labels-614 syntmp-w-596) syntmp-mod-597))))))
syntmp-tmp-609) ((lambda (syntmp-_-620) (syntax-error syntmp-e-593))
syntmp-tmp-599))) (syntax-dispatch syntmp-tmp-599 (quote (any any .
each-any)))))) (syntax-dispatch syntmp-tmp-599 (quote (each-any any .
each-any))))) syntmp-c-594))) (syntmp-chi-body-144 (lambda (syntmp-body-621
syntmp-outer-form-622 syntmp-r-623 syntmp-w-624 syntmp-mod-625) (let
((syntmp-r-626 (cons (quote ("placeholder" placeholder)) syntmp-r-623))) (let
((syntmp-ribcage-627 (syntmp-make-ribcage-111 (quote ()) (quote ()) (quote
())))) (let ((syntmp-w-628 (syntmp-make-wrap-106 (syntmp-wrap-marks-107
syntmp-w-624) (cons syntmp-ribcage-627 (syntmp-wrap-subst-108 syntmp-w-624)))))
(let syntmp-parse-629 ((syntmp-body-630 (map (lambda (syntmp-x-636) (cons
syntmp-r-626 (syntmp-wrap-132 syntmp-x-636 syntmp-w-628 syntmp-mod-625)))
syntmp-body-621)) (syntmp-ids-631 (quote ())) (syntmp-labels-632 (quote ()))
(syntmp-vars-633 (quote ())) (syntmp-vals-634 (quote ())) (syntmp-bindings-635
(quote ()))) (if (null? syntmp-body-630) (syntax-error syntmp-outer-form-622
"no expressions in body") (let ((syntmp-e-637 (cdar syntmp-body-630))
(syntmp-er-638 (caar syntmp-body-630))) (call-with-values (lambda ()
(syntmp-syntax-type-138 syntmp-e-637 syntmp-er-638 (quote (())) #f
syntmp-ribcage-627 syntmp-mod-625)) (lambda (syntmp-type-639 syntmp-value-640
syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644) (let ((syntmp-t-645
syntmp-type-639)) (if (memv syntmp-t-645 (quote (define-form))) (let
((syntmp-id-646 (syntmp-wrap-132 syntmp-value-640 syntmp-w-642 syntmp-mod-644))
(syntmp-label-647 (syntmp-gen-label-109))) (let ((syntmp-var-648
(syntmp-gen-var-152 syntmp-id-646))) (begin (syntmp-extend-ribcage!-120
syntmp-ribcage-627 syntmp-id-646 syntmp-label-647) (syntmp-parse-629 (cdr
syntmp-body-630) (cons syntmp-id-646 syntmp-ids-631) (cons syntmp-label-647
syntmp-labels-632) (cons syntmp-var-648 syntmp-vars-633) (cons (cons
syntmp-er-638 (syntmp-wrap-132 syntmp-e-641 syntmp-w-642 syntmp-mod-644))
syntmp-vals-634) (cons (cons (quote lexical) syntmp-var-648)
syntmp-bindings-635))))) (if (memv syntmp-t-645 (quote (define-syntax-form)))
(let ((syntmp-id-649 (syntmp-wrap-132 syntmp-value-640 syntmp-w-642
syntmp-mod-644)) (syntmp-label-650 (syntmp-gen-label-109))) (begin
(syntmp-extend-ribcage!-120 syntmp-ribcage-627 syntmp-id-649 syntmp-label-650)
(syntmp-parse-629 (cdr syntmp-body-630) (cons syntmp-id-649 syntmp-ids-631)
(cons syntmp-label-650 syntmp-labels-632) syntmp-vars-633 syntmp-vals-634 (cons
(cons (quote macro) (cons syntmp-er-638 (syntmp-wrap-132 syntmp-e-641
syntmp-w-642 syntmp-mod-644))) syntmp-bindings-635)))) (if (memv syntmp-t-645
(quote (begin-form))) ((lambda (syntmp-tmp-651) ((lambda (syntmp-tmp-652) (if
syntmp-tmp-652 (apply (lambda (syntmp-_-653 syntmp-e1-654) (syntmp-parse-629
(let syntmp-f-655 ((syntmp-forms-656 syntmp-e1-654)) (if (null?
syntmp-forms-656) (cdr syntmp-body-630) (cons (cons syntmp-er-638
(syntmp-wrap-132 (car syntmp-forms-656) syntmp-w-642 syntmp-mod-644))
(syntmp-f-655 (cdr syntmp-forms-656))))) syntmp-ids-631 syntmp-labels-632
syntmp-vars-633 syntmp-vals-634 syntmp-bindings-635)) syntmp-tmp-652)
(syntax-error syntmp-tmp-651))) (syntax-dispatch syntmp-tmp-651 (quote (any .
each-any))))) syntmp-e-641) (if (memv syntmp-t-645 (quote (local-syntax-form)))
(syntmp-chi-local-syntax-146 syntmp-value-640 syntmp-e-641 syntmp-er-638
syntmp-w-642 syntmp-s-643 syntmp-mod-644 (lambda (syntmp-forms-658
syntmp-er-659 syntmp-w-660 syntmp-s-661 syntmp-mod-662) (syntmp-parse-629 (let
syntmp-f-663 ((syntmp-forms-664 syntmp-forms-658)) (if (null? syntmp-forms-664)
(cdr syntmp-body-630) (cons (cons syntmp-er-659 (syntmp-wrap-132 (car
syntmp-forms-664) syntmp-w-660 syntmp-mod-662)) (syntmp-f-663 (cdr
syntmp-forms-664))))) syntmp-ids-631 syntmp-labels-632 syntmp-vars-633
syntmp-vals-634 syntmp-bindings-635))) (if (null? syntmp-ids-631)
(syntmp-build-sequence-83 #f (map (lambda (syntmp-x-665) (syntmp-chi-140 (cdr
syntmp-x-665) (car syntmp-x-665) (quote (())) syntmp-mod-644)) (cons (cons
syntmp-er-638 (syntmp-source-wrap-133 syntmp-e-641 syntmp-w-642 syntmp-s-643
syntmp-mod-644)) (cdr syntmp-body-630)))) (begin (if (not
(syntmp-valid-bound-ids?-129 syntmp-ids-631)) (syntax-error
syntmp-outer-form-622 "invalid or duplicate identifier in definition")) (let
syntmp-loop-666 ((syntmp-bs-667 syntmp-bindings-635) (syntmp-er-cache-668 #f)
(syntmp-r-cache-669 #f)) (if (not (null? syntmp-bs-667)) (let ((syntmp-b-670
(car syntmp-bs-667))) (if (eq? (car syntmp-b-670) (quote macro)) (let
((syntmp-er-671 (cadr syntmp-b-670))) (let ((syntmp-r-cache-672 (if (eq?
syntmp-er-671 syntmp-er-cache-668) syntmp-r-cache-669
(syntmp-macros-only-env-100 syntmp-er-671)))) (begin (set-cdr! syntmp-b-670
(syntmp-eval-local-transformer-147 (syntmp-chi-140 (cddr syntmp-b-670)
syntmp-r-cache-672 (quote (())) syntmp-mod-644) syntmp-mod-644))
(syntmp-loop-666 (cdr syntmp-bs-667) syntmp-er-671 syntmp-r-cache-672))))
(syntmp-loop-666 (cdr syntmp-bs-667) syntmp-er-cache-668
syntmp-r-cache-669))))) (set-cdr! syntmp-r-626 (syntmp-extend-env-98
syntmp-labels-632 syntmp-bindings-635 (cdr syntmp-r-626)))
(syntmp-build-letrec-86 #f syntmp-vars-633 (map (lambda (syntmp-x-673)
(syntmp-chi-140 (cdr syntmp-x-673) (car syntmp-x-673) (quote (()))
syntmp-mod-644)) syntmp-vals-634) (syntmp-build-sequence-83 #f (map (lambda
(syntmp-x-674) (syntmp-chi-140 (cdr syntmp-x-674) (car syntmp-x-674) (quote
(())) syntmp-mod-644)) (cons (cons syntmp-er-638 (syntmp-source-wrap-133
syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644)) (cdr
syntmp-body-630)))))))))))))))))))))) (syntmp-chi-macro-143 (lambda
(syntmp-p-675 syntmp-e-676 syntmp-r-677 syntmp-w-678 syntmp-rib-679
syntmp-mod-680) (letrec ((syntmp-rebuild-macro-output-681 (lambda (syntmp-x-682
syntmp-m-683) (cond ((pair? syntmp-x-682) (cons
(syntmp-rebuild-macro-output-681 (car syntmp-x-682) syntmp-m-683)
(syntmp-rebuild-macro-output-681 (cdr syntmp-x-682) syntmp-m-683)))
((syntmp-syntax-object?-88 syntmp-x-682) (let ((syntmp-w-684
(syntmp-syntax-object-wrap-90 syntmp-x-682))) (let ((syntmp-ms-685
(syntmp-wrap-marks-107 syntmp-w-684)) (syntmp-s-686 (syntmp-wrap-subst-108
syntmp-w-684))) (if (and (pair? syntmp-ms-685) (eq? (car syntmp-ms-685) #f))
(syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-682)
(syntmp-make-wrap-106 (cdr syntmp-ms-685) (if syntmp-rib-679 (cons
syntmp-rib-679 (cdr syntmp-s-686)) (cdr syntmp-s-686)))
(syntmp-syntax-object-module-91 syntmp-x-682)) (syntmp-make-syntax-object-87
(syntmp-syntax-object-expression-89 syntmp-x-682) (syntmp-make-wrap-106 (cons
syntmp-m-683 syntmp-ms-685) (if syntmp-rib-679 (cons syntmp-rib-679 (cons
(quote shift) syntmp-s-686)) (cons (quote shift) syntmp-s-686))) (module-name
(procedure-module syntmp-p-675))))))) ((vector? syntmp-x-682) (let
((syntmp-n-687 (vector-length syntmp-x-682))) (let ((syntmp-v-688 (make-vector
syntmp-n-687))) (let syntmp-doloop-689 ((syntmp-i-690 0)) (if (syntmp-fx=-74
syntmp-i-690 syntmp-n-687) syntmp-v-688 (begin (vector-set! syntmp-v-688
syntmp-i-690 (syntmp-rebuild-macro-output-681 (vector-ref syntmp-x-682
syntmp-i-690) syntmp-m-683)) (syntmp-doloop-689 (syntmp-fx+-72 syntmp-i-690
1)))))))) ((symbol? syntmp-x-682) (syntax-error syntmp-x-682 "encountered raw
symbol in macro output")) (else syntmp-x-682)))))
(syntmp-rebuild-macro-output-681 (syntmp-p-675 (syntmp-wrap-132 syntmp-e-676
(syntmp-anti-mark-119 syntmp-w-678) syntmp-mod-680)) (string #\m)))))
(syntmp-chi-application-142 (lambda (syntmp-x-691 syntmp-e-692 syntmp-r-693
syntmp-w-694 syntmp-s-695 syntmp-mod-696) ((lambda (syntmp-tmp-697) ((lambda
(syntmp-tmp-698) (if syntmp-tmp-698 (apply (lambda (syntmp-e0-699
syntmp-e1-700) (syntmp-build-annotated-81 syntmp-s-695 (cons syntmp-x-691 (map
(lambda (syntmp-e-701) (syntmp-chi-140 syntmp-e-701 syntmp-r-693 syntmp-w-694
syntmp-mod-696)) syntmp-e1-700)))) syntmp-tmp-698) (syntax-error
syntmp-tmp-697))) (syntax-dispatch syntmp-tmp-697 (quote (any . each-any)))))
syntmp-e-692))) (syntmp-chi-expr-141 (lambda (syntmp-type-703 syntmp-value-704
syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (let
((syntmp-t-710 syntmp-type-703)) (if (memv syntmp-t-710 (quote (lexical)))
(syntmp-build-annotated-81 syntmp-s-708 syntmp-value-704) (if (memv
syntmp-t-710 (quote (core external-macro))) (syntmp-value-704 syntmp-e-705
syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710
(quote (module-ref))) (call-with-values (lambda () (syntmp-value-704
syntmp-e-705)) (lambda (syntmp-id-711 syntmp-mod-712)
(syntmp-build-annotated-81 syntmp-s-708 (make-module-ref syntmp-mod-712
syntmp-id-711 #f)))) (if (memv syntmp-t-710 (quote (lexical-call)))
(syntmp-chi-application-142 (syntmp-build-annotated-81
(syntmp-source-annotation-95 (car syntmp-e-705)) syntmp-value-704) syntmp-e-705
syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710
(quote (global-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81
(syntmp-source-annotation-95 (car syntmp-e-705)) (make-module-ref (if
(syntmp-syntax-object?-88 (car syntmp-e-705)) (syntmp-syntax-object-module-91
(car syntmp-e-705)) syntmp-mod-709) syntmp-value-704 #f)) syntmp-e-705
syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710
(quote (constant))) (syntmp-build-data-82 syntmp-s-708 (syntmp-strip-151
(syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709)
(quote (())))) (if (memv syntmp-t-710 (quote (global)))
(syntmp-build-annotated-81 syntmp-s-708 (make-module-ref syntmp-mod-709
syntmp-value-704 #f)) (if (memv syntmp-t-710 (quote (call)))
(syntmp-chi-application-142 (syntmp-chi-140 (car syntmp-e-705) syntmp-r-706
syntmp-w-707 syntmp-mod-709) syntmp-e-705 syntmp-r-706 syntmp-w-707
syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (begin-form)))
((lambda (syntmp-tmp-713) ((lambda (syntmp-tmp-714) (if syntmp-tmp-714 (apply
(lambda (syntmp-_-715 syntmp-e1-716 syntmp-e2-717) (syntmp-chi-sequence-134
(cons syntmp-e1-716 syntmp-e2-717) syntmp-r-706 syntmp-w-707 syntmp-s-708
syntmp-mod-709)) syntmp-tmp-714) (syntax-error syntmp-tmp-713)))
(syntax-dispatch syntmp-tmp-713 (quote (any any . each-any))))) syntmp-e-705)
(if (memv syntmp-t-710 (quote (local-syntax-form)))
(syntmp-chi-local-syntax-146 syntmp-value-704 syntmp-e-705 syntmp-r-706
syntmp-w-707 syntmp-s-708 syntmp-mod-709 syntmp-chi-sequence-134) (if (memv
syntmp-t-710 (quote (eval-when-form))) ((lambda (syntmp-tmp-719) ((lambda
(syntmp-tmp-720) (if syntmp-tmp-720 (apply (lambda (syntmp-_-721 syntmp-x-722
syntmp-e1-723 syntmp-e2-724) (let ((syntmp-when-list-725
(syntmp-chi-when-list-137 syntmp-e-705 syntmp-x-722 syntmp-w-707))) (if (memq
(quote eval) syntmp-when-list-725) (syntmp-chi-sequence-134 (cons syntmp-e1-723
syntmp-e2-724) syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709)
(syntmp-chi-void-148)))) syntmp-tmp-720) (syntax-error syntmp-tmp-719)))
(syntax-dispatch syntmp-tmp-719 (quote (any each-any any . each-any)))))
syntmp-e-705) (if (memv syntmp-t-710 (quote (define-form define-syntax-form)))
(syntax-error (syntmp-wrap-132 syntmp-value-704 syntmp-w-707 syntmp-mod-709)
"invalid context for definition of") (if (memv syntmp-t-710 (quote (syntax)))
(syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708
syntmp-mod-709) "reference to pattern variable outside syntax form") (if (memv
syntmp-t-710 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133
syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) "reference to identifier
outside its scope") (syntax-error (syntmp-source-wrap-133 syntmp-e-705
syntmp-w-707 syntmp-s-708 syntmp-mod-709))))))))))))))))))) (syntmp-chi-140
(lambda (syntmp-e-728 syntmp-r-729 syntmp-w-730 syntmp-mod-731)
(call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-728 syntmp-r-729
syntmp-w-730 #f #f syntmp-mod-731)) (lambda (syntmp-type-732 syntmp-value-733
syntmp-e-734 syntmp-w-735 syntmp-s-736 syntmp-mod-737) (syntmp-chi-expr-141
syntmp-type-732 syntmp-value-733 syntmp-e-734 syntmp-r-729 syntmp-w-735
syntmp-s-736 syntmp-mod-737))))) (syntmp-chi-top-139 (lambda (syntmp-e-738
syntmp-r-739 syntmp-w-740 syntmp-m-741 syntmp-esew-742 syntmp-mod-743)
(call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-738 syntmp-r-739
syntmp-w-740 #f #f syntmp-mod-743)) (lambda (syntmp-type-758 syntmp-value-759
syntmp-e-760 syntmp-w-761 syntmp-s-762 syntmp-mod-763) (let ((syntmp-t-764
syntmp-type-758)) (if (memv syntmp-t-764 (quote (begin-form))) ((lambda
(syntmp-tmp-765) ((lambda (syntmp-tmp-766) (if syntmp-tmp-766 (apply (lambda
(syntmp-_-767) (syntmp-chi-void-148)) syntmp-tmp-766) ((lambda (syntmp-tmp-768)
(if syntmp-tmp-768 (apply (lambda (syntmp-_-769 syntmp-e1-770 syntmp-e2-771)
(syntmp-chi-top-sequence-135 (cons syntmp-e1-770 syntmp-e2-771) syntmp-r-739
syntmp-w-761 syntmp-s-762 syntmp-m-741 syntmp-esew-742 syntmp-mod-763))
syntmp-tmp-768) (syntax-error syntmp-tmp-765))) (syntax-dispatch syntmp-tmp-765
(quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-765 (quote
(any))))) syntmp-e-760) (if (memv syntmp-t-764 (quote (local-syntax-form)))
(syntmp-chi-local-syntax-146 syntmp-value-759 syntmp-e-760 syntmp-r-739
syntmp-w-761 syntmp-s-762 syntmp-mod-763 (lambda (syntmp-body-773 syntmp-r-774
syntmp-w-775 syntmp-s-776 syntmp-mod-777) (syntmp-chi-top-sequence-135
syntmp-body-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-m-741
syntmp-esew-742 syntmp-mod-777))) (if (memv syntmp-t-764 (quote
(eval-when-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if
syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-x-781 syntmp-e1-782
syntmp-e2-783) (let ((syntmp-when-list-784 (syntmp-chi-when-list-137
syntmp-e-760 syntmp-x-781 syntmp-w-761)) (syntmp-body-785 (cons syntmp-e1-782
syntmp-e2-783))) (cond ((eq? syntmp-m-741 (quote e)) (if (memq (quote eval)
syntmp-when-list-784) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739
syntmp-w-761 syntmp-s-762 (quote e) (quote (eval)) syntmp-mod-763)
(syntmp-chi-void-148))) ((memq (quote load) syntmp-when-list-784) (if (or (memq
(quote compile) syntmp-when-list-784) (and (eq? syntmp-m-741 (quote c&e)) (memq
(quote eval) syntmp-when-list-784))) (syntmp-chi-top-sequence-135
syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote c&e) (quote
(compile load)) syntmp-mod-763) (if (memq syntmp-m-741 (quote (c c&e)))
(syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761
syntmp-s-762 (quote c) (quote (load)) syntmp-mod-763) (syntmp-chi-void-148))))
((or (memq (quote compile) syntmp-when-list-784) (and (eq? syntmp-m-741 (quote
c&e)) (memq (quote eval) syntmp-when-list-784))) (syntmp-top-level-eval-hook-76
(syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761
syntmp-s-762 (quote e) (quote (eval)) syntmp-mod-763) syntmp-mod-763)
(syntmp-chi-void-148)) (else (syntmp-chi-void-148))))) syntmp-tmp-779)
(syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any
each-any any . each-any))))) syntmp-e-760) (if (memv syntmp-t-764 (quote
(define-syntax-form))) (let ((syntmp-n-788 (syntmp-id-var-name-126
syntmp-value-759 syntmp-w-761)) (syntmp-r-789 (syntmp-macros-only-env-100
syntmp-r-739))) (let ((syntmp-t-790 syntmp-m-741)) (if (memv syntmp-t-790
(quote (c))) (if (memq (quote compile) syntmp-esew-742) (let ((syntmp-e-791
(syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760
syntmp-r-789 syntmp-w-761 syntmp-mod-763)))) (begin
(syntmp-top-level-eval-hook-76 syntmp-e-791 syntmp-mod-763) (if (memq (quote
load) syntmp-esew-742) syntmp-e-791 (syntmp-chi-void-148)))) (if (memq (quote
load) syntmp-esew-742) (syntmp-chi-install-global-136 syntmp-n-788
(syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763))
(syntmp-chi-void-148))) (if (memv syntmp-t-790 (quote (c&e))) (let
((syntmp-e-792 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140
syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)))) (begin
(syntmp-top-level-eval-hook-76 syntmp-e-792 syntmp-mod-763) syntmp-e-792))
(begin (if (memq (quote eval) syntmp-esew-742) (syntmp-top-level-eval-hook-76
(syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760
syntmp-r-789 syntmp-w-761 syntmp-mod-763)) syntmp-mod-763))
(syntmp-chi-void-148)))))) (if (memv syntmp-t-764 (quote (define-form))) (let
((syntmp-n-793 (syntmp-id-var-name-126 syntmp-value-759 syntmp-w-761))) (let
((syntmp-type-794 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-793
syntmp-r-739 syntmp-mod-763)))) (let ((syntmp-t-795 syntmp-type-794)) (if (memv
syntmp-t-795 (quote (global))) (let ((syntmp-x-796 (syntmp-build-annotated-81
syntmp-s-762 (list (quote define) syntmp-n-793 (syntmp-chi-140 syntmp-e-760
syntmp-r-739 syntmp-w-761 syntmp-mod-763))))) (begin (if (eq? syntmp-m-741
(quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-796 syntmp-mod-763))
syntmp-x-796)) (if (memv syntmp-t-795 (quote (displaced-lexical)))
(syntax-error (syntmp-wrap-132 syntmp-value-759 syntmp-w-761 syntmp-mod-763)
"identifier out of context") (if (eq? syntmp-type-794 (quote external-macro))
(let ((syntmp-x-797 (syntmp-build-annotated-81 syntmp-s-762 (list (quote
define) syntmp-n-793 (syntmp-chi-140 syntmp-e-760 syntmp-r-739 syntmp-w-761
syntmp-mod-763))))) (begin (if (eq? syntmp-m-741 (quote c&e))
(syntmp-top-level-eval-hook-76 syntmp-x-797 syntmp-mod-763)) syntmp-x-797))
(syntax-error (syntmp-wrap-132 syntmp-value-759 syntmp-w-761 syntmp-mod-763)
"cannot define keyword at top level"))))))) (let ((syntmp-x-798
(syntmp-chi-expr-141 syntmp-type-758 syntmp-value-759 syntmp-e-760 syntmp-r-739
syntmp-w-761 syntmp-s-762 syntmp-mod-763))) (begin (if (eq? syntmp-m-741 (quote
c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-798 syntmp-mod-763))
syntmp-x-798)))))))))))) (syntmp-syntax-type-138 (lambda (syntmp-e-799
syntmp-r-800 syntmp-w-801 syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (cond
((symbol? syntmp-e-799) (let ((syntmp-n-805 (syntmp-id-var-name-126
syntmp-e-799 syntmp-w-801))) (let ((syntmp-b-806 (syntmp-lookup-101
syntmp-n-805 syntmp-r-800 syntmp-mod-804))) (let ((syntmp-type-807
(syntmp-binding-type-96 syntmp-b-806))) (let ((syntmp-t-808 syntmp-type-807))
(if (memv syntmp-t-808 (quote (lexical))) (values syntmp-type-807
(syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-w-801 syntmp-s-802
syntmp-mod-804) (if (memv syntmp-t-808 (quote (global))) (values
syntmp-type-807 syntmp-n-805 syntmp-e-799 syntmp-w-801 syntmp-s-802
syntmp-mod-804) (if (memv syntmp-t-808 (quote (macro))) (syntmp-syntax-type-138
(syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799
syntmp-r-800 syntmp-w-801 syntmp-rib-803 syntmp-mod-804) syntmp-r-800 (quote
(())) syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (values syntmp-type-807
(syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-w-801 syntmp-s-802
syntmp-mod-804))))))))) ((pair? syntmp-e-799) (let ((syntmp-first-809 (car
syntmp-e-799))) (if (syntmp-id?-104 syntmp-first-809) (let ((syntmp-n-810
(syntmp-id-var-name-126 syntmp-first-809 syntmp-w-801))) (let ((syntmp-b-811
(syntmp-lookup-101 syntmp-n-810 syntmp-r-800 (or (and (syntmp-syntax-object?-88
syntmp-first-809) (syntmp-syntax-object-module-91 syntmp-first-809))
syntmp-mod-804)))) (let ((syntmp-type-812 (syntmp-binding-type-96
syntmp-b-811))) (let ((syntmp-t-813 syntmp-type-812)) (if (memv syntmp-t-813
(quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-97
syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv
syntmp-t-813 (quote (global))) (values (quote global-call) syntmp-n-810
syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813
(quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143
(syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-r-800 syntmp-w-801
syntmp-rib-803 syntmp-mod-804) syntmp-r-800 (quote (())) syntmp-s-802
syntmp-rib-803 syntmp-mod-804) (if (memv syntmp-t-813 (quote (core
external-macro module-ref))) (values syntmp-type-812 (syntmp-binding-value-97
syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv
syntmp-t-813 (quote (local-syntax))) (values (quote local-syntax-form)
(syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802
syntmp-mod-804) (if (memv syntmp-t-813 (quote (begin))) (values (quote
begin-form) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv
syntmp-t-813 (quote (eval-when))) (values (quote eval-when-form) #f
syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813
(quote (define))) ((lambda (syntmp-tmp-814) ((lambda (syntmp-tmp-815) (if (if
syntmp-tmp-815 (apply (lambda (syntmp-_-816 syntmp-name-817 syntmp-val-818)
(syntmp-id?-104 syntmp-name-817)) syntmp-tmp-815) #f) (apply (lambda
(syntmp-_-819 syntmp-name-820 syntmp-val-821) (values (quote define-form)
syntmp-name-820 syntmp-val-821 syntmp-w-801 syntmp-s-802 syntmp-mod-804))
syntmp-tmp-815) ((lambda (syntmp-tmp-822) (if (if syntmp-tmp-822 (apply (lambda
(syntmp-_-823 syntmp-name-824 syntmp-args-825 syntmp-e1-826 syntmp-e2-827) (and
(syntmp-id?-104 syntmp-name-824) (syntmp-valid-bound-ids?-129
(syntmp-lambda-var-list-153 syntmp-args-825)))) syntmp-tmp-822) #f) (apply
(lambda (syntmp-_-828 syntmp-name-829 syntmp-args-830 syntmp-e1-831
syntmp-e2-832) (values (quote define-form) (syntmp-wrap-132 syntmp-name-829
syntmp-w-801 syntmp-mod-804) (cons (quote #(syntax-object lambda ((top)
#(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i"
"i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage ()
() ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list
gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer
chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr
chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence
chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids?
valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks
join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage
new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap
set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels
ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label
make-rename rename-marks rename-new rename-old subst-rename? wrap-subst
wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id?
global-extend lookup macros-only-env extend-var-env extend-env null-env
binding-value binding-type make-binding arg-check source-annotation no-source
unannotate set-syntax-object-module! set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-module syntax-object-wrap
syntax-object-expression syntax-object? make-syntax-object build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application build-annotated get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-132 (cons
syntmp-args-830 (cons syntmp-e1-831 syntmp-e2-832)) syntmp-w-801
syntmp-mod-804)) (quote (())) syntmp-s-802 syntmp-mod-804)) syntmp-tmp-822)
((lambda (syntmp-tmp-834) (if (if syntmp-tmp-834 (apply (lambda (syntmp-_-835
syntmp-name-836) (syntmp-id?-104 syntmp-name-836)) syntmp-tmp-834) #f) (apply
(lambda (syntmp-_-837 syntmp-name-838) (values (quote define-form)
(syntmp-wrap-132 syntmp-name-838 syntmp-w-801 syntmp-mod-804) (quote
(#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ())
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i"))
#(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list
gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer
chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr
chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence
chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids?
valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks
join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage
new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap
set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels
ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label
make-rename rename-marks rename-new rename-old subst-rename? wrap-subst
wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id?
global-extend lookup macros-only-env extend-var-env extend-env null-env
binding-value binding-type make-binding arg-check source-annotation no-source
unannotate set-syntax-object-module! set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-module syntax-object-wrap
syntax-object-expression syntax-object? make-syntax-object build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application build-annotated get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-802
syntmp-mod-804)) syntmp-tmp-834) (syntax-error syntmp-tmp-814)))
(syntax-dispatch syntmp-tmp-814 (quote (any any)))))) (syntax-dispatch
syntmp-tmp-814 (quote (any (any . any) any . each-any)))))) (syntax-dispatch
syntmp-tmp-814 (quote (any any any))))) syntmp-e-799) (if (memv syntmp-t-813
(quote (define-syntax))) ((lambda (syntmp-tmp-839) ((lambda (syntmp-tmp-840)
(if (if syntmp-tmp-840 (apply (lambda (syntmp-_-841 syntmp-name-842
syntmp-val-843) (syntmp-id?-104 syntmp-name-842)) syntmp-tmp-840) #f) (apply
(lambda (syntmp-_-844 syntmp-name-845 syntmp-val-846) (values (quote
define-syntax-form) syntmp-name-845 syntmp-val-846 syntmp-w-801 syntmp-s-802
syntmp-mod-804)) syntmp-tmp-840) (syntax-error syntmp-tmp-839)))
(syntax-dispatch syntmp-tmp-839 (quote (any any any))))) syntmp-e-799) (values
(quote call) #f syntmp-e-799 syntmp-w-801 syntmp-s-802
syntmp-mod-804)))))))))))))) (values (quote call) #f syntmp-e-799 syntmp-w-801
syntmp-s-802 syntmp-mod-804)))) ((syntmp-syntax-object?-88 syntmp-e-799)
(syntmp-syntax-type-138 (syntmp-syntax-object-expression-89 syntmp-e-799)
syntmp-r-800 (syntmp-join-wraps-123 syntmp-w-801 (syntmp-syntax-object-wrap-90
syntmp-e-799)) #f syntmp-rib-803 (or (syntmp-syntax-object-module-91
syntmp-e-799) syntmp-mod-804))) ((annotation? syntmp-e-799)
(syntmp-syntax-type-138 (annotation-expression syntmp-e-799) syntmp-r-800
syntmp-w-801 (annotation-source syntmp-e-799) syntmp-rib-803 syntmp-mod-804))
((self-evaluating? syntmp-e-799) (values (quote constant) #f syntmp-e-799
syntmp-w-801 syntmp-s-802 syntmp-mod-804)) (else (values (quote other) #f
syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)))))
(syntmp-chi-when-list-137 (lambda (syntmp-e-847 syntmp-when-list-848
syntmp-w-849) (let syntmp-f-850 ((syntmp-when-list-851 syntmp-when-list-848)
(syntmp-situations-852 (quote ()))) (if (null? syntmp-when-list-851)
syntmp-situations-852 (syntmp-f-850 (cdr syntmp-when-list-851) (cons (let
((syntmp-x-853 (car syntmp-when-list-851))) (cond ((syntmp-free-id=?-127
syntmp-x-853 (quote #(syntax-object compile ((top) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list
situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage
#(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"))
#(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote
compile)) ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object load
((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis?
chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body
chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"))
#(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load))
((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object eval ((top)
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis?
chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body
chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"))
#(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval))
(else (syntax-error (syntmp-wrap-132 syntmp-x-853 syntmp-w-849 #f) "invalid
eval-when situation")))) syntmp-situations-852))))))
(syntmp-chi-install-global-136 (lambda (syntmp-name-854 syntmp-e-855)
(syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote
install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-854)
syntmp-e-855)))) (syntmp-chi-top-sequence-135 (lambda (syntmp-body-856
syntmp-r-857 syntmp-w-858 syntmp-s-859 syntmp-m-860 syntmp-esew-861
syntmp-mod-862) (syntmp-build-sequence-83 syntmp-s-859 (let syntmp-dobody-863
((syntmp-body-864 syntmp-body-856) (syntmp-r-865 syntmp-r-857) (syntmp-w-866
syntmp-w-858) (syntmp-m-867 syntmp-m-860) (syntmp-esew-868 syntmp-esew-861)
(syntmp-mod-869 syntmp-mod-862)) (if (null? syntmp-body-864) (quote ()) (let
((syntmp-first-870 (syntmp-chi-top-139 (car syntmp-body-864) syntmp-r-865
syntmp-w-866 syntmp-m-867 syntmp-esew-868 syntmp-mod-869))) (cons
syntmp-first-870 (syntmp-dobody-863 (cdr syntmp-body-864) syntmp-r-865
syntmp-w-866 syntmp-m-867 syntmp-esew-868 syntmp-mod-869))))))))
(syntmp-chi-sequence-134 (lambda (syntmp-body-871 syntmp-r-872 syntmp-w-873
syntmp-s-874 syntmp-mod-875) (syntmp-build-sequence-83 syntmp-s-874 (let
syntmp-dobody-876 ((syntmp-body-877 syntmp-body-871) (syntmp-r-878
syntmp-r-872) (syntmp-w-879 syntmp-w-873) (syntmp-mod-880 syntmp-mod-875)) (if
(null? syntmp-body-877) (quote ()) (let ((syntmp-first-881 (syntmp-chi-140 (car
syntmp-body-877) syntmp-r-878 syntmp-w-879 syntmp-mod-880))) (cons
syntmp-first-881 (syntmp-dobody-876 (cdr syntmp-body-877) syntmp-r-878
syntmp-w-879 syntmp-mod-880)))))))) (syntmp-source-wrap-133 (lambda
(syntmp-x-882 syntmp-w-883 syntmp-s-884 syntmp-defmod-885) (syntmp-wrap-132 (if
syntmp-s-884 (make-annotation syntmp-x-882 syntmp-s-884 #f) syntmp-x-882)
syntmp-w-883 syntmp-defmod-885))) (syntmp-wrap-132 (lambda (syntmp-x-886
syntmp-w-887 syntmp-defmod-888) (cond ((and (null? (syntmp-wrap-marks-107
syntmp-w-887)) (null? (syntmp-wrap-subst-108 syntmp-w-887))) syntmp-x-886)
((syntmp-syntax-object?-88 syntmp-x-886) (syntmp-make-syntax-object-87
(syntmp-syntax-object-expression-89 syntmp-x-886) (syntmp-join-wraps-123
syntmp-w-887 (syntmp-syntax-object-wrap-90 syntmp-x-886))
(syntmp-syntax-object-module-91 syntmp-x-886))) ((null? syntmp-x-886)
syntmp-x-886) (else (syntmp-make-syntax-object-87 syntmp-x-886 syntmp-w-887
syntmp-defmod-888))))) (syntmp-bound-id-member?-131 (lambda (syntmp-x-889
syntmp-list-890) (and (not (null? syntmp-list-890)) (or (syntmp-bound-id=?-128
syntmp-x-889 (car syntmp-list-890)) (syntmp-bound-id-member?-131 syntmp-x-889
(cdr syntmp-list-890)))))) (syntmp-distinct-bound-ids?-130 (lambda
(syntmp-ids-891) (let syntmp-distinct?-892 ((syntmp-ids-893 syntmp-ids-891))
(or (null? syntmp-ids-893) (and (not (syntmp-bound-id-member?-131 (car
syntmp-ids-893) (cdr syntmp-ids-893))) (syntmp-distinct?-892 (cdr
syntmp-ids-893))))))) (syntmp-valid-bound-ids?-129 (lambda (syntmp-ids-894)
(and (let syntmp-all-ids?-895 ((syntmp-ids-896 syntmp-ids-894)) (or (null?
syntmp-ids-896) (and (syntmp-id?-104 (car syntmp-ids-896)) (syntmp-all-ids?-895
(cdr syntmp-ids-896))))) (syntmp-distinct-bound-ids?-130 syntmp-ids-894))))
(syntmp-bound-id=?-128 (lambda (syntmp-i-897 syntmp-j-898) (if (and
(syntmp-syntax-object?-88 syntmp-i-897) (syntmp-syntax-object?-88
syntmp-j-898)) (and (eq? (let ((syntmp-e-899
(syntmp-syntax-object-expression-89 syntmp-i-897))) (if (annotation?
syntmp-e-899) (annotation-expression syntmp-e-899) syntmp-e-899)) (let
((syntmp-e-900 (syntmp-syntax-object-expression-89 syntmp-j-898))) (if
(annotation? syntmp-e-900) (annotation-expression syntmp-e-900) syntmp-e-900)))
(syntmp-same-marks?-125 (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90
syntmp-i-897)) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90
syntmp-j-898)))) (eq? (let ((syntmp-e-901 syntmp-i-897)) (if (annotation?
syntmp-e-901) (annotation-expression syntmp-e-901) syntmp-e-901)) (let
((syntmp-e-902 syntmp-j-898)) (if (annotation? syntmp-e-902)
(annotation-expression syntmp-e-902) syntmp-e-902)))))) (syntmp-free-id=?-127
(lambda (syntmp-i-903 syntmp-j-904) (and (eq? (let ((syntmp-x-905
syntmp-i-903)) (let ((syntmp-e-906 (if (syntmp-syntax-object?-88 syntmp-x-905)
(syntmp-syntax-object-expression-89 syntmp-x-905) syntmp-x-905))) (if
(annotation? syntmp-e-906) (annotation-expression syntmp-e-906) syntmp-e-906)))
(let ((syntmp-x-907 syntmp-j-904)) (let ((syntmp-e-908 (if
(syntmp-syntax-object?-88 syntmp-x-907) (syntmp-syntax-object-expression-89
syntmp-x-907) syntmp-x-907))) (if (annotation? syntmp-e-908)
(annotation-expression syntmp-e-908) syntmp-e-908)))) (eq?
(syntmp-id-var-name-126 syntmp-i-903 (quote (()))) (syntmp-id-var-name-126
syntmp-j-904 (quote (()))))))) (syntmp-id-var-name-126 (lambda (syntmp-id-909
syntmp-w-910) (letrec ((syntmp-search-vector-rib-913 (lambda (syntmp-sym-924
syntmp-subst-925 syntmp-marks-926 syntmp-symnames-927 syntmp-ribcage-928) (let
((syntmp-n-929 (vector-length syntmp-symnames-927))) (let syntmp-f-930
((syntmp-i-931 0)) (cond ((syntmp-fx=-74 syntmp-i-931 syntmp-n-929)
(syntmp-search-911 syntmp-sym-924 (cdr syntmp-subst-925) syntmp-marks-926))
((and (eq? (vector-ref syntmp-symnames-927 syntmp-i-931) syntmp-sym-924)
(syntmp-same-marks?-125 syntmp-marks-926 (vector-ref (syntmp-ribcage-marks-114
syntmp-ribcage-928) syntmp-i-931))) (values (vector-ref
(syntmp-ribcage-labels-115 syntmp-ribcage-928) syntmp-i-931) syntmp-marks-926))
(else (syntmp-f-930 (syntmp-fx+-72 syntmp-i-931 1))))))))
(syntmp-search-list-rib-912 (lambda (syntmp-sym-932 syntmp-subst-933
syntmp-marks-934 syntmp-symnames-935 syntmp-ribcage-936) (let syntmp-f-937
((syntmp-symnames-938 syntmp-symnames-935) (syntmp-i-939 0)) (cond ((null?
syntmp-symnames-938) (syntmp-search-911 syntmp-sym-932 (cdr syntmp-subst-933)
syntmp-marks-934)) ((and (eq? (car syntmp-symnames-938) syntmp-sym-932)
(syntmp-same-marks?-125 syntmp-marks-934 (list-ref (syntmp-ribcage-marks-114
syntmp-ribcage-936) syntmp-i-939))) (values (list-ref
(syntmp-ribcage-labels-115 syntmp-ribcage-936) syntmp-i-939) syntmp-marks-934))
(else (syntmp-f-937 (cdr syntmp-symnames-938) (syntmp-fx+-72 syntmp-i-939
1))))))) (syntmp-search-911 (lambda (syntmp-sym-940 syntmp-subst-941
syntmp-marks-942) (if (null? syntmp-subst-941) (values #f syntmp-marks-942)
(let ((syntmp-fst-943 (car syntmp-subst-941))) (if (eq? syntmp-fst-943 (quote
shift)) (syntmp-search-911 syntmp-sym-940 (cdr syntmp-subst-941) (cdr
syntmp-marks-942)) (let ((syntmp-symnames-944 (syntmp-ribcage-symnames-113
syntmp-fst-943))) (if (vector? syntmp-symnames-944)
(syntmp-search-vector-rib-913 syntmp-sym-940 syntmp-subst-941 syntmp-marks-942
syntmp-symnames-944 syntmp-fst-943) (syntmp-search-list-rib-912 syntmp-sym-940
syntmp-subst-941 syntmp-marks-942 syntmp-symnames-944 syntmp-fst-943)))))))))
(cond ((symbol? syntmp-id-909) (or (call-with-values (lambda ()
(syntmp-search-911 syntmp-id-909 (syntmp-wrap-subst-108 syntmp-w-910)
(syntmp-wrap-marks-107 syntmp-w-910))) (lambda (syntmp-x-946 .
syntmp-ignore-945) syntmp-x-946)) syntmp-id-909)) ((syntmp-syntax-object?-88
syntmp-id-909) (let ((syntmp-id-947 (let ((syntmp-e-949
(syntmp-syntax-object-expression-89 syntmp-id-909))) (if (annotation?
syntmp-e-949) (annotation-expression syntmp-e-949) syntmp-e-949)))
(syntmp-w1-948 (syntmp-syntax-object-wrap-90 syntmp-id-909))) (let
((syntmp-marks-950 (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-910)
(syntmp-wrap-marks-107 syntmp-w1-948)))) (call-with-values (lambda ()
(syntmp-search-911 syntmp-id-947 (syntmp-wrap-subst-108 syntmp-w-910)
syntmp-marks-950)) (lambda (syntmp-new-id-951 syntmp-marks-952) (or
syntmp-new-id-951 (call-with-values (lambda () (syntmp-search-911 syntmp-id-947
(syntmp-wrap-subst-108 syntmp-w1-948) syntmp-marks-952)) (lambda (syntmp-x-954
. syntmp-ignore-953) syntmp-x-954)) syntmp-id-947)))))) ((annotation?
syntmp-id-909) (let ((syntmp-id-955 (let ((syntmp-e-956 syntmp-id-909)) (if
(annotation? syntmp-e-956) (annotation-expression syntmp-e-956)
syntmp-e-956)))) (or (call-with-values (lambda () (syntmp-search-911
syntmp-id-955 (syntmp-wrap-subst-108 syntmp-w-910) (syntmp-wrap-marks-107
syntmp-w-910))) (lambda (syntmp-x-958 . syntmp-ignore-957) syntmp-x-958))
syntmp-id-955))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id"
syntmp-id-909)))))) (syntmp-same-marks?-125 (lambda (syntmp-x-959 syntmp-y-960)
(or (eq? syntmp-x-959 syntmp-y-960) (and (not (null? syntmp-x-959)) (not (null?
syntmp-y-960)) (eq? (car syntmp-x-959) (car syntmp-y-960))
(syntmp-same-marks?-125 (cdr syntmp-x-959) (cdr syntmp-y-960))))))
(syntmp-join-marks-124 (lambda (syntmp-m1-961 syntmp-m2-962)
(syntmp-smart-append-122 syntmp-m1-961 syntmp-m2-962))) (syntmp-join-wraps-123
(lambda (syntmp-w1-963 syntmp-w2-964) (let ((syntmp-m1-965
(syntmp-wrap-marks-107 syntmp-w1-963)) (syntmp-s1-966 (syntmp-wrap-subst-108
syntmp-w1-963))) (if (null? syntmp-m1-965) (if (null? syntmp-s1-966)
syntmp-w2-964 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w2-964)
(syntmp-smart-append-122 syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w2-964))))
(syntmp-make-wrap-106 (syntmp-smart-append-122 syntmp-m1-965
(syntmp-wrap-marks-107 syntmp-w2-964)) (syntmp-smart-append-122 syntmp-s1-966
(syntmp-wrap-subst-108 syntmp-w2-964))))))) (syntmp-smart-append-122 (lambda
(syntmp-m1-967 syntmp-m2-968) (if (null? syntmp-m2-968) syntmp-m1-967 (append
syntmp-m1-967 syntmp-m2-968)))) (syntmp-make-binding-wrap-121 (lambda
(syntmp-ids-969 syntmp-labels-970 syntmp-w-971) (if (null? syntmp-ids-969)
syntmp-w-971 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-971) (cons
(let ((syntmp-labelvec-972 (list->vector syntmp-labels-970))) (let
((syntmp-n-973 (vector-length syntmp-labelvec-972))) (let
((syntmp-symnamevec-974 (make-vector syntmp-n-973)) (syntmp-marksvec-975
(make-vector syntmp-n-973))) (begin (let syntmp-f-976 ((syntmp-ids-977
syntmp-ids-969) (syntmp-i-978 0)) (if (not (null? syntmp-ids-977))
(call-with-values (lambda () (syntmp-id-sym-name&marks-105 (car syntmp-ids-977)
syntmp-w-971)) (lambda (syntmp-symname-979 syntmp-marks-980) (begin
(vector-set! syntmp-symnamevec-974 syntmp-i-978 syntmp-symname-979)
(vector-set! syntmp-marksvec-975 syntmp-i-978 syntmp-marks-980) (syntmp-f-976
(cdr syntmp-ids-977) (syntmp-fx+-72 syntmp-i-978 1)))))))
(syntmp-make-ribcage-111 syntmp-symnamevec-974 syntmp-marksvec-975
syntmp-labelvec-972))))) (syntmp-wrap-subst-108 syntmp-w-971))))))
(syntmp-extend-ribcage!-120 (lambda (syntmp-ribcage-981 syntmp-id-982
syntmp-label-983) (begin (syntmp-set-ribcage-symnames!-116 syntmp-ribcage-981
(cons (let ((syntmp-e-984 (syntmp-syntax-object-expression-89 syntmp-id-982)))
(if (annotation? syntmp-e-984) (annotation-expression syntmp-e-984)
syntmp-e-984)) (syntmp-ribcage-symnames-113 syntmp-ribcage-981)))
(syntmp-set-ribcage-marks!-117 syntmp-ribcage-981 (cons (syntmp-wrap-marks-107
(syntmp-syntax-object-wrap-90 syntmp-id-982)) (syntmp-ribcage-marks-114
syntmp-ribcage-981))) (syntmp-set-ribcage-labels!-118 syntmp-ribcage-981 (cons
syntmp-label-983 (syntmp-ribcage-labels-115 syntmp-ribcage-981))))))
(syntmp-anti-mark-119 (lambda (syntmp-w-985) (syntmp-make-wrap-106 (cons #f
(syntmp-wrap-marks-107 syntmp-w-985)) (cons (quote shift)
(syntmp-wrap-subst-108 syntmp-w-985))))) (syntmp-set-ribcage-labels!-118
(lambda (syntmp-x-986 syntmp-update-987) (vector-set! syntmp-x-986 3
syntmp-update-987))) (syntmp-set-ribcage-marks!-117 (lambda (syntmp-x-988
syntmp-update-989) (vector-set! syntmp-x-988 2 syntmp-update-989)))
(syntmp-set-ribcage-symnames!-116 (lambda (syntmp-x-990 syntmp-update-991)
(vector-set! syntmp-x-990 1 syntmp-update-991))) (syntmp-ribcage-labels-115
(lambda (syntmp-x-992) (vector-ref syntmp-x-992 3))) (syntmp-ribcage-marks-114
(lambda (syntmp-x-993) (vector-ref syntmp-x-993 2)))
(syntmp-ribcage-symnames-113 (lambda (syntmp-x-994) (vector-ref syntmp-x-994
1))) (syntmp-ribcage?-112 (lambda (syntmp-x-995) (and (vector? syntmp-x-995) (=
(vector-length syntmp-x-995) 4) (eq? (vector-ref syntmp-x-995 0) (quote
ribcage))))) (syntmp-make-ribcage-111 (lambda (syntmp-symnames-996
syntmp-marks-997 syntmp-labels-998) (vector (quote ribcage) syntmp-symnames-996
syntmp-marks-997 syntmp-labels-998))) (syntmp-gen-labels-110 (lambda
(syntmp-ls-999) (if (null? syntmp-ls-999) (quote ()) (cons
(syntmp-gen-label-109) (syntmp-gen-labels-110 (cdr syntmp-ls-999))))))
(syntmp-gen-label-109 (lambda () (string #\i))) (syntmp-wrap-subst-108 cdr)
(syntmp-wrap-marks-107 car) (syntmp-make-wrap-106 cons)
(syntmp-id-sym-name&marks-105 (lambda (syntmp-x-1000 syntmp-w-1001) (if
(syntmp-syntax-object?-88 syntmp-x-1000) (values (let ((syntmp-e-1002
(syntmp-syntax-object-expression-89 syntmp-x-1000))) (if (annotation?
syntmp-e-1002) (annotation-expression syntmp-e-1002) syntmp-e-1002))
(syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-1001)
(syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-x-1000)))) (values
(let ((syntmp-e-1003 syntmp-x-1000)) (if (annotation? syntmp-e-1003)
(annotation-expression syntmp-e-1003) syntmp-e-1003)) (syntmp-wrap-marks-107
syntmp-w-1001))))) (syntmp-id?-104 (lambda (syntmp-x-1004) (cond ((symbol?
syntmp-x-1004) #t) ((syntmp-syntax-object?-88 syntmp-x-1004) (symbol? (let
((syntmp-e-1005 (syntmp-syntax-object-expression-89 syntmp-x-1004))) (if
(annotation? syntmp-e-1005) (annotation-expression syntmp-e-1005)
syntmp-e-1005)))) ((annotation? syntmp-x-1004) (symbol? (annotation-expression
syntmp-x-1004))) (else #f)))) (syntmp-nonsymbol-id?-103 (lambda (syntmp-x-1006)
(and (syntmp-syntax-object?-88 syntmp-x-1006) (symbol? (let ((syntmp-e-1007
(syntmp-syntax-object-expression-89 syntmp-x-1006))) (if (annotation?
syntmp-e-1007) (annotation-expression syntmp-e-1007) syntmp-e-1007))))))
(syntmp-global-extend-102 (lambda (syntmp-type-1008 syntmp-sym-1009
syntmp-val-1010) (syntmp-put-global-definition-hook-79 syntmp-sym-1009 (cons
syntmp-type-1008 syntmp-val-1010) (module-name (current-module)))))
(syntmp-lookup-101 (lambda (syntmp-x-1011 syntmp-r-1012 syntmp-mod-1013) (cond
((assq syntmp-x-1011 syntmp-r-1012) => cdr) ((symbol? syntmp-x-1011) (or
(syntmp-get-global-definition-hook-80 syntmp-x-1011 syntmp-mod-1013) (quote
(global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-100
(lambda (syntmp-r-1014) (if (null? syntmp-r-1014) (quote ()) (let
((syntmp-a-1015 (car syntmp-r-1014))) (if (eq? (cadr syntmp-a-1015) (quote
macro)) (cons syntmp-a-1015 (syntmp-macros-only-env-100 (cdr syntmp-r-1014)))
(syntmp-macros-only-env-100 (cdr syntmp-r-1014))))))) (syntmp-extend-var-env-99
(lambda (syntmp-labels-1016 syntmp-vars-1017 syntmp-r-1018) (if (null?
syntmp-labels-1016) syntmp-r-1018 (syntmp-extend-var-env-99 (cdr
syntmp-labels-1016) (cdr syntmp-vars-1017) (cons (cons (car syntmp-labels-1016)
(cons (quote lexical) (car syntmp-vars-1017))) syntmp-r-1018)))))
(syntmp-extend-env-98 (lambda (syntmp-labels-1019 syntmp-bindings-1020
syntmp-r-1021) (if (null? syntmp-labels-1019) syntmp-r-1021
(syntmp-extend-env-98 (cdr syntmp-labels-1019) (cdr syntmp-bindings-1020) (cons
(cons (car syntmp-labels-1019) (car syntmp-bindings-1020)) syntmp-r-1021)))))
(syntmp-binding-value-97 cdr) (syntmp-binding-type-96 car)
(syntmp-source-annotation-95 (lambda (syntmp-x-1022) (cond ((annotation?
syntmp-x-1022) (annotation-source syntmp-x-1022)) ((syntmp-syntax-object?-88
syntmp-x-1022) (syntmp-source-annotation-95 (syntmp-syntax-object-expression-89
syntmp-x-1022))) (else #f)))) (syntmp-set-syntax-object-module!-94 (lambda
(syntmp-x-1023 syntmp-update-1024) (vector-set! syntmp-x-1023 3
syntmp-update-1024))) (syntmp-set-syntax-object-wrap!-93 (lambda (syntmp-x-1025
syntmp-update-1026) (vector-set! syntmp-x-1025 2 syntmp-update-1026)))
(syntmp-set-syntax-object-expression!-92 (lambda (syntmp-x-1027
syntmp-update-1028) (vector-set! syntmp-x-1027 1 syntmp-update-1028)))
(syntmp-syntax-object-module-91 (lambda (syntmp-x-1029) (vector-ref
syntmp-x-1029 3))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-1030)
(vector-ref syntmp-x-1030 2))) (syntmp-syntax-object-expression-89 (lambda
(syntmp-x-1031) (vector-ref syntmp-x-1031 1))) (syntmp-syntax-object?-88
(lambda (syntmp-x-1032) (and (vector? syntmp-x-1032) (= (vector-length
syntmp-x-1032) 4) (eq? (vector-ref syntmp-x-1032 0) (quote syntax-object)))))
(syntmp-make-syntax-object-87 (lambda (syntmp-expression-1033 syntmp-wrap-1034
syntmp-module-1035) (vector (quote syntax-object) syntmp-expression-1033
syntmp-wrap-1034 syntmp-module-1035))) (syntmp-build-letrec-86 (lambda
(syntmp-src-1036 syntmp-vars-1037 syntmp-val-exps-1038 syntmp-body-exp-1039)
(if (null? syntmp-vars-1037) (syntmp-build-annotated-81 syntmp-src-1036
syntmp-body-exp-1039) (syntmp-build-annotated-81 syntmp-src-1036 (list (quote
letrec) (map list syntmp-vars-1037 syntmp-val-exps-1038)
syntmp-body-exp-1039))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1040
syntmp-vars-1041 syntmp-val-exps-1042 syntmp-body-exp-1043) (if (null?
syntmp-vars-1041) (syntmp-build-annotated-81 syntmp-src-1040
syntmp-body-exp-1043) (syntmp-build-annotated-81 syntmp-src-1040 (list (quote
let) (car syntmp-vars-1041) (map list (cdr syntmp-vars-1041)
syntmp-val-exps-1042) syntmp-body-exp-1043))))) (syntmp-build-let-84 (lambda
(syntmp-src-1044 syntmp-vars-1045 syntmp-val-exps-1046 syntmp-body-exp-1047)
(if (null? syntmp-vars-1045) (syntmp-build-annotated-81 syntmp-src-1044
syntmp-body-exp-1047) (syntmp-build-annotated-81 syntmp-src-1044 (list (quote
let) (map list syntmp-vars-1045 syntmp-val-exps-1046) syntmp-body-exp-1047)))))
(syntmp-build-sequence-83 (lambda (syntmp-src-1048 syntmp-exps-1049) (if (null?
(cdr syntmp-exps-1049)) (syntmp-build-annotated-81 syntmp-src-1048 (car
syntmp-exps-1049)) (syntmp-build-annotated-81 syntmp-src-1048 (cons (quote
begin) syntmp-exps-1049))))) (syntmp-build-data-82 (lambda (syntmp-src-1050
syntmp-exp-1051) (if (and (self-evaluating? syntmp-exp-1051) (not (vector?
syntmp-exp-1051))) (syntmp-build-annotated-81 syntmp-src-1050 syntmp-exp-1051)
(syntmp-build-annotated-81 syntmp-src-1050 (list (quote quote)
syntmp-exp-1051))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1052
syntmp-exp-1053) (if (and syntmp-src-1052 (not (annotation? syntmp-exp-1053)))
(make-annotation syntmp-exp-1053 syntmp-src-1052 #t) syntmp-exp-1053)))
(syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1054
syntmp-module-1055) (let ((syntmp-module-1056 (if syntmp-module-1055
(resolve-module syntmp-module-1055) (warn "wha" syntmp-symbol-1054
(current-module))))) (let ((syntmp-v-1057 (module-variable syntmp-module-1056
syntmp-symbol-1054))) (and syntmp-v-1057 (or (object-property syntmp-v-1057
(quote *sc-expander*)) (and (variable-bound? syntmp-v-1057) (macro?
(variable-ref syntmp-v-1057)) (macro-transformer (variable-ref syntmp-v-1057))
guile-macro))))))) (syntmp-put-global-definition-hook-79 (lambda
(syntmp-symbol-1058 syntmp-binding-1059 syntmp-module-1060) (let
((syntmp-module-1061 (if syntmp-module-1060 (resolve-module syntmp-module-1060)
(warn "wha" syntmp-symbol-1058 (current-module))))) (let ((syntmp-v-1062 (or
(module-variable syntmp-module-1061 syntmp-symbol-1058) (let ((syntmp-v-1063
(make-variable sc-macro))) (begin (module-add! syntmp-module-1061
syntmp-symbol-1058 syntmp-v-1063) syntmp-v-1063))))) (begin (if (not (and
(symbol-property syntmp-symbol-1058 (quote primitive-syntax)) (eq?
syntmp-module-1061 the-syncase-module))) (variable-set! syntmp-v-1062
sc-macro)) (set-object-property! syntmp-v-1062 (quote *sc-expander*)
syntmp-binding-1059)))))) (syntmp-error-hook-78 (lambda (syntmp-who-1064
syntmp-why-1065 syntmp-what-1066) (error syntmp-who-1064 "~a ~s"
syntmp-why-1065 syntmp-what-1066))) (syntmp-local-eval-hook-77 (lambda
(syntmp-x-1067 syntmp-mod-1068) (eval (list syntmp-noexpand-71 syntmp-x-1067)
(if syntmp-mod-1068 (resolve-module syntmp-mod-1068)
(interaction-environment))))) (syntmp-top-level-eval-hook-76 (lambda
(syntmp-x-1069 syntmp-mod-1070) (eval (list syntmp-noexpand-71 syntmp-x-1069)
(if syntmp-mod-1070 (resolve-module syntmp-mod-1070)
(interaction-environment))))) (syntmp-fx<-75 <) (syntmp-fx=-74 =)
(syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin
(syntmp-global-extend-102 (quote local-syntax) (quote letrec-syntax) #t)
(syntmp-global-extend-102 (quote local-syntax) (quote let-syntax) #f)
(syntmp-global-extend-102 (quote core) (quote fluid-let-syntax) (lambda
(syntmp-e-1071 syntmp-r-1072 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075)
((lambda (syntmp-tmp-1076) ((lambda (syntmp-tmp-1077) (if (if syntmp-tmp-1077
(apply (lambda (syntmp-_-1078 syntmp-var-1079 syntmp-val-1080 syntmp-e1-1081
syntmp-e2-1082) (syntmp-valid-bound-ids?-129 syntmp-var-1079)) syntmp-tmp-1077)
#f) (apply (lambda (syntmp-_-1084 syntmp-var-1085 syntmp-val-1086
syntmp-e1-1087 syntmp-e2-1088) (let ((syntmp-names-1089 (map (lambda
(syntmp-x-1090) (syntmp-id-var-name-126 syntmp-x-1090 syntmp-w-1073))
syntmp-var-1085))) (begin (for-each (lambda (syntmp-id-1092 syntmp-n-1093) (let
((syntmp-t-1094 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-1093
syntmp-r-1072 syntmp-mod-1075)))) (if (memv syntmp-t-1094 (quote
(displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-id-1092
syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) "identifier out of context"))))
syntmp-var-1085 syntmp-names-1089) (syntmp-chi-body-144 (cons syntmp-e1-1087
syntmp-e2-1088) (syntmp-source-wrap-133 syntmp-e-1071 syntmp-w-1073
syntmp-s-1074 syntmp-mod-1075) (syntmp-extend-env-98 syntmp-names-1089 (let
((syntmp-trans-r-1097 (syntmp-macros-only-env-100 syntmp-r-1072))) (map (lambda
(syntmp-x-1098) (cons (quote macro) (syntmp-eval-local-transformer-147
(syntmp-chi-140 syntmp-x-1098 syntmp-trans-r-1097 syntmp-w-1073
syntmp-mod-1075) syntmp-mod-1075))) syntmp-val-1086)) syntmp-r-1072)
syntmp-w-1073 syntmp-mod-1075)))) syntmp-tmp-1077) ((lambda (syntmp-_-1100)
(syntax-error (syntmp-source-wrap-133 syntmp-e-1071 syntmp-w-1073 syntmp-s-1074
syntmp-mod-1075))) syntmp-tmp-1076))) (syntax-dispatch syntmp-tmp-1076 (quote
(any #(each (any any)) any . each-any))))) syntmp-e-1071)))
(syntmp-global-extend-102 (quote core) (quote quote) (lambda (syntmp-e-1101
syntmp-r-1102 syntmp-w-1103 syntmp-s-1104 syntmp-mod-1105) ((lambda
(syntmp-tmp-1106) ((lambda (syntmp-tmp-1107) (if syntmp-tmp-1107 (apply (lambda
(syntmp-_-1108 syntmp-e-1109) (syntmp-build-data-82 syntmp-s-1104
(syntmp-strip-151 syntmp-e-1109 syntmp-w-1103))) syntmp-tmp-1107) ((lambda
(syntmp-_-1110) (syntax-error (syntmp-source-wrap-133 syntmp-e-1101
syntmp-w-1103 syntmp-s-1104 syntmp-mod-1105))) syntmp-tmp-1106)))
(syntax-dispatch syntmp-tmp-1106 (quote (any any))))) syntmp-e-1101)))
(syntmp-global-extend-102 (quote core) (quote syntax) (letrec
((syntmp-regen-1118 (lambda (syntmp-x-1119) (let ((syntmp-t-1120 (car
syntmp-x-1119))) (if (memv syntmp-t-1120 (quote (ref)))
(syntmp-build-annotated-81 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120
(quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1119)) (if
(memv syntmp-t-1120 (quote (quote))) (syntmp-build-data-82 #f (cadr
syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (lambda)))
(syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1119)
(syntmp-regen-1118 (caddr syntmp-x-1119)))) (if (memv syntmp-t-1120 (quote
(map))) (let ((syntmp-ls-1121 (map syntmp-regen-1118 (cdr syntmp-x-1119))))
(syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1121)
2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f
(quote map))) syntmp-ls-1121))) (syntmp-build-annotated-81 #f (cons
(syntmp-build-annotated-81 #f (car syntmp-x-1119)) (map syntmp-regen-1118 (cdr
syntmp-x-1119)))))))))))) (syntmp-gen-vector-1117 (lambda (syntmp-x-1122) (cond
((eq? (car syntmp-x-1122) (quote list)) (cons (quote vector) (cdr
syntmp-x-1122))) ((eq? (car syntmp-x-1122) (quote quote)) (list (quote quote)
(list->vector (cadr syntmp-x-1122)))) (else (list (quote list->vector)
syntmp-x-1122))))) (syntmp-gen-append-1116 (lambda (syntmp-x-1123
syntmp-y-1124) (if (equal? syntmp-y-1124 (quote (quote ()))) syntmp-x-1123
(list (quote append) syntmp-x-1123 syntmp-y-1124)))) (syntmp-gen-cons-1115
(lambda (syntmp-x-1125 syntmp-y-1126) (let ((syntmp-t-1127 (car
syntmp-y-1126))) (if (memv syntmp-t-1127 (quote (quote))) (if (eq? (car
syntmp-x-1125) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1125)
(cadr syntmp-y-1126))) (if (eq? (cadr syntmp-y-1126) (quote ())) (list (quote
list) syntmp-x-1125) (list (quote cons) syntmp-x-1125 syntmp-y-1126))) (if
(memv syntmp-t-1127 (quote (list))) (cons (quote list) (cons syntmp-x-1125 (cdr
syntmp-y-1126))) (list (quote cons) syntmp-x-1125 syntmp-y-1126))))))
(syntmp-gen-map-1114 (lambda (syntmp-e-1128 syntmp-map-env-1129) (let
((syntmp-formals-1130 (map cdr syntmp-map-env-1129)) (syntmp-actuals-1131 (map
(lambda (syntmp-x-1132) (list (quote ref) (car syntmp-x-1132)))
syntmp-map-env-1129))) (cond ((eq? (car syntmp-e-1128) (quote ref)) (car
syntmp-actuals-1131)) ((andmap (lambda (syntmp-x-1133) (and (eq? (car
syntmp-x-1133) (quote ref)) (memq (cadr syntmp-x-1133) syntmp-formals-1130)))
(cdr syntmp-e-1128)) (cons (quote map) (cons (list (quote primitive) (car
syntmp-e-1128)) (map (let ((syntmp-r-1134 (map cons syntmp-formals-1130
syntmp-actuals-1131))) (lambda (syntmp-x-1135) (cdr (assq (cadr syntmp-x-1135)
syntmp-r-1134)))) (cdr syntmp-e-1128))))) (else (cons (quote map) (cons (list
(quote lambda) syntmp-formals-1130 syntmp-e-1128) syntmp-actuals-1131)))))))
(syntmp-gen-mappend-1113 (lambda (syntmp-e-1136 syntmp-map-env-1137) (list
(quote apply) (quote (primitive append)) (syntmp-gen-map-1114 syntmp-e-1136
syntmp-map-env-1137)))) (syntmp-gen-ref-1112 (lambda (syntmp-src-1138
syntmp-var-1139 syntmp-level-1140 syntmp-maps-1141) (if (syntmp-fx=-74
syntmp-level-1140 0) (values syntmp-var-1139 syntmp-maps-1141) (if (null?
syntmp-maps-1141) (syntax-error syntmp-src-1138 "missing ellipsis in syntax
form") (call-with-values (lambda () (syntmp-gen-ref-1112 syntmp-src-1138
syntmp-var-1139 (syntmp-fx--73 syntmp-level-1140 1) (cdr syntmp-maps-1141)))
(lambda (syntmp-outer-var-1142 syntmp-outer-maps-1143) (let ((syntmp-b-1144
(assq syntmp-outer-var-1142 (car syntmp-maps-1141)))) (if syntmp-b-1144 (values
(cdr syntmp-b-1144) syntmp-maps-1141) (let ((syntmp-inner-var-1145
(syntmp-gen-var-152 (quote tmp)))) (values syntmp-inner-var-1145 (cons (cons
(cons syntmp-outer-var-1142 syntmp-inner-var-1145) (car syntmp-maps-1141))
syntmp-outer-maps-1143))))))))))) (syntmp-gen-syntax-1111 (lambda
(syntmp-src-1146 syntmp-e-1147 syntmp-r-1148 syntmp-maps-1149
syntmp-ellipsis?-1150 syntmp-mod-1151) (if (syntmp-id?-104 syntmp-e-1147) (let
((syntmp-label-1152 (syntmp-id-var-name-126 syntmp-e-1147 (quote (()))))) (let
((syntmp-b-1153 (syntmp-lookup-101 syntmp-label-1152 syntmp-r-1148
syntmp-mod-1151))) (if (eq? (syntmp-binding-type-96 syntmp-b-1153) (quote
syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1154
(syntmp-binding-value-97 syntmp-b-1153))) (syntmp-gen-ref-1112 syntmp-src-1146
(car syntmp-var.lev-1154) (cdr syntmp-var.lev-1154) syntmp-maps-1149))) (lambda
(syntmp-var-1155 syntmp-maps-1156) (values (list (quote ref) syntmp-var-1155)
syntmp-maps-1156))) (if (syntmp-ellipsis?-1150 syntmp-e-1147) (syntax-error
syntmp-src-1146 "misplaced ellipsis in syntax form") (values (list (quote
quote) syntmp-e-1147) syntmp-maps-1149))))) ((lambda (syntmp-tmp-1157) ((lambda
(syntmp-tmp-1158) (if (if syntmp-tmp-1158 (apply (lambda (syntmp-dots-1159
syntmp-e-1160) (syntmp-ellipsis?-1150 syntmp-dots-1159)) syntmp-tmp-1158) #f)
(apply (lambda (syntmp-dots-1161 syntmp-e-1162) (syntmp-gen-syntax-1111
syntmp-src-1146 syntmp-e-1162 syntmp-r-1148 syntmp-maps-1149 (lambda
(syntmp-x-1163) #f) syntmp-mod-1151)) syntmp-tmp-1158) ((lambda
(syntmp-tmp-1164) (if (if syntmp-tmp-1164 (apply (lambda (syntmp-x-1165
syntmp-dots-1166 syntmp-y-1167) (syntmp-ellipsis?-1150 syntmp-dots-1166))
syntmp-tmp-1164) #f) (apply (lambda (syntmp-x-1168 syntmp-dots-1169
syntmp-y-1170) (let syntmp-f-1171 ((syntmp-y-1172 syntmp-y-1170) (syntmp-k-1173
(lambda (syntmp-maps-1174) (call-with-values (lambda () (syntmp-gen-syntax-1111
syntmp-src-1146 syntmp-x-1168 syntmp-r-1148 (cons (quote ()) syntmp-maps-1174)
syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-x-1175
syntmp-maps-1176) (if (null? (car syntmp-maps-1176)) (syntax-error
syntmp-src-1146 "extra ellipsis in syntax form") (values (syntmp-gen-map-1114
syntmp-x-1175 (car syntmp-maps-1176)) (cdr syntmp-maps-1176)))))))) ((lambda
(syntmp-tmp-1177) ((lambda (syntmp-tmp-1178) (if (if syntmp-tmp-1178 (apply
(lambda (syntmp-dots-1179 syntmp-y-1180) (syntmp-ellipsis?-1150
syntmp-dots-1179)) syntmp-tmp-1178) #f) (apply (lambda (syntmp-dots-1181
syntmp-y-1182) (syntmp-f-1171 syntmp-y-1182 (lambda (syntmp-maps-1183)
(call-with-values (lambda () (syntmp-k-1173 (cons (quote ())
syntmp-maps-1183))) (lambda (syntmp-x-1184 syntmp-maps-1185) (if (null? (car
syntmp-maps-1185)) (syntax-error syntmp-src-1146 "extra ellipsis in syntax
form") (values (syntmp-gen-mappend-1113 syntmp-x-1184 (car syntmp-maps-1185))
(cdr syntmp-maps-1185)))))))) syntmp-tmp-1178) ((lambda (syntmp-_-1186)
(call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146
syntmp-y-1172 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150
syntmp-mod-1151)) (lambda (syntmp-y-1187 syntmp-maps-1188) (call-with-values
(lambda () (syntmp-k-1173 syntmp-maps-1188)) (lambda (syntmp-x-1189
syntmp-maps-1190) (values (syntmp-gen-append-1116 syntmp-x-1189 syntmp-y-1187)
syntmp-maps-1190)))))) syntmp-tmp-1177))) (syntax-dispatch syntmp-tmp-1177
(quote (any . any))))) syntmp-y-1172))) syntmp-tmp-1164) ((lambda
(syntmp-tmp-1191) (if syntmp-tmp-1191 (apply (lambda (syntmp-x-1192
syntmp-y-1193) (call-with-values (lambda () (syntmp-gen-syntax-1111
syntmp-src-1146 syntmp-x-1192 syntmp-r-1148 syntmp-maps-1149
syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-x-1194
syntmp-maps-1195) (call-with-values (lambda () (syntmp-gen-syntax-1111
syntmp-src-1146 syntmp-y-1193 syntmp-r-1148 syntmp-maps-1195
syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-y-1196
syntmp-maps-1197) (values (syntmp-gen-cons-1115 syntmp-x-1194 syntmp-y-1196)
syntmp-maps-1197)))))) syntmp-tmp-1191) ((lambda (syntmp-tmp-1198) (if
syntmp-tmp-1198 (apply (lambda (syntmp-e1-1199 syntmp-e2-1200)
(call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 (cons
syntmp-e1-1199 syntmp-e2-1200) syntmp-r-1148 syntmp-maps-1149
syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-e-1202
syntmp-maps-1203) (values (syntmp-gen-vector-1117 syntmp-e-1202)
syntmp-maps-1203)))) syntmp-tmp-1198) ((lambda (syntmp-_-1204) (values (list
(quote quote) syntmp-e-1147) syntmp-maps-1149)) syntmp-tmp-1157)))
(syntax-dispatch syntmp-tmp-1157 (quote #(vector (any . each-any)))))))
(syntax-dispatch syntmp-tmp-1157 (quote (any . any)))))) (syntax-dispatch
syntmp-tmp-1157 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1157
(quote (any any))))) syntmp-e-1147))))) (lambda (syntmp-e-1205 syntmp-r-1206
syntmp-w-1207 syntmp-s-1208 syntmp-mod-1209) (let ((syntmp-e-1210
(syntmp-source-wrap-133 syntmp-e-1205 syntmp-w-1207 syntmp-s-1208
syntmp-mod-1209))) ((lambda (syntmp-tmp-1211) ((lambda (syntmp-tmp-1212) (if
syntmp-tmp-1212 (apply (lambda (syntmp-_-1213 syntmp-x-1214) (call-with-values
(lambda () (syntmp-gen-syntax-1111 syntmp-e-1210 syntmp-x-1214 syntmp-r-1206
(quote ()) syntmp-ellipsis?-149 syntmp-mod-1209)) (lambda (syntmp-e-1215
syntmp-maps-1216) (syntmp-regen-1118 syntmp-e-1215)))) syntmp-tmp-1212)
((lambda (syntmp-_-1217) (syntax-error syntmp-e-1210)) syntmp-tmp-1211)))
(syntax-dispatch syntmp-tmp-1211 (quote (any any))))) syntmp-e-1210)))))
(syntmp-global-extend-102 (quote core) (quote lambda) (lambda (syntmp-e-1218
syntmp-r-1219 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) ((lambda
(syntmp-tmp-1223) ((lambda (syntmp-tmp-1224) (if syntmp-tmp-1224 (apply (lambda
(syntmp-_-1225 syntmp-c-1226) (syntmp-chi-lambda-clause-145
(syntmp-source-wrap-133 syntmp-e-1218 syntmp-w-1220 syntmp-s-1221
syntmp-mod-1222) syntmp-c-1226 syntmp-r-1219 syntmp-w-1220 syntmp-mod-1222
(lambda (syntmp-vars-1227 syntmp-body-1228) (syntmp-build-annotated-81
syntmp-s-1221 (list (quote lambda) syntmp-vars-1227 syntmp-body-1228)))))
syntmp-tmp-1224) (syntax-error syntmp-tmp-1223))) (syntax-dispatch
syntmp-tmp-1223 (quote (any . any))))) syntmp-e-1218)))
(syntmp-global-extend-102 (quote core) (quote let) (letrec
((syntmp-chi-let-1229 (lambda (syntmp-e-1230 syntmp-r-1231 syntmp-w-1232
syntmp-s-1233 syntmp-mod-1234 syntmp-constructor-1235 syntmp-ids-1236
syntmp-vals-1237 syntmp-exps-1238) (if (not (syntmp-valid-bound-ids?-129
syntmp-ids-1236)) (syntax-error syntmp-e-1230 "duplicate bound variable in")
(let ((syntmp-labels-1239 (syntmp-gen-labels-110 syntmp-ids-1236))
(syntmp-new-vars-1240 (map syntmp-gen-var-152 syntmp-ids-1236))) (let
((syntmp-nw-1241 (syntmp-make-binding-wrap-121 syntmp-ids-1236
syntmp-labels-1239 syntmp-w-1232)) (syntmp-nr-1242 (syntmp-extend-var-env-99
syntmp-labels-1239 syntmp-new-vars-1240 syntmp-r-1231)))
(syntmp-constructor-1235 syntmp-s-1233 syntmp-new-vars-1240 (map (lambda
(syntmp-x-1243) (syntmp-chi-140 syntmp-x-1243 syntmp-r-1231 syntmp-w-1232
syntmp-mod-1234)) syntmp-vals-1237) (syntmp-chi-body-144 syntmp-exps-1238
(syntmp-source-wrap-133 syntmp-e-1230 syntmp-nw-1241 syntmp-s-1233
syntmp-mod-1234) syntmp-nr-1242 syntmp-nw-1241 syntmp-mod-1234)))))))) (lambda
(syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248)
((lambda (syntmp-tmp-1249) ((lambda (syntmp-tmp-1250) (if syntmp-tmp-1250
(apply (lambda (syntmp-_-1251 syntmp-id-1252 syntmp-val-1253 syntmp-e1-1254
syntmp-e2-1255) (syntmp-chi-let-1229 syntmp-e-1244 syntmp-r-1245 syntmp-w-1246
syntmp-s-1247 syntmp-mod-1248 syntmp-build-let-84 syntmp-id-1252
syntmp-val-1253 (cons syntmp-e1-1254 syntmp-e2-1255))) syntmp-tmp-1250)
((lambda (syntmp-tmp-1259) (if (if syntmp-tmp-1259 (apply (lambda
(syntmp-_-1260 syntmp-f-1261 syntmp-id-1262 syntmp-val-1263 syntmp-e1-1264
syntmp-e2-1265) (syntmp-id?-104 syntmp-f-1261)) syntmp-tmp-1259) #f) (apply
(lambda (syntmp-_-1266 syntmp-f-1267 syntmp-id-1268 syntmp-val-1269
syntmp-e1-1270 syntmp-e2-1271) (syntmp-chi-let-1229 syntmp-e-1244 syntmp-r-1245
syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248 syntmp-build-named-let-85 (cons
syntmp-f-1267 syntmp-id-1268) syntmp-val-1269 (cons syntmp-e1-1270
syntmp-e2-1271))) syntmp-tmp-1259) ((lambda (syntmp-_-1275) (syntax-error
(syntmp-source-wrap-133 syntmp-e-1244 syntmp-w-1246 syntmp-s-1247
syntmp-mod-1248))) syntmp-tmp-1249))) (syntax-dispatch syntmp-tmp-1249 (quote
(any any #(each (any any)) any . each-any)))))) (syntax-dispatch
syntmp-tmp-1249 (quote (any #(each (any any)) any . each-any)))))
syntmp-e-1244)))) (syntmp-global-extend-102 (quote core) (quote letrec) (lambda
(syntmp-e-1276 syntmp-r-1277 syntmp-w-1278 syntmp-s-1279 syntmp-mod-1280)
((lambda (syntmp-tmp-1281) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282
(apply (lambda (syntmp-_-1283 syntmp-id-1284 syntmp-val-1285 syntmp-e1-1286
syntmp-e2-1287) (let ((syntmp-ids-1288 syntmp-id-1284)) (if (not
(syntmp-valid-bound-ids?-129 syntmp-ids-1288)) (syntax-error syntmp-e-1276
"duplicate bound variable in") (let ((syntmp-labels-1290 (syntmp-gen-labels-110
syntmp-ids-1288)) (syntmp-new-vars-1291 (map syntmp-gen-var-152
syntmp-ids-1288))) (let ((syntmp-w-1292 (syntmp-make-binding-wrap-121
syntmp-ids-1288 syntmp-labels-1290 syntmp-w-1278)) (syntmp-r-1293
(syntmp-extend-var-env-99 syntmp-labels-1290 syntmp-new-vars-1291
syntmp-r-1277))) (syntmp-build-letrec-86 syntmp-s-1279 syntmp-new-vars-1291
(map (lambda (syntmp-x-1294) (syntmp-chi-140 syntmp-x-1294 syntmp-r-1293
syntmp-w-1292 syntmp-mod-1280)) syntmp-val-1285) (syntmp-chi-body-144 (cons
syntmp-e1-1286 syntmp-e2-1287) (syntmp-source-wrap-133 syntmp-e-1276
syntmp-w-1292 syntmp-s-1279 syntmp-mod-1280) syntmp-r-1293 syntmp-w-1292
syntmp-mod-1280))))))) syntmp-tmp-1282) ((lambda (syntmp-_-1297) (syntax-error
(syntmp-source-wrap-133 syntmp-e-1276 syntmp-w-1278 syntmp-s-1279
syntmp-mod-1280))) syntmp-tmp-1281))) (syntax-dispatch syntmp-tmp-1281 (quote
(any #(each (any any)) any . each-any))))) syntmp-e-1276)))
(syntmp-global-extend-102 (quote core) (quote set!) (lambda (syntmp-e-1298
syntmp-r-1299 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302) ((lambda
(syntmp-tmp-1303) ((lambda (syntmp-tmp-1304) (if (if syntmp-tmp-1304 (apply
(lambda (syntmp-_-1305 syntmp-id-1306 syntmp-val-1307) (syntmp-id?-104
syntmp-id-1306)) syntmp-tmp-1304) #f) (apply (lambda (syntmp-_-1308
syntmp-id-1309 syntmp-val-1310) (let ((syntmp-val-1311 (syntmp-chi-140
syntmp-val-1310 syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302)) (syntmp-n-1312
(syntmp-id-var-name-126 syntmp-id-1309 syntmp-w-1300))) (let ((syntmp-b-1313
(syntmp-lookup-101 syntmp-n-1312 syntmp-r-1299 syntmp-mod-1302))) (let
((syntmp-t-1314 (syntmp-binding-type-96 syntmp-b-1313))) (if (memv
syntmp-t-1314 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1301 (list
(quote set!) (syntmp-binding-value-97 syntmp-b-1313) syntmp-val-1311)) (if
(memv syntmp-t-1314 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1301
(list (quote set!) (make-module-ref syntmp-mod-1302 syntmp-n-1312 #f)
syntmp-val-1311)) (if (memv syntmp-t-1314 (quote (displaced-lexical)))
(syntax-error (syntmp-wrap-132 syntmp-id-1309 syntmp-w-1300 syntmp-mod-1302)
"identifier out of context") (syntax-error (syntmp-source-wrap-133
syntmp-e-1298 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302)))))))))
syntmp-tmp-1304) ((lambda (syntmp-tmp-1315) (if syntmp-tmp-1315 (apply (lambda
(syntmp-_-1316 syntmp-head-1317 syntmp-tail-1318 syntmp-val-1319)
(call-with-values (lambda () (syntmp-syntax-type-138 syntmp-head-1317
syntmp-r-1299 (quote (())) #f #f syntmp-mod-1302)) (lambda (syntmp-type-1320
syntmp-value-1321 syntmp-ee-1322 syntmp-ww-1323 syntmp-ss-1324
syntmp-modmod-1325) (let ((syntmp-t-1326 syntmp-type-1320)) (if (memv
syntmp-t-1326 (quote (module-ref))) (call-with-values (lambda ()
(syntmp-value-1321 (cons syntmp-head-1317 syntmp-tail-1318))) (lambda
(syntmp-id-1328 syntmp-mod-1329) (syntmp-build-annotated-81 syntmp-s-1301 (list
(quote set!) (make-module-ref syntmp-mod-1329 syntmp-id-1328 #f)
syntmp-val-1319)))) (syntmp-build-annotated-81 syntmp-s-1301 (cons
(syntmp-chi-140 (list (quote #(syntax-object setter ((top) #(ribcage () () ())
#(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top))
#("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top)
(top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list
gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer
chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr
chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence
chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids?
valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks
join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage
new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap
set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels
ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label
make-rename rename-marks rename-new rename-old subst-rename? wrap-subst
wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id?
global-extend lookup macros-only-env extend-var-env extend-env null-env
binding-value binding-type make-binding arg-check source-annotation no-source
unannotate set-syntax-object-module! set-syntax-object-wrap!
set-syntax-object-expression! syntax-object-module syntax-object-wrap
syntax-object-expression syntax-object? make-syntax-object build-lexical-var
build-letrec build-named-let build-let build-sequence build-data build-primref
build-lambda build-global-definition build-global-assignment
build-global-reference build-lexical-assignment build-lexical-reference
build-conditional build-application build-annotated get-global-definition-hook
put-global-definition-hook gensym-hook error-hook local-eval-hook
top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage
(define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-head-1317)
syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302) (map (lambda (syntmp-e-1330)
(syntmp-chi-140 syntmp-e-1330 syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302))
(append syntmp-tail-1318 (list syntmp-val-1319)))))))))) syntmp-tmp-1315)
((lambda (syntmp-_-1332) (syntax-error (syntmp-source-wrap-133 syntmp-e-1298
syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302))) syntmp-tmp-1303)))
(syntax-dispatch syntmp-tmp-1303 (quote (any (any . each-any) any))))))
(syntax-dispatch syntmp-tmp-1303 (quote (any any any))))) syntmp-e-1298)))
(syntmp-global-extend-102 (quote module-ref) (quote @) (lambda (syntmp-e-1333)
((lambda (syntmp-tmp-1334) ((lambda (syntmp-tmp-1335) (if (if syntmp-tmp-1335
(apply (lambda (syntmp-_-1336 syntmp-mod-1337 syntmp-id-1338) (and (andmap
syntmp-id?-104 syntmp-mod-1337) (syntmp-id?-104 syntmp-id-1338)))
syntmp-tmp-1335) #f) (apply (lambda (syntmp-_-1340 syntmp-mod-1341
syntmp-id-1342) (values (syntax-object->datum syntmp-id-1342)
(syntax-object->datum (append syntmp-mod-1341 (quote (#(syntax-object
%module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top))
#("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage
(lambda-var-list gen-var strip strip-annotation ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source unannotate set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"))
#(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))))
syntmp-tmp-1335) (syntax-error syntmp-tmp-1334))) (syntax-dispatch
syntmp-tmp-1334 (quote (any each-any any))))) syntmp-e-1333)))
(syntmp-global-extend-102 (quote module-ref) (quote @@) (lambda (syntmp-e-1344)
((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if (if syntmp-tmp-1346
(apply (lambda (syntmp-_-1347 syntmp-mod-1348 syntmp-id-1349) (and (andmap
syntmp-id?-104 syntmp-mod-1348) (syntmp-id?-104 syntmp-id-1349)))
syntmp-tmp-1346) #f) (apply (lambda (syntmp-_-1351 syntmp-mod-1352
syntmp-id-1353) (values (syntax-object->datum syntmp-id-1353)
(syntax-object->datum syntmp-mod-1352))) syntmp-tmp-1346) (syntax-error
syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any each-any
any))))) syntmp-e-1344))) (syntmp-global-extend-102 (quote begin) (quote begin)
(quote ())) (syntmp-global-extend-102 (quote define) (quote define) (quote ()))
(syntmp-global-extend-102 (quote define-syntax) (quote define-syntax) (quote
())) (syntmp-global-extend-102 (quote eval-when) (quote eval-when) (quote ()))
(syntmp-global-extend-102 (quote core) (quote syntax-case) (letrec
((syntmp-gen-syntax-case-1358 (lambda (syntmp-x-1359 syntmp-keys-1360
syntmp-clauses-1361 syntmp-r-1362 syntmp-mod-1363) (if (null?
syntmp-clauses-1361) (syntmp-build-annotated-81 #f (list
(syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1359)) ((lambda
(syntmp-tmp-1364) ((lambda (syntmp-tmp-1365) (if syntmp-tmp-1365 (apply (lambda
(syntmp-pat-1366 syntmp-exp-1367) (if (and (syntmp-id?-104 syntmp-pat-1366)
(andmap (lambda (syntmp-x-1368) (not (syntmp-free-id=?-127 syntmp-pat-1366
syntmp-x-1368))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r
mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage
(gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top)
(top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip
strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source unannotate
set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression!
syntax-object-module syntax-object-wrap syntax-object-expression syntax-object?
make-syntax-object build-lexical-var build-letrec build-named-let build-let
build-sequence build-data build-primref build-lambda build-global-definition
build-global-assignment build-global-reference build-lexical-assignment
build-lexical-reference build-conditional build-application build-annotated
get-global-definition-hook put-global-definition-hook gensym-hook error-hook
local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"))
#(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))
syntmp-keys-1360))) (let ((syntmp-labels-1369 (list (syntmp-gen-label-109)))
(syntmp-var-1370 (syntmp-gen-var-152 syntmp-pat-1366)))
(syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote
lambda) (list syntmp-var-1370) (syntmp-chi-140 syntmp-exp-1367
(syntmp-extend-env-98 syntmp-labels-1369 (list (cons (quote syntax) (cons
syntmp-var-1370 0))) syntmp-r-1362) (syntmp-make-binding-wrap-121 (list
syntmp-pat-1366) syntmp-labels-1369 (quote (()))) syntmp-mod-1363)))
syntmp-x-1359))) (syntmp-gen-clause-1357 syntmp-x-1359 syntmp-keys-1360 (cdr
syntmp-clauses-1361) syntmp-r-1362 syntmp-pat-1366 #t syntmp-exp-1367
syntmp-mod-1363))) syntmp-tmp-1365) ((lambda (syntmp-tmp-1371) (if
syntmp-tmp-1371 (apply (lambda (syntmp-pat-1372 syntmp-fender-1373
syntmp-exp-1374) (syntmp-gen-clause-1357 syntmp-x-1359 syntmp-keys-1360 (cdr
syntmp-clauses-1361) syntmp-r-1362 syntmp-pat-1372 syntmp-fender-1373
syntmp-exp-1374 syntmp-mod-1363)) syntmp-tmp-1371) ((lambda (syntmp-_-1375)
(syntax-error (car syntmp-clauses-1361) "invalid syntax-case clause"))
syntmp-tmp-1364))) (syntax-dispatch syntmp-tmp-1364 (quote (any any any))))))
(syntax-dispatch syntmp-tmp-1364 (quote (any any))))) (car
syntmp-clauses-1361))))) (syntmp-gen-clause-1357 (lambda (syntmp-x-1376
syntmp-keys-1377 syntmp-clauses-1378 syntmp-r-1379 syntmp-pat-1380
syntmp-fender-1381 syntmp-exp-1382 syntmp-mod-1383) (call-with-values (lambda
() (syntmp-convert-pattern-1355 syntmp-pat-1380 syntmp-keys-1377)) (lambda
(syntmp-p-1384 syntmp-pvars-1385) (cond ((not (syntmp-distinct-bound-ids?-130
(map car syntmp-pvars-1385))) (syntax-error syntmp-pat-1380 "duplicate pattern
variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1386) (not
(syntmp-ellipsis?-149 (car syntmp-x-1386)))) syntmp-pvars-1385)) (syntax-error
syntmp-pat-1380 "misplaced ellipsis in syntax-case pattern")) (else (let
((syntmp-y-1387 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81
#f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list
syntmp-y-1387) (let ((syntmp-y-1388 (syntmp-build-annotated-81 #f
syntmp-y-1387))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda
(syntmp-tmp-1389) ((lambda (syntmp-tmp-1390) (if syntmp-tmp-1390 (apply (lambda
() syntmp-y-1388) syntmp-tmp-1390) ((lambda (syntmp-_-1391)
(syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1388
(syntmp-build-dispatch-call-1356 syntmp-pvars-1385 syntmp-fender-1381
syntmp-y-1388 syntmp-r-1379 syntmp-mod-1383) (syntmp-build-data-82 #f #f))))
syntmp-tmp-1389))) (syntax-dispatch syntmp-tmp-1389 (quote #(atom #t)))))
syntmp-fender-1381) (syntmp-build-dispatch-call-1356 syntmp-pvars-1385
syntmp-exp-1382 syntmp-y-1388 syntmp-r-1379 syntmp-mod-1383)
(syntmp-gen-syntax-case-1358 syntmp-x-1376 syntmp-keys-1377 syntmp-clauses-1378
syntmp-r-1379 syntmp-mod-1383)))))) (if (eq? syntmp-p-1384 (quote any))
(syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list))
syntmp-x-1376)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81
#f (quote syntax-dispatch)) syntmp-x-1376 (syntmp-build-data-82 #f
syntmp-p-1384))))))))))))) (syntmp-build-dispatch-call-1356 (lambda
(syntmp-pvars-1392 syntmp-exp-1393 syntmp-y-1394 syntmp-r-1395 syntmp-mod-1396)
(let ((syntmp-ids-1397 (map car syntmp-pvars-1392)) (syntmp-levels-1398 (map
cdr syntmp-pvars-1392))) (let ((syntmp-labels-1399 (syntmp-gen-labels-110
syntmp-ids-1397)) (syntmp-new-vars-1400 (map syntmp-gen-var-152
syntmp-ids-1397))) (syntmp-build-annotated-81 #f (list
(syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f
(list (quote lambda) syntmp-new-vars-1400 (syntmp-chi-140 syntmp-exp-1393
(syntmp-extend-env-98 syntmp-labels-1399 (map (lambda (syntmp-var-1401
syntmp-level-1402) (cons (quote syntax) (cons syntmp-var-1401
syntmp-level-1402))) syntmp-new-vars-1400 (map cdr syntmp-pvars-1392))
syntmp-r-1395) (syntmp-make-binding-wrap-121 syntmp-ids-1397 syntmp-labels-1399
(quote (()))) syntmp-mod-1396))) syntmp-y-1394))))))
(syntmp-convert-pattern-1355 (lambda (syntmp-pattern-1403 syntmp-keys-1404)
(let syntmp-cvt-1405 ((syntmp-p-1406 syntmp-pattern-1403) (syntmp-n-1407 0)
(syntmp-ids-1408 (quote ()))) (if (syntmp-id?-104 syntmp-p-1406) (if
(syntmp-bound-id-member?-131 syntmp-p-1406 syntmp-keys-1404) (values (vector
(quote free-id) syntmp-p-1406) syntmp-ids-1408) (values (quote any) (cons (cons
syntmp-p-1406 syntmp-n-1407) syntmp-ids-1408))) ((lambda (syntmp-tmp-1409)
((lambda (syntmp-tmp-1410) (if (if syntmp-tmp-1410 (apply (lambda
(syntmp-x-1411 syntmp-dots-1412) (syntmp-ellipsis?-149 syntmp-dots-1412))
syntmp-tmp-1410) #f) (apply (lambda (syntmp-x-1413 syntmp-dots-1414)
(call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1413 (syntmp-fx+-72
syntmp-n-1407 1) syntmp-ids-1408)) (lambda (syntmp-p-1415 syntmp-ids-1416)
(values (if (eq? syntmp-p-1415 (quote any)) (quote each-any) (vector (quote
each) syntmp-p-1415)) syntmp-ids-1416)))) syntmp-tmp-1410) ((lambda
(syntmp-tmp-1417) (if syntmp-tmp-1417 (apply (lambda (syntmp-x-1418
syntmp-y-1419) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-y-1419
syntmp-n-1407 syntmp-ids-1408)) (lambda (syntmp-y-1420 syntmp-ids-1421)
(call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1418 syntmp-n-1407
syntmp-ids-1421)) (lambda (syntmp-x-1422 syntmp-ids-1423) (values (cons
syntmp-x-1422 syntmp-y-1420) syntmp-ids-1423)))))) syntmp-tmp-1417) ((lambda
(syntmp-tmp-1424) (if syntmp-tmp-1424 (apply (lambda () (values (quote ())
syntmp-ids-1408)) syntmp-tmp-1424) ((lambda (syntmp-tmp-1425) (if
syntmp-tmp-1425 (apply (lambda (syntmp-x-1426) (call-with-values (lambda ()
(syntmp-cvt-1405 syntmp-x-1426 syntmp-n-1407 syntmp-ids-1408)) (lambda
(syntmp-p-1428 syntmp-ids-1429) (values (vector (quote vector) syntmp-p-1428)
syntmp-ids-1429)))) syntmp-tmp-1425) ((lambda (syntmp-x-1430) (values (vector
(quote atom) (syntmp-strip-151 syntmp-p-1406 (quote (())))) syntmp-ids-1408))
syntmp-tmp-1409))) (syntax-dispatch syntmp-tmp-1409 (quote #(vector
each-any)))))) (syntax-dispatch syntmp-tmp-1409 (quote ()))))) (syntax-dispatch
syntmp-tmp-1409 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1409 (quote
(any any))))) syntmp-p-1406)))))) (lambda (syntmp-e-1431 syntmp-r-1432
syntmp-w-1433 syntmp-s-1434 syntmp-mod-1435) (let ((syntmp-e-1436
(syntmp-source-wrap-133 syntmp-e-1431 syntmp-w-1433 syntmp-s-1434
syntmp-mod-1435))) ((lambda (syntmp-tmp-1437) ((lambda (syntmp-tmp-1438) (if
syntmp-tmp-1438 (apply (lambda (syntmp-_-1439 syntmp-val-1440 syntmp-key-1441
syntmp-m-1442) (if (andmap (lambda (syntmp-x-1443) (and (syntmp-id?-104
syntmp-x-1443) (not (syntmp-ellipsis?-149 syntmp-x-1443)))) syntmp-key-1441)
(let ((syntmp-x-1445 (syntmp-gen-var-152 (quote tmp))))
(syntmp-build-annotated-81 syntmp-s-1434 (list (syntmp-build-annotated-81 #f
(list (quote lambda) (list syntmp-x-1445) (syntmp-gen-syntax-case-1358
(syntmp-build-annotated-81 #f syntmp-x-1445) syntmp-key-1441 syntmp-m-1442
syntmp-r-1432 syntmp-mod-1435))) (syntmp-chi-140 syntmp-val-1440 syntmp-r-1432
(quote (())) syntmp-mod-1435)))) (syntax-error syntmp-e-1436 "invalid literals
list in"))) syntmp-tmp-1438) (syntax-error syntmp-tmp-1437))) (syntax-dispatch
syntmp-tmp-1437 (quote (any any each-any . each-any))))) syntmp-e-1436)))))
(set! sc-expand (let ((syntmp-m-1448 (quote e)) (syntmp-esew-1449 (quote
(eval)))) (lambda (syntmp-x-1450) (if (and (pair? syntmp-x-1450) (equal? (car
syntmp-x-1450) syntmp-noexpand-71)) (cadr syntmp-x-1450) (syntmp-chi-top-139
syntmp-x-1450 (quote ()) (quote ((top))) syntmp-m-1448 syntmp-esew-1449
(module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1451
(quote e)) (syntmp-esew-1452 (quote (eval)))) (lambda (syntmp-x-1454 .
syntmp-rest-1453) (if (and (pair? syntmp-x-1454) (equal? (car syntmp-x-1454)
syntmp-noexpand-71)) (cadr syntmp-x-1454) (syntmp-chi-top-139 syntmp-x-1454
(quote ()) (quote ((top))) (if (null? syntmp-rest-1453) syntmp-m-1451 (car
syntmp-rest-1453)) (if (or (null? syntmp-rest-1453) (null? (cdr
syntmp-rest-1453))) syntmp-esew-1452 (cadr syntmp-rest-1453)) (module-name
(current-module))))))) (set! identifier? (lambda (syntmp-x-1455)
(syntmp-nonsymbol-id?-103 syntmp-x-1455))) (set! datum->syntax-object (lambda
(syntmp-id-1456 syntmp-datum-1457) (syntmp-make-syntax-object-87
syntmp-datum-1457 (syntmp-syntax-object-wrap-90 syntmp-id-1456) #f))) (set!
syntax-object->datum (lambda (syntmp-x-1458) (syntmp-strip-151 syntmp-x-1458
(quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1459) (begin (let
((syntmp-x-1460 syntmp-ls-1459)) (if (not (list? syntmp-x-1460))
(syntmp-error-hook-78 (quote generate-temporaries) "invalid argument"
syntmp-x-1460))) (map (lambda (syntmp-x-1461) (syntmp-wrap-132 (gensym) (quote
((top))) #f)) syntmp-ls-1459)))) (set! free-identifier=? (lambda (syntmp-x-1462
syntmp-y-1463) (begin (let ((syntmp-x-1464 syntmp-x-1462)) (if (not
(syntmp-nonsymbol-id?-103 syntmp-x-1464)) (syntmp-error-hook-78 (quote
free-identifier=?) "invalid argument" syntmp-x-1464))) (let ((syntmp-x-1465
syntmp-y-1463)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1465))
(syntmp-error-hook-78 (quote free-identifier=?) "invalid argument"
syntmp-x-1465))) (syntmp-free-id=?-127 syntmp-x-1462 syntmp-y-1463)))) (set!
bound-identifier=? (lambda (syntmp-x-1466 syntmp-y-1467) (begin (let
((syntmp-x-1468 syntmp-x-1466)) (if (not (syntmp-nonsymbol-id?-103
syntmp-x-1468)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid
argument" syntmp-x-1468))) (let ((syntmp-x-1469 syntmp-y-1467)) (if (not
(syntmp-nonsymbol-id?-103 syntmp-x-1469)) (syntmp-error-hook-78 (quote
bound-identifier=?) "invalid argument" syntmp-x-1469))) (syntmp-bound-id=?-128
syntmp-x-1466 syntmp-y-1467)))) (set! syntax-error (lambda (syntmp-object-1471
. syntmp-messages-1470) (begin (for-each (lambda (syntmp-x-1472) (let
((syntmp-x-1473 syntmp-x-1472)) (if (not (string? syntmp-x-1473))
(syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1473))))
syntmp-messages-1470) (let ((syntmp-message-1474 (if (null?
syntmp-messages-1470) "invalid syntax" (apply string-append
syntmp-messages-1470)))) (syntmp-error-hook-78 #f syntmp-message-1474
(syntmp-strip-151 syntmp-object-1471 (quote (())))))))) (set!
install-global-transformer (lambda (syntmp-sym-1475 syntmp-v-1476) (begin (let
((syntmp-x-1477 syntmp-sym-1475)) (if (not (symbol? syntmp-x-1477))
(syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1477)))
(let ((syntmp-x-1478 syntmp-v-1476)) (if (not (procedure? syntmp-x-1478))
(syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1478)))
(syntmp-global-extend-102 (quote macro) syntmp-sym-1475 syntmp-v-1476))))
(letrec ((syntmp-match-1483 (lambda (syntmp-e-1484 syntmp-p-1485 syntmp-w-1486
syntmp-r-1487 syntmp-mod-1488) (cond ((not syntmp-r-1487) #f) ((eq?
syntmp-p-1485 (quote any)) (cons (syntmp-wrap-132 syntmp-e-1484 syntmp-w-1486
syntmp-mod-1488) syntmp-r-1487)) ((syntmp-syntax-object?-88 syntmp-e-1484)
(syntmp-match*-1482 (let ((syntmp-e-1489 (syntmp-syntax-object-expression-89
syntmp-e-1484))) (if (annotation? syntmp-e-1489) (annotation-expression
syntmp-e-1489) syntmp-e-1489)) syntmp-p-1485 (syntmp-join-wraps-123
syntmp-w-1486 (syntmp-syntax-object-wrap-90 syntmp-e-1484)) syntmp-r-1487
(syntmp-syntax-object-module-91 syntmp-e-1484))) (else (syntmp-match*-1482 (let
((syntmp-e-1490 syntmp-e-1484)) (if (annotation? syntmp-e-1490)
(annotation-expression syntmp-e-1490) syntmp-e-1490)) syntmp-p-1485
syntmp-w-1486 syntmp-r-1487 syntmp-mod-1488))))) (syntmp-match*-1482 (lambda
(syntmp-e-1491 syntmp-p-1492 syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495) (cond
((null? syntmp-p-1492) (and (null? syntmp-e-1491) syntmp-r-1494)) ((pair?
syntmp-p-1492) (and (pair? syntmp-e-1491) (syntmp-match-1483 (car
syntmp-e-1491) (car syntmp-p-1492) syntmp-w-1493 (syntmp-match-1483 (cdr
syntmp-e-1491) (cdr syntmp-p-1492) syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495)
syntmp-mod-1495))) ((eq? syntmp-p-1492 (quote each-any)) (let ((syntmp-l-1496
(syntmp-match-each-any-1480 syntmp-e-1491 syntmp-w-1493 syntmp-mod-1495))) (and
syntmp-l-1496 (cons syntmp-l-1496 syntmp-r-1494)))) (else (let ((syntmp-t-1497
(vector-ref syntmp-p-1492 0))) (if (memv syntmp-t-1497 (quote (each))) (if
(null? syntmp-e-1491) (syntmp-match-empty-1481 (vector-ref syntmp-p-1492 1)
syntmp-r-1494) (let ((syntmp-l-1498 (syntmp-match-each-1479 syntmp-e-1491
(vector-ref syntmp-p-1492 1) syntmp-w-1493 syntmp-mod-1495))) (and
syntmp-l-1498 (let syntmp-collect-1499 ((syntmp-l-1500 syntmp-l-1498)) (if
(null? (car syntmp-l-1500)) syntmp-r-1494 (cons (map car syntmp-l-1500)
(syntmp-collect-1499 (map cdr syntmp-l-1500)))))))) (if (memv syntmp-t-1497
(quote (free-id))) (and (syntmp-id?-104 syntmp-e-1491) (syntmp-free-id=?-127
(syntmp-wrap-132 syntmp-e-1491 syntmp-w-1493 syntmp-mod-1495) (vector-ref
syntmp-p-1492 1)) syntmp-r-1494) (if (memv syntmp-t-1497 (quote (atom))) (and
(equal? (vector-ref syntmp-p-1492 1) (syntmp-strip-151 syntmp-e-1491
syntmp-w-1493)) syntmp-r-1494) (if (memv syntmp-t-1497 (quote (vector))) (and
(vector? syntmp-e-1491) (syntmp-match-1483 (vector->list syntmp-e-1491)
(vector-ref syntmp-p-1492 1) syntmp-w-1493 syntmp-r-1494
syntmp-mod-1495))))))))))) (syntmp-match-empty-1481 (lambda (syntmp-p-1501
syntmp-r-1502) (cond ((null? syntmp-p-1501) syntmp-r-1502) ((eq? syntmp-p-1501
(quote any)) (cons (quote ()) syntmp-r-1502)) ((pair? syntmp-p-1501)
(syntmp-match-empty-1481 (car syntmp-p-1501) (syntmp-match-empty-1481 (cdr
syntmp-p-1501) syntmp-r-1502))) ((eq? syntmp-p-1501 (quote each-any)) (cons
(quote ()) syntmp-r-1502)) (else (let ((syntmp-t-1503 (vector-ref syntmp-p-1501
0))) (if (memv syntmp-t-1503 (quote (each))) (syntmp-match-empty-1481
(vector-ref syntmp-p-1501 1) syntmp-r-1502) (if (memv syntmp-t-1503 (quote
(free-id atom))) syntmp-r-1502 (if (memv syntmp-t-1503 (quote (vector)))
(syntmp-match-empty-1481 (vector-ref syntmp-p-1501 1) syntmp-r-1502)))))))))
(syntmp-match-each-any-1480 (lambda (syntmp-e-1504 syntmp-w-1505
syntmp-mod-1506) (cond ((annotation? syntmp-e-1504) (syntmp-match-each-any-1480
(annotation-expression syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506)) ((pair?
syntmp-e-1504) (let ((syntmp-l-1507 (syntmp-match-each-any-1480 (cdr
syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506))) (and syntmp-l-1507 (cons
(syntmp-wrap-132 (car syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506)
syntmp-l-1507)))) ((null? syntmp-e-1504) (quote ())) ((syntmp-syntax-object?-88
syntmp-e-1504) (syntmp-match-each-any-1480 (syntmp-syntax-object-expression-89
syntmp-e-1504) (syntmp-join-wraps-123 syntmp-w-1505
(syntmp-syntax-object-wrap-90 syntmp-e-1504)) syntmp-mod-1506)) (else #f))))
(syntmp-match-each-1479 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510
syntmp-mod-1511) (cond ((annotation? syntmp-e-1508) (syntmp-match-each-1479
(annotation-expression syntmp-e-1508) syntmp-p-1509 syntmp-w-1510
syntmp-mod-1511)) ((pair? syntmp-e-1508) (let ((syntmp-first-1512
(syntmp-match-1483 (car syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 (quote ())
syntmp-mod-1511))) (and syntmp-first-1512 (let ((syntmp-rest-1513
(syntmp-match-each-1479 (cdr syntmp-e-1508) syntmp-p-1509 syntmp-w-1510
syntmp-mod-1511))) (and syntmp-rest-1513 (cons syntmp-first-1512
syntmp-rest-1513)))))) ((null? syntmp-e-1508) (quote ()))
((syntmp-syntax-object?-88 syntmp-e-1508) (syntmp-match-each-1479
(syntmp-syntax-object-expression-89 syntmp-e-1508) syntmp-p-1509
(syntmp-join-wraps-123 syntmp-w-1510 (syntmp-syntax-object-wrap-90
syntmp-e-1508)) (syntmp-syntax-object-module-91 syntmp-e-1508))) (else #f)))))
(begin (set! syntax-dispatch (lambda (syntmp-e-1514 syntmp-p-1515) (cond ((eq?
syntmp-p-1515 (quote any)) (list syntmp-e-1514)) ((syntmp-syntax-object?-88
syntmp-e-1514) (syntmp-match*-1482 (let ((syntmp-e-1516
(syntmp-syntax-object-expression-89 syntmp-e-1514))) (if (annotation?
syntmp-e-1516) (annotation-expression syntmp-e-1516) syntmp-e-1516))
syntmp-p-1515 (syntmp-syntax-object-wrap-90 syntmp-e-1514) (quote ())
(syntmp-syntax-object-module-91 syntmp-e-1514))) (else (syntmp-match*-1482 (let
((syntmp-e-1517 syntmp-e-1514)) (if (annotation? syntmp-e-1517)
(annotation-expression syntmp-e-1517) syntmp-e-1517)) syntmp-p-1515 (quote
(())) (quote ()) #f))))) (set! sc-chi syntmp-chi-140)))))
-(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1518)
((lambda (syntmp-tmp-1519) ((lambda (syntmp-tmp-1520) (if syntmp-tmp-1520
(apply (lambda (syntmp-_-1521 syntmp-e1-1522 syntmp-e2-1523) (cons (quote
#(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9
syncase))) (cons syntmp-e1-1522 syntmp-e2-1523))) syntmp-tmp-1520) ((lambda
(syntmp-tmp-1525) (if syntmp-tmp-1525 (apply (lambda (syntmp-_-1526
syntmp-out-1527 syntmp-in-1528 syntmp-e1-1529 syntmp-e2-1530) (list (quote
#(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (ice-9 syncase))) syntmp-in-1528 (quote ()) (list
syntmp-out-1527 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in
e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () ()
()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1529
syntmp-e2-1530))))) syntmp-tmp-1525) ((lambda (syntmp-tmp-1532) (if
syntmp-tmp-1532 (apply (lambda (syntmp-_-1533 syntmp-out-1534 syntmp-in-1535
syntmp-e1-1536 syntmp-e2-1537) (list (quote #(syntax-object syntax-case ((top)
#(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))
(cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top)
(top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1535) (quote ()) (list
syntmp-out-1534 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in
e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () ()
()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1536
syntmp-e2-1537))))) syntmp-tmp-1532) (syntax-error syntmp-tmp-1519)))
(syntax-dispatch syntmp-tmp-1519 (quote (any #(each (any any)) any .
each-any)))))) (syntax-dispatch syntmp-tmp-1519 (quote (any ((any any)) any .
each-any)))))) (syntax-dispatch syntmp-tmp-1519 (quote (any () any .
each-any))))) syntmp-x-1518)))
-(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1559)
((lambda (syntmp-tmp-1560) ((lambda (syntmp-tmp-1561) (if syntmp-tmp-1561
(apply (lambda (syntmp-_-1562 syntmp-k-1563 syntmp-keyword-1564
syntmp-pattern-1565 syntmp-template-1566) (list (quote #(syntax-object lambda
((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k
keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))
(cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern
template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage ()
() ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote
#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top)
(top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1563 (map (lambda
(syntmp-tmp-1569 syntmp-tmp-1568) (list (cons (quote #(syntax-object dummy
((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i"))) (ice-9 syncase))) syntmp-tmp-1568) (list (quote #(syntax-object syntax
((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i"))) (ice-9 syncase))) syntmp-tmp-1569))) syntmp-template-1566
syntmp-pattern-1565)))))) syntmp-tmp-1561) (syntax-error syntmp-tmp-1560)))
(syntax-dispatch syntmp-tmp-1560 (quote (any each-any . #(each ((any . any)
any))))))) syntmp-x-1559)))
-(install-global-transformer (quote let*) (lambda (syntmp-x-1580) ((lambda
(syntmp-tmp-1581) ((lambda (syntmp-tmp-1582) (if (if syntmp-tmp-1582 (apply
(lambda (syntmp-let*-1583 syntmp-x-1584 syntmp-v-1585 syntmp-e1-1586
syntmp-e2-1587) (andmap identifier? syntmp-x-1584)) syntmp-tmp-1582) #f) (apply
(lambda (syntmp-let*-1589 syntmp-x-1590 syntmp-v-1591 syntmp-e1-1592
syntmp-e2-1593) (let syntmp-f-1594 ((syntmp-bindings-1595 (map list
syntmp-x-1590 syntmp-v-1591))) (if (null? syntmp-bindings-1595) (cons (quote
#(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top)
(top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top))
#("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1592 syntmp-e2-1593)))
((lambda (syntmp-tmp-1599) ((lambda (syntmp-tmp-1600) (if syntmp-tmp-1600
(apply (lambda (syntmp-body-1601 syntmp-binding-1602) (list (quote
#(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i"))
#(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))
(list syntmp-binding-1602) syntmp-body-1601)) syntmp-tmp-1600) (syntax-error
syntmp-tmp-1599))) (syntax-dispatch syntmp-tmp-1599 (quote (any any))))) (list
(syntmp-f-1594 (cdr syntmp-bindings-1595)) (car syntmp-bindings-1595))))))
syntmp-tmp-1582) (syntax-error syntmp-tmp-1581))) (syntax-dispatch
syntmp-tmp-1581 (quote (any #(each (any any)) any . each-any)))))
syntmp-x-1580)))
-(install-global-transformer (quote do) (lambda (syntmp-orig-x-1622) ((lambda
(syntmp-tmp-1623) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda
(syntmp-_-1625 syntmp-var-1626 syntmp-init-1627 syntmp-step-1628 syntmp-e0-1629
syntmp-e1-1630 syntmp-c-1631) ((lambda (syntmp-tmp-1632) ((lambda
(syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-step-1634)
((lambda (syntmp-tmp-1635) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636
(apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step)
#((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object
doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0
e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9
syncase))) (map list syntmp-var-1626 syntmp-init-1627) (list (quote
#(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var
init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i"
"i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step)
#((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1629) (cons
(quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i"))
#(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x)
#((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1631 (list (cons (quote
#(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_
var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(ice-9 syncase))) syntmp-step-1634))))))) syntmp-tmp-1636) ((lambda
(syntmp-tmp-1641) (if syntmp-tmp-1641 (apply (lambda (syntmp-e1-1642
syntmp-e2-1643) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2)
#((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var
init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i"
"i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2)
#((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var
init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i"
"i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(ice-9 syncase))) (map list syntmp-var-1626 syntmp-init-1627) (list (quote
#(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i"))
#(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top)
(top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase)))
syntmp-e0-1629 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2)
#((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var
init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i"
"i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(ice-9 syncase))) (cons syntmp-e1-1642 syntmp-e2-1643)) (cons (quote
#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i"))
#(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top)
(top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append
syntmp-c-1631 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1
e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_
var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(ice-9 syncase))) syntmp-step-1634))))))) syntmp-tmp-1641) (syntax-error
syntmp-tmp-1635))) (syntax-dispatch syntmp-tmp-1635 (quote (any .
each-any)))))) (syntax-dispatch syntmp-tmp-1635 (quote ())))) syntmp-e1-1630))
syntmp-tmp-1633) (syntax-error syntmp-tmp-1632))) (syntax-dispatch
syntmp-tmp-1632 (quote each-any)))) (map (lambda (syntmp-v-1650 syntmp-s-1651)
((lambda (syntmp-tmp-1652) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653
(apply (lambda () syntmp-v-1650) syntmp-tmp-1653) ((lambda (syntmp-tmp-1654)
(if syntmp-tmp-1654 (apply (lambda (syntmp-e-1655) syntmp-e-1655)
syntmp-tmp-1654) ((lambda (syntmp-_-1656) (syntax-error syntmp-orig-x-1622))
syntmp-tmp-1652))) (syntax-dispatch syntmp-tmp-1652 (quote (any))))))
(syntax-dispatch syntmp-tmp-1652 (quote ())))) syntmp-s-1651)) syntmp-var-1626
syntmp-step-1628))) syntmp-tmp-1624) (syntax-error syntmp-tmp-1623)))
(syntax-dispatch syntmp-tmp-1623 (quote (any #(each (any any . any)) (any .
each-any) . each-any))))) syntmp-orig-x-1622)))
-(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1684
(lambda (syntmp-x-1688 syntmp-y-1689) ((lambda (syntmp-tmp-1690) ((lambda
(syntmp-tmp-1691) (if syntmp-tmp-1691 (apply (lambda (syntmp-x-1692
syntmp-y-1693) ((lambda (syntmp-tmp-1694) ((lambda (syntmp-tmp-1695) (if
syntmp-tmp-1695 (apply (lambda (syntmp-dy-1696) ((lambda (syntmp-tmp-1697)
((lambda (syntmp-tmp-1698) (if syntmp-tmp-1698 (apply (lambda (syntmp-dx-1699)
(list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i"))
#(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i"
"i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top)
(top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1699
syntmp-dy-1696))) syntmp-tmp-1698) ((lambda (syntmp-_-1700) (if (null?
syntmp-dy-1696) (list (quote #(syntax-object list ((top) #(ribcage #(_)
#((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y)
#((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi)
#((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))
syntmp-x-1692) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top))
#("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top))
#("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top)
(top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692
syntmp-y-1693))) syntmp-tmp-1697))) (syntax-dispatch syntmp-tmp-1697 (quote
(#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i"))
#(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () ()
()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(ice-9 syncase))) any))))) syntmp-x-1692)) syntmp-tmp-1695) ((lambda
(syntmp-tmp-1701) (if syntmp-tmp-1701 (apply (lambda (syntmp-stuff-1702) (cons
(quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i"))
#(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () ()
()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(ice-9 syncase))) (cons syntmp-x-1692 syntmp-stuff-1702))) syntmp-tmp-1701)
((lambda (syntmp-else-1703) (list (quote #(syntax-object cons ((top) #(ribcage
#(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage
() () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692 syntmp-y-1693))
syntmp-tmp-1694))) (syntax-dispatch syntmp-tmp-1694 (quote (#(free-id
#(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i"
"i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top)
(top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch
syntmp-tmp-1694 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage
#(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))
any))))) syntmp-y-1693)) syntmp-tmp-1691) (syntax-error syntmp-tmp-1690)))
(syntax-dispatch syntmp-tmp-1690 (quote (any any))))) (list syntmp-x-1688
syntmp-y-1689)))) (syntmp-quasiappend-1685 (lambda (syntmp-x-1704
syntmp-y-1705) ((lambda (syntmp-tmp-1706) ((lambda (syntmp-tmp-1707) (if
syntmp-tmp-1707 (apply (lambda (syntmp-x-1708 syntmp-y-1709) ((lambda
(syntmp-tmp-1710) ((lambda (syntmp-tmp-1711) (if syntmp-tmp-1711 (apply (lambda
() syntmp-x-1708) syntmp-tmp-1711) ((lambda (syntmp-_-1712) (list (quote
#(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage
#(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))
syntmp-x-1708 syntmp-y-1709)) syntmp-tmp-1710))) (syntax-dispatch
syntmp-tmp-1710 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage
#(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))
()))))) syntmp-y-1709)) syntmp-tmp-1707) (syntax-error syntmp-tmp-1706)))
(syntax-dispatch syntmp-tmp-1706 (quote (any any))))) (list syntmp-x-1704
syntmp-y-1705)))) (syntmp-quasivector-1686 (lambda (syntmp-x-1713) ((lambda
(syntmp-tmp-1714) ((lambda (syntmp-x-1715) ((lambda (syntmp-tmp-1716) ((lambda
(syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-x-1718) (list
(quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage
#(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector
syntmp-x-1718))) syntmp-tmp-1717) ((lambda (syntmp-tmp-1720) (if
syntmp-tmp-1720 (apply (lambda (syntmp-x-1721) (cons (quote #(syntax-object
vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i"))
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1721)) syntmp-tmp-1720)
((lambda (syntmp-_-1723) (list (quote #(syntax-object list->vector ((top)
#(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(ice-9 syncase))) syntmp-x-1715)) syntmp-tmp-1716))) (syntax-dispatch
syntmp-tmp-1716 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x)
#((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any))))))
(syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object quote ((top)
#(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))
each-any))))) syntmp-x-1715)) syntmp-tmp-1714)) syntmp-x-1713)))
(syntmp-quasi-1687 (lambda (syntmp-p-1724 syntmp-lev-1725) ((lambda
(syntmp-tmp-1726) ((lambda (syntmp-tmp-1727) (if syntmp-tmp-1727 (apply (lambda
(syntmp-p-1728) (if (= syntmp-lev-1725 0) syntmp-p-1728 (syntmp-quasicons-1684
(quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage
() () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i"))
#(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage
#(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i"
"i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1728) (-
syntmp-lev-1725 1))))) syntmp-tmp-1727) ((lambda (syntmp-tmp-1729) (if
syntmp-tmp-1729 (apply (lambda (syntmp-p-1730 syntmp-q-1731) (if (=
syntmp-lev-1725 0) (syntmp-quasiappend-1685 syntmp-p-1730 (syntmp-quasi-1687
syntmp-q-1731 syntmp-lev-1725)) (syntmp-quasicons-1684 (syntmp-quasicons-1684
(quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top)
#(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p
lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))))
(syntmp-quasi-1687 (list syntmp-p-1730) (- syntmp-lev-1725 1)))
(syntmp-quasi-1687 syntmp-q-1731 syntmp-lev-1725)))) syntmp-tmp-1729) ((lambda
(syntmp-tmp-1732) (if syntmp-tmp-1732 (apply (lambda (syntmp-p-1733)
(syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p)
#((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i"
"i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top)
(top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top)
#(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top)
(top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687
(list syntmp-p-1733) (+ syntmp-lev-1725 1)))) syntmp-tmp-1732) ((lambda
(syntmp-tmp-1734) (if syntmp-tmp-1734 (apply (lambda (syntmp-p-1735
syntmp-q-1736) (syntmp-quasicons-1684 (syntmp-quasi-1687 syntmp-p-1735
syntmp-lev-1725) (syntmp-quasi-1687 syntmp-q-1736 syntmp-lev-1725)))
syntmp-tmp-1734) ((lambda (syntmp-tmp-1737) (if syntmp-tmp-1737 (apply (lambda
(syntmp-x-1738) (syntmp-quasivector-1686 (syntmp-quasi-1687 syntmp-x-1738
syntmp-lev-1725))) syntmp-tmp-1737) ((lambda (syntmp-p-1740) (list (quote
#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(ice-9 syncase))) syntmp-p-1740)) syntmp-tmp-1726))) (syntax-dispatch
syntmp-tmp-1726 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1726
(quote (any . any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (#(free-id
#(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev)
#((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi)
#((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))))
(syntax-dispatch syntmp-tmp-1726 (quote ((#(free-id #(syntax-object
unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top))
#("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top)
(top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any))))))
(syntax-dispatch syntmp-tmp-1726 (quote (#(free-id #(syntax-object unquote
((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1724)))) (lambda
(syntmp-x-1741) ((lambda (syntmp-tmp-1742) ((lambda (syntmp-tmp-1743) (if
syntmp-tmp-1743 (apply (lambda (syntmp-_-1744 syntmp-e-1745) (syntmp-quasi-1687
syntmp-e-1745 0)) syntmp-tmp-1743) (syntax-error syntmp-tmp-1742)))
(syntax-dispatch syntmp-tmp-1742 (quote (any any))))) syntmp-x-1741))))
-(install-global-transformer (quote include) (lambda (syntmp-x-1805) (letrec
((syntmp-read-file-1806 (lambda (syntmp-fn-1807 syntmp-k-1808) (let
((syntmp-p-1809 (open-input-file syntmp-fn-1807))) (let syntmp-f-1810
((syntmp-x-1811 (read syntmp-p-1809))) (if (eof-object? syntmp-x-1811) (begin
(close-input-port syntmp-p-1809) (quote ())) (cons (datum->syntax-object
syntmp-k-1808 syntmp-x-1811) (syntmp-f-1810 (read syntmp-p-1809)))))))))
((lambda (syntmp-tmp-1812) ((lambda (syntmp-tmp-1813) (if syntmp-tmp-1813
(apply (lambda (syntmp-k-1814 syntmp-filename-1815) (let ((syntmp-fn-1816
(syntax-object->datum syntmp-filename-1815))) ((lambda (syntmp-tmp-1817)
((lambda (syntmp-tmp-1818) (if syntmp-tmp-1818 (apply (lambda (syntmp-exp-1819)
(cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i"))
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i"))
#(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file)
((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))
syntmp-exp-1819)) syntmp-tmp-1818) (syntax-error syntmp-tmp-1817)))
(syntax-dispatch syntmp-tmp-1817 (quote each-any)))) (syntmp-read-file-1806
syntmp-fn-1816 syntmp-k-1814)))) syntmp-tmp-1813) (syntax-error
syntmp-tmp-1812))) (syntax-dispatch syntmp-tmp-1812 (quote (any any)))))
syntmp-x-1805))))
-(install-global-transformer (quote unquote) (lambda (syntmp-x-1836) ((lambda
(syntmp-tmp-1837) ((lambda (syntmp-tmp-1838) (if syntmp-tmp-1838 (apply (lambda
(syntmp-_-1839 syntmp-e-1840) (error (quote unquote) "expression ,~s not valid
outside of quasiquote" (syntax-object->datum syntmp-e-1840))) syntmp-tmp-1838)
(syntax-error syntmp-tmp-1837))) (syntax-dispatch syntmp-tmp-1837 (quote (any
any))))) syntmp-x-1836)))
-(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1846)
((lambda (syntmp-tmp-1847) ((lambda (syntmp-tmp-1848) (if syntmp-tmp-1848
(apply (lambda (syntmp-_-1849 syntmp-e-1850) (error (quote unquote-splicing)
"expression ,@~s not valid outside of quasiquote" (syntax-object->datum
syntmp-e-1850))) syntmp-tmp-1848) (syntax-error syntmp-tmp-1847)))
(syntax-dispatch syntmp-tmp-1847 (quote (any any))))) syntmp-x-1846)))
-(install-global-transformer (quote case) (lambda (syntmp-x-1856) ((lambda
(syntmp-tmp-1857) ((lambda (syntmp-tmp-1858) (if syntmp-tmp-1858 (apply (lambda
(syntmp-_-1859 syntmp-e-1860 syntmp-m1-1861 syntmp-m2-1862) ((lambda
(syntmp-tmp-1863) ((lambda (syntmp-body-1864) (list (quote #(syntax-object let
((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top)
(top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top)
#(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(ice-9 syncase))) syntmp-e-1860)) syntmp-body-1864)) syntmp-tmp-1863)) (let
syntmp-f-1865 ((syntmp-clause-1866 syntmp-m1-1861) (syntmp-clauses-1867
syntmp-m2-1862)) (if (null? syntmp-clauses-1867) ((lambda (syntmp-tmp-1869)
((lambda (syntmp-tmp-1870) (if syntmp-tmp-1870 (apply (lambda (syntmp-e1-1871
syntmp-e2-1872) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(ice-9 syncase))) (cons syntmp-e1-1871 syntmp-e2-1872))) syntmp-tmp-1870)
((lambda (syntmp-tmp-1874) (if syntmp-tmp-1874 (apply (lambda (syntmp-k-1875
syntmp-e1-1876 syntmp-e2-1877) (list (quote #(syntax-object if ((top) #(ribcage
#(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage
#(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2)
#((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv
((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage ()
() ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote
#(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top))
#("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))
(list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(ice-9 syncase))) syntmp-k-1875)) (cons (quote #(syntax-object begin ((top)
#(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ())
#(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
#(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1876
syntmp-e2-1877)))) syntmp-tmp-1874) ((lambda (syntmp-_-1880) (syntax-error
syntmp-x-1856)) syntmp-tmp-1869))) (syntax-dispatch syntmp-tmp-1869 (quote
(each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1869 (quote
(#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause
clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top)
(top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1866)
((lambda (syntmp-tmp-1881) ((lambda (syntmp-rest-1882) ((lambda
(syntmp-tmp-1883) ((lambda (syntmp-tmp-1884) (if syntmp-tmp-1884 (apply (lambda
(syntmp-k-1885 syntmp-e1-1886 syntmp-e2-1887) (list (quote #(syntax-object if
((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
#(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i"))
#(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote
#(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f
clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2)
#((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote
((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
#(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(ice-9 syncase))) syntmp-k-1885)) (cons (quote #(syntax-object begin ((top)
#(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest)
#((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top)
(top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top))
#("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9
syncase))) (cons syntmp-e1-1886 syntmp-e2-1887)) syntmp-rest-1882))
syntmp-tmp-1884) ((lambda (syntmp-_-1890) (syntax-error syntmp-x-1856))
syntmp-tmp-1883))) (syntax-dispatch syntmp-tmp-1883 (quote (each-any any .
each-any))))) syntmp-clause-1866)) syntmp-tmp-1881)) (syntmp-f-1865 (car
syntmp-clauses-1867) (cdr syntmp-clauses-1867))))))) syntmp-tmp-1858)
(syntax-error syntmp-tmp-1857))) (syntax-dispatch syntmp-tmp-1857 (quote (any
any any . each-any))))) syntmp-x-1856)))
-(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1920)
((lambda (syntmp-tmp-1921) ((lambda (syntmp-tmp-1922) (if syntmp-tmp-1922
(apply (lambda (syntmp-_-1923 syntmp-e-1924) (list (quote #(syntax-object
lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x
((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote
#(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote
#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list
(quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote
(#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))
(#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))
#(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote
#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))
syntmp-e-1924)) (list (cons syntmp-_-1923 (quote (#(syntax-object x ((top)
#(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(ice-9 syncase))) (cons syntmp-e-1924 (quote (#(syntax-object x ((top)
#(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(ice-9 syncase)))))))))) syntmp-tmp-1922) (syntax-error syntmp-tmp-1921)))
(syntax-dispatch syntmp-tmp-1921 (quote (any any))))) syntmp-x-1920)))
+(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
+(if #f #f)
+(letrec ((and-map*151 (lambda (f191 first190 . rest189) (let ((t192 (null?
first190))) (if t192 t192 (if (null? rest189) (letrec ((andmap193 (lambda
(first194) (let ((x195 (car first194)) (first196 (cdr first194))) (if (null?
first196) (f191 x195) (if (f191 x195) (andmap193 first196) #f)))))) (andmap193
first190)) (letrec ((andmap197 (lambda (first198 rest199) (let ((x200 (car
first198)) (xr201 (map car rest199)) (first202 (cdr first198)) (rest203 (map
cdr rest199))) (if (null? first202) (apply f191 (cons x200 xr201)) (if (apply
f191 (cons x200 xr201)) (andmap197 first202 rest203) #f)))))) (andmap197
first190 rest189)))))))) (letrec ((lambda-var-list296 (lambda (vars420) (letrec
((lvl421 (lambda (vars422 ls423 w424) (if (pair? vars422) (lvl421 (cdr vars422)
(cons (wrap276 (car vars422) w424 #f) ls423) w424) (if (id?248 vars422) (cons
(wrap276 vars422 w424 #f) ls423) (if (null? vars422) ls423 (if
(syntax-object?232 vars422) (lvl421 (syntax-object-expression233 vars422) ls423
(join-wraps267 w424 (syntax-object-wrap234 vars422))) (cons vars422
ls423)))))))) (lvl421 vars420 (quote ()) (quote (())))))) (gen-var295 (lambda
(id425) (let ((id426 (if (syntax-object?232 id425) (syntax-object-expression233
id425) id425))) (gensym (symbol->string id426))))) (strip294 (lambda (x427
w428) (if (memq (quote top) (wrap-marks251 w428)) x427 (letrec ((f429 (lambda
(x430) (if (syntax-object?232 x430) (strip294 (syntax-object-expression233
x430) (syntax-object-wrap234 x430)) (if (pair? x430) (let ((a431 (f429 (car
x430))) (d432 (f429 (cdr x430)))) (if (if (eq? a431 (car x430)) (eq? d432 (cdr
x430)) #f) x430 (cons a431 d432))) (if (vector? x430) (let ((old433
(vector->list x430))) (let ((new434 (map f429 old433))) (if (and-map*151 eq?
old433 new434) x430 (list->vector new434)))) x430)))))) (f429 x427)))))
(ellipsis?293 (lambda (x435) (if (nonsymbol-id?247 x435) (free-id=?271 x435
(quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip
ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause
chi-body chi-macro chi-application chi-expr chi chi-top syntax-type
chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition maybe-name-value!
build-global-assignment build-global-reference analyze-variable
build-lexical-assignment build-lexical-reference build-conditional
build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void292 (lambda ()
(build-void214 #f))) (eval-local-transformer291 (lambda (expanded436 mod437)
(let ((p438 (local-eval-hook211 expanded436 mod437))) (if (procedure? p438)
p438 (syntax-violation #f "nonprocedure transformer" p438)))))
(chi-local-syntax290 (lambda (rec?439 e440 r441 w442 s443 mod444 k445) ((lambda
(tmp446) ((lambda (tmp447) (if tmp447 (apply (lambda (_448 id449 val450 e1451
e2452) (let ((ids453 id449)) (if (not (valid-bound-ids?273 ids453))
(syntax-violation #f "duplicate bound keyword" e440) (let ((labels455
(gen-labels254 ids453))) (let ((new-w456 (make-binding-wrap265 ids453 labels455
w442))) (k445 (cons e1451 e2452) (extend-env242 labels455 (let ((w458 (if
rec?439 new-w456 w442)) (trans-r459 (macros-only-env244 r441))) (map (lambda
(x460) (cons (quote macro) (eval-local-transformer291 (chi284 x460 trans-r459
w458 mod444) mod444))) val450)) r441) new-w456 s443 mod444)))))) tmp447)
((lambda (_462) (syntax-violation #f "bad local syntax definition"
(source-wrap277 e440 w442 s443 mod444))) tmp446))) ($sc-dispatch tmp446 (quote
(any #(each (any any)) any . each-any))))) e440))) (chi-lambda-clause289
(lambda (e463 docstring464 c465 r466 w467 mod468 k469) ((lambda (tmp470)
((lambda (tmp471) (if (if tmp471 (apply (lambda (args472 doc473 e1474 e2475)
(if (string? (syntax->datum doc473)) (not docstring464) #f)) tmp471) #f) (apply
(lambda (args476 doc477 e1478 e2479) (chi-lambda-clause289 e463 doc477 (cons
args476 (cons e1478 e2479)) r466 w467 mod468 k469)) tmp471) ((lambda (tmp481)
(if tmp481 (apply (lambda (id482 e1483 e2484) (let ((ids485 id482)) (if (not
(valid-bound-ids?273 ids485)) (syntax-violation (quote lambda) "invalid
parameter list" e463) (let ((labels487 (gen-labels254 ids485)) (new-vars488
(map gen-var295 ids485))) (k469 (map syntax->datum ids485) new-vars488 (if
docstring464 (syntax->datum docstring464) #f) (chi-body288 (cons e1483 e2484)
e463 (extend-var-env243 labels487 new-vars488 r466) (make-binding-wrap265
ids485 labels487 w467) mod468)))))) tmp481) ((lambda (tmp490) (if tmp490 (apply
(lambda (ids491 e1492 e2493) (let ((old-ids494 (lambda-var-list296 ids491)))
(if (not (valid-bound-ids?273 old-ids494)) (syntax-violation (quote lambda)
"invalid parameter list" e463) (let ((labels495 (gen-labels254 old-ids494))
(new-vars496 (map gen-var295 old-ids494))) (k469 (letrec ((f497 (lambda (ls1498
ls2499) (if (null? ls1498) (syntax->datum ls2499) (f497 (cdr ls1498) (cons
(syntax->datum (car ls1498)) ls2499)))))) (f497 (cdr old-ids494) (car
old-ids494))) (letrec ((f500 (lambda (ls1501 ls2502) (if (null? ls1501) ls2502
(f500 (cdr ls1501) (cons (car ls1501) ls2502)))))) (f500 (cdr new-vars496) (car
new-vars496))) (if docstring464 (syntax->datum docstring464) #f) (chi-body288
(cons e1492 e2493) e463 (extend-var-env243 labels495 new-vars496 r466)
(make-binding-wrap265 old-ids494 labels495 w467) mod468)))))) tmp490) ((lambda
(_504) (syntax-violation (quote lambda) "bad lambda" e463)) tmp470)))
($sc-dispatch tmp470 (quote (any any . each-any)))))) ($sc-dispatch tmp470
(quote (each-any any . each-any)))))) ($sc-dispatch tmp470 (quote (any any any
. each-any))))) c465))) (chi-body288 (lambda (body505 outer-form506 r507 w508
mod509) (let ((r510 (cons (quote ("placeholder" placeholder)) r507))) (let
((ribcage511 (make-ribcage255 (quote ()) (quote ()) (quote ())))) (let ((w512
(make-wrap250 (wrap-marks251 w508) (cons ribcage511 (wrap-subst252 w508)))))
(letrec ((parse513 (lambda (body514 ids515 labels516 var-ids517 vars518 vals519
bindings520) (if (null? body514) (syntax-violation #f "no expressions in body"
outer-form506) (let ((e522 (cdar body514)) (er523 (caar body514)))
(call-with-values (lambda () (syntax-type282 e522 er523 (quote (()))
(source-annotation239 er523) ribcage511 mod509)) (lambda (type524 value525 e526
w527 s528 mod529) (if (memv type524 (quote (define-form))) (let ((id530
(wrap276 value525 w527 mod529)) (label531 (gen-label253))) (let ((var532
(gen-var295 id530))) (begin (extend-ribcage!264 ribcage511 id530 label531)
(parse513 (cdr body514) (cons id530 ids515) (cons label531 labels516) (cons
id530 var-ids517) (cons var532 vars518) (cons (cons er523 (wrap276 e526 w527
mod529)) vals519) (cons (cons (quote lexical) var532) bindings520))))) (if
(memv type524 (quote (define-syntax-form))) (let ((id533 (wrap276 value525 w527
mod529)) (label534 (gen-label253))) (begin (extend-ribcage!264 ribcage511 id533
label534) (parse513 (cdr body514) (cons id533 ids515) (cons label534 labels516)
var-ids517 vars518 vals519 (cons (cons (quote macro) (cons er523 (wrap276 e526
w527 mod529))) bindings520)))) (if (memv type524 (quote (begin-form))) ((lambda
(tmp535) ((lambda (tmp536) (if tmp536 (apply (lambda (_537 e1538) (parse513
(letrec ((f539 (lambda (forms540) (if (null? forms540) (cdr body514) (cons
(cons er523 (wrap276 (car forms540) w527 mod529)) (f539 (cdr forms540)))))))
(f539 e1538)) ids515 labels516 var-ids517 vars518 vals519 bindings520)) tmp536)
(syntax-violation #f "source expression failed to match any pattern" tmp535)))
($sc-dispatch tmp535 (quote (any . each-any))))) e526) (if (memv type524 (quote
(local-syntax-form))) (chi-local-syntax290 value525 e526 er523 w527 s528 mod529
(lambda (forms542 er543 w544 s545 mod546) (parse513 (letrec ((f547 (lambda
(forms548) (if (null? forms548) (cdr body514) (cons (cons er543 (wrap276 (car
forms548) w544 mod546)) (f547 (cdr forms548))))))) (f547 forms542)) ids515
labels516 var-ids517 vars518 vals519 bindings520))) (if (null? ids515)
(build-sequence227 #f (map (lambda (x549) (chi284 (cdr x549) (car x549) (quote
(())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528 mod529)) (cdr
body514)))) (begin (if (not (valid-bound-ids?273 ids515)) (syntax-violation #f
"invalid or duplicate identifier in definition" outer-form506)) (letrec
((loop550 (lambda (bs551 er-cache552 r-cache553) (if (not (null? bs551)) (let
((b554 (car bs551))) (if (eq? (car b554) (quote macro)) (let ((er555 (cadr
b554))) (let ((r-cache556 (if (eq? er555 er-cache552) r-cache553
(macros-only-env244 er555)))) (begin (set-cdr! b554 (eval-local-transformer291
(chi284 (cddr b554) r-cache556 (quote (())) mod529) mod529)) (loop550 (cdr
bs551) er555 r-cache556)))) (loop550 (cdr bs551) er-cache552 r-cache553)))))))
(loop550 bindings520 #f #f)) (set-cdr! r510 (extend-env242 labels516
bindings520 (cdr r510))) (build-letrec230 #f (map syntax->datum var-ids517)
vars518 (map (lambda (x557) (chi284 (cdr x557) (car x557) (quote (())) mod529))
vals519) (build-sequence227 #f (map (lambda (x558) (chi284 (cdr x558) (car
x558) (quote (())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528
mod529)) (cdr body514)))))))))))))))))) (parse513 (map (lambda (x521) (cons
r510 (wrap276 x521 w512 mod509))) body505) (quote ()) (quote ()) (quote ())
(quote ()) (quote ()) (quote ())))))))) (chi-macro287 (lambda (p559 e560 r561
w562 rib563 mod564) (letrec ((rebuild-macro-output565 (lambda (x566 m567) (if
(pair? x566) (cons (rebuild-macro-output565 (car x566) m567)
(rebuild-macro-output565 (cdr x566) m567)) (if (syntax-object?232 x566) (let
((w568 (syntax-object-wrap234 x566))) (let ((ms569 (wrap-marks251 w568)) (s570
(wrap-subst252 w568))) (if (if (pair? ms569) (eq? (car ms569) #f) #f)
(make-syntax-object231 (syntax-object-expression233 x566) (make-wrap250 (cdr
ms569) (if rib563 (cons rib563 (cdr s570)) (cdr s570)))
(syntax-object-module235 x566)) (make-syntax-object231
(syntax-object-expression233 x566) (make-wrap250 (cons m567 ms569) (if rib563
(cons rib563 (cons (quote shift) s570)) (cons (quote shift) s570))) (let
((pmod571 (procedure-module p559))) (if pmod571 (cons (quote hygiene)
(module-name pmod571)) (quote (hygiene guile)))))))) (if (vector? x566) (let
((n572 (vector-length x566))) (let ((v573 (make-vector n572))) (letrec
((loop574 (lambda (i575) (if (fx=208 i575 n572) (begin (if #f #f) v573) (begin
(vector-set! v573 i575 (rebuild-macro-output565 (vector-ref x566 i575) m567))
(loop574 (fx+206 i575 1))))))) (loop574 0)))) (if (symbol? x566)
(syntax-violation #f "encountered raw symbol in macro output" (source-wrap277
e560 w562 s mod564) x566) x566))))))) (rebuild-macro-output565 (p559 (wrap276
e560 (anti-mark263 w562) mod564)) (string #\m))))) (chi-application286 (lambda
(x576 e577 r578 w579 s580 mod581) ((lambda (tmp582) ((lambda (tmp583) (if
tmp583 (apply (lambda (e0584 e1585) (build-application215 s580 x576 (map
(lambda (e586) (chi284 e586 r578 w579 mod581)) e1585))) tmp583)
(syntax-violation #f "source expression failed to match any pattern" tmp582)))
($sc-dispatch tmp582 (quote (any . each-any))))) e577))) (chi-expr285 (lambda
(type588 value589 e590 r591 w592 s593 mod594) (if (memv type588 (quote
(lexical))) (build-lexical-reference217 (quote value) s593 e590 value589) (if
(memv type588 (quote (core external-macro))) (value589 e590 r591 w592 s593
mod594) (if (memv type588 (quote (module-ref))) (call-with-values (lambda ()
(value589 e590)) (lambda (id595 mod596) (build-global-reference220 s593 id595
mod596))) (if (memv type588 (quote (lexical-call))) (chi-application286
(build-lexical-reference217 (quote fun) (source-annotation239 (car e590)) (car
e590) value589) e590 r591 w592 s593 mod594) (if (memv type588 (quote
(global-call))) (chi-application286 (build-global-reference220
(source-annotation239 (car e590)) value589 (if (syntax-object?232 (car e590))
(syntax-object-module235 (car e590)) mod594)) e590 r591 w592 s593 mod594) (if
(memv type588 (quote (constant))) (build-data226 s593 (strip294 (source-wrap277
e590 w592 s593 mod594) (quote (())))) (if (memv type588 (quote (global)))
(build-global-reference220 s593 value589 mod594) (if (memv type588 (quote
(call))) (chi-application286 (chi284 (car e590) r591 w592 mod594) e590 r591
w592 s593 mod594) (if (memv type588 (quote (begin-form))) ((lambda (tmp597)
((lambda (tmp598) (if tmp598 (apply (lambda (_599 e1600 e2601) (chi-sequence278
(cons e1600 e2601) r591 w592 s593 mod594)) tmp598) (syntax-violation #f "source
expression failed to match any pattern" tmp597))) ($sc-dispatch tmp597 (quote
(any any . each-any))))) e590) (if (memv type588 (quote (local-syntax-form)))
(chi-local-syntax290 value589 e590 r591 w592 s593 mod594 chi-sequence278) (if
(memv type588 (quote (eval-when-form))) ((lambda (tmp603) ((lambda (tmp604) (if
tmp604 (apply (lambda (_605 x606 e1607 e2608) (let ((when-list609
(chi-when-list281 e590 x606 w592))) (if (memq (quote eval) when-list609)
(chi-sequence278 (cons e1607 e2608) r591 w592 s593 mod594) (chi-void292))))
tmp604) (syntax-violation #f "source expression failed to match any pattern"
tmp603))) ($sc-dispatch tmp603 (quote (any each-any any . each-any))))) e590)
(if (memv type588 (quote (define-form define-syntax-form))) (syntax-violation
#f "definition in expression context" e590 (wrap276 value589 w592 mod594)) (if
(memv type588 (quote (syntax))) (syntax-violation #f "reference to pattern
variable outside syntax form" (source-wrap277 e590 w592 s593 mod594)) (if (memv
type588 (quote (displaced-lexical))) (syntax-violation #f "reference to
identifier outside its scope" (source-wrap277 e590 w592 s593 mod594))
(syntax-violation #f "unexpected syntax" (source-wrap277 e590 w592 s593
mod594)))))))))))))))))) (chi284 (lambda (e612 r613 w614 mod615)
(call-with-values (lambda () (syntax-type282 e612 r613 w614
(source-annotation239 e612) #f mod615)) (lambda (type616 value617 e618 w619
s620 mod621) (chi-expr285 type616 value617 e618 r613 w619 s620 mod621)))))
(chi-top283 (lambda (e622 r623 w624 m625 esew626 mod627) (call-with-values
(lambda () (syntax-type282 e622 r623 w624 (source-annotation239 e622) #f
mod627)) (lambda (type635 value636 e637 w638 s639 mod640) (if (memv type635
(quote (begin-form))) ((lambda (tmp641) ((lambda (tmp642) (if tmp642 (apply
(lambda (_643) (chi-void292)) tmp642) ((lambda (tmp644) (if tmp644 (apply
(lambda (_645 e1646 e2647) (chi-top-sequence279 (cons e1646 e2647) r623 w638
s639 m625 esew626 mod640)) tmp644) (syntax-violation #f "source expression
failed to match any pattern" tmp641))) ($sc-dispatch tmp641 (quote (any any .
each-any)))))) ($sc-dispatch tmp641 (quote (any))))) e637) (if (memv type635
(quote (local-syntax-form))) (chi-local-syntax290 value636 e637 r623 w638 s639
mod640 (lambda (body649 r650 w651 s652 mod653) (chi-top-sequence279 body649
r650 w651 s652 m625 esew626 mod653))) (if (memv type635 (quote
(eval-when-form))) ((lambda (tmp654) ((lambda (tmp655) (if tmp655 (apply
(lambda (_656 x657 e1658 e2659) (let ((when-list660 (chi-when-list281 e637 x657
w638)) (body661 (cons e1658 e2659))) (if (eq? m625 (quote e)) (if (memq (quote
eval) when-list660) (chi-top-sequence279 body661 r623 w638 s639 (quote e)
(quote (eval)) mod640) (chi-void292)) (if (memq (quote load) when-list660) (if
(let ((t664 (memq (quote compile) when-list660))) (if t664 t664 (if (eq? m625
(quote c&e)) (memq (quote eval) when-list660) #f))) (chi-top-sequence279
body661 r623 w638 s639 (quote c&e) (quote (compile load)) mod640) (if (memq
m625 (quote (c c&e))) (chi-top-sequence279 body661 r623 w638 s639 (quote c)
(quote (load)) mod640) (chi-void292))) (if (let ((t665 (memq (quote compile)
when-list660))) (if t665 t665 (if (eq? m625 (quote c&e)) (memq (quote eval)
when-list660) #f))) (begin (top-level-eval-hook210 (chi-top-sequence279 body661
r623 w638 s639 (quote e) (quote (eval)) mod640) mod640) (chi-void292))
(chi-void292)))))) tmp655) (syntax-violation #f "source expression failed to
match any pattern" tmp654))) ($sc-dispatch tmp654 (quote (any each-any any .
each-any))))) e637) (if (memv type635 (quote (define-syntax-form))) (let ((n666
(id-var-name270 value636 w638)) (r667 (macros-only-env244 r623))) (if (memv
m625 (quote (c))) (if (memq (quote compile) esew626) (let ((e668
(chi-install-global280 n666 (chi284 e637 r667 w638 mod640)))) (begin
(top-level-eval-hook210 e668 mod640) (if (memq (quote load) esew626) e668
(chi-void292)))) (if (memq (quote load) esew626) (chi-install-global280 n666
(chi284 e637 r667 w638 mod640)) (chi-void292))) (if (memv m625 (quote (c&e)))
(let ((e669 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640))))
(begin (top-level-eval-hook210 e669 mod640) e669)) (begin (if (memq (quote
eval) esew626) (top-level-eval-hook210 (chi-install-global280 n666 (chi284 e637
r667 w638 mod640)) mod640)) (chi-void292))))) (if (memv type635 (quote
(define-form))) (let ((n670 (id-var-name270 value636 w638))) (let ((type671
(binding-type240 (lookup245 n670 r623 mod640)))) (if (memv type671 (quote
(global core macro module-ref))) (let ((x672 (build-global-definition223 s639
n670 (chi284 e637 r623 w638 mod640)))) (begin (if (eq? m625 (quote c&e))
(top-level-eval-hook210 x672 mod640)) x672)) (if (memv type671 (quote
(displaced-lexical))) (syntax-violation #f "identifier out of context" e637
(wrap276 value636 w638 mod640)) (syntax-violation #f "cannot define keyword at
top level" e637 (wrap276 value636 w638 mod640)))))) (let ((x673 (chi-expr285
type635 value636 e637 r623 w638 s639 mod640))) (begin (if (eq? m625 (quote
c&e)) (top-level-eval-hook210 x673 mod640)) x673))))))))))) (syntax-type282
(lambda (e674 r675 w676 s677 rib678 mod679) (if (symbol? e674) (let ((n680
(id-var-name270 e674 w676))) (let ((b681 (lookup245 n680 r675 mod679))) (let
((type682 (binding-type240 b681))) (if (memv type682 (quote (lexical))) (values
type682 (binding-value241 b681) e674 w676 s677 mod679) (if (memv type682 (quote
(global))) (values type682 n680 e674 w676 s677 mod679) (if (memv type682 (quote
(macro))) (syntax-type282 (chi-macro287 (binding-value241 b681) e674 r675 w676
rib678 mod679) r675 (quote (())) s677 rib678 mod679) (values type682
(binding-value241 b681) e674 w676 s677 mod679))))))) (if (pair? e674) (let
((first683 (car e674))) (if (id?248 first683) (let ((n684 (id-var-name270
first683 w676))) (let ((b685 (lookup245 n684 r675 (let ((t686 (if
(syntax-object?232 first683) (syntax-object-module235 first683) #f))) (if t686
t686 mod679))))) (let ((type687 (binding-type240 b685))) (if (memv type687
(quote (lexical))) (values (quote lexical-call) (binding-value241 b685) e674
w676 s677 mod679) (if (memv type687 (quote (global))) (values (quote
global-call) n684 e674 w676 s677 mod679) (if (memv type687 (quote (macro)))
(syntax-type282 (chi-macro287 (binding-value241 b685) e674 r675 w676 rib678
mod679) r675 (quote (())) s677 rib678 mod679) (if (memv type687 (quote (core
external-macro module-ref))) (values type687 (binding-value241 b685) e674 w676
s677 mod679) (if (memv type687 (quote (local-syntax))) (values (quote
local-syntax-form) (binding-value241 b685) e674 w676 s677 mod679) (if (memv
type687 (quote (begin))) (values (quote begin-form) #f e674 w676 s677 mod679)
(if (memv type687 (quote (eval-when))) (values (quote eval-when-form) #f e674
w676 s677 mod679) (if (memv type687 (quote (define))) ((lambda (tmp688)
((lambda (tmp689) (if (if tmp689 (apply (lambda (_690 name691 val692) (id?248
name691)) tmp689) #f) (apply (lambda (_693 name694 val695) (values (quote
define-form) name694 val695 w676 s677 mod679)) tmp689) ((lambda (tmp696) (if
(if tmp696 (apply (lambda (_697 name698 args699 e1700 e2701) (if (id?248
name698) (valid-bound-ids?273 (lambda-var-list296 args699)) #f)) tmp696) #f)
(apply (lambda (_702 name703 args704 e1705 e2706) (values (quote define-form)
(wrap276 name703 w676 mod679) (cons (quote #(syntax-object lambda ((top)
#(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i"
"i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage
#(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i"))
#(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var
strip ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition maybe-name-value!
build-global-assignment build-global-reference analyze-variable
build-lexical-assignment build-lexical-reference build-conditional
build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile))) (wrap276 (cons args704 (cons e1705
e2706)) w676 mod679)) (quote (())) s677 mod679)) tmp696) ((lambda (tmp708) (if
(if tmp708 (apply (lambda (_709 name710) (id?248 name710)) tmp708) #f) (apply
(lambda (_711 name712) (values (quote define-form) (wrap276 name712 w676
mod679) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var
strip ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition maybe-name-value!
build-global-assignment build-global-reference analyze-variable
build-lexical-assignment build-lexical-reference build-conditional
build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage
#(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod)
#((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer
chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr
chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence
chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids?
valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks
join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage
new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap
set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels
ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label
make-rename rename-marks rename-new rename-old subst-rename? wrap-subst
wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id?
global-extend lookup macros-only-env extend-var-env extend-env null-env
binding-value binding-type make-binding arg-check source-annotation no-source
set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression!
syntax-object-module syntax-object-wrap syntax-object-expression syntax-object?
make-syntax-object build-lexical-var build-letrec build-named-let build-let
build-sequence build-data build-primref build-lambda build-global-definition
maybe-name-value! build-global-assignment build-global-reference
analyze-variable build-lexical-assignment build-lexical-reference
build-conditional build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage
#(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod)
#((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage
(lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer
chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr
chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence
chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids?
valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks
join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage
new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap
set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels
ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label
make-rename rename-marks rename-new rename-old subst-rename? wrap-subst
wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id?
global-extend lookup macros-only-env extend-var-env extend-env null-env
binding-value binding-type make-binding arg-check source-annotation no-source
set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression!
syntax-object-module syntax-object-wrap syntax-object-expression syntax-object?
make-syntax-object build-lexical-var build-letrec build-named-let build-let
build-sequence build-data build-primref build-lambda build-global-definition
maybe-name-value! build-global-assignment build-global-reference
analyze-variable build-lexical-assignment build-lexical-reference
build-conditional build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s677 mod679)) tmp708)
(syntax-violation #f "source expression failed to match any pattern" tmp688)))
($sc-dispatch tmp688 (quote (any any)))))) ($sc-dispatch tmp688 (quote (any
(any . any) any . each-any)))))) ($sc-dispatch tmp688 (quote (any any any)))))
e674) (if (memv type687 (quote (define-syntax))) ((lambda (tmp713) ((lambda
(tmp714) (if (if tmp714 (apply (lambda (_715 name716 val717) (id?248 name716))
tmp714) #f) (apply (lambda (_718 name719 val720) (values (quote
define-syntax-form) name719 val720 w676 s677 mod679)) tmp714) (syntax-violation
#f "source expression failed to match any pattern" tmp713))) ($sc-dispatch
tmp713 (quote (any any any))))) e674) (values (quote call) #f e674 w676 s677
mod679))))))))))))) (values (quote call) #f e674 w676 s677 mod679))) (if
(syntax-object?232 e674) (syntax-type282 (syntax-object-expression233 e674)
r675 (join-wraps267 w676 (syntax-object-wrap234 e674)) s677 rib678 (let ((t721
(syntax-object-module235 e674))) (if t721 t721 mod679))) (if (self-evaluating?
e674) (values (quote constant) #f e674 w676 s677 mod679) (values (quote other)
#f e674 w676 s677 mod679))))))) (chi-when-list281 (lambda (e722 when-list723
w724) (letrec ((f725 (lambda (when-list726 situations727) (if (null?
when-list726) situations727 (f725 (cdr when-list726) (cons (let ((x728 (car
when-list726))) (if (free-id=?271 x728 (quote #(syntax-object compile ((top)
#(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e
when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list
gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax
chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top
syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence
source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids?
bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append
make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark
the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels!
set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks
ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename
rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks
make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup
macros-only-env extend-var-env extend-env null-env binding-value binding-type
make-binding arg-check source-annotation no-source set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition maybe-name-value!
build-global-assignment build-global-reference analyze-variable
build-lexical-assignment build-lexical-reference build-conditional
build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?271
x728 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition maybe-name-value!
build-global-assignment build-global-reference analyze-variable
build-lexical-assignment build-lexical-reference build-conditional
build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?271
x728 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition maybe-name-value!
build-global-assignment build-global-reference analyze-variable
build-lexical-assignment build-lexical-reference build-conditional
build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation
(quote eval-when) "invalid situation" e722 (wrap276 x728 w724 #f))))))
situations727)))))) (f725 when-list723 (quote ()))))) (chi-install-global280
(lambda (name729 e730) (build-global-definition223 #f name729 (if (let ((v731
(module-variable (current-module) name729))) (if v731 (if (variable-bound?
v731) (if (macro? (variable-ref v731)) (not (eq? (macro-type (variable-ref
v731)) (quote syncase-macro))) #f) #f) #f)) (build-application215 #f
(build-primref225 #f (quote make-extended-syncase-macro)) (list
(build-application215 #f (build-primref225 #f (quote module-ref)) (list
(build-application215 #f (build-primref225 #f (quote current-module)) (quote
())) (build-data226 #f name729))) (build-data226 #f (quote macro)) e730))
(build-application215 #f (build-primref225 #f (quote make-syncase-macro)) (list
(build-data226 #f (quote macro)) e730)))))) (chi-top-sequence279 (lambda
(body732 r733 w734 s735 m736 esew737 mod738) (build-sequence227 s735 (letrec
((dobody739 (lambda (body740 r741 w742 m743 esew744 mod745) (if (null? body740)
(quote ()) (let ((first746 (chi-top283 (car body740) r741 w742 m743 esew744
mod745))) (cons first746 (dobody739 (cdr body740) r741 w742 m743 esew744
mod745))))))) (dobody739 body732 r733 w734 m736 esew737 mod738)))))
(chi-sequence278 (lambda (body747 r748 w749 s750 mod751) (build-sequence227
s750 (letrec ((dobody752 (lambda (body753 r754 w755 mod756) (if (null? body753)
(quote ()) (let ((first757 (chi284 (car body753) r754 w755 mod756))) (cons
first757 (dobody752 (cdr body753) r754 w755 mod756))))))) (dobody752 body747
r748 w749 mod751))))) (source-wrap277 (lambda (x758 w759 s760 defmod761) (begin
(if (if s760 (pair? x758) #f) (set-source-properties! x758 s760)) (wrap276 x758
w759 defmod761)))) (wrap276 (lambda (x762 w763 defmod764) (if (if (null?
(wrap-marks251 w763)) (null? (wrap-subst252 w763)) #f) x762 (if
(syntax-object?232 x762) (make-syntax-object231 (syntax-object-expression233
x762) (join-wraps267 w763 (syntax-object-wrap234 x762))
(syntax-object-module235 x762)) (if (null? x762) x762 (make-syntax-object231
x762 w763 defmod764)))))) (bound-id-member?275 (lambda (x765 list766) (if (not
(null? list766)) (let ((t767 (bound-id=?272 x765 (car list766)))) (if t767 t767
(bound-id-member?275 x765 (cdr list766)))) #f))) (distinct-bound-ids?274
(lambda (ids768) (letrec ((distinct?769 (lambda (ids770) (let ((t771 (null?
ids770))) (if t771 t771 (if (not (bound-id-member?275 (car ids770) (cdr
ids770))) (distinct?769 (cdr ids770)) #f)))))) (distinct?769 ids768))))
(valid-bound-ids?273 (lambda (ids772) (if (letrec ((all-ids?773 (lambda
(ids774) (let ((t775 (null? ids774))) (if t775 t775 (if (id?248 (car ids774))
(all-ids?773 (cdr ids774)) #f)))))) (all-ids?773 ids772))
(distinct-bound-ids?274 ids772) #f))) (bound-id=?272 (lambda (i776 j777) (if
(if (syntax-object?232 i776) (syntax-object?232 j777) #f) (if (eq?
(syntax-object-expression233 i776) (syntax-object-expression233 j777))
(same-marks?269 (wrap-marks251 (syntax-object-wrap234 i776)) (wrap-marks251
(syntax-object-wrap234 j777))) #f) (eq? i776 j777)))) (free-id=?271 (lambda
(i778 j779) (if (eq? (let ((x780 i778)) (if (syntax-object?232 x780)
(syntax-object-expression233 x780) x780)) (let ((x781 j779)) (if
(syntax-object?232 x781) (syntax-object-expression233 x781) x781))) (eq?
(id-var-name270 i778 (quote (()))) (id-var-name270 j779 (quote (())))) #f)))
(id-var-name270 (lambda (id782 w783) (letrec ((search-vector-rib786 (lambda
(sym792 subst793 marks794 symnames795 ribcage796) (let ((n797 (vector-length
symnames795))) (letrec ((f798 (lambda (i799) (if (fx=208 i799 n797) (search784
sym792 (cdr subst793) marks794) (if (if (eq? (vector-ref symnames795 i799)
sym792) (same-marks?269 marks794 (vector-ref (ribcage-marks258 ribcage796)
i799)) #f) (values (vector-ref (ribcage-labels259 ribcage796) i799) marks794)
(f798 (fx+206 i799 1))))))) (f798 0))))) (search-list-rib785 (lambda (sym800
subst801 marks802 symnames803 ribcage804) (letrec ((f805 (lambda (symnames806
i807) (if (null? symnames806) (search784 sym800 (cdr subst801) marks802) (if
(if (eq? (car symnames806) sym800) (same-marks?269 marks802 (list-ref
(ribcage-marks258 ribcage804) i807)) #f) (values (list-ref (ribcage-labels259
ribcage804) i807) marks802) (f805 (cdr symnames806) (fx+206 i807 1))))))) (f805
symnames803 0)))) (search784 (lambda (sym808 subst809 marks810) (if (null?
subst809) (values #f marks810) (let ((fst811 (car subst809))) (if (eq? fst811
(quote shift)) (search784 sym808 (cdr subst809) (cdr marks810)) (let
((symnames812 (ribcage-symnames257 fst811))) (if (vector? symnames812)
(search-vector-rib786 sym808 subst809 marks810 symnames812 fst811)
(search-list-rib785 sym808 subst809 marks810 symnames812 fst811))))))))) (if
(symbol? id782) (let ((t813 (call-with-values (lambda () (search784 id782
(wrap-subst252 w783) (wrap-marks251 w783))) (lambda (x815 . ignore814) x815))))
(if t813 t813 id782)) (if (syntax-object?232 id782) (let ((id816
(syntax-object-expression233 id782)) (w1817 (syntax-object-wrap234 id782)))
(let ((marks818 (join-marks268 (wrap-marks251 w783) (wrap-marks251 w1817))))
(call-with-values (lambda () (search784 id816 (wrap-subst252 w783) marks818))
(lambda (new-id819 marks820) (let ((t821 new-id819)) (if t821 t821 (let ((t822
(call-with-values (lambda () (search784 id816 (wrap-subst252 w1817) marks820))
(lambda (x824 . ignore823) x824)))) (if t822 t822 id816))))))))
(syntax-violation (quote id-var-name) "invalid id" id782)))))) (same-marks?269
(lambda (x825 y826) (let ((t827 (eq? x825 y826))) (if t827 t827 (if (not (null?
x825)) (if (not (null? y826)) (if (eq? (car x825) (car y826)) (same-marks?269
(cdr x825) (cdr y826)) #f) #f) #f))))) (join-marks268 (lambda (m1828 m2829)
(smart-append266 m1828 m2829))) (join-wraps267 (lambda (w1830 w2831) (let
((m1832 (wrap-marks251 w1830)) (s1833 (wrap-subst252 w1830))) (if (null? m1832)
(if (null? s1833) w2831 (make-wrap250 (wrap-marks251 w2831) (smart-append266
s1833 (wrap-subst252 w2831)))) (make-wrap250 (smart-append266 m1832
(wrap-marks251 w2831)) (smart-append266 s1833 (wrap-subst252 w2831)))))))
(smart-append266 (lambda (m1834 m2835) (if (null? m2835) m1834 (append m1834
m2835)))) (make-binding-wrap265 (lambda (ids836 labels837 w838) (if (null?
ids836) w838 (make-wrap250 (wrap-marks251 w838) (cons (let ((labelvec839
(list->vector labels837))) (let ((n840 (vector-length labelvec839))) (let
((symnamevec841 (make-vector n840)) (marksvec842 (make-vector n840))) (begin
(letrec ((f843 (lambda (ids844 i845) (if (not (null? ids844)) (call-with-values
(lambda () (id-sym-name&marks249 (car ids844) w838)) (lambda (symname846
marks847) (begin (vector-set! symnamevec841 i845 symname846) (vector-set!
marksvec842 i845 marks847) (f843 (cdr ids844) (fx+206 i845 1))))))))) (f843
ids836 0)) (make-ribcage255 symnamevec841 marksvec842 labelvec839)))))
(wrap-subst252 w838)))))) (extend-ribcage!264 (lambda (ribcage848 id849
label850) (begin (set-ribcage-symnames!260 ribcage848 (cons
(syntax-object-expression233 id849) (ribcage-symnames257 ribcage848)))
(set-ribcage-marks!261 ribcage848 (cons (wrap-marks251 (syntax-object-wrap234
id849)) (ribcage-marks258 ribcage848))) (set-ribcage-labels!262 ribcage848
(cons label850 (ribcage-labels259 ribcage848)))))) (anti-mark263 (lambda (w851)
(make-wrap250 (cons #f (wrap-marks251 w851)) (cons (quote shift) (wrap-subst252
w851))))) (set-ribcage-labels!262 (lambda (x852 update853) (vector-set! x852 3
update853))) (set-ribcage-marks!261 (lambda (x854 update855) (vector-set! x854
2 update855))) (set-ribcage-symnames!260 (lambda (x856 update857) (vector-set!
x856 1 update857))) (ribcage-labels259 (lambda (x858) (vector-ref x858 3)))
(ribcage-marks258 (lambda (x859) (vector-ref x859 2))) (ribcage-symnames257
(lambda (x860) (vector-ref x860 1))) (ribcage?256 (lambda (x861) (if (vector?
x861) (if (= (vector-length x861) 4) (eq? (vector-ref x861 0) (quote ribcage))
#f) #f))) (make-ribcage255 (lambda (symnames862 marks863 labels864) (vector
(quote ribcage) symnames862 marks863 labels864))) (gen-labels254 (lambda
(ls865) (if (null? ls865) (quote ()) (cons (gen-label253) (gen-labels254 (cdr
ls865)))))) (gen-label253 (lambda () (string #\i))) (wrap-subst252 cdr)
(wrap-marks251 car) (make-wrap250 cons) (id-sym-name&marks249 (lambda (x866
w867) (if (syntax-object?232 x866) (values (syntax-object-expression233 x866)
(join-marks268 (wrap-marks251 w867) (wrap-marks251 (syntax-object-wrap234
x866)))) (values x866 (wrap-marks251 w867))))) (id?248 (lambda (x868) (if
(symbol? x868) #t (if (syntax-object?232 x868) (symbol?
(syntax-object-expression233 x868)) #f)))) (nonsymbol-id?247 (lambda (x869) (if
(syntax-object?232 x869) (symbol? (syntax-object-expression233 x869)) #f)))
(global-extend246 (lambda (type870 sym871 val872)
(put-global-definition-hook212 sym871 type870 val872))) (lookup245 (lambda
(x873 r874 mod875) (let ((t876 (assq x873 r874))) (if t876 (cdr t876) (if
(symbol? x873) (let ((t877 (get-global-definition-hook213 x873 mod875))) (if
t877 t877 (quote (global)))) (quote (displaced-lexical)))))))
(macros-only-env244 (lambda (r878) (if (null? r878) (quote ()) (let ((a879 (car
r878))) (if (eq? (cadr a879) (quote macro)) (cons a879 (macros-only-env244 (cdr
r878))) (macros-only-env244 (cdr r878))))))) (extend-var-env243 (lambda
(labels880 vars881 r882) (if (null? labels880) r882 (extend-var-env243 (cdr
labels880) (cdr vars881) (cons (cons (car labels880) (cons (quote lexical) (car
vars881))) r882))))) (extend-env242 (lambda (labels883 bindings884 r885) (if
(null? labels883) r885 (extend-env242 (cdr labels883) (cdr bindings884) (cons
(cons (car labels883) (car bindings884)) r885))))) (binding-value241 cdr)
(binding-type240 car) (source-annotation239 (lambda (x886) (if
(syntax-object?232 x886) (source-annotation239 (syntax-object-expression233
x886)) (if (pair? x886) (let ((props887 (source-properties x886))) (if (pair?
props887) props887 #f)) #f)))) (set-syntax-object-module!238 (lambda (x888
update889) (vector-set! x888 3 update889))) (set-syntax-object-wrap!237 (lambda
(x890 update891) (vector-set! x890 2 update891)))
(set-syntax-object-expression!236 (lambda (x892 update893) (vector-set! x892 1
update893))) (syntax-object-module235 (lambda (x894) (vector-ref x894 3)))
(syntax-object-wrap234 (lambda (x895) (vector-ref x895 2)))
(syntax-object-expression233 (lambda (x896) (vector-ref x896 1)))
(syntax-object?232 (lambda (x897) (if (vector? x897) (if (= (vector-length
x897) 4) (eq? (vector-ref x897 0) (quote syntax-object)) #f) #f)))
(make-syntax-object231 (lambda (expression898 wrap899 module900) (vector (quote
syntax-object) expression898 wrap899 module900))) (build-letrec230 (lambda
(src901 ids902 vars903 val-exps904 body-exp905) (if (null? vars903) body-exp905
(let ((atom-key906 (fluid-ref *mode*205))) (if (memv atom-key906 (quote (c)))
(begin (for-each maybe-name-value!222 ids902 val-exps904) ((@ (language
tree-il) make-letrec) src901 ids902 vars903 val-exps904 body-exp905)) (list
(quote letrec) (map list vars903 val-exps904) body-exp905))))))
(build-named-let229 (lambda (src907 ids908 vars909 val-exps910 body-exp911)
(let ((f912 (car vars909)) (f-name913 (car ids908)) (vars914 (cdr vars909))
(ids915 (cdr ids908))) (let ((atom-key916 (fluid-ref *mode*205))) (if (memv
atom-key916 (quote (c))) (let ((proc917 (build-lambda224 src907 ids915 vars914
#f body-exp911))) (begin (maybe-name-value!222 f-name913 proc917) (for-each
maybe-name-value!222 ids915 val-exps910) ((@ (language tree-il) make-letrec)
src907 (list f-name913) (list f912) (list proc917) (build-application215 src907
(build-lexical-reference217 (quote fun) src907 f-name913 f912) val-exps910))))
(list (quote let) f912 (map list vars914 val-exps910) body-exp911))))))
(build-let228 (lambda (src918 ids919 vars920 val-exps921 body-exp922) (if
(null? vars920) body-exp922 (let ((atom-key923 (fluid-ref *mode*205))) (if
(memv atom-key923 (quote (c))) (begin (for-each maybe-name-value!222 ids919
val-exps921) ((@ (language tree-il) make-let) src918 ids919 vars920 val-exps921
body-exp922)) (list (quote let) (map list vars920 val-exps921)
body-exp922)))))) (build-sequence227 (lambda (src924 exps925) (if (null? (cdr
exps925)) (car exps925) (let ((atom-key926 (fluid-ref *mode*205))) (if (memv
atom-key926 (quote (c))) ((@ (language tree-il) make-sequence) src924 exps925)
(cons (quote begin) exps925)))))) (build-data226 (lambda (src927 exp928) (let
((atom-key929 (fluid-ref *mode*205))) (if (memv atom-key929 (quote (c))) ((@
(language tree-il) make-const) src927 exp928) (if (if (self-evaluating? exp928)
(not (vector? exp928)) #f) exp928 (list (quote quote) exp928))))))
(build-primref225 (lambda (src930 name931) (if (equal? (module-name
(current-module)) (quote (guile))) (let ((atom-key932 (fluid-ref *mode*205)))
(if (memv atom-key932 (quote (c))) ((@ (language tree-il) make-toplevel-ref)
src930 name931) name931)) (let ((atom-key933 (fluid-ref *mode*205))) (if (memv
atom-key933 (quote (c))) ((@ (language tree-il) make-module-ref) src930 (quote
(guile)) name931 #f) (list (quote @@) (quote (guile)) name931))))))
(build-lambda224 (lambda (src934 ids935 vars936 docstring937 exp938) (let
((atom-key939 (fluid-ref *mode*205))) (if (memv atom-key939 (quote (c))) ((@
(language tree-il) make-lambda) src934 ids935 vars936 (if docstring937 (list
(cons (quote documentation) docstring937)) (quote ())) exp938) (cons (quote
lambda) (cons vars936 (append (if docstring937 (list docstring937) (quote ()))
(list exp938)))))))) (build-global-definition223 (lambda (source940 var941
exp942) (let ((atom-key943 (fluid-ref *mode*205))) (if (memv atom-key943 (quote
(c))) (begin (maybe-name-value!222 var941 exp942) ((@ (language tree-il)
make-toplevel-define) source940 var941 exp942)) (list (quote define) var941
exp942))))) (maybe-name-value!222 (lambda (name944 val945) (if ((@ (language
tree-il) lambda?) val945) (let ((meta946 ((@ (language tree-il) lambda-meta)
val945))) (if (not (assq (quote name) meta946)) ((setter (@ (language tree-il)
lambda-meta)) val945 (acons (quote name) name944 meta946)))))))
(build-global-assignment221 (lambda (source947 var948 exp949 mod950)
(analyze-variable219 mod950 var948 (lambda (mod951 var952 public?953) (let
((atom-key954 (fluid-ref *mode*205))) (if (memv atom-key954 (quote (c))) ((@
(language tree-il) make-module-set) source947 mod951 var952 public?953 exp949)
(list (quote set!) (list (if public?953 (quote @) (quote @@)) mod951 var952)
exp949)))) (lambda (var955) (let ((atom-key956 (fluid-ref *mode*205))) (if
(memv atom-key956 (quote (c))) ((@ (language tree-il) make-toplevel-set)
source947 var955 exp949) (list (quote set!) var955 exp949)))))))
(build-global-reference220 (lambda (source957 var958 mod959)
(analyze-variable219 mod959 var958 (lambda (mod960 var961 public?962) (let
((atom-key963 (fluid-ref *mode*205))) (if (memv atom-key963 (quote (c))) ((@
(language tree-il) make-module-ref) source957 mod960 var961 public?962) (list
(if public?962 (quote @) (quote @@)) mod960 var961)))) (lambda (var964) (let
((atom-key965 (fluid-ref *mode*205))) (if (memv atom-key965 (quote (c))) ((@
(language tree-il) make-toplevel-ref) source957 var964) var964))))))
(analyze-variable219 (lambda (mod966 var967 modref-cont968 bare-cont969) (if
(not mod966) (bare-cont969 var967) (let ((kind970 (car mod966)) (mod971 (cdr
mod966))) (if (memv kind970 (quote (public))) (modref-cont968 mod971 var967 #t)
(if (memv kind970 (quote (private))) (if (not (equal? mod971 (module-name
(current-module)))) (modref-cont968 mod971 var967 #f) (bare-cont969 var967))
(if (memv kind970 (quote (bare))) (bare-cont969 var967) (if (memv kind970
(quote (hygiene))) (if (if (not (equal? mod971 (module-name (current-module))))
(module-variable (resolve-module mod971) var967) #f) (modref-cont968 mod971
var967 #f) (bare-cont969 var967)) (syntax-violation #f "bad module kind" var967
mod971))))))))) (build-lexical-assignment218 (lambda (source972 name973 var974
exp975) (let ((atom-key976 (fluid-ref *mode*205))) (if (memv atom-key976 (quote
(c))) ((@ (language tree-il) make-lexical-set) source972 name973 var974 exp975)
(list (quote set!) var974 exp975))))) (build-lexical-reference217 (lambda
(type977 source978 name979 var980) (let ((atom-key981 (fluid-ref *mode*205)))
(if (memv atom-key981 (quote (c))) ((@ (language tree-il) make-lexical-ref)
source978 name979 var980) var980)))) (build-conditional216 (lambda (source982
test-exp983 then-exp984 else-exp985) (let ((atom-key986 (fluid-ref *mode*205)))
(if (memv atom-key986 (quote (c))) ((@ (language tree-il) make-conditional)
source982 test-exp983 then-exp984 else-exp985) (if (equal? else-exp985 (quote
(if #f #f))) (list (quote if) test-exp983 then-exp984) (list (quote if)
test-exp983 then-exp984 else-exp985)))))) (build-application215 (lambda
(source987 fun-exp988 arg-exps989) (let ((atom-key990 (fluid-ref *mode*205)))
(if (memv atom-key990 (quote (c))) ((@ (language tree-il) make-application)
source987 fun-exp988 arg-exps989) (cons fun-exp988 arg-exps989)))))
(build-void214 (lambda (source991) (let ((atom-key992 (fluid-ref *mode*205)))
(if (memv atom-key992 (quote (c))) ((@ (language tree-il) make-void) source991)
(quote (if #f #f)))))) (get-global-definition-hook213 (lambda (symbol993
module994) (begin (if (if (not module994) (current-module) #f) (warn "module
system is booted, we should have a module" symbol993)) (let ((v995
(module-variable (if module994 (resolve-module (cdr module994))
(current-module)) symbol993))) (if v995 (if (variable-bound? v995) (let
((val996 (variable-ref v995))) (if (macro? val996) (if (syncase-macro-type
val996) (cons (syncase-macro-type val996) (syncase-macro-binding val996)) #f)
#f)) #f) #f))))) (put-global-definition-hook212 (lambda (symbol997 type998
val999) (let ((existing1000 (let ((v1001 (module-variable (current-module)
symbol997))) (if v1001 (if (variable-bound? v1001) (let ((val1002 (variable-ref
v1001))) (if (macro? val1002) (if (not (syncase-macro-type val1002)) val1002
#f) #f)) #f) #f)))) (module-define! (current-module) symbol997 (if existing1000
(make-extended-syncase-macro existing1000 type998 val999) (make-syncase-macro
type998 val999)))))) (local-eval-hook211 (lambda (x1003 mod1004)
(primitive-eval (list noexpand204 (let ((atom-key1005 (fluid-ref *mode*205)))
(if (memv atom-key1005 (quote (c))) ((@ (language tree-il) tree-il->scheme)
x1003) x1003)))))) (top-level-eval-hook210 (lambda (x1006 mod1007)
(primitive-eval (list noexpand204 (let ((atom-key1008 (fluid-ref *mode*205)))
(if (memv atom-key1008 (quote (c))) ((@ (language tree-il) tree-il->scheme)
x1006) x1006)))))) (fx<209 <) (fx=208 =) (fx-207 -) (fx+206 +) (*mode*205
(make-fluid)) (noexpand204 "noexpand")) (begin (global-extend246 (quote
local-syntax) (quote letrec-syntax) #t) (global-extend246 (quote local-syntax)
(quote let-syntax) #f) (global-extend246 (quote core) (quote fluid-let-syntax)
(lambda (e1009 r1010 w1011 s1012 mod1013) ((lambda (tmp1014) ((lambda (tmp1015)
(if (if tmp1015 (apply (lambda (_1016 var1017 val1018 e11019 e21020)
(valid-bound-ids?273 var1017)) tmp1015) #f) (apply (lambda (_1022 var1023
val1024 e11025 e21026) (let ((names1027 (map (lambda (x1028) (id-var-name270
x1028 w1011)) var1023))) (begin (for-each (lambda (id1030 n1031) (let
((atom-key1032 (binding-type240 (lookup245 n1031 r1010 mod1013)))) (if (memv
atom-key1032 (quote (displaced-lexical))) (syntax-violation (quote
fluid-let-syntax) "identifier out of context" e1009 (source-wrap277 id1030
w1011 s1012 mod1013))))) var1023 names1027) (chi-body288 (cons e11025 e21026)
(source-wrap277 e1009 w1011 s1012 mod1013) (extend-env242 names1027 (let
((trans-r1035 (macros-only-env244 r1010))) (map (lambda (x1036) (cons (quote
macro) (eval-local-transformer291 (chi284 x1036 trans-r1035 w1011 mod1013)
mod1013))) val1024)) r1010) w1011 mod1013)))) tmp1015) ((lambda (_1038)
(syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap277 e1009
w1011 s1012 mod1013))) tmp1014))) ($sc-dispatch tmp1014 (quote (any #(each (any
any)) any . each-any))))) e1009))) (global-extend246 (quote core) (quote quote)
(lambda (e1039 r1040 w1041 s1042 mod1043) ((lambda (tmp1044) ((lambda (tmp1045)
(if tmp1045 (apply (lambda (_1046 e1047) (build-data226 s1042 (strip294 e1047
w1041))) tmp1045) ((lambda (_1048) (syntax-violation (quote quote) "bad syntax"
(source-wrap277 e1039 w1041 s1042 mod1043))) tmp1044))) ($sc-dispatch tmp1044
(quote (any any))))) e1039))) (global-extend246 (quote core) (quote syntax)
(letrec ((regen1056 (lambda (x1057) (let ((atom-key1058 (car x1057))) (if (memv
atom-key1058 (quote (ref))) (build-lexical-reference217 (quote value) #f (cadr
x1057) (cadr x1057)) (if (memv atom-key1058 (quote (primitive)))
(build-primref225 #f (cadr x1057)) (if (memv atom-key1058 (quote (quote)))
(build-data226 #f (cadr x1057)) (if (memv atom-key1058 (quote (lambda)))
(build-lambda224 #f (cadr x1057) (cadr x1057) #f (regen1056 (caddr x1057)))
(build-application215 #f (build-primref225 #f (car x1057)) (map regen1056 (cdr
x1057)))))))))) (gen-vector1055 (lambda (x1059) (if (eq? (car x1059) (quote
list)) (cons (quote vector) (cdr x1059)) (if (eq? (car x1059) (quote quote))
(list (quote quote) (list->vector (cadr x1059))) (list (quote list->vector)
x1059))))) (gen-append1054 (lambda (x1060 y1061) (if (equal? y1061 (quote
(quote ()))) x1060 (list (quote append) x1060 y1061)))) (gen-cons1053 (lambda
(x1062 y1063) (let ((atom-key1064 (car y1063))) (if (memv atom-key1064 (quote
(quote))) (if (eq? (car x1062) (quote quote)) (list (quote quote) (cons (cadr
x1062) (cadr y1063))) (if (eq? (cadr y1063) (quote ())) (list (quote list)
x1062) (list (quote cons) x1062 y1063))) (if (memv atom-key1064 (quote (list)))
(cons (quote list) (cons x1062 (cdr y1063))) (list (quote cons) x1062
y1063)))))) (gen-map1052 (lambda (e1065 map-env1066) (let ((formals1067 (map
cdr map-env1066)) (actuals1068 (map (lambda (x1069) (list (quote ref) (car
x1069))) map-env1066))) (if (eq? (car e1065) (quote ref)) (car actuals1068) (if
(and-map (lambda (x1070) (if (eq? (car x1070) (quote ref)) (memq (cadr x1070)
formals1067) #f)) (cdr e1065)) (cons (quote map) (cons (list (quote primitive)
(car e1065)) (map (let ((r1071 (map cons formals1067 actuals1068))) (lambda
(x1072) (cdr (assq (cadr x1072) r1071)))) (cdr e1065)))) (cons (quote map)
(cons (list (quote lambda) formals1067 e1065) actuals1068)))))))
(gen-mappend1051 (lambda (e1073 map-env1074) (list (quote apply) (quote
(primitive append)) (gen-map1052 e1073 map-env1074)))) (gen-ref1050 (lambda
(src1075 var1076 level1077 maps1078) (if (fx=208 level1077 0) (values var1076
maps1078) (if (null? maps1078) (syntax-violation (quote syntax) "missing
ellipsis" src1075) (call-with-values (lambda () (gen-ref1050 src1075 var1076
(fx-207 level1077 1) (cdr maps1078))) (lambda (outer-var1079 outer-maps1080)
(let ((b1081 (assq outer-var1079 (car maps1078)))) (if b1081 (values (cdr
b1081) maps1078) (let ((inner-var1082 (gen-var295 (quote tmp)))) (values
inner-var1082 (cons (cons (cons outer-var1079 inner-var1082) (car maps1078))
outer-maps1080))))))))))) (gen-syntax1049 (lambda (src1083 e1084 r1085 maps1086
ellipsis?1087 mod1088) (if (id?248 e1084) (let ((label1089 (id-var-name270
e1084 (quote (()))))) (let ((b1090 (lookup245 label1089 r1085 mod1088))) (if
(eq? (binding-type240 b1090) (quote syntax)) (call-with-values (lambda () (let
((var.lev1091 (binding-value241 b1090))) (gen-ref1050 src1083 (car var.lev1091)
(cdr var.lev1091) maps1086))) (lambda (var1092 maps1093) (values (list (quote
ref) var1092) maps1093))) (if (ellipsis?1087 e1084) (syntax-violation (quote
syntax) "misplaced ellipsis" src1083) (values (list (quote quote) e1084)
maps1086))))) ((lambda (tmp1094) ((lambda (tmp1095) (if (if tmp1095 (apply
(lambda (dots1096 e1097) (ellipsis?1087 dots1096)) tmp1095) #f) (apply (lambda
(dots1098 e1099) (gen-syntax1049 src1083 e1099 r1085 maps1086 (lambda (x1100)
#f) mod1088)) tmp1095) ((lambda (tmp1101) (if (if tmp1101 (apply (lambda (x1102
dots1103 y1104) (ellipsis?1087 dots1103)) tmp1101) #f) (apply (lambda (x1105
dots1106 y1107) (letrec ((f1108 (lambda (y1109 k1110) ((lambda (tmp1114)
((lambda (tmp1115) (if (if tmp1115 (apply (lambda (dots1116 y1117)
(ellipsis?1087 dots1116)) tmp1115) #f) (apply (lambda (dots1118 y1119) (f1108
y1119 (lambda (maps1120) (call-with-values (lambda () (k1110 (cons (quote ())
maps1120))) (lambda (x1121 maps1122) (if (null? (car maps1122))
(syntax-violation (quote syntax) "extra ellipsis" src1083) (values
(gen-mappend1051 x1121 (car maps1122)) (cdr maps1122)))))))) tmp1115) ((lambda
(_1123) (call-with-values (lambda () (gen-syntax1049 src1083 y1109 r1085
maps1086 ellipsis?1087 mod1088)) (lambda (y1124 maps1125) (call-with-values
(lambda () (k1110 maps1125)) (lambda (x1126 maps1127) (values (gen-append1054
x1126 y1124) maps1127)))))) tmp1114))) ($sc-dispatch tmp1114 (quote (any .
any))))) y1109)))) (f1108 y1107 (lambda (maps1111) (call-with-values (lambda ()
(gen-syntax1049 src1083 x1105 r1085 (cons (quote ()) maps1111) ellipsis?1087
mod1088)) (lambda (x1112 maps1113) (if (null? (car maps1113)) (syntax-violation
(quote syntax) "extra ellipsis" src1083) (values (gen-map1052 x1112 (car
maps1113)) (cdr maps1113))))))))) tmp1101) ((lambda (tmp1128) (if tmp1128
(apply (lambda (x1129 y1130) (call-with-values (lambda () (gen-syntax1049
src1083 x1129 r1085 maps1086 ellipsis?1087 mod1088)) (lambda (x1131 maps1132)
(call-with-values (lambda () (gen-syntax1049 src1083 y1130 r1085 maps1132
ellipsis?1087 mod1088)) (lambda (y1133 maps1134) (values (gen-cons1053 x1131
y1133) maps1134)))))) tmp1128) ((lambda (tmp1135) (if tmp1135 (apply (lambda
(e11136 e21137) (call-with-values (lambda () (gen-syntax1049 src1083 (cons
e11136 e21137) r1085 maps1086 ellipsis?1087 mod1088)) (lambda (e1139 maps1140)
(values (gen-vector1055 e1139) maps1140)))) tmp1135) ((lambda (_1141) (values
(list (quote quote) e1084) maps1086)) tmp1094))) ($sc-dispatch tmp1094 (quote
#(vector (any . each-any))))))) ($sc-dispatch tmp1094 (quote (any . any))))))
($sc-dispatch tmp1094 (quote (any any . any)))))) ($sc-dispatch tmp1094 (quote
(any any))))) e1084))))) (lambda (e1142 r1143 w1144 s1145 mod1146) (let ((e1147
(source-wrap277 e1142 w1144 s1145 mod1146))) ((lambda (tmp1148) ((lambda
(tmp1149) (if tmp1149 (apply (lambda (_1150 x1151) (call-with-values (lambda ()
(gen-syntax1049 e1147 x1151 r1143 (quote ()) ellipsis?293 mod1146)) (lambda
(e1152 maps1153) (regen1056 e1152)))) tmp1149) ((lambda (_1154)
(syntax-violation (quote syntax) "bad `syntax' form" e1147)) tmp1148)))
($sc-dispatch tmp1148 (quote (any any))))) e1147))))) (global-extend246 (quote
core) (quote lambda) (lambda (e1155 r1156 w1157 s1158 mod1159) ((lambda
(tmp1160) ((lambda (tmp1161) (if tmp1161 (apply (lambda (_1162 c1163)
(chi-lambda-clause289 (source-wrap277 e1155 w1157 s1158 mod1159) #f c1163 r1156
w1157 mod1159 (lambda (names1164 vars1165 docstring1166 body1167)
(build-lambda224 s1158 names1164 vars1165 docstring1166 body1167)))) tmp1161)
(syntax-violation #f "source expression failed to match any pattern" tmp1160)))
($sc-dispatch tmp1160 (quote (any . any))))) e1155))) (global-extend246 (quote
core) (quote let) (letrec ((chi-let1168 (lambda (e1169 r1170 w1171 s1172
mod1173 constructor1174 ids1175 vals1176 exps1177) (if (not
(valid-bound-ids?273 ids1175)) (syntax-violation (quote let) "duplicate bound
variable" e1169) (let ((labels1178 (gen-labels254 ids1175)) (new-vars1179 (map
gen-var295 ids1175))) (let ((nw1180 (make-binding-wrap265 ids1175 labels1178
w1171)) (nr1181 (extend-var-env243 labels1178 new-vars1179 r1170)))
(constructor1174 s1172 (map syntax->datum ids1175) new-vars1179 (map (lambda
(x1182) (chi284 x1182 r1170 w1171 mod1173)) vals1176) (chi-body288 exps1177
(source-wrap277 e1169 nw1180 s1172 mod1173) nr1181 nw1180 mod1173))))))))
(lambda (e1183 r1184 w1185 s1186 mod1187) ((lambda (tmp1188) ((lambda (tmp1189)
(if (if tmp1189 (apply (lambda (_1190 id1191 val1192 e11193 e21194) (and-map
id?248 id1191)) tmp1189) #f) (apply (lambda (_1196 id1197 val1198 e11199
e21200) (chi-let1168 e1183 r1184 w1185 s1186 mod1187 build-let228 id1197
val1198 (cons e11199 e21200))) tmp1189) ((lambda (tmp1204) (if (if tmp1204
(apply (lambda (_1205 f1206 id1207 val1208 e11209 e21210) (if (id?248 f1206)
(and-map id?248 id1207) #f)) tmp1204) #f) (apply (lambda (_1212 f1213 id1214
val1215 e11216 e21217) (chi-let1168 e1183 r1184 w1185 s1186 mod1187
build-named-let229 (cons f1213 id1214) val1215 (cons e11216 e21217))) tmp1204)
((lambda (_1221) (syntax-violation (quote let) "bad let" (source-wrap277 e1183
w1185 s1186 mod1187))) tmp1188))) ($sc-dispatch tmp1188 (quote (any any #(each
(any any)) any . each-any)))))) ($sc-dispatch tmp1188 (quote (any #(each (any
any)) any . each-any))))) e1183)))) (global-extend246 (quote core) (quote
letrec) (lambda (e1222 r1223 w1224 s1225 mod1226) ((lambda (tmp1227) ((lambda
(tmp1228) (if (if tmp1228 (apply (lambda (_1229 id1230 val1231 e11232 e21233)
(and-map id?248 id1230)) tmp1228) #f) (apply (lambda (_1235 id1236 val1237
e11238 e21239) (let ((ids1240 id1236)) (if (not (valid-bound-ids?273 ids1240))
(syntax-violation (quote letrec) "duplicate bound variable" e1222) (let
((labels1242 (gen-labels254 ids1240)) (new-vars1243 (map gen-var295 ids1240)))
(let ((w1244 (make-binding-wrap265 ids1240 labels1242 w1224)) (r1245
(extend-var-env243 labels1242 new-vars1243 r1223))) (build-letrec230 s1225 (map
syntax->datum ids1240) new-vars1243 (map (lambda (x1246) (chi284 x1246 r1245
w1244 mod1226)) val1237) (chi-body288 (cons e11238 e21239) (source-wrap277
e1222 w1244 s1225 mod1226) r1245 w1244 mod1226))))))) tmp1228) ((lambda (_1249)
(syntax-violation (quote letrec) "bad letrec" (source-wrap277 e1222 w1224 s1225
mod1226))) tmp1227))) ($sc-dispatch tmp1227 (quote (any #(each (any any)) any .
each-any))))) e1222))) (global-extend246 (quote core) (quote set!) (lambda
(e1250 r1251 w1252 s1253 mod1254) ((lambda (tmp1255) ((lambda (tmp1256) (if (if
tmp1256 (apply (lambda (_1257 id1258 val1259) (id?248 id1258)) tmp1256) #f)
(apply (lambda (_1260 id1261 val1262) (let ((val1263 (chi284 val1262 r1251
w1252 mod1254)) (n1264 (id-var-name270 id1261 w1252))) (let ((b1265 (lookup245
n1264 r1251 mod1254))) (let ((atom-key1266 (binding-type240 b1265))) (if (memv
atom-key1266 (quote (lexical))) (build-lexical-assignment218 s1253
(syntax->datum id1261) (binding-value241 b1265) val1263) (if (memv atom-key1266
(quote (global))) (build-global-assignment221 s1253 n1264 val1263 mod1254) (if
(memv atom-key1266 (quote (displaced-lexical))) (syntax-violation (quote set!)
"identifier out of context" (wrap276 id1261 w1252 mod1254)) (syntax-violation
(quote set!) "bad set!" (source-wrap277 e1250 w1252 s1253 mod1254)))))))))
tmp1256) ((lambda (tmp1267) (if tmp1267 (apply (lambda (_1268 head1269 tail1270
val1271) (call-with-values (lambda () (syntax-type282 head1269 r1251 (quote
(())) #f #f mod1254)) (lambda (type1272 value1273 ee1274 ww1275 ss1276
modmod1277) (if (memv type1272 (quote (module-ref))) (let ((val1278 (chi284
val1271 r1251 w1252 mod1254))) (call-with-values (lambda () (value1273 (cons
head1269 tail1270))) (lambda (id1280 mod1281) (build-global-assignment221 s1253
id1280 val1278 mod1281)))) (build-application215 s1253 (chi284 (list (quote
#(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage
#(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip
ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause
chi-body chi-macro chi-application chi-expr chi chi-top syntax-type
chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition maybe-name-value!
build-global-assignment build-global-reference analyze-variable
build-lexical-assignment build-lexical-reference build-conditional
build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile))) head1269) r1251 w1252 mod1254) (map
(lambda (e1282) (chi284 e1282 r1251 w1252 mod1254)) (append tail1270 (list
val1271)))))))) tmp1267) ((lambda (_1284) (syntax-violation (quote set!) "bad
set!" (source-wrap277 e1250 w1252 s1253 mod1254))) tmp1255))) ($sc-dispatch
tmp1255 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1255 (quote
(any any any))))) e1250))) (global-extend246 (quote module-ref) (quote @)
(lambda (e1285) ((lambda (tmp1286) ((lambda (tmp1287) (if (if tmp1287 (apply
(lambda (_1288 mod1289 id1290) (if (and-map id?248 mod1289) (id?248 id1290)
#f)) tmp1287) #f) (apply (lambda (_1292 mod1293 id1294) (values (syntax->datum
id1294) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_
mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e)
#((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition maybe-name-value!
build-global-assignment build-global-reference analyze-variable
build-lexical-assignment build-lexical-reference build-conditional
build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile))) mod1293)))) tmp1287)
(syntax-violation #f "source expression failed to match any pattern" tmp1286)))
($sc-dispatch tmp1286 (quote (any each-any any))))) e1285))) (global-extend246
(quote module-ref) (quote @@) (lambda (e1296) ((lambda (tmp1297) ((lambda
(tmp1298) (if (if tmp1298 (apply (lambda (_1299 mod1300 id1301) (if (and-map
id?248 mod1300) (id?248 id1301) #f)) tmp1298) #f) (apply (lambda (_1303 mod1304
id1305) (values (syntax->datum id1305) (syntax->datum (cons (quote
#(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage
(lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer
chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr
chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence
chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids?
valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks
join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage
new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap
set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels
ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label
make-rename rename-marks rename-new rename-old subst-rename? wrap-subst
wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id?
global-extend lookup macros-only-env extend-var-env extend-env null-env
binding-value binding-type make-binding arg-check source-annotation no-source
set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression!
syntax-object-module syntax-object-wrap syntax-object-expression syntax-object?
make-syntax-object build-lexical-var build-letrec build-named-let build-let
build-sequence build-data build-primref build-lambda build-global-definition
maybe-name-value! build-global-assignment build-global-reference
analyze-variable build-lexical-assignment build-lexical-reference
build-conditional build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile))) mod1304)))) tmp1298)
(syntax-violation #f "source expression failed to match any pattern" tmp1297)))
($sc-dispatch tmp1297 (quote (any each-any any))))) e1296))) (global-extend246
(quote core) (quote if) (lambda (e1307 r1308 w1309 s1310 mod1311) ((lambda
(tmp1312) ((lambda (tmp1313) (if tmp1313 (apply (lambda (_1314 test1315
then1316) (build-conditional216 s1310 (chi284 test1315 r1308 w1309 mod1311)
(chi284 then1316 r1308 w1309 mod1311) (build-void214 #f))) tmp1313) ((lambda
(tmp1317) (if tmp1317 (apply (lambda (_1318 test1319 then1320 else1321)
(build-conditional216 s1310 (chi284 test1319 r1308 w1309 mod1311) (chi284
then1320 r1308 w1309 mod1311) (chi284 else1321 r1308 w1309 mod1311))) tmp1317)
(syntax-violation #f "source expression failed to match any pattern" tmp1312)))
($sc-dispatch tmp1312 (quote (any any any any)))))) ($sc-dispatch tmp1312
(quote (any any any))))) e1307))) (global-extend246 (quote begin) (quote begin)
(quote ())) (global-extend246 (quote define) (quote define) (quote ()))
(global-extend246 (quote define-syntax) (quote define-syntax) (quote ()))
(global-extend246 (quote eval-when) (quote eval-when) (quote ()))
(global-extend246 (quote core) (quote syntax-case) (letrec
((gen-syntax-case1325 (lambda (x1326 keys1327 clauses1328 r1329 mod1330) (if
(null? clauses1328) (build-application215 #f (build-primref225 #f (quote
syntax-violation)) (list (build-data226 #f #f) (build-data226 #f "source
expression failed to match any pattern") x1326)) ((lambda (tmp1331) ((lambda
(tmp1332) (if tmp1332 (apply (lambda (pat1333 exp1334) (if (if (id?248 pat1333)
(and-map (lambda (x1335) (not (free-id=?271 pat1333 x1335))) (cons (quote
#(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause
build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i"
"i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void
eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro
chi-application chi-expr chi chi-top syntax-type chi-when-list
chi-install-global chi-top-sequence chi-sequence source-wrap wrap
bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=?
id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap
extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked?
top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks!
set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage?
make-ribcage gen-labels gen-label make-rename rename-marks rename-new
rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks
id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env
extend-var-env extend-env null-env binding-value binding-type make-binding
arg-check source-annotation no-source set-syntax-object-module!
set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module
syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object
build-lexical-var build-letrec build-named-let build-let build-sequence
build-data build-primref build-lambda build-global-definition maybe-name-value!
build-global-assignment build-global-reference analyze-variable
build-lexical-assignment build-lexical-reference build-conditional
build-application build-void get-global-definition-hook
put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx<
fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)
(top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i"
"i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*)
((top) (top)) ("i" "i"))) (hygiene guile))) keys1327)) #f) (let ((labels1336
(list (gen-label253))) (var1337 (gen-var295 pat1333))) (build-application215 #f
(build-lambda224 #f (list (syntax->datum pat1333)) (list var1337) #f (chi284
exp1334 (extend-env242 labels1336 (list (cons (quote syntax) (cons var1337 0)))
r1329) (make-binding-wrap265 (list pat1333) labels1336 (quote (()))) mod1330))
(list x1326))) (gen-clause1324 x1326 keys1327 (cdr clauses1328) r1329 pat1333
#t exp1334 mod1330))) tmp1332) ((lambda (tmp1338) (if tmp1338 (apply (lambda
(pat1339 fender1340 exp1341) (gen-clause1324 x1326 keys1327 (cdr clauses1328)
r1329 pat1339 fender1340 exp1341 mod1330)) tmp1338) ((lambda (_1342)
(syntax-violation (quote syntax-case) "invalid clause" (car clauses1328)))
tmp1331))) ($sc-dispatch tmp1331 (quote (any any any)))))) ($sc-dispatch
tmp1331 (quote (any any))))) (car clauses1328))))) (gen-clause1324 (lambda
(x1343 keys1344 clauses1345 r1346 pat1347 fender1348 exp1349 mod1350)
(call-with-values (lambda () (convert-pattern1322 pat1347 keys1344)) (lambda
(p1351 pvars1352) (if (not (distinct-bound-ids?274 (map car pvars1352)))
(syntax-violation (quote syntax-case) "duplicate pattern variable" pat1347) (if
(not (and-map (lambda (x1353) (not (ellipsis?293 (car x1353)))) pvars1352))
(syntax-violation (quote syntax-case) "misplaced ellipsis" pat1347) (let
((y1354 (gen-var295 (quote tmp)))) (build-application215 #f (build-lambda224 #f
(list (quote tmp)) (list y1354) #f (let ((y1355 (build-lexical-reference217
(quote value) #f (quote tmp) y1354))) (build-conditional216 #f ((lambda
(tmp1356) ((lambda (tmp1357) (if tmp1357 (apply (lambda () y1355) tmp1357)
((lambda (_1358) (build-conditional216 #f y1355 (build-dispatch-call1323
pvars1352 fender1348 y1355 r1346 mod1350) (build-data226 #f #f))) tmp1356)))
($sc-dispatch tmp1356 (quote #(atom #t))))) fender1348)
(build-dispatch-call1323 pvars1352 exp1349 y1355 r1346 mod1350)
(gen-syntax-case1325 x1343 keys1344 clauses1345 r1346 mod1350)))) (list (if
(eq? p1351 (quote any)) (build-application215 #f (build-primref225 #f (quote
list)) (list x1343)) (build-application215 #f (build-primref225 #f (quote
$sc-dispatch)) (list x1343 (build-data226 #f p1351)))))))))))))
(build-dispatch-call1323 (lambda (pvars1359 exp1360 y1361 r1362 mod1363) (let
((ids1364 (map car pvars1359)) (levels1365 (map cdr pvars1359))) (let
((labels1366 (gen-labels254 ids1364)) (new-vars1367 (map gen-var295 ids1364)))
(build-application215 #f (build-primref225 #f (quote apply)) (list
(build-lambda224 #f (map syntax->datum ids1364) new-vars1367 #f (chi284 exp1360
(extend-env242 labels1366 (map (lambda (var1368 level1369) (cons (quote syntax)
(cons var1368 level1369))) new-vars1367 (map cdr pvars1359)) r1362)
(make-binding-wrap265 ids1364 labels1366 (quote (()))) mod1363)) y1361))))))
(convert-pattern1322 (lambda (pattern1370 keys1371) (letrec ((cvt1372 (lambda
(p1373 n1374 ids1375) (if (id?248 p1373) (if (bound-id-member?275 p1373
keys1371) (values (vector (quote free-id) p1373) ids1375) (values (quote any)
(cons (cons p1373 n1374) ids1375))) ((lambda (tmp1376) ((lambda (tmp1377) (if
(if tmp1377 (apply (lambda (x1378 dots1379) (ellipsis?293 dots1379)) tmp1377)
#f) (apply (lambda (x1380 dots1381) (call-with-values (lambda () (cvt1372 x1380
(fx+206 n1374 1) ids1375)) (lambda (p1382 ids1383) (values (if (eq? p1382
(quote any)) (quote each-any) (vector (quote each) p1382)) ids1383)))) tmp1377)
((lambda (tmp1384) (if tmp1384 (apply (lambda (x1385 y1386) (call-with-values
(lambda () (cvt1372 y1386 n1374 ids1375)) (lambda (y1387 ids1388)
(call-with-values (lambda () (cvt1372 x1385 n1374 ids1388)) (lambda (x1389
ids1390) (values (cons x1389 y1387) ids1390)))))) tmp1384) ((lambda (tmp1391)
(if tmp1391 (apply (lambda () (values (quote ()) ids1375)) tmp1391) ((lambda
(tmp1392) (if tmp1392 (apply (lambda (x1393) (call-with-values (lambda ()
(cvt1372 x1393 n1374 ids1375)) (lambda (p1395 ids1396) (values (vector (quote
vector) p1395) ids1396)))) tmp1392) ((lambda (x1397) (values (vector (quote
atom) (strip294 p1373 (quote (())))) ids1375)) tmp1376))) ($sc-dispatch tmp1376
(quote #(vector each-any)))))) ($sc-dispatch tmp1376 (quote ())))))
($sc-dispatch tmp1376 (quote (any . any)))))) ($sc-dispatch tmp1376 (quote (any
any))))) p1373))))) (cvt1372 pattern1370 0 (quote ())))))) (lambda (e1398 r1399
w1400 s1401 mod1402) (let ((e1403 (source-wrap277 e1398 w1400 s1401 mod1402)))
((lambda (tmp1404) ((lambda (tmp1405) (if tmp1405 (apply (lambda (_1406 val1407
key1408 m1409) (if (and-map (lambda (x1410) (if (id?248 x1410) (not
(ellipsis?293 x1410)) #f)) key1408) (let ((x1412 (gen-var295 (quote tmp))))
(build-application215 s1401 (build-lambda224 #f (list (quote tmp)) (list x1412)
#f (gen-syntax-case1325 (build-lexical-reference217 (quote value) #f (quote
tmp) x1412) key1408 m1409 r1399 mod1402)) (list (chi284 val1407 r1399 (quote
(())) mod1402)))) (syntax-violation (quote syntax-case) "invalid literals list"
e1403))) tmp1405) (syntax-violation #f "source expression failed to match any
pattern" tmp1404))) ($sc-dispatch tmp1404 (quote (any any each-any .
each-any))))) e1403))))) (set! sc-expand (lambda (x1416 . rest1415) (if (if
(pair? x1416) (equal? (car x1416) noexpand204) #f) (cadr x1416) (let ((m1417
(if (null? rest1415) (quote e) (car rest1415))) (esew1418 (if (let ((t1419
(null? rest1415))) (if t1419 t1419 (null? (cdr rest1415)))) (quote (eval))
(cadr rest1415)))) (with-fluid* *mode*205 m1417 (lambda () (chi-top283 x1416
(quote ()) (quote ((top))) m1417 esew1418 (cons (quote hygiene) (module-name
(current-module)))))))))) (set! identifier? (lambda (x1420) (nonsymbol-id?247
x1420))) (set! datum->syntax (lambda (id1421 datum1422) (make-syntax-object231
datum1422 (syntax-object-wrap234 id1421) #f))) (set! syntax->datum (lambda
(x1423) (strip294 x1423 (quote (()))))) (set! generate-temporaries (lambda
(ls1424) (begin (let ((x1425 ls1424)) (if (not (list? x1425)) (syntax-violation
(quote generate-temporaries) "invalid argument" x1425))) (map (lambda (x1426)
(wrap276 (gensym) (quote ((top))) #f)) ls1424)))) (set! free-identifier=?
(lambda (x1427 y1428) (begin (let ((x1429 x1427)) (if (not (nonsymbol-id?247
x1429)) (syntax-violation (quote free-identifier=?) "invalid argument" x1429)))
(let ((x1430 y1428)) (if (not (nonsymbol-id?247 x1430)) (syntax-violation
(quote free-identifier=?) "invalid argument" x1430))) (free-id=?271 x1427
y1428)))) (set! bound-identifier=? (lambda (x1431 y1432) (begin (let ((x1433
x1431)) (if (not (nonsymbol-id?247 x1433)) (syntax-violation (quote
bound-identifier=?) "invalid argument" x1433))) (let ((x1434 y1432)) (if (not
(nonsymbol-id?247 x1434)) (syntax-violation (quote bound-identifier=?) "invalid
argument" x1434))) (bound-id=?272 x1431 y1432)))) (set! syntax-violation
(lambda (who1438 message1437 form1436 . subform1435) (begin (let ((x1439
who1438)) (if (not ((lambda (x1440) (let ((t1441 (not x1440))) (if t1441 t1441
(let ((t1442 (string? x1440))) (if t1442 t1442 (symbol? x1440)))))) x1439))
(syntax-violation (quote syntax-violation) "invalid argument" x1439))) (let
((x1443 message1437)) (if (not (string? x1443)) (syntax-violation (quote
syntax-violation) "invalid argument" x1443))) (scm-error (quote syntax-error)
(quote sc-expand) (string-append (if who1438 "~a: " "") "~a " (if (null?
subform1435) "in ~a" "in subform `~s' of `~s'")) (let ((tail1444 (cons
message1437 (map (lambda (x1445) (strip294 x1445 (quote (())))) (append
subform1435 (list form1436)))))) (if who1438 (cons who1438 tail1444) tail1444))
#f)))) (letrec ((match1450 (lambda (e1451 p1452 w1453 r1454 mod1455) (if (not
r1454) #f (if (eq? p1452 (quote any)) (cons (wrap276 e1451 w1453 mod1455)
r1454) (if (syntax-object?232 e1451) (match*1449 (syntax-object-expression233
e1451) p1452 (join-wraps267 w1453 (syntax-object-wrap234 e1451)) r1454
(syntax-object-module235 e1451)) (match*1449 e1451 p1452 w1453 r1454
mod1455)))))) (match*1449 (lambda (e1456 p1457 w1458 r1459 mod1460) (if (null?
p1457) (if (null? e1456) r1459 #f) (if (pair? p1457) (if (pair? e1456)
(match1450 (car e1456) (car p1457) w1458 (match1450 (cdr e1456) (cdr p1457)
w1458 r1459 mod1460) mod1460) #f) (if (eq? p1457 (quote each-any)) (let ((l1461
(match-each-any1447 e1456 w1458 mod1460))) (if l1461 (cons l1461 r1459) #f))
(let ((atom-key1462 (vector-ref p1457 0))) (if (memv atom-key1462 (quote
(each))) (if (null? e1456) (match-empty1448 (vector-ref p1457 1) r1459) (let
((l1463 (match-each1446 e1456 (vector-ref p1457 1) w1458 mod1460))) (if l1463
(letrec ((collect1464 (lambda (l1465) (if (null? (car l1465)) r1459 (cons (map
car l1465) (collect1464 (map cdr l1465))))))) (collect1464 l1463)) #f))) (if
(memv atom-key1462 (quote (free-id))) (if (id?248 e1456) (if (free-id=?271
(wrap276 e1456 w1458 mod1460) (vector-ref p1457 1)) r1459 #f) #f) (if (memv
atom-key1462 (quote (atom))) (if (equal? (vector-ref p1457 1) (strip294 e1456
w1458)) r1459 #f) (if (memv atom-key1462 (quote (vector))) (if (vector? e1456)
(match1450 (vector->list e1456) (vector-ref p1457 1) w1458 r1459 mod1460)
#f))))))))))) (match-empty1448 (lambda (p1466 r1467) (if (null? p1466) r1467
(if (eq? p1466 (quote any)) (cons (quote ()) r1467) (if (pair? p1466)
(match-empty1448 (car p1466) (match-empty1448 (cdr p1466) r1467)) (if (eq?
p1466 (quote each-any)) (cons (quote ()) r1467) (let ((atom-key1468 (vector-ref
p1466 0))) (if (memv atom-key1468 (quote (each))) (match-empty1448 (vector-ref
p1466 1) r1467) (if (memv atom-key1468 (quote (free-id atom))) r1467 (if (memv
atom-key1468 (quote (vector))) (match-empty1448 (vector-ref p1466 1)
r1467))))))))))) (match-each-any1447 (lambda (e1469 w1470 mod1471) (if (pair?
e1469) (let ((l1472 (match-each-any1447 (cdr e1469) w1470 mod1471))) (if l1472
(cons (wrap276 (car e1469) w1470 mod1471) l1472) #f)) (if (null? e1469) (quote
()) (if (syntax-object?232 e1469) (match-each-any1447
(syntax-object-expression233 e1469) (join-wraps267 w1470 (syntax-object-wrap234
e1469)) mod1471) #f))))) (match-each1446 (lambda (e1473 p1474 w1475 mod1476)
(if (pair? e1473) (let ((first1477 (match1450 (car e1473) p1474 w1475 (quote
()) mod1476))) (if first1477 (let ((rest1478 (match-each1446 (cdr e1473) p1474
w1475 mod1476))) (if rest1478 (cons first1477 rest1478) #f)) #f)) (if (null?
e1473) (quote ()) (if (syntax-object?232 e1473) (match-each1446
(syntax-object-expression233 e1473) p1474 (join-wraps267 w1475
(syntax-object-wrap234 e1473)) (syntax-object-module235 e1473)) #f)))))) (set!
$sc-dispatch (lambda (e1479 p1480) (if (eq? p1480 (quote any)) (list e1479) (if
(syntax-object?232 e1479) (match*1449 (syntax-object-expression233 e1479) p1480
(syntax-object-wrap234 e1479) (quote ()) (syntax-object-module235 e1479))
(match*1449 e1479 p1480 (quote (())) (quote ()) #f)))))))))
+(define with-syntax (make-syncase-macro (quote macro) (lambda (x1481) ((lambda
(tmp1482) ((lambda (tmp1483) (if tmp1483 (apply (lambda (_1484 e11485 e21486)
(cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (cons e11485 e21486))) tmp1483) ((lambda (tmp1488) (if
tmp1488 (apply (lambda (_1489 out1490 in1491 e11492 e21493) (list (quote
#(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) in1491 (quote ()) (list out1490 (cons
(quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) (cons e11492 e21493))))) tmp1488) ((lambda
(tmp1495) (if tmp1495 (apply (lambda (_1496 out1497 in1498 e11499 e21500) (list
(quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top)
(top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list
((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) in1498) (quote ()) (list out1497 (cons (quote #(syntax-object begin
((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) (cons e11499 e21500))))) tmp1495) (syntax-violation #f "source
expression failed to match any pattern" tmp1482))) ($sc-dispatch tmp1482 (quote
(any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any
((any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any () any .
each-any))))) x1481))))
+(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1504)
((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (_1507 k1508
keyword1509 pattern1510 template1511) (list (quote #(syntax-object lambda
((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top))
#("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k
keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))
(cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern
template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage ()
() ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote
#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top)
(top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) (cons k1508 (map (lambda (tmp1514
tmp1513) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k
keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
tmp1513) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword
pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
tmp1514))) template1511 pattern1510)))))) tmp1506) (syntax-violation #f "source
expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote
(any each-any . #(each ((any . any) any))))))) x1504))))
+(define let* (make-extended-syncase-macro (module-ref (current-module) (quote
let*)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if
(if tmp1517 (apply (lambda (let*1518 x1519 v1520 e11521 e21522) (and-map
identifier? x1519)) tmp1517) #f) (apply (lambda (let*1524 x1525 v1526 e11527
e21528) (letrec ((f1529 (lambda (bindings1530) (if (null? bindings1530) (cons
(quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings)
#((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11527 e21528)))
((lambda (tmp1534) ((lambda (tmp1535) (if tmp1535 (apply (lambda (body1536
binding1537) (list (quote #(syntax-object let ((top) #(ribcage #(body binding)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top)
(top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top))
#("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (list binding1537) body1536)) tmp1535) (syntax-violation #f
"source expression failed to match any pattern" tmp1534))) ($sc-dispatch
tmp1534 (quote (any any))))) (list (f1529 (cdr bindings1530)) (car
bindings1530))))))) (f1529 (map list x1525 v1526)))) tmp1517) (syntax-violation
#f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch
tmp1516 (quote (any #(each (any any)) any . each-any))))) x1515))))
+(define do (make-extended-syncase-macro (module-ref (current-module) (quote
do)) (quote macro) (lambda (orig-x1538) ((lambda (tmp1539) ((lambda (tmp1540)
(if tmp1540 (apply (lambda (_1541 var1542 init1543 step1544 e01545 e11546
c1547) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda
(step1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda ()
(list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i"))
#(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x)
#((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top)
#(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top)
(top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list
var1542 init1543) (list (quote #(syntax-object if ((top) #(ribcage #(step)
#((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top)
(top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote
#(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var
init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i"
"i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(hygiene guile))) e01545) (cons (quote #(syntax-object begin ((top) #(ribcage
#(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top)
(top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () ()
()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1547 (list
(cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i"))
#(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top)
(top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x)
#((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1552) ((lambda (tmp1557)
(if tmp1557 (apply (lambda (e11558 e21559) (list (quote #(syntax-object let
((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top))
#("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop
((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top))
#("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1542 init1543) (list
(quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i"))
#(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top)
(top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01545 (cons
(quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i"
"i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c)
#((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile)))
(cons e11558 e21559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1
e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_
var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i"
"i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")))
(hygiene guile))) (append c1547 (list (cons (quote #(syntax-object doloop
((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top))
#("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top)
(top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(orig-x) #((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1557)
(syntax-violation #f "source expression failed to match any pattern" tmp1551)))
($sc-dispatch tmp1551 (quote (any . each-any)))))) ($sc-dispatch tmp1551 (quote
())))) e11546)) tmp1549) (syntax-violation #f "source expression failed to
match any pattern" tmp1548))) ($sc-dispatch tmp1548 (quote each-any)))) (map
(lambda (v1566 s1567) ((lambda (tmp1568) ((lambda (tmp1569) (if tmp1569 (apply
(lambda () v1566) tmp1569) ((lambda (tmp1570) (if tmp1570 (apply (lambda
(e1571) e1571) tmp1570) ((lambda (_1572) (syntax-violation (quote do) "bad step
expression" orig-x1538 s1567)) tmp1568))) ($sc-dispatch tmp1568 (quote
(any)))))) ($sc-dispatch tmp1568 (quote ())))) s1567)) var1542 step1544)))
tmp1540) (syntax-violation #f "source expression failed to match any pattern"
tmp1539))) ($sc-dispatch tmp1539 (quote (any #(each (any any . any)) (any .
each-any) . each-any))))) orig-x1538))))
+(define quasiquote (make-extended-syncase-macro (module-ref (current-module)
(quote quasiquote)) (quote macro) (letrec ((quasicons1575 (lambda (x1579 y1580)
((lambda (tmp1581) ((lambda (tmp1582) (if tmp1582 (apply (lambda (x1583 y1584)
((lambda (tmp1585) ((lambda (tmp1586) (if tmp1586 (apply (lambda (dy1587)
((lambda (tmp1588) ((lambda (tmp1589) (if tmp1589 (apply (lambda (dx1590) (list
(quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage
#(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage ()
() ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile))) (cons dx1590 dy1587))) tmp1589) ((lambda
(_1591) (if (null? dy1587) (list (quote #(syntax-object list ((top) #(ribcage
#(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y)
#((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi)
#((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583) (list
(quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage
#(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage ()
() ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile))) x1583 y1584))) tmp1588))) ($sc-dispatch
tmp1588 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top))
#("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage
#(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i"
"i" "i"))) (hygiene guile))) any))))) x1583)) tmp1586) ((lambda (tmp1592) (if
tmp1592 (apply (lambda (stuff1593) (cons (quote #(syntax-object list ((top)
#(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i"
"i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top)
(top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1583 stuff1593))) tmp1592)
((lambda (else1594) (list (quote #(syntax-object cons ((top) #(ribcage #(else)
#((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage
#(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i"
"i" "i"))) (hygiene guile))) x1583 y1584)) tmp1585))) ($sc-dispatch tmp1585
(quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top)
(top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any))))))
($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object quote ((top) #(ribcage
#(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend
quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene
guile))) any))))) y1584)) tmp1582) (syntax-violation #f "source expression
failed to match any pattern" tmp1581))) ($sc-dispatch tmp1581 (quote (any
any))))) (list x1579 y1580)))) (quasiappend1576 (lambda (x1595 y1596) ((lambda
(tmp1597) ((lambda (tmp1598) (if tmp1598 (apply (lambda (x1599 y1600) ((lambda
(tmp1601) ((lambda (tmp1602) (if tmp1602 (apply (lambda () x1599) tmp1602)
((lambda (_1603) (list (quote #(syntax-object append ((top) #(ribcage #(_)
#((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage
#(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i"
"i" "i"))) (hygiene guile))) x1599 y1600)) tmp1601))) ($sc-dispatch tmp1601
(quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top)
(top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1600))
tmp1598) (syntax-violation #f "source expression failed to match any pattern"
tmp1597))) ($sc-dispatch tmp1597 (quote (any any))))) (list x1595 y1596))))
(quasivector1577 (lambda (x1604) ((lambda (tmp1605) ((lambda (x1606) ((lambda
(tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (x1609) (list (quote
#(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x)
#((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector
x1609))) tmp1608) ((lambda (tmp1611) (if tmp1611 (apply (lambda (x1612) (cons
(quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage
#(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1612)) tmp1611)
((lambda (_1614) (list (quote #(syntax-object list->vector ((top) #(ribcage
#(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) x1606)) tmp1607))) ($sc-dispatch tmp1607 (quote (#(free-id
#(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ())
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) . each-any)))))) ($sc-dispatch tmp1607 (quote (#(free-id
#(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () ()
()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) each-any))))) x1606)) tmp1605)) x1604))) (quasi1578 (lambda
(p1615 lev1616) ((lambda (tmp1617) ((lambda (tmp1618) (if tmp1618 (apply
(lambda (p1619) (if (= lev1616 0) p1619 (quasicons1575 (quote (#(syntax-object
quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p
lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector
quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))
#(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile)))) (quasi1578 (list p1619) (- lev1616 1))))) tmp1618) ((lambda
(tmp1620) (if (if tmp1620 (apply (lambda (args1621) (= lev1616 0)) tmp1620) #f)
(apply (lambda (args1622) (syntax-violation (quote unquote) "unquote takes
exactly one argument" p1615 (cons (quote #(syntax-object unquote ((top)
#(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev)
#((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi)
#((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1622)))
tmp1620) ((lambda (tmp1623) (if tmp1623 (apply (lambda (p1624 q1625) (if (=
lev1616 0) (quasiappend1576 p1624 (quasi1578 q1625 lev1616)) (quasicons1575
(quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i"
"i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top)
(top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing
((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ())
#(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend
quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene
guile)))) (quasi1578 (list p1624) (- lev1616 1))) (quasi1578 q1625 lev1616))))
tmp1623) ((lambda (tmp1626) (if (if tmp1626 (apply (lambda (args1627 q1628) (=
lev1616 0)) tmp1626) #f) (apply (lambda (args1629 q1630) (syntax-violation
(quote unquote-splicing) "unquote-splicing takes exactly one argument" p1615
(cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top)
(top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top)
(top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1629))) tmp1626)
((lambda (tmp1631) (if tmp1631 (apply (lambda (p1632) (quasicons1575 (quote
(#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top))
#("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1632) (+ lev1616
1)))) tmp1631) ((lambda (tmp1633) (if tmp1633 (apply (lambda (p1634 q1635)
(quasicons1575 (quasi1578 p1634 lev1616) (quasi1578 q1635 lev1616))) tmp1633)
((lambda (tmp1636) (if tmp1636 (apply (lambda (x1637) (quasivector1577
(quasi1578 x1637 lev1616))) tmp1636) ((lambda (p1639) (list (quote
#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons
quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))
(hygiene guile))) p1639)) tmp1617))) ($sc-dispatch tmp1617 (quote #(vector
each-any)))))) ($sc-dispatch tmp1617 (quote (any . any)))))) ($sc-dispatch
tmp1617 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ())
#(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend
quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene
guile))) any)))))) ($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object
unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top))
#("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top)
(top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any))))))
($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object unquote-splicing
((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i"))
#(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top))
#("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1617
(quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage
#(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend
quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene
guile))) . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object
unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i"
"i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top)
(top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1615)))) (lambda
(x1640) ((lambda (tmp1641) ((lambda (tmp1642) (if tmp1642 (apply (lambda (_1643
e1644) (quasi1578 e1644 0)) tmp1642) (syntax-violation #f "source expression
failed to match any pattern" tmp1641))) ($sc-dispatch tmp1641 (quote (any
any))))) x1640)))))
+(define include (make-syncase-macro (quote macro) (lambda (x1645) (letrec
((read-file1646 (lambda (fn1647 k1648) (let ((p1649 (open-input-file fn1647)))
(letrec ((f1650 (lambda (x1651) (if (eof-object? x1651) (begin
(close-input-port p1649) (quote ())) (cons (datum->syntax k1648 x1651) (f1650
(read p1649))))))) (f1650 (read p1649))))))) ((lambda (tmp1652) ((lambda
(tmp1653) (if tmp1653 (apply (lambda (k1654 filename1655) (let ((fn1656
(syntax->datum filename1655))) ((lambda (tmp1657) ((lambda (tmp1658) (if
tmp1658 (apply (lambda (exp1659) (cons (quote #(syntax-object begin ((top)
#(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ())
#(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i"
"i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) exp1659)) tmp1658) (syntax-violation #f "source expression
failed to match any pattern" tmp1657))) ($sc-dispatch tmp1657 (quote
each-any)))) (read-file1646 fn1656 k1654)))) tmp1653) (syntax-violation #f
"source expression failed to match any pattern" tmp1652))) ($sc-dispatch
tmp1652 (quote (any any))))) x1645)))))
+(define unquote (make-syncase-macro (quote macro) (lambda (x1661) ((lambda
(tmp1662) ((lambda (tmp1663) (if tmp1663 (apply (lambda (_1664 e1665)
(syntax-violation (quote unquote) "expression not valid outside of quasiquote"
x1661)) tmp1663) (syntax-violation #f "source expression failed to match any
pattern" tmp1662))) ($sc-dispatch tmp1662 (quote (any any))))) x1661))))
+(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1666)
((lambda (tmp1667) ((lambda (tmp1668) (if tmp1668 (apply (lambda (_1669 e1670)
(syntax-violation (quote unquote-splicing) "expression not valid outside of
quasiquote" x1666)) tmp1668) (syntax-violation #f "source expression failed to
match any pattern" tmp1667))) ($sc-dispatch tmp1667 (quote (any any)))))
x1666))))
+(define case (make-extended-syncase-macro (module-ref (current-module) (quote
case)) (quote macro) (lambda (x1671) ((lambda (tmp1672) ((lambda (tmp1673) (if
tmp1673 (apply (lambda (_1674 e1675 m11676 m21677) ((lambda (tmp1678) ((lambda
(body1679) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top))
#("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list
(list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1675)) body1679))
tmp1678)) (letrec ((f1680 (lambda (clause1681 clauses1682) (if (null?
clauses1682) ((lambda (tmp1684) ((lambda (tmp1685) (if tmp1685 (apply (lambda
(e11686 e21687) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (cons e11686 e21687))) tmp1685) ((lambda (tmp1689) (if
tmp1689 (apply (lambda (k1690 e11691 e21692) (list (quote #(syntax-object if
((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage ()
() ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote
#(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i"
"i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top))
#("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
(quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i"
"i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top)
(top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) k1690)) (cons (quote #(syntax-object begin ((top) #(ribcage
#(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage
#(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2)
#((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) (cons e11691 e21692)))) tmp1689)
((lambda (_1695) (syntax-violation (quote case) "bad clause" x1671 clause1681))
tmp1684))) ($sc-dispatch tmp1684 (quote (each-any any . each-any))))))
($sc-dispatch tmp1684 (quote (#(free-id #(syntax-object else ((top) #(ribcage
() () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any .
each-any))))) clause1681) ((lambda (tmp1696) ((lambda (rest1697) ((lambda
(tmp1698) ((lambda (tmp1699) (if tmp1699 (apply (lambda (k1700 e11701 e21702)
(list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top)
(top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ())
#(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
#(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object
memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage
#(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses)
#((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top)
(top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top)
(top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () ()
()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage
() () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote
#(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i"
"i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f
clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2)
#((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage
#(x) #((top)) #("i"))) (hygiene guile))) k1700)) (cons (quote #(syntax-object
begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i"))
#(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause
clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top)
(top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x)
#((top)) #("i"))) (hygiene guile))) (cons e11701 e21702)) rest1697)) tmp1699)
((lambda (_1705) (syntax-violation (quote case) "bad clause" x1671 clause1681))
tmp1698))) ($sc-dispatch tmp1698 (quote (each-any any . each-any)))))
clause1681)) tmp1696)) (f1680 (car clauses1682) (cdr clauses1682))))))) (f1680
m11676 m21677)))) tmp1673) (syntax-violation #f "source expression failed to
match any pattern" tmp1672))) ($sc-dispatch tmp1672 (quote (any any any .
each-any))))) x1671))))
+(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1706)
((lambda (tmp1707) ((lambda (tmp1708) (if tmp1708 (apply (lambda (_1709 e1710)
(list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))
(list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
(quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i"))
#(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list
(quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i"
"i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))
e1710)) (list (cons _1709 (quote (#(syntax-object x ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top)
(top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile))) (cons e1710 (quote (#(syntax-object x ((top) #(ribcage #(_ e)
#((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))
(hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top))
#("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene
guile)))))))))) tmp1708) (syntax-violation #f "source expression failed to
match any pattern" tmp1707))) ($sc-dispatch tmp1707 (quote (any any)))))
x1706))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index cd2c532..c2668c0 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -22,6 +22,9 @@
;;; Extracted from Chez Scheme Version 5.9f
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
+;;; Modified by Andy Wingo <address@hidden> according to the Git
+;;; revision control logs corresponding to this file: 2009.
+
;;; Modified by Mikael Djurfeldt <address@hidden> according
;;; to the ChangeLog distributed in the same directory as this file:
;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
@@ -49,7 +52,7 @@
;;; also documented in the R4RS and draft R5RS.
;;;
;;; bound-identifier=?
-;;; datum->syntax-object
+;;; datum->syntax
;;; define-syntax
;;; fluid-let-syntax
;;; free-identifier=?
@@ -60,7 +63,7 @@
;;; letrec-syntax
;;; syntax
;;; syntax-case
-;;; syntax-object->datum
+;;; syntax->datum
;;; syntax-rules
;;; with-syntax
;;;
@@ -79,46 +82,14 @@
;;; conditionally evaluates expr ... at compile-time or run-time
;;; depending upon situations (see the Chez Scheme System Manual,
;;; Revision 3, for a complete description)
-;;; (syntax-error object message)
+;;; (syntax-violation who message form [subform])
;;; used to report errors found during expansion
-;;; (install-global-transformer symbol value)
-;;; used by expanded code to install top-level syntactic abstractions
-;;; (syntax-dispatch e p)
+;;; ($sc-dispatch e p)
;;; used by expanded code to handle syntax-case matching
;;; The following nonstandard procedures must be provided by the
-;;; implementation for this code to run.
-;;;
-;;; (void)
-;;; returns the implementation's cannonical "unspecified value". This
-;;; usually works: (define void (lambda () (if #f #f))).
-;;;
-;;; (andmap proc list1 list2 ...)
-;;; returns true if proc returns true when applied to each element of list1
-;;; along with the corresponding elements of list2 ....
-;;; The following definition works but does no error checking:
-;;;
-;;; (define andmap
-;;; (lambda (f first . rest)
-;;; (or (null? first)
-;;; (if (null? rest)
-;;; (let andmap ((first first))
-;;; (let ((x (car first)) (first (cdr first)))
-;;; (if (null? first)
-;;; (f x)
-;;; (and (f x) (andmap first)))))
-;;; (let andmap ((first first) (rest rest))
-;;; (let ((x (car first))
-;;; (xr (map car rest))
-;;; (first (cdr first))
-;;; (rest (map cdr rest)))
-;;; (if (null? first)
-;;; (apply f (cons x xr))
-;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
-;;;
-;;; The following nonstandard procedures must also be provided by the
;;; implementation for this code to run using the standard portable
-;;; hooks and output constructors. They are not used by expanded code,
+;;; hooks and output constructors. They are not used by expanded code,
;;; and so need be present only at expansion time.
;;;
;;; (eval x)
@@ -134,21 +105,8 @@
;;; by eval, and eval accepts one argument, nothing special must be done
;;; to support the "noexpand" flag, since it is handled by sc-expand.
;;;
-;;; (error who format-string why what)
-;;; where who is either a symbol or #f, format-string is always "~a ~s",
-;;; why is always a string, and what may be any object. error should
-;;; signal an error with a message something like
-;;;
-;;; "error in <who>: <why> <what>"
-;;;
;;; (gensym)
;;; returns a unique symbol each time it's called
-;;;
-;;; (putprop symbol key value)
-;;; (getprop symbol key)
-;;; key is always the symbol *sc-expander*; value may be any object.
-;;; putprop should associate the given value with the given symbol in
-;;; some way that it can be retrieved later with getprop.
;;; When porting to a new Scheme implementation, you should define the
;;; procedures listed above, load the expanded version of psyntax.ss
@@ -209,7 +167,7 @@
;;; Objects with no standard print syntax, including objects containing
;;; cycles and syntax object, are allowed in quoted data as long as they
-;;; are contained within a syntax form or produced by datum->syntax-object.
+;;; are contained within a syntax form or produced by datum->syntax.
;;; Such objects are never copied.
;;; All identifiers that don't have macro definitions and are not bound
@@ -233,19 +191,6 @@
;;; The implementation of generate-temporaries assumes that it is possible
;;; to generate globally unique symbols (gensyms).
-;;; The input to sc-expand may contain "annotations" describing, e.g., the
-;;; source file and character position from where each object was read if
-;;; it was read from a file. These annotations are handled properly by
-;;; sc-expand only if the annotation? hook (see hooks below) is implemented
-;;; properly and the operators make-annotation, annotation-expression,
-;;; annotation-source, annotation-stripped, and set-annotation-stripped!
-;;; are supplied. If annotations are supplied, the proper annotation
-;;; source is passed to the various output constructors, allowing
-;;; implementations to accurately correlate source and expanded code.
-;;; Contact one of the authors for details if you wish to make use of
-;;; this feature.
-
-
;;; Bootstrapping:
@@ -256,23 +201,45 @@
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
(let ()
+;;; Private version of and-map that handles multiple lists.
+(define and-map*
+ (lambda (f first . rest)
+ (or (null? first)
+ (if (null? rest)
+ (let andmap ((first first))
+ (let ((x (car first)) (first (cdr first)))
+ (if (null? first)
+ (f x)
+ (and (f x) (andmap first)))))
+ (let andmap ((first first) (rest rest))
+ (let ((x (car first))
+ (xr (map car rest))
+ (first (cdr first))
+ (rest (map cdr rest)))
+ (if (null? first)
+ (apply f (cons x xr))
+ (and (apply f (cons x xr)) (andmap first rest)))))))))
+
(define-syntax define-structure
(lambda (x)
(define construct-name
(lambda (template-identifier . args)
- (datum->syntax-object
+ (datum->syntax
template-identifier
(string->symbol
(apply string-append
(map (lambda (x)
(if (string? x)
x
- (symbol->string (syntax-object->datum x))))
+ (symbol->string (syntax->datum x))))
args))))))
(syntax-case x ()
((_ (name id1 ...))
- (andmap identifier? (syntax (name id1 ...)))
+ (and-map identifier? (syntax (name id1 ...)))
(with-syntax
((constructor (construct-name (syntax name) "make-" (syntax name)))
(predicate (construct-name (syntax name) (syntax name) "?"))
@@ -310,6 +277,7 @@
(let ()
(define noexpand "noexpand")
+(define *mode* (make-fluid))
;;; hooks to nonportable run-time helpers
(begin
@@ -320,170 +288,255 @@
(define top-level-eval-hook
(lambda (x mod)
- (eval `(,noexpand ,x) (if mod (resolve-module mod)
- (interaction-environment)))))
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
(define local-eval-hook
(lambda (x mod)
- (eval `(,noexpand ,x) (if mod (resolve-module mod)
- (interaction-environment)))))
-
-(define error-hook
- (lambda (who why what)
- (error who "~a ~s" why what)))
+ (primitive-eval
+ `(,noexpand
+ ,(case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) tree-il->scheme) x))
+ (else x))))))
(define-syntax gensym-hook
(syntax-rules ()
((_) (gensym))))
(define put-global-definition-hook
- (lambda (symbol binding module)
- (let* ((module (if module
- (resolve-module module)
- (warn "wha" symbol (current-module))))
- (v (or (module-variable module symbol)
- (let ((v (make-variable sc-macro)))
- (module-add! module symbol v)
- v))))
- ;; Don't destroy Guile macros corresponding to primitive syntax
- ;; when syncase boots.
- (if (not (and (symbol-property symbol 'primitive-syntax)
- (eq? module the-syncase-module)))
- (variable-set! v sc-macro))
- ;; Properties are tied to variable objects
- (set-object-property! v '*sc-expander* binding))))
+ (lambda (symbol type val)
+ (let ((existing (let ((v (module-variable (current-module) symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val)
+ (not (syncase-macro-type val))
+ val))))))
+ (module-define! (current-module)
+ symbol
+ (if existing
+ (make-extended-syncase-macro existing type val)
+ (make-syncase-macro type val))))))
(define get-global-definition-hook
(lambda (symbol module)
- (let* ((module (if module
- (resolve-module module)
- (warn "wha" symbol (current-module))))
- (v (module-variable module symbol)))
- (and v
- (or (object-property v '*sc-expander*)
- (and (variable-bound? v)
- (macro? (variable-ref v))
- (macro-transformer (variable-ref v)) ;non-primitive
- guile-macro))))))
+ (if (and (not module) (current-module))
+ (warn "module system is booted, we should have a module" symbol))
+ (let ((v (module-variable (if module
+ (resolve-module (cdr module))
+ (current-module))
+ symbol)))
+ (and v (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val) (syncase-macro-type val)
+ (cons (syncase-macro-type val)
+ (syncase-macro-binding val))))))))
+
)
;;; output constructors
-(define (build-annotated src exp)
- (if (and src (not (annotation? exp)))
- (make-annotation exp src #t)
- exp))
-
-(define-syntax build-application
- (syntax-rules ()
- ((_ source fun-exp arg-exps)
- (build-annotated source `(,fun-exp . ,arg-exps)))))
-
-(define-syntax build-conditional
- (syntax-rules ()
- ((_ source test-exp then-exp else-exp)
- (build-annotated source `(if ,test-exp ,then-exp ,else-exp)))))
-
-(define-syntax build-lexical-reference
- (syntax-rules ()
- ((_ type source var)
- (build-annotated source var))))
-
-(define-syntax build-lexical-assignment
- (syntax-rules ()
- ((_ source var exp)
- (build-annotated source `(set! ,var ,exp)))))
-
-(define-syntax build-global-reference
- (syntax-rules ()
- ((_ source var mod)
- (build-annotated source
- (make-module-ref mod var #f)))))
-
-(define-syntax build-global-assignment
- (syntax-rules ()
- ((_ source var exp mod)
- (build-annotated source
- `(set! ,(make-module-ref mod var #f) ,exp)))))
-
-(define-syntax build-global-definition
- (syntax-rules ()
- ((_ source var exp mod)
- (build-annotated source `(define ,var ,exp)))))
-
-(define-syntax build-lambda
- (syntax-rules ()
- ((_ src vars exp)
- (build-annotated src `(lambda ,vars ,exp)))))
-
-;; FIXME: wingo: add modules here somehow?
-(define-syntax build-primref
- (syntax-rules ()
- ((_ src name) (build-annotated src name))
- ((_ src level name) (build-annotated src name))))
+(define build-void
+ (lambda (source)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-void) source))
+ (else '(if #f #f)))))
+
+(define build-application
+ (lambda (source fun-exp arg-exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
+ (else `(,fun-exp . ,arg-exps)))))
+
+(define build-conditional
+ (lambda (source test-exp then-exp else-exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-conditional)
+ source test-exp then-exp else-exp))
+ (else (if (equal? else-exp '(if #f #f))
+ `(if ,test-exp ,then-exp)
+ `(if ,test-exp ,then-exp ,else-exp))))))
+
+(define build-lexical-reference
+ (lambda (type source name var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-ref) source name var))
+ (else var))))
+
+(define build-lexical-assignment
+ (lambda (source name var exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
+ (else `(set! ,var ,exp)))))
+
+;; Before modules are booted, we can't expand into data structures from
+;; (language tree-il) -- we need to give the evaluator the
+;; s-expressions that it understands natively. Actually the real truth
+;; of the matter is that the evaluator doesn't understand tree-il
+;; structures at all. So until we fix the evaluator, if ever, the
+;; conflation that we should use tree-il iff we are compiling
+;; holds true.
+;;
+(define (analyze-variable mod var modref-cont bare-cont)
+ (if (not mod)
+ (bare-cont var)
+ (let ((kind (car mod))
+ (mod (cdr mod)))
+ (case kind
+ ((public) (modref-cont mod var #t))
+ ((private) (if (not (equal? mod (module-name (current-module))))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ ((bare) (bare-cont var))
+ ((hygiene) (if (and (not (equal? mod (module-name (current-module))))
+ (module-variable (resolve-module mod) var))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ (else (syntax-violation #f "bad module kind" var mod))))))
+
+(define build-global-reference
+ (lambda (source var mod)
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) source mod var public?))
+ (else (list (if public? '@ '@@) mod var))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) source var))
+ (else var))))))
+
+(define build-global-assignment
+ (lambda (source var exp mod)
+ (analyze-variable
+ mod var
+ (lambda (mod var public?)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-set) source mod var public?
exp))
+ (else `(set! ,(list (if public? '@ '@@) mod var) ,exp))))
+ (lambda (var)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
+ (else `(set! ,var ,exp)))))))
+
+;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz)
+;; from working. Hack around it.
+(define (maybe-name-value! name val)
+ (cond
+ (((@ (language tree-il) lambda?) val)
+ (let ((meta ((@ (language tree-il) lambda-meta) val)))
+ (if (not (assq 'name meta))
+ ((setter (@ (language tree-il) lambda-meta))
+ val
+ (acons 'name name meta)))))))
+
+(define build-global-definition
+ (lambda (source var exp)
+ (case (fluid-ref *mode*)
+ ((c)
+ (maybe-name-value! var exp)
+ ((@ (language tree-il) make-toplevel-define) source var exp))
+ (else `(define ,var ,exp)))))
+
+(define build-lambda
+ (lambda (src ids vars docstring exp)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-lambda) src ids vars
+ (if docstring `((documentation . ,docstring)) '())
+ exp))
+ (else `(lambda ,vars ,@(if docstring (list docstring) '())
+ ,exp)))))
+
+(define build-primref
+ (lambda (src name)
+ (if (equal? (module-name (current-module)) '(guile))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-toplevel-ref) src name))
+ (else name))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
+ (else `(@@ (guile) ,name))))))
(define (build-data src exp)
- (if (and (self-evaluating? exp)
- (not (vector? exp)))
- (build-annotated src exp)
- (build-annotated src (list 'quote exp))))
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-const) src exp))
+ (else (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp)))))
(define build-sequence
(lambda (src exps)
(if (null? (cdr exps))
- (build-annotated src (car exps))
- (build-annotated src `(begin ,@exps)))))
+ (car exps)
+ (case (fluid-ref *mode*)
+ ((c) ((@ (language tree-il) make-sequence) src exps))
+ (else `(begin ,@exps))))))
(define build-let
- (lambda (src vars val-exps body-exp)
+ (lambda (src ids vars val-exps body-exp)
(if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src `(let ,(map list vars val-exps) ,body-exp)))))
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-let) src ids vars val-exps body-exp))
+ (else `(let ,(map list vars val-exps) ,body-exp))))))
(define build-named-let
- (lambda (src vars val-exps body-exp)
- (if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src
- `(let ,(car vars)
- ,(map list (cdr vars) val-exps) ,body-exp)))))
+ (lambda (src ids vars val-exps body-exp)
+ (let ((f (car vars))
+ (f-name (car ids))
+ (vars (cdr vars))
+ (ids (cdr ids)))
+ (case (fluid-ref *mode*)
+ ((c)
+ (let ((proc (build-lambda src ids vars #f body-exp)))
+ (maybe-name-value! f-name proc)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-letrec) src
+ (list f-name) (list f) (list proc)
+ (build-application src (build-lexical-reference 'fun src f-name f)
+ val-exps))))
+ (else `(let ,f ,(map list vars val-exps) ,body-exp))))))
(define build-letrec
- (lambda (src vars val-exps body-exp)
+ (lambda (src ids vars val-exps body-exp)
(if (null? vars)
- (build-annotated src body-exp)
- (build-annotated src
- `(letrec ,(map list vars val-exps) ,body-exp)))))
-
-;; FIXME: wingo: use make-lexical
+ body-exp
+ (case (fluid-ref *mode*)
+ ((c)
+ (for-each maybe-name-value! ids val-exps)
+ ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
+ (else `(letrec ,(map list vars val-exps) ,body-exp))))))
+
+;; FIXME: wingo: use make-lexical ?
(define-syntax build-lexical-var
(syntax-rules ()
- ((_ src id) (build-annotated src (gensym (symbol->string id))))))
+ ((_ src id) (gensym (symbol->string id)))))
(define-structure (syntax-object expression wrap module))
-(define-syntax unannotate
- (syntax-rules ()
- ((_ x)
- (let ((e x))
- (if (annotation? e)
- (annotation-expression e)
- e)))))
-
(define-syntax no-source (identifier-syntax #f))
(define source-annotation
(lambda (x)
(cond
- ((annotation? x) (annotation-source x))
- ((syntax-object? x) (source-annotation (syntax-object-expression x)))
- (else no-source))))
+ ((syntax-object? x)
+ (source-annotation (syntax-object-expression x)))
+ ((pair? x) (let ((props (source-properties x)))
+ (if (pair? props)
+ props
+ #f)))
+ (else #f))))
(define-syntax arg-check
(syntax-rules ()
((_ pred? e who)
(let ((x e))
- (if (not (pred? x)) (error-hook who "invalid argument" x))))))
+ (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
;;; compile-time environments
@@ -593,8 +646,7 @@
(define global-extend
(lambda (type sym val)
- (put-global-definition-hook sym (make-binding type val)
- (module-name (current-module)))))
+ (put-global-definition-hook sym type val)))
;;; Conceptually, identifiers are always syntax objects. Internally,
@@ -605,29 +657,30 @@
(define nonsymbol-id?
(lambda (x)
(and (syntax-object? x)
- (symbol? (unannotate (syntax-object-expression x))))))
+ (symbol? (syntax-object-expression x)))))
(define id?
(lambda (x)
(cond
((symbol? x) #t)
- ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
- ((annotation? x) (symbol? (annotation-expression x)))
+ ((syntax-object? x) (symbol? (syntax-object-expression x)))
(else #f))))
(define-syntax id-sym-name
(syntax-rules ()
((_ e)
(let ((x e))
- (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
+ (if (syntax-object? x)
+ (syntax-object-expression x)
+ x)))))
(define id-sym-name&marks
(lambda (x w)
(if (syntax-object? x)
(values
- (unannotate (syntax-object-expression x))
- (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
- (values (unannotate x) (wrap-marks w)))))
+ (syntax-object-expression x)
+ (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
+ (values x (wrap-marks w)))))
;;; syntax object wraps
@@ -693,7 +746,7 @@
; must receive ids with complete wraps
(lambda (ribcage id label)
(set-ribcage-symnames! ribcage
- (cons (unannotate (syntax-object-expression id))
+ (cons (syntax-object-expression id)
(ribcage-symnames ribcage)))
(set-ribcage-marks! ribcage
(cons (wrap-marks (syntax-object-wrap id))
@@ -793,7 +846,7 @@
((symbol? id)
(or (first (search id (wrap-subst w) (wrap-marks w))) id))
((syntax-object? id)
- (let ((id (unannotate (syntax-object-expression id)))
+ (let ((id (syntax-object-expression id))
(w1 (syntax-object-wrap id)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
(call-with-values (lambda () (search id (wrap-subst w) marks))
@@ -801,10 +854,7 @@
(or new-id
(first (search id (wrap-subst w1) marks))
id))))))
- ((annotation? id)
- (let ((id (unannotate id)))
- (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
- (else (error-hook 'id-var-name "invalid id" id)))))
+ (else (syntax-violation 'id-var-name "invalid id" id)))))
;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
@@ -821,11 +871,11 @@
(define bound-id=?
(lambda (i j)
(if (and (syntax-object? i) (syntax-object? j))
- (and (eq? (unannotate (syntax-object-expression i))
- (unannotate (syntax-object-expression j)))
+ (and (eq? (syntax-object-expression i)
+ (syntax-object-expression j))
(same-marks? (wrap-marks (syntax-object-wrap i))
(wrap-marks (syntax-object-wrap j))))
- (eq? (unannotate i) (unannotate j)))))
+ (eq? i j))))
;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
@@ -875,7 +925,9 @@
(define source-wrap
(lambda (x w s defmod)
- (wrap (if s (make-annotation x s #f) x) w defmod)))
+ (if (and s (pair? x))
+ (set-source-properties! x s))
+ (wrap x w defmod)))
;;; expanding
@@ -897,12 +949,33 @@
(let ((first (chi-top (car body) r w m esew mod)))
(cons first (dobody (cdr body) r w m esew mod))))))))
-;; FIXME: module?
(define chi-install-global
(lambda (name e)
- (build-application no-source
- (build-primref no-source 'install-global-transformer)
- (list (build-data no-source name) e))))
+ (build-global-definition
+ no-source
+ name
+ ;; FIXME: seems nasty to call current-module here
+ (if (let ((v (module-variable (current-module) name)))
+ ;; FIXME use primitive-macro?
+ (and v (variable-bound? v) (macro? (variable-ref v))
+ (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
+ (build-application
+ no-source
+ (build-primref no-source 'make-extended-syncase-macro)
+ (list (build-application
+ no-source
+ (build-primref no-source 'module-ref)
+ (list (build-application
+ no-source
+ (build-primref no-source 'current-module)
+ '())
+ (build-data no-source name)))
+ (build-data no-source 'macro)
+ e))
+ (build-application
+ no-source
+ (build-primref no-source 'make-syncase-macro)
+ (list (build-data no-source 'macro) e))))))
(define chi-when-list
(lambda (e when-list w)
@@ -916,8 +989,9 @@
((free-id=? x (syntax compile)) 'compile)
((free-id=? x (syntax load)) 'load)
((free-id=? x (syntax eval)) 'eval)
- (else (syntax-error (wrap x w #f)
- "invalid eval-when situation"))))
+ (else (syntax-violation 'eval-when
+ "invalid situation"
+ e (wrap x w #f)))))
situations))))))
;;; syntax-type returns six values: type, value, e, w, s, and mod. The
@@ -1009,7 +1083,7 @@
((_ name)
(id? (syntax name))
(values 'define-form (wrap (syntax name) w mod)
- (syntax (void))
+ (syntax (if #f #f))
empty-wrap s mod))))
((define-syntax)
(syntax-case e ()
@@ -1021,13 +1095,10 @@
(values 'call #f e w s mod))))
(values 'call #f e w s mod))))
((syntax-object? e)
- ;; s can't be valid source if we've unwrapped
(syntax-type (syntax-object-expression e)
r
(join-wraps w (syntax-object-wrap e))
- no-source rib (or (syntax-object-module e) mod)))
- ((annotation? e)
- (syntax-type (annotation-expression e) r w (annotation-source e) rib
mod))
+ s rib (or (syntax-object-module e) mod)))
((self-evaluating? e) (values 'constant #f e w s mod))
(else (values 'other #f e w s mod)))))
@@ -1040,7 +1111,7 @@
(if (eq? m 'c&e) (top-level-eval-hook x mod))
x))))
(call-with-values
- (lambda () (syntax-type e r w no-source #f mod))
+ (lambda () (syntax-type e r w (source-annotation e) #f mod))
(lambda (type value e w s mod)
(case type
((begin-form)
@@ -1101,25 +1172,22 @@
(let* ((n (id-var-name value w))
(type (binding-type (lookup n r mod))))
(case type
- ((global)
+ ((global core macro module-ref)
(eval-if-c&e m
- (build-global-definition s n (chi e r w mod) mod)
+ (build-global-definition s n (chi e r w mod))
mod))
((displaced-lexical)
- (syntax-error (wrap value w mod) "identifier out of context"))
+ (syntax-violation #f "identifier out of context"
+ e (wrap value w mod)))
(else
- (if (eq? type 'external-macro)
- (eval-if-c&e m
- (build-global-definition s n (chi e r w mod) mod)
- mod)
- (syntax-error (wrap value w mod)
- "cannot define keyword at top level"))))))
+ (syntax-violation #f "cannot define keyword at top level"
+ e (wrap value w mod))))))
(else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
(define chi
(lambda (e r w mod)
(call-with-values
- (lambda () (syntax-type e r w no-source #f mod))
+ (lambda () (syntax-type e r w (source-annotation e) #f mod))
(lambda (type value e w s mod)
(chi-expr type value e r w s mod)))))
@@ -1127,7 +1195,7 @@
(lambda (type value e r w s mod)
(case type
((lexical)
- (build-lexical-reference 'value s value))
+ (build-lexical-reference 'value s e value))
((core external-macro)
;; apply transformer
(value e r w s mod))
@@ -1137,7 +1205,8 @@
(lambda (id mod) (build-global-reference s id mod))))
((lexical-call)
(chi-application
- (build-lexical-reference 'fun (source-annotation (car e)) value)
+ (build-lexical-reference 'fun (source-annotation (car e))
+ (car e) value)
e r w s mod))
((global-call)
(chi-application
@@ -1162,14 +1231,16 @@
(chi-sequence (syntax (e1 e2 ...)) r w s mod)
(chi-void))))))
((define-form define-syntax-form)
- (syntax-error (wrap value w mod) "invalid context for definition of"))
+ (syntax-violation #f "definition in expression context"
+ e (wrap value w mod)))
((syntax)
- (syntax-error (source-wrap e w s mod)
- "reference to pattern variable outside syntax form"))
+ (syntax-violation #f "reference to pattern variable outside syntax form"
+ (source-wrap e w s mod)))
((displaced-lexical)
- (syntax-error (source-wrap e w s mod)
- "reference to identifier outside its scope"))
- (else (syntax-error (source-wrap e w s mod))))))
+ (syntax-violation #f "reference to identifier outside its scope"
+ (source-wrap e w s mod)))
+ (else (syntax-violation #f "unexpected syntax"
+ (source-wrap e w s mod))))))
(define chi-application
(lambda (x e r w s mod)
@@ -1201,7 +1272,14 @@
(if rib
(cons rib (cons 'shift s))
(cons 'shift s)))
- (module-name (procedure-module p))))))) ;; hither the
hygiene
+ (let ((pmod (procedure-module p)))
+ (if pmod
+ ;; hither the hygiene
+ (cons 'hygiene (module-name pmod))
+ ;; but it's possible for the proc to have
+ ;; no mod, if it was made before modules
+ ;; were booted
+ '(hygiene guile))))))))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector n)))
(do ((i 0 (fx+ i 1)))
@@ -1209,7 +1287,8 @@
(vector-set! v i
(rebuild-macro-output (vector-ref x i) m)))))
((symbol? x)
- (syntax-error x "encountered raw symbol in macro output"))
+ (syntax-violation #f "encountered raw symbol in macro output"
+ (source-wrap e w s mod) x))
(else x))))
(rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
@@ -1257,12 +1336,13 @@
(ribcage (make-empty-ribcage))
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
(let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
- (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
+ (ids '()) (labels '())
+ (var-ids '()) (vars '()) (vals '()) (bindings '()))
(if (null? body)
- (syntax-error outer-form "no expressions in body")
+ (syntax-violation #f "no expressions in body" outer-form)
(let ((e (cdar body)) (er (caar body)))
(call-with-values
- (lambda () (syntax-type e er empty-wrap no-source ribcage mod))
+ (lambda () (syntax-type e er empty-wrap (source-annotation er)
ribcage mod))
(lambda (type value e w s mod)
(case type
((define-form)
@@ -1271,6 +1351,7 @@
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
+ (cons id var-ids)
(cons var vars) (cons (cons er (wrap e w mod)) vals)
(cons (make-binding 'lexical var) bindings)))))
((define-syntax-form)
@@ -1278,7 +1359,7 @@
(extend-ribcage! ribcage id label)
(parse (cdr body)
(cons id ids) (cons label labels)
- vars vals
+ var-ids vars vals
(cons (make-binding 'macro (cons er (wrap e w mod)))
bindings))))
((begin-form)
@@ -1289,7 +1370,7 @@
(cdr body)
(cons (cons er (wrap (car forms) w mod))
(f (cdr forms)))))
- ids labels vars vals bindings))))
+ ids labels var-ids vars vals bindings))))
((local-syntax-form)
(chi-local-syntax value e er w s mod
(lambda (forms er w s mod)
@@ -1298,7 +1379,7 @@
(cdr body)
(cons (cons er (wrap (car forms) w mod))
(f (cdr forms)))))
- ids labels vars vals bindings))))
+ ids labels var-ids vars vals bindings))))
(else ; found a non-definition
(if (null? ids)
(build-sequence no-source
@@ -1308,8 +1389,9 @@
(cdr body))))
(begin
(if (not (valid-bound-ids? ids))
- (syntax-error outer-form
- "invalid or duplicate identifier in
definition"))
+ (syntax-violation
+ #f "invalid or duplicate identifier in
definition"
+ outer-form))
(let loop ((bs bindings) (er-cache #f) (r-cache #f))
(if (not (null? bs))
(let* ((b (car bs)))
@@ -1327,6 +1409,7 @@
(loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r)))
(build-letrec no-source
+ (map syntax->datum var-ids)
vars
(map (lambda (x)
(chi (cdr x) (car x) empty-wrap mod))
@@ -1338,15 +1421,20 @@
(cdr body)))))))))))))))))
(define chi-lambda-clause
- (lambda (e c r w mod k)
+ (lambda (e docstring c r w mod k)
(syntax-case c ()
+ ((args doc e1 e2 ...)
+ (and (string? (syntax->datum (syntax doc))) (not docstring))
+ (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))
(((id ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "invalid parameter list in")
+ (syntax-violation 'lambda "invalid parameter list" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
- (k new-vars
+ (k (map syntax->datum ids)
+ new-vars
+ (and docstring (syntax->datum docstring))
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
@@ -1355,19 +1443,24 @@
((ids e1 e2 ...)
(let ((old-ids (lambda-var-list (syntax ids))))
(if (not (valid-bound-ids? old-ids))
- (syntax-error e "invalid parameter list in")
+ (syntax-violation 'lambda "invalid parameter list" e)
(let ((labels (gen-labels old-ids))
(new-vars (map gen-var old-ids)))
- (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
+ (k (let f ((ls1 (cdr old-ids)) (ls2 (car old-ids)))
+ (if (null? ls1)
+ (syntax->datum ls2)
+ (f (cdr ls1) (cons (syntax->datum (car ls1)) ls2))))
+ (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
(if (null? ls1)
ls2
(f (cdr ls1) (cons (car ls1) ls2))))
+ (and docstring (syntax->datum docstring))
(chi-body (syntax (e1 e2 ...))
e
(extend-var-env labels new-vars r)
(make-binding-wrap old-ids labels w)
mod))))))
- (_ (syntax-error e)))))
+ (_ (syntax-violation 'lambda "bad lambda" e)))))
(define chi-local-syntax
(lambda (rec? e r w s mod k)
@@ -1375,7 +1468,7 @@
((_ ((id val) ...) e1 e2 ...)
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound keyword in")
+ (syntax-violation #f "duplicate bound keyword" e)
(let ((labels (gen-labels ids)))
(let ((new-w (make-binding-wrap ids labels w)))
(k (syntax (e1 e2 ...))
@@ -1393,18 +1486,19 @@
new-w
s
mod))))))
- (_ (syntax-error (source-wrap e w s mod))))))
+ (_ (syntax-violation #f "bad local syntax definition"
+ (source-wrap e w s mod))))))
(define eval-local-transformer
(lambda (expanded mod)
(let ((p (local-eval-hook expanded mod)))
(if (procedure? p)
p
- (syntax-error p "nonprocedure transformer")))))
+ (syntax-violation #f "nonprocedure transformer" p)))))
(define chi-void
(lambda ()
- (build-application no-source (build-primref no-source 'void) '())))
+ (build-void no-source)))
(define ellipsis?
(lambda (x)
@@ -1413,32 +1507,8 @@
;;; data
-;;; strips all annotations from potentially circular reader output
-
-(define strip-annotation
- (lambda (x parent)
- (cond
- ((pair? x)
- (let ((new (cons #f #f)))
- (if parent (set-annotation-stripped! parent new))
- (set-car! new (strip-annotation (car x) #f))
- (set-cdr! new (strip-annotation (cdr x) #f))
- new))
- ((annotation? x)
- (or (annotation-stripped x)
- (strip-annotation (annotation-expression x) x)))
- ((vector? x)
- (let ((new (make-vector (vector-length x))))
- (if parent (set-annotation-stripped! parent new))
- (let loop ((i (- (vector-length x) 1)))
- (unless (fx< i 0)
- (vector-set! new i (strip-annotation (vector-ref x i) #f))
- (loop (fx- i 1))))
- new))
- (else x))))
-
-;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
-;;; on an annotation, strips the annotation as well.
+;;; strips syntax-objects down to top-wrap
+;;;
;;; since only the head of a list is annotated by the reader, not each pair
;;; in the spine, we also check for pairs whose cars are annotated in case
;;; we've been passed the cdr of an annotated list
@@ -1446,32 +1516,28 @@
(define strip
(lambda (x w)
(if (top-marked? w)
- (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
- (strip-annotation x #f)
- x)
+ x
(let f ((x x))
(cond
- ((syntax-object? x)
- (strip (syntax-object-expression x) (syntax-object-wrap x)))
- ((pair? x)
- (let ((a (f (car x))) (d (f (cdr x))))
- (if (and (eq? a (car x)) (eq? d (cdr x)))
- x
- (cons a d))))
- ((vector? x)
- (let ((old (vector->list x)))
- (let ((new (map f old)))
- (if (andmap eq? old new) x (list->vector new)))))
- (else x))))))
+ ((syntax-object? x)
+ (strip (syntax-object-expression x) (syntax-object-wrap x)))
+ ((pair? x)
+ (let ((a (f (car x))) (d (f (cdr x))))
+ (if (and (eq? a (car x)) (eq? d (cdr x)))
+ x
+ (cons a d))))
+ ((vector? x)
+ (let ((old (vector->list x)))
+ (let ((new (map f old)))
+ (if (and-map* eq? old new) x (list->vector new)))))
+ (else x))))))
;;; lexical variables
(define gen-var
(lambda (id)
(let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
- (if (annotation? id)
- (build-lexical-var (annotation-source id) (annotation-expression id))
- (build-lexical-var no-source id)))))
+ (build-lexical-var no-source id))))
(define lambda-var-list
(lambda (vars)
@@ -1484,8 +1550,6 @@
(lvl (syntax-object-expression vars)
ls
(join-wraps w (syntax-object-wrap vars))))
- ((annotation? vars)
- (lvl (annotation-expression vars) ls w))
; include anything else to be caught by subsequent error
; checking
(else (cons vars ls))))))
@@ -1505,8 +1569,10 @@
(lambda (id n)
(case (binding-type (lookup n r mod))
((displaced-lexical)
- (syntax-error (source-wrap id w s mod)
- "identifier out of context"))))
+ (syntax-violation 'fluid-let-syntax
+ "identifier out of context"
+ e
+ (source-wrap id w s mod)))))
(syntax (var ...))
names)
(chi-body
@@ -1523,13 +1589,15 @@
r)
w
mod)))
- (_ (syntax-error (source-wrap e w s mod))))))
+ (_ (syntax-violation 'fluid-let-syntax "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'quote
(lambda (e r w s mod)
(syntax-case e ()
((_ e) (build-data s (strip (syntax e) w)))
- (_ (syntax-error (source-wrap e w s mod))))))
+ (_ (syntax-violation 'quote "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'syntax
(let ()
@@ -1545,7 +1613,7 @@
(gen-ref src (car var.lev) (cdr var.lev) maps)))
(lambda (var maps) (values `(ref ,var) maps)))
(if (ellipsis? e)
- (syntax-error src "misplaced ellipsis in syntax form")
+ (syntax-violation 'syntax "misplaced ellipsis" src)
(values `(quote ,e) maps)))))
(syntax-case e ()
((dots e)
@@ -1563,8 +1631,8 @@
(cons '() maps) ellipsis? mod))
(lambda (x maps)
(if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
+ (syntax-violation 'syntax "extra ellipsis"
+ src)
(values (gen-map x (car maps))
(cdr maps))))))))
(syntax-case y ()
@@ -1576,8 +1644,7 @@
(lambda () (k (cons '() maps)))
(lambda (x maps)
(if (null? (car maps))
- (syntax-error src
- "extra ellipsis in syntax form")
+ (syntax-violation 'syntax "extra ellipsis"
src)
(values (gen-mappend x (car maps))
(cdr maps))))))))
(_ (call-with-values
@@ -1606,7 +1673,7 @@
(if (fx= level 0)
(values var maps)
(if (null? maps)
- (syntax-error src "missing ellipsis in syntax form")
+ (syntax-violation 'syntax "missing ellipsis" src)
(call-with-values
(lambda () (gen-ref src var (fx- level 1) (cdr maps)))
(lambda (outer-var outer-maps)
@@ -1632,7 +1699,7 @@
; identity map equivalence:
; (map (lambda (x) x) y) == y
(car actuals))
- ((andmap
+ ((and-map
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e))
; eta map equivalence:
@@ -1672,17 +1739,10 @@
(define regen
(lambda (x)
(case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x)))
+ ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
- ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
- ((map) (let ((ls (map regen (cdr x))))
- (build-application no-source
- (if (fx= (length ls) 2)
- (build-primref no-source 'map)
- ; really need to do our own checking here
- (build-primref no-source 2 'map)) ; require error
check
- ls)))
+ ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr
x))))
(else (build-application no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
@@ -1694,27 +1754,29 @@
(call-with-values
(lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
(lambda (e maps) (regen e))))
- (_ (syntax-error e)))))))
+ (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
(global-extend 'core 'lambda
(lambda (e r w s mod)
(syntax-case e ()
((_ . c)
- (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod
- (lambda (vars body) (build-lambda s vars body)))))))
+ (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
+ (lambda (names vars docstring body)
+ (build-lambda s names vars docstring body)))))))
(global-extend 'core 'let
(let ()
(define (chi-let e r w s mod constructor ids vals exps)
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound variable in")
+ (syntax-violation 'let "duplicate bound variable" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(let ((nw (make-binding-wrap ids labels w))
(nr (extend-var-env labels new-vars r)))
(constructor s
+ (map syntax->datum ids)
new-vars
(map (lambda (x) (chi x r w mod)) vals)
(chi-body exps (source-wrap e nw s mod)
@@ -1722,38 +1784,41 @@
(lambda (e r w s mod)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
+ (and-map id? (syntax (id ...)))
(chi-let e r w s mod
build-let
(syntax (id ...))
(syntax (val ...))
(syntax (e1 e2 ...))))
((_ f ((id val) ...) e1 e2 ...)
- (id? (syntax f))
+ (and (id? (syntax f)) (and-map id? (syntax (id ...))))
(chi-let e r w s mod
build-named-let
(syntax (f id ...))
(syntax (val ...))
(syntax (e1 e2 ...))))
- (_ (syntax-error (source-wrap e w s mod)))))))
+ (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
(global-extend 'core 'letrec
(lambda (e r w s mod)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
+ (and-map id? (syntax (id ...)))
(let ((ids (syntax (id ...))))
(if (not (valid-bound-ids? ids))
- (syntax-error e "duplicate bound variable in")
+ (syntax-violation 'letrec "duplicate bound variable" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(let ((w (make-binding-wrap ids labels w))
(r (extend-var-env labels new-vars r)))
(build-letrec s
+ (map syntax->datum ids)
new-vars
(map (lambda (x) (chi x r w mod)) (syntax (val ...)))
(chi-body (syntax (e1 e2 ...))
(source-wrap e w s mod) r w mod)))))))
- (_ (syntax-error (source-wrap e w s mod))))))
+ (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
(global-extend 'core 'set!
@@ -1766,45 +1831,66 @@
(let ((b (lookup n r mod)))
(case (binding-type b)
((lexical)
- (build-lexical-assignment s (binding-value b) val))
+ (build-lexical-assignment s
+ (syntax->datum (syntax id))
+ (binding-value b)
+ val))
((global) (build-global-assignment s n val mod))
((displaced-lexical)
- (syntax-error (wrap (syntax id) w mod)
- "identifier out of context"))
- (else (syntax-error (source-wrap e w s mod)))))))
+ (syntax-violation 'set! "identifier out of context"
+ (wrap (syntax id) w mod)))
+ (else (syntax-violation 'set! "bad set!"
+ (source-wrap e w s mod)))))))
((_ (head tail ...) val)
(call-with-values
(lambda () (syntax-type (syntax head) r empty-wrap no-source #f
mod))
(lambda (type value ee ww ss modmod)
(case type
((module-ref)
- (call-with-values (lambda () (value (syntax (head tail ...))))
- (lambda (id mod)
- (build-global-assignment s id (syntax val) mod))))
+ (let ((val (chi (syntax val) r w mod)))
+ (call-with-values (lambda () (value (syntax (head tail ...))))
+ (lambda (id mod)
+ (build-global-assignment s id val mod)))))
(else
(build-application s
(chi (syntax (setter head)) r w mod)
(map (lambda (e) (chi e r w mod))
(syntax (tail ... val)))))))))
- (_ (syntax-error (source-wrap e w s mod))))))
+ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@
(lambda (e)
- (syntax-case e (%module-public-interface)
+ (syntax-case e ()
((_ (mod ...) id)
- (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
- (values (syntax-object->datum (syntax id))
- (syntax-object->datum
- (syntax (mod ... %module-public-interface))))))))
+ (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
+ (values (syntax->datum (syntax id))
+ (syntax->datum
+ (syntax (public mod ...))))))))
(global-extend 'module-ref '@@
(lambda (e)
(syntax-case e ()
((_ (mod ...) id)
- (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
- (values (syntax-object->datum (syntax id))
- (syntax-object->datum
- (syntax (mod ...))))))))
+ (and (and-map id? (syntax (mod ...))) (id? (syntax id)))
+ (values (syntax->datum (syntax id))
+ (syntax->datum
+ (syntax (private mod ...))))))))
+
+(global-extend 'core 'if
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ test then)
+ (build-conditional
+ s
+ (chi (syntax test) r w mod)
+ (chi (syntax then) r w mod)
+ (build-void no-source)))
+ ((_ test then else)
+ (build-conditional
+ s
+ (chi (syntax test) r w mod)
+ (chi (syntax then) r w mod)
+ (chi (syntax else) r w mod))))))
(global-extend 'begin 'begin '())
@@ -1818,7 +1904,7 @@
(let ()
(define convert-pattern
; accepts pattern & keys
- ; returns syntax-dispatch pattern & ids
+ ; returns $sc-dispatch pattern & ids
(lambda (pattern keys)
(let cvt ((p pattern) (n 0) (ids '()))
(if (id? p)
@@ -1854,7 +1940,7 @@
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source
(build-primref no-source 'apply)
- (list (build-lambda no-source new-vars
+ (list (build-lambda no-source (map syntax->datum ids) new-vars #f
(chi exp
(extend-env
labels
@@ -1874,17 +1960,16 @@
(lambda (p pvars)
(cond
((not (distinct-bound-ids? (map car pvars)))
- (syntax-error pat
- "duplicate pattern variable in syntax-case pattern"))
- ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
- (syntax-error pat
- "misplaced ellipsis in syntax-case pattern"))
+ (syntax-violation 'syntax-case "duplicate pattern variable"
pat))
+ ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
+ (syntax-violation 'syntax-case "misplaced ellipsis" pat))
(else
(let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y
(build-application no-source
- (build-lambda no-source (list y)
- (let ((y (build-lexical-reference 'value no-source y)))
+ (build-lambda no-source (list 'tmp) (list y) #f
+ (let ((y (build-lexical-reference 'value no-source
+ 'tmp y)))
(build-conditional no-source
(syntax-case fender ()
(#t y)
@@ -1899,24 +1984,29 @@
(build-primref no-source 'list)
(list x))
(build-application no-source
- (build-primref no-source 'syntax-dispatch)
+ (build-primref no-source '$sc-dispatch)
(list x (build-data no-source p)))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r mod)
(if (null? clauses)
(build-application no-source
- (build-primref no-source 'syntax-error)
- (list x))
+ (build-primref no-source 'syntax-violation)
+ (list (build-data no-source #f)
+ (build-data no-source
+ "source expression failed to match any
pattern")
+ x))
(syntax-case (car clauses) ()
((pat exp)
(if (and (id? (syntax pat))
- (andmap (lambda (x) (not (free-id=? (syntax pat) x)))
- (cons (syntax (... ...)) keys)))
+ (and-map (lambda (x) (not (free-id=? (syntax pat) x)))
+ (cons (syntax (... ...)) keys)))
(let ((labels (list (gen-label)))
(var (gen-var (syntax pat))))
(build-application no-source
- (build-lambda no-source (list var)
+ (build-lambda no-source
+ (list (syntax->datum (syntax pat))) (list
var)
+ #f
(chi (syntax exp)
(extend-env labels
(list (make-binding 'syntax `(,var . 0)))
@@ -1930,24 +2020,26 @@
((pat fender exp)
(gen-clause x keys (cdr clauses) r
(syntax pat) (syntax fender) (syntax exp) mod))
- (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
+ (_ (syntax-violation 'syntax-case "invalid clause"
+ (car clauses)))))))
(lambda (e r w s mod)
(let ((e (source-wrap e w s mod)))
(syntax-case e ()
((_ val (key ...) m ...)
- (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
- (syntax (key ...)))
+ (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
+ (syntax (key ...)))
(let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x
(build-application s
- (build-lambda no-source (list x)
- (gen-syntax-case (build-lexical-reference 'value
no-source x)
+ (build-lambda no-source (list 'tmp) (list x) #f
+ (gen-syntax-case (build-lexical-reference 'value no-source
+ 'tmp x)
(syntax (key ...)) (syntax (m ...))
r
mod))
(list (chi (syntax val) r empty-wrap mod))))
- (syntax-error e "invalid literals list in"))))))))
+ (syntax-violation 'syntax-case "invalid literals list" e))))))))
;;; The portable sc-expand seeds chi-top's mode m with 'e (for
;;; evaluating) and esew (which stands for "eval syntax expanders
@@ -1959,36 +2051,27 @@
;;; expanded, and the expanded definitions are also residualized into
;;; the object file if we are compiling a file.
(set! sc-expand
- (let ((m 'e) (esew '(eval)))
- (lambda (x)
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (chi-top x null-env top-wrap m esew
- (module-name (current-module)))))))
-
-(set! sc-expand3
- (let ((m 'e) (esew '(eval)))
- (lambda (x . rest)
- (if (and (pair? x) (equal? (car x) noexpand))
- (cadr x)
- (chi-top x
- null-env
- top-wrap
- (if (null? rest) m (car rest))
- (if (or (null? rest) (null? (cdr rest)))
- esew
- (cadr rest))
- (module-name (current-module)))))))
+ (lambda (x . rest)
+ (if (and (pair? x) (equal? (car x) noexpand))
+ (cadr x)
+ (let ((m (if (null? rest) 'e (car rest)))
+ (esew (if (or (null? rest) (null? (cdr rest)))
+ '(eval)
+ (cadr rest))))
+ (with-fluid* *mode* m
+ (lambda ()
+ (chi-top x null-env top-wrap m esew
+ (cons 'hygiene (module-name
(current-module))))))))))
(set! identifier?
(lambda (x)
(nonsymbol-id? x)))
-(set! datum->syntax-object
+(set! datum->syntax
(lambda (id datum)
(make-syntax-object datum (syntax-object-wrap id) #f)))
-(set! syntax-object->datum
+(set! syntax->datum
; accepts any object, since syntax objects may consist partially
; or entirely of unwrapped, nonsymbolic data
(lambda (x)
@@ -2011,21 +2094,23 @@
(arg-check nonsymbol-id? y 'bound-identifier=?)
(bound-id=? x y)))
-(set! syntax-error
- (lambda (object . messages)
- (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
- (let ((message (if (null? messages)
- "invalid syntax"
- (apply string-append messages))))
- (error-hook #f message (strip object empty-wrap)))))
-
-(set! install-global-transformer
- (lambda (sym v)
- (arg-check symbol? sym 'define-syntax)
- (arg-check procedure? v 'define-syntax)
- (global-extend 'macro sym v)))
-
-;;; syntax-dispatch expects an expression and a pattern. If the expression
+(set! syntax-violation
+ (lambda (who message form . subform)
+ (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+ who 'syntax-violation)
+ (arg-check string? message 'syntax-violation)
+ (scm-error 'syntax-error 'sc-expand
+ (string-append
+ (if who "~a: " "")
+ "~a "
+ (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
+ (let ((tail (cons message
+ (map (lambda (x) (strip x empty-wrap))
+ (append subform (list form))))))
+ (if who (cons who tail) tail))
+ #f)))
+
+;;; $sc-dispatch expects an expression and a pattern. If the expression
;;; matches the pattern a list of the matching expressions for each
;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
;;; not work on r4rs implementations that violate the ieee requirement
@@ -2052,35 +2137,31 @@
(define match-each
(lambda (e p w mod)
(cond
- ((annotation? e)
- (match-each (annotation-expression e) p w mod))
- ((pair? e)
- (let ((first (match (car e) p w '() mod)))
- (and first
- (let ((rest (match-each (cdr e) p w mod)))
- (and rest (cons first rest))))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each (syntax-object-expression e)
- p
- (join-wraps w (syntax-object-wrap e))
- (syntax-object-module e)))
- (else #f))))
+ ((pair? e)
+ (let ((first (match (car e) p w '() mod)))
+ (and first
+ (let ((rest (match-each (cdr e) p w mod)))
+ (and rest (cons first rest))))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))
+ (syntax-object-module e)))
+ (else #f))))
(define match-each-any
(lambda (e w mod)
(cond
- ((annotation? e)
- (match-each-any (annotation-expression e) w mod))
- ((pair? e)
- (let ((l (match-each-any (cdr e) w mod)))
- (and l (cons (wrap (car e) w mod) l))))
- ((null? e) '())
- ((syntax-object? e)
- (match-each-any (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))
- mod))
- (else #f))))
+ ((pair? e)
+ (let ((l (match-each-any (cdr e) w mod)))
+ (and l (cons (wrap (car e) w mod) l))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each-any (syntax-object-expression e)
+ (join-wraps w (syntax-object-wrap e))
+ mod))
+ (else #f))))
(define match-empty
(lambda (p r)
@@ -2129,23 +2210,22 @@
((eq? p 'any) (cons (wrap e w mod) r))
((syntax-object? e)
(match*
- (unannotate (syntax-object-expression e))
- p
- (join-wraps w (syntax-object-wrap e))
- r
- (syntax-object-module e)))
- (else (match* (unannotate e) p w r mod)))))
-
-(set! syntax-dispatch
+ (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))
+ r
+ (syntax-object-module e)))
+ (else (match* e p w r mod)))))
+
+(set! $sc-dispatch
(lambda (e p)
(cond
((eq? p 'any) (list e))
((syntax-object? e)
- (match* (unannotate (syntax-object-expression e))
- p (syntax-object-wrap e) '() (syntax-object-module e)))
- (else (match* (unannotate e) p empty-wrap '() #f)))))
+ (match* (syntax-object-expression e)
+ p (syntax-object-wrap e) '() (syntax-object-module e)))
+ (else (match* e p empty-wrap '() #f)))))
-(set! sc-chi chi)
))
)
@@ -2173,7 +2253,7 @@
(lambda (x)
(syntax-case x ()
((let* ((x v) ...) e1 e2 ...)
- (andmap identifier? (syntax (x ...)))
+ (and-map identifier? (syntax (x ...)))
(let f ((bindings (syntax ((x v) ...))))
(if (null? bindings)
(syntax (let () e1 e2 ...))
@@ -2190,7 +2270,9 @@
(syntax-case s ()
(() v)
((e) (syntax e))
- (_ (syntax-error orig-x))))
+ (_ (syntax-violation
+ 'do "bad step expression"
+ orig-x s))))
(syntax (var ...))
(syntax (step ...)))))
(syntax-case (syntax (e1 ...)) ()
@@ -2238,12 +2320,22 @@
(syntax p)
(quasicons (syntax (quote unquote))
(quasi (syntax (p)) (- lev 1)))))
+ ((unquote . args)
+ (= lev 0)
+ (syntax-violation 'unquote
+ "unquote takes exactly one argument"
+ p (syntax (unquote . args))))
(((unquote-splicing p) . q)
(if (= lev 0)
(quasiappend (syntax p) (quasi (syntax q) lev))
(quasicons (quasicons (syntax (quote unquote-splicing))
(quasi (syntax (p)) (- lev 1)))
(quasi (syntax q) lev))))
+ (((unquote-splicing . args) . q)
+ (= lev 0)
+ (syntax-violation 'unquote-splicing
+ "unquote-splicing takes exactly one argument"
+ p (syntax (unquote-splicing . args))))
((quasiquote p)
(quasicons (syntax (quote quasiquote))
(quasi (syntax (p)) (+ lev 1))))
@@ -2263,29 +2355,29 @@
(let f ((x (read p)))
(if (eof-object? x)
(begin (close-input-port p) '())
- (cons (datum->syntax-object k x)
+ (cons (datum->syntax k x)
(f (read p))))))))
(syntax-case x ()
((k filename)
- (let ((fn (syntax-object->datum (syntax filename))))
+ (let ((fn (syntax->datum (syntax filename))))
(with-syntax (((exp ...) (read-file fn (syntax k))))
(syntax (begin exp ...))))))))
(define-syntax unquote
- (lambda (x)
- (syntax-case x ()
- ((_ e)
- (error 'unquote
- "expression ,~s not valid outside of quasiquote"
- (syntax-object->datum (syntax e)))))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (syntax-violation 'unquote
+ "expression not valid outside of quasiquote"
+ x)))))
(define-syntax unquote-splicing
- (lambda (x)
- (syntax-case x ()
- ((_ e)
- (error 'unquote-splicing
- "expression ,@~s not valid outside of quasiquote"
- (syntax-object->datum (syntax e)))))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (syntax-violation 'unquote-splicing
+ "expression not valid outside of quasiquote"
+ x)))))
(define-syntax case
(lambda (x)
@@ -2298,14 +2390,15 @@
((else e1 e2 ...) (syntax (begin e1 e2 ...)))
(((k ...) e1 e2 ...)
(syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
- (_ (syntax-error x)))
+ (_ (syntax-violation 'case "bad clause" x clause)))
(with-syntax ((rest (f (car clauses) (cdr clauses))))
(syntax-case clause (else)
(((k ...) e1 e2 ...)
(syntax (if (memv t '(k ...))
(begin e1 e2 ...)
rest)))
- (_ (syntax-error x))))))))
+ (_ (syntax-violation 'case "bad clause" x
+ clause))))))))
(syntax (let ((t e)) body)))))))
(define-syntax identifier-syntax
diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm
index de2aeb2..7b1c11c 100644
--- a/module/ice-9/r4rs.scm
+++ b/module/ice-9/r4rs.scm
@@ -17,6 +17,9 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+(eval-when (compile)
+ (set-current-module (resolve-module '(guile))))
+
;;;; apply and call-with-current-continuation
@@ -186,28 +189,3 @@ procedures, their behavior is implementation dependent."
(lambda (p) (with-error-to-port p thunk))))
(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
-
-
-;;;; Loading
-
-(if (not (defined? '%load-verbosely))
- (define %load-verbosely #f))
-(define (assert-load-verbosity v) (set! %load-verbosely v))
-
-(define (%load-announce file)
- (if %load-verbosely
- (with-output-to-port (current-error-port)
- (lambda ()
- (display ";;; ")
- (display "loading ")
- (display file)
- (newline)
- (force-output)))))
-
-(set! %load-hook %load-announce)
-
-(define (load name . reader)
- (with-fluid* current-reader (and (pair? reader) (car reader))
- (lambda ()
- (start-stack 'load-stack
- (primitive-load name)))))
diff --git a/module/ice-9/stack-catch.scm b/module/ice-9/stack-catch.scm
index 2f4b3d1..a542676 100644
--- a/module/ice-9/stack-catch.scm
+++ b/module/ice-9/stack-catch.scm
@@ -40,4 +40,4 @@ this call to @code{catch}."
(catch key
thunk
handler
- pre-unwind-handler-dispatch))
+ default-pre-unwind-handler))
diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm
index d8fdeb4..22391a8 100644
--- a/module/ice-9/syncase.scm
+++ b/module/ice-9/syncase.scm
@@ -17,197 +17,15 @@
(define-module (ice-9 syncase)
- :use-module (ice-9 expand-support)
- :use-module (ice-9 debug)
- :use-module (ice-9 threads)
- :export-syntax (sc-macro define-syntax define-syntax-public
- fluid-let-syntax
- identifier-syntax let-syntax
- letrec-syntax syntax syntax-case syntax-rules
- with-syntax
- include)
- :export (sc-expand sc-expand3 install-global-transformer
- syntax-dispatch syntax-error bound-identifier=?
- datum->syntax-object free-identifier=?
- generate-temporaries identifier? syntax-object->datum
- void syncase)
- :replace (eval eval-when))
+ )
-
-
-(define (annotation? x) #f)
-
-(define sc-macro
- (procedure->memoizing-macro
- (lambda (exp env)
- (save-module-excursion
- (lambda ()
- ;; Because memoization happens lazily, env's module isn't
- ;; necessarily the current module.
- (set-current-module (eval-closure-module (car (last-pair env))))
- (strip-expansion-structures (sc-expand exp)))))))
-
-;;; Exported variables
-
-(define sc-expand #f)
-(define sc-expand3 #f)
-(define sc-chi #f)
-(define install-global-transformer #f)
-(define syntax-dispatch #f)
-(define syntax-error #f)
-
-(define bound-identifier=? #f)
-(define datum->syntax-object #f)
-(define free-identifier=? #f)
-(define generate-temporaries #f)
-(define identifier? #f)
-(define syntax-object->datum #f)
-
-(define primitive-syntax '(quote lambda letrec if set! begin define or
- and let let* cond do quasiquote unquote
- unquote-splicing case @ @@))
-
-(for-each (lambda (symbol)
- (set-symbol-property! symbol 'primitive-syntax #t))
- primitive-syntax)
-
-;;; Hooks needed by the syntax-case macro package
-
-(define (void) *unspecified*)
-
-(define andmap
- (lambda (f first . rest)
- (or (null? first)
- (if (null? rest)
- (let andmap ((first first))
- (let ((x (car first)) (first (cdr first)))
- (if (null? first)
- (f x)
- (and (f x) (andmap first)))))
- (let andmap ((first first) (rest rest))
- (let ((x (car first))
- (xr (map car rest))
- (first (cdr first))
- (rest (map cdr rest)))
- (if (null? first)
- (apply f (cons x xr))
- (and (apply f (cons x xr)) (andmap first rest)))))))))
-
-(define (error who format-string why what)
- (start-stack 'syncase-stack
- (scm-error 'misc-error
- who
- "~A ~S"
- (list why what)
- '())))
-
-(define the-syncase-module (current-module))
-
-(define guile-macro
- (cons 'external-macro
- (lambda (e r w s mod)
- (let ((e (syntax-object->datum e)))
- (if (symbol? e)
- ;; pass the expression through
- e
- (let* ((mod (resolve-module mod))
- (m (module-ref mod (car e))))
- (if (eq? (macro-type m) 'syntax)
- ;; pass the expression through
- e
- ;; perform Guile macro transform
- (let ((e ((macro-transformer m)
- (strip-expansion-structures e)
- (append r (list (module-eval-closure mod))))))
- (if (variable? e)
- e
- (if (null? r)
- (sc-expand e)
- (sc-chi e r w (module-name mod))))))))))))
-
-(define generated-symbols (make-weak-key-hash-table 1019))
-
-;; We define our own gensym here because the Guile built-in one will
-;; eventually produce uninterned and unreadable symbols (as needed for
-;; safe macro expansions) and will the be inappropriate for dumping to
-;; pssyntax.pp.
-;;
-;; syncase is supposed to only require that gensym produce unique
-;; readable symbols, and they only need be unique with respect to
-;; multiple calls to gensym, not globally unique.
-;;
-(define gensym
- (let ((counter 0))
-
- (define next-id
- (if (provided? 'threads)
- (let ((symlock (make-mutex)))
- (lambda ()
- (let ((result #f))
- (with-mutex symlock
- (set! result counter)
- (set! counter (+ counter 1)))
- result)))
- ;; faster, non-threaded case.
- (lambda ()
- (let ((result counter))
- (set! counter (+ counter 1))
- result))))
-
- ;; actual gensym body code.
- (lambda (. rest)
- (let* ((next-val (next-id))
- (valstr (number->string next-val)))
- (cond
- ((null? rest)
- (string->symbol (string-append "syntmp-" valstr)))
- ((null? (cdr rest))
- (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
- (else
- (error
- (string-append
- "syncase's gensym expected 0 or 1 arguments, got "
- (length rest)))))))))
-
-;;; Load the preprocessed code
-
-(let ((old-debug #f)
- (old-read #f))
- (dynamic-wind (lambda ()
- (set! old-debug (debug-options))
- (set! old-read (read-options)))
- (lambda ()
- (debug-disable 'debug 'procnames)
- (read-disable 'positions)
- (load-from-path "ice-9/psyntax-pp"))
- (lambda ()
- (debug-options old-debug)
- (read-options old-read))))
-
-(define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))
-
-(define (eval x environment)
- (internal-eval (if (and (pair? x)
- (equal? (car x) "noexpand"))
- (strip-expansion-structures (cadr x))
- (strip-expansion-structures (sc-expand x)))
- environment))
+(issue-deprecation-warning
+ "Syntax-case macros are now a part of Guile core; importing (ice-9 syncase)
is no longer necessary.")
;;; Hack to make syncase macros work in the slib module
-(let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
- (if m
- (set-object-property! (module-local-variable m 'define)
- '*sc-expander*
- '(define))))
-
-(define (syncase exp)
- (strip-expansion-structures (sc-expand exp)))
-
-(set-module-transformer! the-syncase-module syncase)
-
-(define-syntax define-syntax-public
- (syntax-rules ()
- ((_ name rules ...)
- (begin
- ;(eval-case ((load-toplevel) (export-syntax name)))
- (define-syntax name rules ...)))))
+;; FIXME wingo is this still necessary?
+;; (let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
+;; (if m
+;; (set-object-property! (module-local-variable m 'define)
+;; '*sc-expander*
+;; '(define))))
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index bd0f7b7..e07d766 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -32,21 +32,71 @@
;;; Code:
(define-module (ice-9 threads)
- :export (par-map
+ :export (begin-thread
+ parallel
+ letpar
+ make-thread
+ with-mutex
+ monitor
+
+ par-map
par-for-each
n-par-map
n-par-for-each
n-for-each-par-map
- %thread-handler)
- :export-syntax (begin-thread
- parallel
- letpar
- make-thread
- with-mutex
- monitor))
+ %thread-handler))
+;;; Macros first, so that the procedures expand correctly.
+
+(define-syntax begin-thread
+ (syntax-rules ()
+ ((_ e0 e1 ...)
+ (call-with-new-thread
+ (lambda () e0 e1 ...)
+ %thread-handler))))
+
+(define-syntax parallel
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e0 ...)
+ (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
+ (syntax
+ (let ((tmp0 (begin-thread e0))
+ ...)
+ (values (join-thread tmp0) ...))))))))
+
+(define-syntax letpar
+ (syntax-rules ()
+ ((_ ((v e) ...) b0 b1 ...)
+ (call-with-values
+ (lambda () (parallel e ...))
+ (lambda (v ...)
+ b0 b1 ...)))))
+
+(define-syntax make-thread
+ (syntax-rules ()
+ ((_ proc arg ...)
+ (call-with-new-thread
+ (lambda () (proc arg ...))
+ %thread-handler))))
+
+(define-syntax with-mutex
+ (syntax-rules ()
+ ((_ m e0 e1 ...)
+ (let ((x m))
+ (dynamic-wind
+ (lambda () (lock-mutex x))
+ (lambda () (begin e0 e1 ...))
+ (lambda () (unlock-mutex x)))))))
+
+(define-syntax monitor
+ (syntax-rules ()
+ ((_ first rest ...)
+ (with-mutex (make-mutex)
+ first rest ...))))
+
(define (par-mapper mapper)
(lambda (proc . arglists)
(mapper join-thread
@@ -171,52 +221,4 @@ of applying P-PROC on ARGLISTS."
;;; Set system thread handler
(define %thread-handler thread-handler)
-; --- MACROS -------------------------------------------------------
-
-(define-macro (begin-thread . forms)
- (if (null? forms)
- '(begin)
- `(call-with-new-thread
- (lambda ()
- ,@forms)
- %thread-handler)))
-
-(define-macro (parallel . forms)
- (cond ((null? forms) '(values))
- ((null? (cdr forms)) (car forms))
- (else
- (let ((vars (map (lambda (f)
- (make-symbol "f"))
- forms)))
- `((lambda ,vars
- (values ,@(map (lambda (v) `(join-thread ,v)) vars)))
- ,@(map (lambda (form) `(begin-thread ,form)) forms))))))
-
-(define-macro (letpar bindings . body)
- (cond ((or (null? bindings) (null? (cdr bindings)))
- `(let ,bindings ,@body))
- (else
- (let ((vars (map car bindings)))
- `((lambda ,vars
- ((lambda ,vars ,@body)
- ,@(map (lambda (v) `(join-thread ,v)) vars)))
- ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings))))))
-
-(define-macro (make-thread proc . args)
- `(call-with-new-thread
- (lambda ()
- (,proc ,@args))
- %thread-handler))
-
-(define-macro (with-mutex m . body)
- `(dynamic-wind
- (lambda () (lock-mutex ,m))
- (lambda () (begin ,@body))
- (lambda () (unlock-mutex ,m))))
-
-(define-macro (monitor first . rest)
- `(with-mutex ,(make-mutex)
- (begin
- ,first ,@rest)))
-
;;; threads.scm ends here
diff --git a/module/ice-9/time.scm b/module/ice-9/time.scm
index a704596..86ebcbf 100644
--- a/module/ice-9/time.scm
+++ b/module/ice-9/time.scm
@@ -53,6 +53,6 @@
result))
(define-macro (time exp)
- `(,time-proc (lambda () ,exp)))
+ `((@@ (ice-9 time) time-proc) (lambda () ,exp)))
;;; time.scm ends here
diff --git a/module/language/assembly/disassemble.scm
b/module/language/assembly/disassemble.scm
index 2752934..df61999 100644
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -82,7 +82,7 @@
(if (program? x)
(begin (display "----------------------------------------\n")
(disassemble x))))
- (cddr (vector->list objs))))))
+ (cdr (vector->list objs))))))
(else
(error "bad load-program form" asm))))
diff --git a/module/language/ecmascript/spec.scm
b/module/language/ecmascript/spec.scm
index 550a0b7..0112af5 100644
--- a/module/language/ecmascript/spec.scm
+++ b/module/language/ecmascript/spec.scm
@@ -33,7 +33,6 @@
#:title "Guile ECMAScript"
#:version "3.0"
#:reader (lambda () (read-ecmascript/1 (current-input-port)))
- #:read-file read-ecmascript
#:compilers `((ghil . ,compile-ghil))
;; a pretty-printer would be interesting.
#:printer write
diff --git a/module/language/ghil/compile-glil.scm
b/module/language/ghil/compile-glil.scm
index c813319..02187be 100644
--- a/module/language/ghil/compile-glil.scm
+++ b/module/language/ghil/compile-glil.scm
@@ -187,7 +187,7 @@
(define (make-glil-var op env var)
(case (ghil-var-kind var)
((argument)
- (make-glil-argument op (ghil-var-index var)))
+ (make-glil-local op (ghil-var-index var)))
((local)
(make-glil-local op (ghil-var-index var)))
((external)
@@ -217,7 +217,9 @@
(set! stack (cons code stack))
(if loc (set! stack (cons (make-glil-source loc) stack))))
(define (var->binding var)
- (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
+ (list (ghil-var-name var) (let ((kind (ghil-var-kind var)))
+ (case kind ((argument) 'local) (else kind)))
+ (ghil-var-index var)))
(define (push-bindings! loc vars)
(if (not (null? vars))
(push-code! loc (make-glil-bind (map var->binding vars)))))
@@ -496,7 +498,7 @@
(locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
(exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
(nargs (allocate-indices-linearly! vars))
- (nlocs (allocate-locals! locs body))
+ (nlocs (allocate-locals! locs body nargs))
(nexts (allocate-indices-linearly! exts)))
;; meta bindings
(push-bindings! #f vars)
@@ -509,7 +511,7 @@
(let ((v (car l)))
(case (ghil-var-kind v)
((external)
- (push-code! #f (make-glil-argument 'ref n))
+ (push-code! #f (make-glil-local 'ref n))
(push-code! #f (make-glil-external 'set 0 (ghil-var-index
v)))))))
;; compile body
(comp body #t #f)
@@ -523,8 +525,8 @@
((null? l) n)
(let ((v (car l))) (set! (ghil-var-index v) n))))
-(define (allocate-locals! vars body)
- (let ((free '()) (nlocs 0))
+(define (allocate-locals! vars body nargs)
+ (let ((free '()) (nlocs nargs))
(define (allocate! var)
(cond
((pair? free)
diff --git a/module/language/glil.scm b/module/language/glil.scm
index 01b6801..625760e 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -44,9 +44,6 @@
<glil-const> make-glil-const glil-const?
glil-const-obj
- <glil-argument> make-glil-argument glil-argument?
- glil-argument-op glil-argument-index
-
<glil-local> make-glil-local glil-local?
glil-local-op glil-local-index
@@ -87,7 +84,6 @@
(<glil-void>)
(<glil-const> obj)
;; Variables
- (<glil-argument> op index)
(<glil-local> op index)
(<glil-external> op depth index)
(<glil-toplevel> op name)
@@ -125,13 +121,12 @@
((source ,props) (make-glil-source props))
((void) (make-glil-void))
((const ,obj) (make-glil-const obj))
- ((argument ,op ,index) (make-glil-argument op index))
((local ,op ,index) (make-glil-local op index))
((external ,op ,depth ,index) (make-glil-external op depth index))
((toplevel ,op ,name) (make-glil-toplevel op name))
((module public ,op ,mod ,name) (make-glil-module op mod name #t))
((module private ,op ,mod ,name) (make-glil-module op mod name #f))
- ((label ,label) (make-label ,label))
+ ((label ,label) (make-label label))
((branch ,inst ,label) (make-glil-branch inst label))
((call ,inst ,nargs) (make-glil-call inst nargs))
((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
@@ -150,8 +145,6 @@
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
;; variables
- ((<glil-argument> op index)
- `(argument ,op ,index))
((<glil-local> op index)
`(local ,op ,index))
((<glil-external> op depth index)
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index ffac9db..4c92e0f 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -83,16 +83,15 @@
(define (make-closed-binding open-binding start end)
(make-binding (car open-binding) (cadr open-binding)
(caddr open-binding) start end))
-(define (open-binding bindings vars nargs start)
+(define (open-binding bindings vars start)
(cons
(acons start
(map
(lambda (v)
(pmatch v
- ((,name argument ,i) (make-open-binding name #f i))
- ((,name local ,i) (make-open-binding name #f (+ nargs i)))
+ ((,name local ,i) (make-open-binding name #f i))
((,name external ,i) (make-open-binding name #t i))
- (else (error "unknown binding type" name type))))
+ (else (error "unknown binding type" v))))
vars)
(car bindings))
(cdr bindings)))
@@ -129,13 +128,13 @@
(define (compile-assembly glil)
(receive (code . _)
- (glil->assembly glil 0 '() '(()) '() '() #f -1)
+ (glil->assembly glil '() '(()) '() '() #f -1)
(car code)))
(define (make-object-table objects)
(and (not (null? objects))
(list->vector (cons #f objects))))
-(define (glil->assembly glil nargs nexts-stack bindings
+(define (glil->assembly glil nexts-stack bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
(values (map assembly-pack x) bindings source-alist label-alist
object-alist))
@@ -159,7 +158,7 @@
addr))
(else
(receive (subcode bindings source-alist label-alist
object-alist)
- (glil->assembly (car body) nargs nexts-stack bindings
+ (glil->assembly (car body) nexts-stack bindings
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
@@ -196,14 +195,14 @@
((<glil-bind> vars)
(values '()
- (open-binding bindings vars nargs addr)
+ (open-binding bindings vars addr)
source-alist
label-alist
object-alist))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
- (open-binding bindings vars nargs addr)
+ (open-binding bindings vars addr)
source-alist
label-alist
object-alist))
@@ -238,16 +237,11 @@
(emit-code/object `((object-ref ,i))
object-alist)))))
- ((<glil-argument> op index)
+ ((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,index))
`((local-set ,index)))))
- ((<glil-local> op index)
- (emit-code (if (eq? op 'ref)
- `((local-ref ,(+ nargs index)))
- `((local-set ,(+ nargs index))))))
-
((<glil-external> op depth index)
(emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
(if (> d 0)
@@ -318,7 +312,12 @@
(error "Unknown instruction:" inst))
(let ((pops (instruction-pops inst)))
(cond ((< pops 0)
- (emit-code `((,inst ,nargs))))
+ (case (instruction-length inst)
+ ((1) (emit-code `((,inst ,nargs))))
+ ((2) (emit-code `((,inst ,(quotient nargs 256)
+ ,(modulo nargs 256)))))
+ (else (error "Unknown length for variable-arg instruction:"
+ inst (instruction-length inst)))))
((= pops nargs)
(emit-code `((,inst))))
(else
diff --git a/module/language/glil/decompile-assembly.scm
b/module/language/glil/decompile-assembly.scm
index a98c399..a47bd80 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -175,15 +175,11 @@
(1+ pos)))
((local-ref ,n)
(lp (cdr in) (cons *placeholder* stack)
- (cons (if (< n nargs)
- (make-glil-argument 'ref n)
- (make-glil-local 'ref (- n nargs)))
+ (cons (make-glil-local 'ref n)
out) (+ pos 2)))
((local-set ,n)
(lp (cdr in) (cdr stack)
- (cons (if (< n nargs)
- (make-glil-argument 'set n)
- (make-glil-local 'set (- n nargs)))
+ (cons (make-glil-local 'set n)
(emit-constants (list-head stack 1) out))
(+ pos 2)))
((br-if-not ,l)
diff --git a/module/language/scheme/amatch.scm
b/module/language/scheme/amatch.scm
deleted file mode 100644
index 4ac9736..0000000
--- a/module/language/scheme/amatch.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-(define-module (language scheme amatch)
- #:use-module (ice-9 syncase)
- #:export (amatch apat))
-;; FIXME: shouldn't have to export apat...
-
-;; This is exactly the same as pmatch except that it unpacks annotations
-;; as needed.
-
-(define-syntax amatch
- (syntax-rules (else guard)
- ((_ (op arg ...) cs ...)
- (let ((v (op arg ...)))
- (amatch v cs ...)))
- ((_ v) (if #f #f))
- ((_ v (else e0 e ...)) (begin e0 e ...))
- ((_ v (pat (guard g ...) e0 e ...) cs ...)
- (let ((fk (lambda () (amatch v cs ...))))
- (apat v pat
- (if (and g ...) (begin e0 e ...) (fk))
- (fk))))
- ((_ v (pat e0 e ...) cs ...)
- (let ((fk (lambda () (amatch v cs ...))))
- (apat v pat (begin e0 e ...) (fk))))))
-
-(define-syntax apat
- (syntax-rules (_ quote unquote)
- ((_ v _ kt kf) kt)
- ((_ v () kt kf) (if (null? v) kt kf))
- ((_ v (quote lit) kt kf)
- (if (equal? v (quote lit)) kt kf))
- ((_ v (unquote var) kt kf) (let ((var v)) kt))
- ((_ v (x . y) kt kf)
- (if (apair? v)
- (let ((vx (acar v)) (vy (acdr v)))
- (apat vx x (apat vy y kt kf) kf))
- kf))
- ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))
diff --git a/module/language/scheme/compile-ghil.scm
b/module/language/scheme/compile-ghil.scm
index 8623405..8d8332c 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -27,13 +27,11 @@
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
- #:use-module (ice-9 expand-support)
- #:use-module ((ice-9 syncase) #:select (sc-macro))
+ #:use-module (language tree-il)
#:use-module ((system base compile) #:select (syntax-error))
#:export (compile-ghil translate-1
*translate-table* define-scheme-translator))
-
;;; environment := #f
;;; | MODULE
;;; | COMPILE-ENV
@@ -70,12 +68,14 @@
(and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars)
- (let ((x (make-ghil-lambda env #f vars #f '()
- (translate-1 env #f x)))
- (cenv (make-cenv (current-module)
- (ghil-env-parent env)
- (if e (cenv-externals e) '()))))
- (values x cenv cenv)))))))
+ (let ((x (tree-il->scheme
+ (sc-expand x 'c '(compile load eval)))))
+ (let ((x (make-ghil-lambda env #f vars #f '()
+ (translate-1 env #f x)))
+ (cenv (make-cenv (current-module)
+ (ghil-env-parent env)
+ (if e (cenv-externals e) '()))))
+ (values x cenv cenv))))))))
;;;
@@ -104,9 +104,6 @@
(let* ((mod (current-module))
(val (cond
((symbol? head) (module-ref/safe mod head))
- ;; allow macros to be unquoted into the output of a macro
- ;; expansion
- ((macro? head) head)
((pmatch head
((@ ,modname ,sym)
(module-ref/safe (resolve-interface modname) sym))
@@ -117,21 +114,6 @@
(cond
((hashq-ref *translate-table* val))
- ((defmacro? val)
- (lambda (env loc exp)
- (retrans (apply (defmacro-transformer val) (cdr exp)))))
-
- ((eq? val sc-macro)
- ;; syncase!
- (let ((sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
- (lambda (env loc exp)
- (retrans
- (strip-expansion-structures
- (sc-expand3 exp 'c '(compile load eval)))))))
-
- ((primitive-macro? val)
- (syntax-error #f "unhandled primitive macro" head))
-
((macro? val)
(syntax-error #f "unknown kind of macro" head))
@@ -180,7 +162,7 @@
(define-macro (define-scheme-translator sym . clauses)
`(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
- ,sym
+ (module-ref (current-module) ',sym)
(lambda (e l exp)
(define (retrans x)
((@ (language scheme compile-ghil) translate-1)
@@ -432,16 +414,6 @@
(,args
(-> (values (map retrans args)))))
-(define-scheme-translator compile-time-environment
- ;; (compile-time-environment)
- ;; => (MODULE LEXICALS . EXTERNALS)
- (()
- (-> (inline 'cons
- (list (retrans '(current-module))
- (-> (inline 'cons
- (list (-> (reified-env))
- (-> (inline 'externals '()))))))))))
-
(define (lookup-apply-transformer proc)
(cond ((eq? proc values)
(lambda (e l args)
diff --git a/module/language/scheme/compile-tree-il.scm
b/module/language/scheme/compile-tree-il.scm
new file mode 100644
index 0000000..4635abc
--- /dev/null
+++ b/module/language/scheme/compile-tree-il.scm
@@ -0,0 +1,64 @@
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme compile-tree-il)
+ #:use-module (language tree-il)
+ #:export (compile-tree-il))
+
+;;; environment := #f
+;;; | MODULE
+;;; | COMPILE-ENV
+;;; compile-env := (MODULE LEXICALS . EXTERNALS)
+(define (cenv-module env)
+ (cond ((not env) #f)
+ ((module? env) env)
+ ((and (pair? env) (module? (car env))) (car env))
+ (else (error "bad environment" env))))
+
+(define (cenv-lexicals env)
+ (cond ((not env) '())
+ ((module? env) '())
+ ((pair? env) (cadr env))
+ (else (error "bad environment" env))))
+
+(define (cenv-externals env)
+ (cond ((not env) '())
+ ((module? env) '())
+ ((pair? env) (cddr env))
+ (else (error "bad environment" env))))
+
+(define (make-cenv module lexicals externals)
+ (cons module (cons lexicals externals)))
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ props))))
+
+(define (compile-tree-il x e opts)
+ (save-module-excursion
+ (lambda ()
+ (and=> (cenv-module e) set-current-module)
+ (let* ((x (sc-expand x 'c '(compile load eval)))
+ (cenv (make-cenv (current-module)
+ (cenv-lexicals e) (cenv-externals e))))
+ (values x cenv cenv)))))
diff --git a/module/language/scheme/decompile-tree-il.scm
b/module/language/scheme/decompile-tree-il.scm
new file mode 100644
index 0000000..c4903d8
--- /dev/null
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -0,0 +1,27 @@
+;;; Guile VM code converters
+
+;; Copyright (C) 2001,2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme decompile-tree-il)
+ #:use-module (language tree-il)
+ #:export (decompile-tree-il))
+
+(define (decompile-tree-il x env opts)
+ (values (tree-il->scheme x) env))
diff --git a/module/language/scheme/expand.scm
b/module/language/scheme/expand.scm
deleted file mode 100644
index 2ffefb3..0000000
--- a/module/language/scheme/expand.scm
+++ /dev/null
@@ -1,307 +0,0 @@
-;;; Guile Scheme specification
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(define-module (language scheme expand)
- #:use-module (language scheme amatch)
- #:use-module (ice-9 expand-support)
- #:use-module (ice-9 optargs)
- #:use-module ((ice-9 syncase) #:select (sc-macro))
- #:use-module ((system base compile) #:select (syntax-error))
- #:export (expand *expand-table* define-scheme-expander))
-
-(define (aref x) (if (annotation? x) (annotation-expression x) x))
-(define (apair? x) (pair? (aref x)))
-(define (acar x) (car (aref x)))
-(define (acdr x) (cdr (aref x)))
-(define (acaar x) (acar (acar x)))
-(define (acdar x) (acdr (acar x)))
-(define (acadr x) (acar (acdr x)))
-(define (acddr x) (acdr (acdr x)))
-(define (aloc x) (and (annotation? x) (annotation-source x)))
-(define (re-annotate x y)
- (if (and (annotation? x) (not (annotation? y)))
- (make-annotation y (annotation-source x))
- y))
-(define-macro (-> exp) `(re-annotate x ,exp))
-
-(define* (expand x #:optional (mod (current-module)) (once? #f))
- (define re-expand
- (if once?
- (lambda (x) x)
- (lambda (x) (expand x mod once?))))
- (let ((exp (if (annotation? x) (annotation-expression x) x)))
- (cond
- ((pair? exp)
- (let ((head (car exp)) (tail (cdr exp)))
- (cond
- ;; allow macros to be unquoted into the output of a macro
- ;; expansion
- ((or (symbol? head) (macro? head))
- (let ((val (cond
- ((macro? head) head)
- ((module-variable mod head)
- => (lambda (var)
- ;; unbound vars can happen if the module
- ;; definition forward-declared them
- (and (variable-bound? var) (variable-ref var))))
- (else #f))))
- (cond
- ((hashq-ref *expand-table* val)
- => (lambda (expand1) (expand1 x re-expand)))
-
- ((defmacro? val)
- (re-expand (-> (apply (defmacro-transformer val)
- (deannotate tail)))))
-
- ((eq? val sc-macro)
- ;; syncase!
- (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure))
- (sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
- (re-expand
- (with-fluids ((eec (module-eval-closure mod)))
- ;; fixme -- use ewes fluid?
- (sc-expand3 exp 'c '(compile load eval))))))
-
- ((primitive-macro? val)
- (syntax-error (aloc x) "unhandled primitive macro" head))
-
- ((macro? val)
- (syntax-error (aloc x) "unknown kind of macro" head))
-
- (else
- (-> (cons head (map re-expand tail)))))))
-
- (else
- (-> (map re-expand exp))))))
-
- (else x))))
-
-
-(define *expand-table* (make-hash-table))
-
-(define-macro (define-scheme-expander sym . clauses)
- `(hashq-set! (@ (language scheme expand) *expand-table*)
- ,sym
- (lambda (x re-expand)
- (define syntax-error (@ (system base compile) syntax-error))
- (amatch (acdr x)
- ,@clauses
- ,@(if (assq 'else clauses) '()
- `((else
- (syntax-error (aloc x) (format #f "bad ~A" ',sym)
x))))))))
-
-(define-scheme-expander quote
- ;; (quote OBJ)
- ((,obj) x))
-
-(define-scheme-expander quasiquote
- ;; (quasiquote OBJ)
- ((,obj)
- (-> `(,'quasiquote
- ,(let lp ((x obj) (level 0))
- (cond ((not (apair? x)) x)
- ;; FIXME: hygiene regarding imported , / ,@ rebinding
- ((memq (acar x) '(unquote unquote-splicing))
- (amatch (acdr x)
- ((,obj)
- (cond
- ((zero? level)
- (-> `(,(acar x) ,(re-expand obj))))
- (else
- (-> `(,(acar x) ,(lp obj (1- level)))))))
- (else (syntax-error (aloc x) (format #f "bad ~A" (acar
x)) x))))
- ((eq? (acar x) 'quasiquote)
- (amatch (acdr x)
- ((,obj) (-> `(,'quasiquote ,(lp obj (1+ level)))))
- (else (syntax-error (aloc x) "bad quasiquote" x))))
- (else (-> (cons (lp (acar x) level) (lp (acdr x)
level))))))))))
-
-(define-scheme-expander define
- ;; (define NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> `(define ,name ,(re-expand val))))
- ;; (define (NAME FORMALS...) BODY...)
- (((,name . ,formals) . ,body) (guard (symbol? name))
- ;; -> (define NAME (lambda FORMALS BODY...))
- (re-expand (-> `(define ,name (lambda ,formals . ,body))))))
-
-(define-scheme-expander set!
- ;; (set! (NAME ARGS...) VAL)
- (((,name . ,args) ,val) (guard (symbol? name)
- (not (eq? name '@)) (not (eq? name '@@)))
- ;; -> ((setter NAME) ARGS... VAL)
- (re-expand (-> `((setter ,name) ,@args ,val))))
-
- ;; (set! NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> `(set! ,name ,(re-expand val)))))
-
-(define-scheme-expander if
- ;; (if TEST THEN [ELSE])
- ((,test ,then)
- (-> `(if ,(re-expand test) ,(re-expand then))))
- ((,test ,then ,else)
- (-> `(if ,(re-expand test) ,(re-expand then) ,(re-expand else)))))
-
-(define-scheme-expander and
- ;; (and EXPS...)
- (,tail
- (-> `(and . ,(map re-expand tail)))))
-
-(define-scheme-expander or
- ;; (or EXPS...)
- (,tail
- (-> `(or . ,(map re-expand tail)))))
-
-(define-scheme-expander begin
- ;; (begin EXPS...)
- ((,single-exp)
- (-> (re-expand single-exp)))
- (,tail
- (-> `(begin . ,(map re-expand tail)))))
-
-(define (valid-bindings? bindings . it-is-for-do)
- (define (valid-binding? b)
- (amatch b
- ((,sym ,var) (guard (symbol? sym)) #t)
- ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
- (else #f)))
- (and (list? (aref bindings))
- (and-map valid-binding? (aref bindings))))
-
-(define-scheme-expander let
- ;; (let NAME ((SYM VAL) ...) BODY...)
- ((,name ,bindings . ,body) (guard (symbol? name)
- (valid-bindings? bindings))
- ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
- (re-expand (-> `(letrec ((,name (lambda ,(map acar (aref bindings))
- . ,body)))
- (,name . ,(map acadr (aref bindings)))))))
-
- ((() . ,body)
- (re-expand (expand-internal-defines body)))
-
- ;; (let ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (-> `(let ,(map (lambda (x)
- ;; nb, relies on -> non-hygiene
- (-> `(,(acar x) ,(re-expand (acadr x)))))
- (aref bindings))
- ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander let*
- ;; (let* ((SYM VAL) ...) BODY...)
- ((() . ,body)
- (re-expand (-> `(let () . ,body))))
- ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
- (re-expand (-> `(let ((,sym ,val)) (let* ,rest . ,body))))))
-
-(define-scheme-expander letrec
- ;; (letrec ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (-> `(letrec ,(map (lambda (x)
- ;; nb, relies on -> non-hygiene
- (-> `(,(acar x) ,(re-expand (acadr x)))))
- (aref bindings))
- ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander cond
- ;; (cond (CLAUSE BODY...) ...)
- (() (-> '(begin)))
- (((else . ,body)) (re-expand (-> `(begin ,@body))))
- (((,test) . ,rest) (re-expand (-> `(or ,test (cond ,@rest)))))
- (((,test => ,proc) . ,rest)
- ;; FIXME hygiene!
- (re-expand (-> `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))))
- (((,test . ,body) . ,rest)
- (re-expand (-> `(if ,test (begin ,@body) (cond ,@rest))))))
-
-(define-scheme-expander case
- ;; (case EXP ((KEY...) BODY...) ...)
- ((,exp . ,clauses)
- ;; FIXME hygiene!
- (re-expand
- (->`(let ((_t ,exp))
- ,(let loop ((ls clauses))
- (cond ((null? ls) '(begin))
- ((eq? (acaar ls) 'else) `(begin ,@(acdar ls)))
- (else `(if (memv _t ',(acaar ls))
- (begin ,@(acdar ls))
- ,(loop (acdr ls)))))))))))
-
-(define-scheme-expander do
- ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
- ((,bindings (,test . ,result) . ,body) (guard (valid-bindings? bindings #t))
- (let ((sym (map acar (aref bindings)))
- (val (map acadr (aref bindings)))
- (update (map acddr (aref bindings))))
- (define (next s x) (if (pair? x) (car x) s))
- (re-expand
- ;; FIXME hygiene!
- (-> `(letrec ((_l (lambda ,sym
- (if ,test
- (begin ,@result)
- (begin ,@body
- (_l ,@(map next sym update)))))))
- (_l ,@val)))))))
-
-(define-scheme-expander lambda
- ;; (lambda FORMALS BODY...)
- ((,formals ,docstring ,body1 . ,body) (guard (string? docstring))
- (-> `(lambda ,formals ,docstring ,(expand-internal-defines
- (map re-expand (cons body1 body))))))
- ((,formals . ,body)
- (-> `(lambda ,formals ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander delay
- ;; FIXME not hygienic
- ((,expr)
- (re-expand `(make-promise (lambda () ,expr)))))
-
-(define-scheme-expander @
- ((,modname ,sym)
- x))
-
-(define-scheme-expander @@
- ((,modname ,sym)
- x))
-
-(define-scheme-expander eval-when
- ((,when . ,body) (guard (list? when) (and-map symbol? when))
- (if (memq 'compile when)
- (primitive-eval `(begin . ,body)))
- (if (memq 'load when)
- (-> `(begin . ,body))
- (-> `(begin)))))
-
-;;; Hum, I don't think this takes imported modifications to `define'
-;;; properly into account. (Lexical bindings are OK because of alpha
-;;; renaming.)
-(define (expand-internal-defines body)
- (let loop ((ls body) (ds '()))
- (amatch ls
- (() (syntax-error l "bad body" body))
- (((define ,name ,val) . _)
- (loop (acdr ls) (cons (list name val) ds)))
- (else
- (if (null? ds)
- (if (null? (cdr ls)) (car ls) `(begin ,@ls))
- `(letrec ,ds ,(if (null? (cdr ls)) (car ls) `(begin ,@ls))))))))
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 8f958eb..cec2693 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -22,6 +22,8 @@
(define-module (language scheme spec)
#:use-module (system base language)
#:use-module (language scheme compile-ghil)
+ #:use-module (language scheme compile-tree-il)
+ #:use-module (language scheme decompile-tree-il)
#:export (scheme))
;;;
@@ -30,12 +32,6 @@
(read-enable 'positions)
-(define (read-file port)
- (do ((x (read port) (read port))
- (l '() (cons x l)))
- ((eof-object? x)
- (cons 'begin (reverse! l)))))
-
;;;
;;; Language definition
;;;
@@ -44,8 +40,9 @@
#:title "Guile Scheme"
#:version "0.5"
#:reader read
- #:read-file read-file
- #:compilers `((ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il)
+ (ghil . ,compile-ghil))
+ #:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
new file mode 100644
index 0000000..3350311
--- /dev/null
+++ b/module/language/tree-il.scm
@@ -0,0 +1,359 @@
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+
+(define-module (language tree-il)
+ #:use-module (system base pmatch)
+ #:use-module (system base syntax)
+ #:export (tree-il-src
+
+ <void> void? make-void void-src
+ <const> const? make-const const-src const-exp
+ <primitive-ref> primitive-ref? make-primitive-ref
primitive-ref-src primitive-ref-name
+ <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src
lexical-ref-name lexical-ref-gensym
+ <lexical-set> lexical-set? make-lexical-set lexical-set-src
lexical-set-name lexical-set-gensym lexical-set-exp
+ <module-ref> module-ref? make-module-ref module-ref-src
module-ref-mod module-ref-name module-ref-public?
+ <module-set> module-set? make-module-set module-set-src
module-set-mod module-set-name module-set-public? module-set-exp
+ <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src
toplevel-ref-name
+ <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src
toplevel-set-name toplevel-set-exp
+ <toplevel-define> toplevel-define? make-toplevel-define
toplevel-define-src toplevel-define-name toplevel-define-exp
+ <conditional> conditional? make-conditional conditional-src
conditional-test conditional-then conditional-else
+ <application> application? make-application application-src
application-proc application-args
+ <sequence> sequence? make-sequence sequence-src sequence-exps
+ <lambda> lambda? make-lambda lambda-src lambda-names lambda-vars
lambda-meta lambda-body
+ <let> let? make-let let-src let-names let-vars let-vals let-exp
+ <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars
letrec-vals letrec-exp
+
+ parse-tree-il
+ unparse-tree-il
+ tree-il->scheme
+
+ post-order!
+ pre-order!))
+
+(define-type (<tree-il> #:common-slots (src))
+ (<void>)
+ (<const> exp)
+ (<primitive-ref> name)
+ (<lexical-ref> name gensym)
+ (<lexical-set> name gensym exp)
+ (<module-ref> mod name public?)
+ (<module-set> mod name public? exp)
+ (<toplevel-ref> name)
+ (<toplevel-set> name exp)
+ (<toplevel-define> name exp)
+ (<conditional> test then else)
+ (<application> proc args)
+ (<sequence> exps)
+ (<lambda> names vars meta body)
+ (<let> names vars vals exp)
+ (<letrec> names vars vals exp))
+
+
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (pair? props) props))))
+
+(define (parse-tree-il exp)
+ (let ((loc (location exp))
+ (retrans (lambda (x) (parse-tree-il x))))
+ (pmatch exp
+ ((void)
+ (make-void loc))
+
+ ((apply ,proc . ,args)
+ (make-application loc (retrans proc) (map retrans args)))
+
+ ((if ,test ,then ,else)
+ (make-conditional loc (retrans test) (retrans then) (retrans else)))
+
+ ((primitive ,name) (guard (symbol? name))
+ (make-primitive-ref loc name))
+
+ ((lexical ,name) (guard (symbol? name))
+ (make-lexical-ref loc name name))
+
+ ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
+ (make-lexical-ref loc name sym))
+
+ ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
+ (make-lexical-set loc name sym (retrans exp)))
+
+ ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-ref loc mod name #t))
+
+ ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-set loc mod name #t (retrans exp)))
+
+ ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-ref loc mod name #f))
+
+ ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+ (make-module-set loc mod name #f (retrans exp)))
+
+ ((toplevel ,name) (guard (symbol? name))
+ (make-toplevel-ref loc name))
+
+ ((set! (toplevel ,name) ,exp) (guard (symbol? name))
+ (make-toplevel-set loc name (retrans exp)))
+
+ ((define ,name ,exp) (guard (symbol? name))
+ (make-toplevel-define loc name (retrans exp)))
+
+ ((lambda ,names ,vars ,exp)
+ (make-lambda loc names vars '() (retrans exp)))
+
+ ((lambda ,names ,vars ,meta ,exp)
+ (make-lambda loc names vars meta (retrans exp)))
+
+ ((const ,exp)
+ (make-const loc exp))
+
+ ((begin . ,exps)
+ (make-sequence loc (map retrans exps)))
+
+ ((let ,names ,vars ,vals ,exp)
+ (make-let loc names vars (map retrans vals) (retrans exp)))
+
+ ((letrec ,names ,vars ,vals ,exp)
+ (make-letrec loc names vars (map retrans vals) (retrans exp)))
+
+ (else
+ (error "unrecognized tree-il" exp)))))
+
+(define (unparse-tree-il tree-il)
+ (record-case tree-il
+ ((<void>)
+ '(void))
+
+ ((<application> proc args)
+ `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+
+ ((<conditional> test then else)
+ `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il
else)))
+
+ ((<primitive-ref> name)
+ `(primitive ,name))
+
+ ((<lexical-ref> name gensym)
+ `(lexical ,name ,gensym))
+
+ ((<lexical-set> name gensym exp)
+ `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
+
+ ((<toplevel-ref> name)
+ `(toplevel ,name))
+
+ ((<toplevel-set> name exp)
+ `(set! (toplevel ,name) ,(unparse-tree-il exp)))
+
+ ((<toplevel-define> name exp)
+ `(define ,name ,(unparse-tree-il exp)))
+
+ ((<lambda> names vars meta body)
+ `(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
+
+ ((<const> exp)
+ `(const ,exp))
+
+ ((<sequence> exps)
+ `(begin ,@(map unparse-tree-il exps)))
+
+ ((<let> names vars vals exp)
+ `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
+
+ ((<letrec> names vars vals exp)
+ `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il
exp)))))
+
+(define (tree-il->scheme e)
+ (cond ((list? e)
+ (map tree-il->scheme e))
+ ((pair? e)
+ (cons (tree-il->scheme (car e))
+ (tree-il->scheme (cdr e))))
+ ((record? e)
+ (record-case e
+ ((<void>)
+ '(if #f #f))
+
+ ((<application> proc args)
+ `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
+
+ ((<conditional> test then else)
+ (if (void? else)
+ `(if ,(tree-il->scheme test) ,(tree-il->scheme then))
+ `(if ,(tree-il->scheme test) ,(tree-il->scheme then)
,(tree-il->scheme else))))
+
+ ((<primitive-ref> name)
+ name)
+
+ ((<lexical-ref> name gensym)
+ gensym)
+
+ ((<lexical-set> name gensym exp)
+ `(set! ,gensym ,(tree-il->scheme exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
+
+ ((<toplevel-ref> name)
+ name)
+
+ ((<toplevel-set> name exp)
+ `(set! ,name ,(tree-il->scheme exp)))
+
+ ((<toplevel-define> name exp)
+ `(define ,name ,(tree-il->scheme exp)))
+
+ ((<lambda> vars meta body)
+ `(lambda ,vars
+ ,@(cond ((assq-ref meta 'documentation) => list) (else '()))
+ ,(tree-il->scheme body)))
+
+ ((<const> exp)
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp)))
+
+ ((<sequence> exps)
+ `(begin ,@(map tree-il->scheme exps)))
+
+ ((<let> vars vals exp)
+ `(let ,(map list vars (map tree-il->scheme vals))
,(tree-il->scheme exp)))
+
+ ((<letrec> vars vals exp)
+ `(letrec ,(map list vars (map tree-il->scheme vals))
,(tree-il->scheme exp)))))
+ (else e)))
+
+(define (post-order! f x)
+ (let lp ((x x))
+ (record-case x
+ ((<void>)
+ (or (f x) x))
+
+ ((<application> proc args)
+ (set! (application-proc x) (lp proc))
+ (set! (application-args x) (map lp args))
+ (or (f x) x))
+
+ ((<conditional> test then else)
+ (set! (conditional-test x) (lp test))
+ (set! (conditional-then x) (lp then))
+ (set! (conditional-else x) (lp else))
+ (or (f x) x))
+
+ ((<primitive-ref> name)
+ (or (f x) x))
+
+ ((<lexical-ref> name gensym)
+ (or (f x) x))
+
+ ((<lexical-set> name gensym exp)
+ (set! (lexical-set-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<module-ref> mod name public?)
+ (or (f x) x))
+
+ ((<module-set> mod name public? exp)
+ (set! (module-set-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<toplevel-ref> name)
+ (or (f x) x))
+
+ ((<toplevel-set> name exp)
+ (set! (toplevel-set-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<toplevel-define> name exp)
+ (set! (toplevel-define-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<lambda> vars meta body)
+ (set! (lambda-body x) (lp body))
+ (or (f x) x))
+
+ ((<const> exp)
+ (or (f x) x))
+
+ ((<sequence> exps)
+ (set! (sequence-exps x) (map lp exps))
+ (or (f x) x))
+
+ ((<let> vars vals exp)
+ (set! (let-vals x) (map lp vals))
+ (set! (let-exp x) (lp exp))
+ (or (f x) x))
+
+ ((<letrec> vars vals exp)
+ (set! (letrec-vals x) (map lp vals))
+ (set! (letrec-exp x) (lp exp))
+ (or (f x) x)))))
+
+(define (pre-order! f x)
+ (let lp ((x x))
+ (let ((x (or (f x) x)))
+ (record-case x
+ ((<application> proc args)
+ (set! (application-proc x) (lp proc))
+ (set! (application-args x) (map lp args)))
+
+ ((<conditional> test then else)
+ (set! (conditional-test x) (lp test))
+ (set! (conditional-then x) (lp then))
+ (set! (conditional-else x) (lp else)))
+
+ ((<lexical-set> name gensym exp)
+ (set! (lexical-set-exp x) (lp exp)))
+
+ ((<module-set> mod name public? exp)
+ (set! (module-set-exp x) (lp exp)))
+
+ ((<toplevel-set> name exp)
+ (set! (toplevel-set-exp x) (lp exp)))
+
+ ((<toplevel-define> name exp)
+ (set! (toplevel-define-exp x) (lp exp)))
+
+ ((<lambda> vars meta body)
+ (set! (lambda-body x) (lp body)))
+
+ ((<sequence> exps)
+ (set! (sequence-exps x) (map lp exps)))
+
+ ((<let> vars vals exp)
+ (set! (let-vals x) (map lp vals))
+ (set! (let-exp x) (lp exp)))
+
+ ((<letrec> vars vals exp)
+ (set! (letrec-vals x) (map lp vals))
+ (set! (letrec-exp x) (lp exp)))
+
+ (else #f))
+ x)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
new file mode 100644
index 0000000..477f1fc
--- /dev/null
+++ b/module/language/tree-il/analyze.scm
@@ -0,0 +1,235 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il analyze)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:export (analyze-lexicals))
+
+;; allocation: the process of assigning a type and index to each var
+;; a var is external if it is heaps; assigning index is easy
+;; args are assigned in order
+;; locals are indexed as their linear position in the binding path
+;; (let (0 1)
+;; (let (2 3) ...)
+;; (let (2) ...))
+;; (let (2 3 4) ...))
+;; etc.
+;;
+;; This algorithm has the problem that variables are only allocated
+;; indices at the end of the binding path. If variables bound early in
+;; the path are not used in later portions of the path, their indices
+;; will not be recycled. This problem is particularly egregious in the
+;; expansion of `or':
+;;
+;; (or x y z)
+;; -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
+;;
+;; As you can see, the `a' binding is only used in the ephemeral `then'
+;; clause of the first `if', but its index would be reserved for the
+;; whole of the `or' expansion. So we have a hack for this specific
+;; case. A proper solution would be some sort of liveness analysis, and
+;; not our linear allocation algorithm.
+;;
+;; allocation:
+;; sym -> (local . index) | (heap level . index)
+;; lambda -> (nlocs . nexts)
+
+(define (analyze-lexicals x)
+ ;; parents: lambda -> parent
+ ;; useful when we see a closed-over var, so we can calculate its
+ ;; coordinates (depth and index).
+ ;; bindings: lambda -> (sym ...)
+ ;; useful for two reasons: one, so we know how much space to allocate
+ ;; when we go into a lambda; and two, so that we know when to stop,
+ ;; when looking for closed-over vars.
+ ;; heaps: sym -> lambda
+ ;; allows us to heapify vars in an O(1) fashion
+ ;; refcounts: sym -> count
+ ;; allows us to detect the or-expansion an O(1) time
+
+ (define (find-heap sym parent)
+ ;; fixme: check displaced lexicals here?
+ (if (memq sym (hashq-ref bindings parent))
+ parent
+ (find-heap sym (hashq-ref parents parent))))
+
+ (define (analyze! x parent level)
+ (define (step y) (analyze! y parent level))
+ (define (recur x parent) (analyze! x parent (1+ level)))
+ (record-case x
+ ((<application> proc args)
+ (step proc) (for-each step args))
+
+ ((<conditional> test then else)
+ (step test) (step then) (step else))
+
+ ((<lexical-ref> name gensym)
+ (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+ (if (and (not (memq gensym (hashq-ref bindings parent)))
+ (not (hashq-ref heaps gensym)))
+ (hashq-set! heaps gensym (find-heap gensym parent))))
+
+ ((<lexical-set> name gensym exp)
+ (step exp)
+ (if (not (hashq-ref heaps gensym))
+ (hashq-set! heaps gensym (find-heap gensym parent))))
+
+ ((<module-set> mod name public? exp)
+ (step exp))
+
+ ((<toplevel-set> name exp)
+ (step exp))
+
+ ((<toplevel-define> name exp)
+ (step exp))
+
+ ((<sequence> exps)
+ (for-each step exps))
+
+ ((<lambda> vars meta body)
+ (hashq-set! parents x parent)
+ (hashq-set! bindings x
+ (let rev* ((vars vars) (out '()))
+ (cond ((null? vars) out)
+ ((pair? vars) (rev* (cdr vars)
+ (cons (car vars) out)))
+ (else (cons vars out)))))
+ (recur body x)
+ (hashq-set! bindings x (reverse! (hashq-ref bindings x))))
+
+ ((<let> vars vals exp)
+ (for-each step vals)
+ (hashq-set! bindings parent
+ (append (reverse vars) (hashq-ref bindings parent)))
+ (step exp))
+
+ ((<letrec> vars vals exp)
+ (hashq-set! bindings parent
+ (append (reverse vars) (hashq-ref bindings parent)))
+ (for-each step vals)
+ (step exp))
+
+ (else #f)))
+
+ (define (allocate-heap! binder)
+ (hashq-set! heap-indexes binder
+ (1+ (hashq-ref heap-indexes binder -1))))
+
+ (define (allocate! x level n)
+ (define (recur y) (allocate! y level n))
+ (record-case x
+ ((<application> proc args)
+ (apply max (recur proc) (map recur args)))
+
+ ((<conditional> test then else)
+ (max (recur test) (recur then) (recur else)))
+
+ ((<lexical-set> name gensym exp)
+ (recur exp))
+
+ ((<module-set> mod name public? exp)
+ (recur exp))
+
+ ((<toplevel-set> name exp)
+ (recur exp))
+
+ ((<toplevel-define> name exp)
+ (recur exp))
+
+ ((<sequence> exps)
+ (apply max (map recur exps)))
+
+ ((<lambda> vars meta body)
+ (let lp ((vars vars) (n 0))
+ (if (null? vars)
+ (hashq-set! allocation x
+ (let ((nlocs (- (allocate! body (1+ level) n) n)))
+ (cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
+ (let ((v (if (pair? vars) (car vars) vars)))
+ (let ((binder (hashq-ref heaps v)))
+ (hashq-set!
+ allocation v
+ (if binder
+ (cons* 'heap (1+ level) (allocate-heap! binder))
+ (cons 'stack n))))
+ (lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
+ n)
+
+ ((<let> vars vals exp)
+ (let ((nmax (apply max (map recur vals))))
+ (cond
+ ;; the `or' hack
+ ((and (conditional? exp)
+ (= (length vars) 1)
+ (let ((v (car vars)))
+ (and (not (hashq-ref heaps v))
+ (= (hashq-ref refcounts v 0) 2)
+ (lexical-ref? (conditional-test exp))
+ (eq? (lexical-ref-gensym (conditional-test exp)) v)
+ (lexical-ref? (conditional-then exp))
+ (eq? (lexical-ref-gensym (conditional-then exp)) v))))
+ (hashq-set! allocation (car vars) (cons 'stack n))
+ ;; the 1+ for this var
+ (max nmax (1+ n) (allocate! (conditional-else exp) level n)))
+ (else
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (max nmax (allocate! exp level n))
+ (let ((v (car vars)))
+ (let ((binder (hashq-ref heaps v)))
+ (hashq-set!
+ allocation v
+ (if binder
+ (cons* 'heap level (allocate-heap! binder))
+ (cons 'stack n)))
+ (lp (cdr vars) (if binder n (1+ n)))))))))))
+
+ ((<letrec> vars vals exp)
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (let ((nmax (apply max
+ (map (lambda (x)
+ (allocate! x level n))
+ vals))))
+ (max nmax (allocate! exp level n)))
+ (let ((v (car vars)))
+ (let ((binder (hashq-ref heaps v)))
+ (hashq-set!
+ allocation v
+ (if binder
+ (cons* 'heap level (allocate-heap! binder))
+ (cons 'stack n)))
+ (lp (cdr vars) (if binder n (1+ n))))))))
+
+ (else n)))
+
+ (define parents (make-hash-table))
+ (define bindings (make-hash-table))
+ (define heaps (make-hash-table))
+ (define refcounts (make-hash-table))
+ (define allocation (make-hash-table))
+ (define heap-indexes (make-hash-table))
+
+ (analyze! x #f -1)
+ (allocate! x -1 0)
+
+ allocation)
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
new file mode 100644
index 0000000..94ace7e
--- /dev/null
+++ b/module/language/tree-il/compile-glil.scm
@@ -0,0 +1,448 @@
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il compile-glil)
+ #:use-module (system base syntax)
+ #:use-module (ice-9 receive)
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il optimize)
+ #:use-module (language tree-il analyze)
+ #:export (compile-glil))
+
+;;; TODO:
+;;
+;; call-with-values -> mv-bind
+;; basic degenerate-case reduction
+
+;; allocation:
+;; sym -> (local . index) | (heap level . index)
+;; lambda -> (nlocs . nexts)
+
+(define *comp-module* (make-fluid))
+
+(define (compile-glil x e opts)
+ (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+ (x (optimize! x e opts))
+ (allocation (analyze-lexicals x)))
+ (with-fluid* *comp-module* (or (and e (car e)) (current-module))
+ (lambda ()
+ (values (flatten-lambda x -1 allocation)
+ (and e (cons (car e) (cddr e)))
+ e)))))
+
+
+
+(define *primcall-ops* (make-hash-table))
+(for-each
+ (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
+ '(((eq? . 2) . eq?)
+ ((eqv? . 2) . eqv?)
+ ((equal? . 2) . equal?)
+ ((= . 2) . ee?)
+ ((< . 2) . lt?)
+ ((> . 2) . gt?)
+ ((<= . 2) . le?)
+ ((>= . 2) . ge?)
+ ((+ . 2) . add)
+ ((- . 2) . sub)
+ ((* . 2) . mul)
+ ((/ . 2) . div)
+ ((quotient . 2) . quo)
+ ((remainder . 2) . rem)
+ ((modulo . 2) . mod)
+ ((not . 1) . not)
+ ((pair? . 1) . pair?)
+ ((cons . 2) . cons)
+ ((car . 1) . car)
+ ((cdr . 1) . cdr)
+ ((set-car! . 2) . set-car!)
+ ((set-cdr! . 2) . set-cdr!)
+ ((null? . 1) . null?)
+ ((list? . 1) . list?)
+ (list . list)
+ (vector . vector)
+ ((@slot-ref . 2) . slot-ref)
+ ((@slot-set! . 3) . slot-set)))
+
+(define (make-label) (gensym ":L"))
+
+(define (vars->bind-list ids vars allocation)
+ (map (lambda (id v)
+ (let ((loc (hashq-ref allocation v)))
+ (case (car loc)
+ ((stack) (list id 'local (cdr loc)))
+ ((heap) (list id 'external (cddr loc)))
+ (else (error "badness" id v loc)))))
+ ids
+ vars))
+
+(define (emit-bindings src ids vars allocation emit-code)
+ (if (pair? vars)
+ (emit-code src (make-glil-bind
+ (vars->bind-list ids vars allocation)))))
+
+(define (with-output-to-code proc)
+ (let ((out '()))
+ (define (emit-code src x)
+ (set! out (cons x out))
+ (if src
+ (set! out (cons (make-glil-source src) out))))
+ (proc emit-code)
+ (reverse out)))
+
+(define (flatten-lambda x level allocation)
+ (receive (ids vars nargs nrest)
+ (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
+ (oids '()) (ovars '()) (n 0))
+ (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
+ ((pair? vars) (lp (cdr ids) (cdr vars)
+ (cons (car ids) oids) (cons (car vars) ovars)
+ (1+ n)))
+ (else (values (reverse (cons ids oids))
+ (reverse (cons vars ovars))
+ (1+ n) 1))))
+ (let ((nlocs (car (hashq-ref allocation x)))
+ (nexts (cdr (hashq-ref allocation x))))
+ (make-glil-program
+ nargs nrest nlocs nexts (lambda-meta x)
+ (with-output-to-code
+ (lambda (emit-code)
+ ;; write bindings and source debugging info
+ (emit-bindings #f ids vars allocation emit-code)
+ (if (lambda-src x)
+ (emit-code #f (make-glil-source (lambda-src x))))
+
+ ;; copy args to the heap if necessary
+ (let lp ((in vars) (n 0))
+ (if (not (null? in))
+ (let ((loc (hashq-ref allocation (car in))))
+ (case (car loc)
+ ((heap)
+ (emit-code #f (make-glil-local 'ref n))
+ (emit-code #f (make-glil-external 'set 0 (cddr loc)))))
+ (lp (cdr in) (1+ n)))))
+
+ ;; and here, here, dear reader: we compile.
+ (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
+
+(define (flatten x level allocation emit-code)
+ (define (emit-label label)
+ (emit-code #f (make-glil-label label)))
+ (define (emit-branch src inst label)
+ (emit-code src (make-glil-branch inst label)))
+
+ (let comp ((x x) (context 'tail))
+ (define (comp-tail tree) (comp tree context))
+ (define (comp-push tree) (comp tree 'push))
+ (define (comp-drop tree) (comp tree 'drop))
+
+ (record-case x
+ ((<void>)
+ (case context
+ ((push) (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<const> src exp)
+ (case context
+ ((push) (emit-code src (make-glil-const exp)))
+ ((tail)
+ (emit-code src (make-glil-const exp))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ;; FIXME: should represent sequence as exps tail
+ ((<sequence> src exps)
+ (let lp ((exps exps))
+ (if (null? (cdr exps))
+ (comp-tail (car exps))
+ (begin
+ (comp-drop (car exps))
+ (lp (cdr exps))))))
+
+ ((<application> src proc args)
+ ;; FIXME: need a better pattern-matcher here
+ (cond
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@apply)
+ (>= (length args) 1))
+ (let ((proc (car args))
+ (args (cdr args)))
+ (cond
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)))
+ ;; tail: (lambda () (apply values '(1 2)))
+ ;; drop: (lambda () (apply values '(1 2)) 3)
+ ;; push: (lambda () (list (apply values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values* (length
args))))))
+
+ (else
+ (case context
+ ((tail)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'goto/apply (1+ (length
args)))))
+ ((push)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'apply (1+ (length args)))))
+ ((drop)
+ ;; Well, shit. The proc might return any number of
+ ;; values (including 0), since it's in a drop context,
+ ;; yet apply does not create a MV continuation. So we
+ ;; mv-call out to our trampoline instead.
+ (comp-drop
+ (make-application src (make-primitive-ref #f 'apply)
+ (cons proc args)))))))))
+
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)))
+ ;; tail: (lambda () (values '(1 2)))
+ ;; drop: (lambda () (values '(1 2)) 3)
+ ;; push: (lambda () (list (values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values (length args))))))
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@call-with-values)
+ (= (length args) 2))
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (let ((MV (make-label)) (POST (make-label))
+ (producer (car args)) (consumer (cadr args)))
+ (comp-push consumer)
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/args 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))))))
+
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@call-with-current-continuation)
+ (= (length args) 1))
+ (case context
+ ((tail)
+ (comp-push (car args))
+ (emit-code src (make-glil-call 'goto/cc 1)))
+ ((push)
+ (comp-push (car args))
+ (emit-code src (make-glil-call 'call/cc 1)))
+ ((drop)
+ ;; Crap. Just like `apply' in drop context.
+ (comp-drop
+ (make-application
+ src (make-primitive-ref #f 'call-with-current-continuation)
+ args)))))
+
+ ((and (primitive-ref? proc)
+ (or (hash-ref *primcall-ops*
+ (cons (primitive-ref-name proc) (length args)))
+ (hash-ref *primcall-ops* (primitive-ref-name proc))))
+ => (lambda (op)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call op (length args)))
+ (case context
+ ((tail) (emit-code #f (make-glil-call 'return 1)))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))))
+ (else
+ (comp-push proc)
+ (for-each comp-push args)
+ (let ((len (length args)))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'goto/args len)))
+ ((push) (emit-code src (make-glil-call 'call len)))
+ ((drop)
+ (let ((MV (make-label)) (POST (make-label)))
+ (emit-code src (make-glil-mv-call len MV))
+ (emit-code #f (make-glil-call 'drop 1))
+ (emit-branch #f 'br POST)
+ (emit-label MV)
+ (emit-code #f (make-glil-mv-bind '() #f))
+ (emit-code #f (make-glil-unbind))
+ (emit-label POST))))))))
+
+ ((<conditional> src test then else)
+ ;; TEST
+ ;; (br-if-not L1)
+ ;; THEN
+ ;; (br L2)
+ ;; L1: ELSE
+ ;; L2:
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (comp-push test)
+ (emit-branch src 'br-if-not L1)
+ (comp-tail then)
+ (if (not (eq? context 'tail))
+ (emit-branch #f 'br L2))
+ (emit-label L1)
+ (comp-tail else)
+ (if (not (eq? context 'tail))
+ (emit-label L2))))
+
+ ((<primitive-ref> src name)
+ (cond
+ ((eq? (module-variable (fluid-ref *comp-module*) name)
+ (module-variable the-root-module name))
+ (case context
+ ((push)
+ (emit-code src (make-glil-toplevel 'ref name)))
+ ((tail)
+ (emit-code src (make-glil-toplevel 'ref name))
+ (emit-code #f (make-glil-call 'return 1)))))
+ (else
+ (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
+ (case context
+ ((push)
+ (emit-code src (make-glil-module 'ref '(guile) name #f)))
+ ((tail)
+ (emit-code src (make-glil-module 'ref '(guile) name #f))
+ (emit-code #f (make-glil-call 'return 1)))))))
+
+ ((<lexical-ref> src name gensym)
+ (case context
+ ((push tail)
+ (let ((loc (hashq-ref allocation gensym)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'ref (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external
+ 'ref (- level (cadr loc)) (cddr loc))))
+ (else (error "badness" x loc)))
+ (if (eq? context 'tail)
+ (emit-code #f (make-glil-call 'return 1)))))))
+
+ ((<lexical-set> src name gensym exp)
+ (comp-push exp)
+ (let ((loc (hashq-ref allocation gensym)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'set (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external
+ 'set (- level (cadr loc)) (cddr loc))))
+ (else (error "badness" x loc))))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<module-ref> src mod name public?)
+ (emit-code src (make-glil-module 'ref mod name public?))
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1)))
+ ((tail) (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<module-set> src mod name public? exp)
+ (comp-push exp)
+ (emit-code src (make-glil-module 'set mod name public?))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<toplevel-ref> src name)
+ (emit-code src (make-glil-toplevel 'ref name))
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1)))
+ ((tail) (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<toplevel-set> src name exp)
+ (comp-push exp)
+ (emit-code src (make-glil-toplevel 'set name))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<toplevel-define> src name exp)
+ (comp-push exp)
+ (emit-code src (make-glil-toplevel 'define name))
+ (case context
+ ((push)
+ (emit-code #f (make-glil-void)))
+ ((tail)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<lambda>)
+ (case context
+ ((push)
+ (emit-code #f (flatten-lambda x level allocation)))
+ ((tail)
+ (emit-code #f (flatten-lambda x level allocation))
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ((<let> src names vars vals exp)
+ (for-each comp-push vals)
+ (emit-bindings src names vars allocation emit-code)
+ (for-each (lambda (v)
+ (let ((loc (hashq-ref allocation v)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'set (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external 'set 0 (cddr loc))))
+ (else (error "badness" x loc)))))
+ (reverse vars))
+ (comp-tail exp)
+ (emit-code #f (make-glil-unbind)))
+
+ ((<letrec> src names vars vals exp)
+ (for-each comp-push vals)
+ (emit-bindings src names vars allocation emit-code)
+ (for-each (lambda (v)
+ (let ((loc (hashq-ref allocation v)))
+ (case (car loc)
+ ((stack)
+ (emit-code src (make-glil-local 'set (cdr loc))))
+ ((heap)
+ (emit-code src (make-glil-external 'set 0 (cddr loc))))
+ (else (error "badness" x loc)))))
+ (reverse vars))
+ (comp-tail exp)
+ (emit-code #f (make-glil-unbind))))))
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
new file mode 100644
index 0000000..3a02e02
--- /dev/null
+++ b/module/language/tree-il/optimize.scm
@@ -0,0 +1,42 @@
+;;; Tree-il optimizer
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il optimize)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:export (optimize!))
+
+(define (env-module e)
+ (if e (car e) (current-module)))
+
+(define (optimize! x env opts)
+ (expand-primitives! (resolve-primitives! x (env-module env))))
+
+;; Possible optimizations:
+;; * constant folding, propagation
+;; * procedure inlining
+;; * always when single call site
+;; * always for "trivial" procs
+;; * otherwise who knows
+;; * dead code elimination
+;; * degenerate case optimizations
+;; * "fixing letrec"
+
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
new file mode 100644
index 0000000..51bbfea
--- /dev/null
+++ b/module/language/tree-il/primitives.scm
@@ -0,0 +1,206 @@
+;;; GHIL macros
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il primitives)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:use-module (srfi srfi-16)
+ #:export (resolve-primitives! add-interesting-primitive!
+ expand-primitives!))
+
+(define *interesting-primitive-names*
+ '(apply @apply
+ call-with-values @call-with-values
+ call-with-current-continuation @call-with-current-continuation
+ call/cc
+ values
+ eq? eqv? equal?
+ = < > <= >= zero?
+ + * - / 1- 1+ quotient remainder modulo
+ not
+ pair? null? list? acons cons cons*
+
+ list vector
+
+ car cdr
+ set-car! set-cdr!
+
+ caar cadr cdar cddr
+
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
+
+(define (add-interesting-primitive! name)
+ (hashq-set! *interesting-primitive-vars*
+ (module-variable (current-module) name) name))
+
+(define *interesting-primitive-vars* (make-hash-table))
+
+(for-each add-interesting-primitive! *interesting-primitive-names*)
+
+(define (resolve-primitives! x mod)
+ (post-order!
+ (lambda (x)
+ (record-case x
+ ((<toplevel-ref> src name)
+ (and (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name))
+ (make-primitive-ref src name)))
+ ((<module-ref> src mod name public?)
+ ;; for the moment, we're disabling primitive resolution for
+ ;; public refs because resolve-interface can raise errors.
+ (let ((m (and (not public?) (resolve-module mod))))
+ (and m (hashq-ref *interesting-primitive-vars*
+ (module-variable m name))
+ (make-primitive-ref src name))))
+ (else #f)))
+ x))
+
+
+
+(define *primitive-expand-table* (make-hash-table))
+
+(define (expand-primitives! x)
+ (pre-order!
+ (lambda (x)
+ (record-case x
+ ((<application> src proc args)
+ (and (primitive-ref? proc)
+ (let ((expand (hashq-ref *primitive-expand-table*
+ (primitive-ref-name proc))))
+ (and expand (apply expand src args)))))
+ (else #f)))
+ x))
+
+;;; I actually did spend about 10 minutes trying to redo this with
+;;; syntax-rules. Patches appreciated.
+;;;
+(define-macro (define-primitive-expander sym . clauses)
+ (define (inline-args args)
+ (let lp ((in args) (out '()))
+ (cond ((null? in) `(list ,@(reverse out)))
+ ((symbol? in) `(cons* ,@(reverse out) ,in))
+ ((pair? (car in))
+ (lp (cdr in)
+ (cons `(make-application src (make-primitive-ref src ',(caar
in))
+ ,(inline-args (cdar in)))
+ out)))
+ ((symbol? (car in))
+ ;; assume it's locally bound
+ (lp (cdr in) (cons (car in) out)))
+ ((number? (car in))
+ (lp (cdr in) (cons `(make-const src ,(car in)) out)))
+ (else
+ (error "what what" (car in))))))
+ (define (consequent exp)
+ (cond
+ ((pair? exp)
+ `(make-application src (make-primitive-ref src ',(car exp))
+ ,(inline-args (cdr exp))))
+ ((symbol? exp)
+ ;; assume locally bound
+ exp)
+ ((number? exp)
+ `(make-const src ,exp))
+ (else (error "bad consequent yall" exp))))
+ `(hashq-set! *primitive-expand-table*
+ ',sym
+ (case-lambda
+ ,@(let lp ((in clauses) (out '()))
+ (if (null? in)
+ (reverse (cons '(else #f) out))
+ (lp (cddr in)
+ (cons `((src . ,(car in))
+ ,(consequent (cadr in))) out)))))))
+
+(define-primitive-expander +
+ () 0
+ (x) x
+ (x y z . rest) (+ x (+ y z . rest)))
+
+(define-primitive-expander *
+ () 1
+ (x) x
+ (x y z . rest) (* x (* y z . rest)))
+
+(define-primitive-expander -
+ (x) (- 0 x)
+ (x y z . rest) (- x (+ y z . rest)))
+
+(define-primitive-expander 1-
+ (x) (- x 1))
+
+(define-primitive-expander /
+ (x) (/ 1 x)
+ (x y z . rest) (/ x (* y z . rest)))
+
+(define-primitive-expander caar (x) (car (car x)))
+(define-primitive-expander cadr (x) (car (cdr x)))
+(define-primitive-expander cdar (x) (cdr (car x)))
+(define-primitive-expander cddr (x) (cdr (cdr x)))
+(define-primitive-expander caaar (x) (car (car (car x))))
+(define-primitive-expander caadr (x) (car (car (cdr x))))
+(define-primitive-expander cadar (x) (car (cdr (car x))))
+(define-primitive-expander caddr (x) (car (cdr (cdr x))))
+(define-primitive-expander cdaar (x) (cdr (car (car x))))
+(define-primitive-expander cdadr (x) (cdr (car (cdr x))))
+(define-primitive-expander cddar (x) (cdr (cdr (car x))))
+(define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
+(define-primitive-expander caaaar (x) (car (car (car (car x)))))
+(define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
+(define-primitive-expander caadar (x) (car (car (cdr (car x)))))
+(define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
+(define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
+(define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
+(define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
+(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
+(define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
+(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
+(define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
+(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
+(define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
+(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
+(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
+(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
+
+(define-primitive-expander cons*
+ (x) x
+ (x y) (cons x y)
+ (x y . rest) (cons x (cons* y . rest)))
+
+(define-primitive-expander acons (x y z)
+ (cons (cons x y) z))
+
+(define-primitive-expander apply (f . args)
+ (@apply f . args))
+
+(define-primitive-expander call-with-values (producer consumer)
+ (@call-with-values producer consumer))
+
+(define-primitive-expander call-with-current-continuation (proc)
+ (@call-with-current-continuation proc))
+
+(define-primitive-expander call/cc (proc)
+ (@call-with-current-continuation proc))
+
+(define-primitive-expander values (x) x)
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
new file mode 100644
index 0000000..c1f0982
--- /dev/null
+++ b/module/language/tree-il/spec.scm
@@ -0,0 +1,43 @@
+;;; Tree Intermediate Language
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language tree-il spec)
+ #:use-module (system base language)
+ #:use-module (language glil)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il compile-glil)
+ #:export (tree-il))
+
+(define (write-tree-il exp . port)
+ (apply write (unparse-tree-il exp) port))
+
+(define (join exps env)
+ (make-sequence #f exps))
+
+(define-language tree-il
+ #:title "Tree Intermediate Language"
+ #:version "1.0"
+ #:reader read
+ #:printer write-tree-il
+ #:parser parse-tree-il
+ #:joiner join
+ #:compilers `((glil . ,compile-glil))
+ )
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 2254f93..6e3b150 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -154,17 +154,6 @@
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
-(define (define-class-pre-definition kw val)
- (case kw
- ((#:getter #:setter)
- `(if (or (not (defined? ',val))
- (not (is-a? ,val <generic>)))
- (define-generic ,val)))
- ((#:accessor)
- `(if (or (not (defined? ',val))
- (not (is-a? ,val <accessor>)))
- (define-accessor ,val)))
- (else #f)))
(define (kw-do-map mapper f kwargs)
(define (keywords l)
@@ -180,31 +169,37 @@
(a (args kwargs)))
(mapper f k a)))
-;;; This code should be implemented in C.
-;;;
-(define-macro (define-class name supers . slots)
- ;; Some slot options require extra definitions to be made. In
- ;; particular, we want to make sure that the generic function objects
- ;; which represent accessors exist before `make-class' tries to add
- ;; methods to them.
- ;;
- ;; Postpone some error handling to class macro.
- ;;
- `(begin
- ;; define accessors
- ,@(append-map (lambda (slot)
- (kw-do-map filter-map
- define-class-pre-definition
- (if (pair? slot) (cdr slot) '())))
- (take-while (lambda (x) (not (keyword? x))) slots))
- (if (and (defined? ',name)
- (is-a? ,name <class>)
- (memq <object> (class-precedence-list ,name)))
- (class-redefinition ,name
- (class ,supers ,@slots #:name ',name))
- (define ,name (class ,supers ,@slots #:name ',name)))))
-
-(define standard-define-class define-class)
+(define (make-class supers slots . options)
+ (let ((env (or (get-keyword #:environment options #f)
+ (top-level-env))))
+ (let* ((name (get-keyword #:name options (make-unbound)))
+ (supers (if (not (or-map (lambda (class)
+ (memq <object>
+ (class-precedence-list class)))
+ supers))
+ (append supers (list <object>))
+ supers))
+ (metaclass (or (get-keyword #:metaclass options #f)
+ (ensure-metaclass supers env))))
+
+ ;; Verify that all direct slots are different and that we don't inherit
+ ;; several time from the same class
+ (let ((tmp1 (find-duplicate supers))
+ (tmp2 (find-duplicate (map slot-definition-name slots))))
+ (if tmp1
+ (goops-error "make-class: super class ~S is duplicate in class ~S"
+ tmp1 name))
+ (if tmp2
+ (goops-error "make-class: slot ~S is duplicate in class ~S"
+ tmp2 name)))
+
+ ;; Everything seems correct, build the class
+ (apply make metaclass
+ #:dsupers supers
+ #:slots slots
+ #:name name
+ #:environment env
+ options))))
;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
@@ -229,7 +224,6 @@
(else
`(list ',def))))
slots))
-
(if (not (list? supers))
(goops-error "malformed superclass list: ~S" supers))
(let ((slot-defs (cons #f '()))
@@ -243,37 +237,71 @@
;; evaluate class options
,@options)))
-(define (make-class supers slots . options)
- (let ((env (or (get-keyword #:environment options #f)
- (top-level-env))))
- (let* ((name (get-keyword #:name options (make-unbound)))
- (supers (if (not (or-map (lambda (class)
- (memq <object>
- (class-precedence-list class)))
- supers))
- (append supers (list <object>))
- supers))
- (metaclass (or (get-keyword #:metaclass options #f)
- (ensure-metaclass supers env))))
-
- ;; Verify that all direct slots are different and that we don't inherit
- ;; several time from the same class
- (let ((tmp1 (find-duplicate supers))
- (tmp2 (find-duplicate (map slot-definition-name slots))))
- (if tmp1
- (goops-error "make-class: super class ~S is duplicate in class ~S"
- tmp1 name))
- (if tmp2
- (goops-error "make-class: slot ~S is duplicate in class ~S"
- tmp2 name)))
-
- ;; Everything seems correct, build the class
- (apply make metaclass
- #:dsupers supers
- #:slots slots
- #:name name
- #:environment env
- options))))
+(define-syntax define-class-pre-definition
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (k arg rest ...) out ...)
+ (keyword? (syntax->datum (syntax k)))
+ (case (syntax->datum (syntax k))
+ ((#:getter #:setter)
+ (syntax
+ (define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <generic>)))
+ (toplevel-define!
+ 'arg
+ (ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
+ ((#:accessor)
+ (syntax
+ (define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <accessor>)))
+ (toplevel-define!
+ 'arg
+ (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
+ (else
+ (syntax
+ (define-class-pre-definition (rest ...) out ...)))))
+ ((_ () out ...)
+ (syntax (begin out ...))))))
+
+;; Some slot options require extra definitions to be made. In
+;; particular, we want to make sure that the generic function objects
+;; which represent accessors exist before `make-class' tries to add
+;; methods to them.
+(define-syntax define-class-pre-definitions
+ (lambda (x)
+ (syntax-case x ()
+ ((_ () out ...)
+ (syntax (begin out ...)))
+ ((_ (slot rest ...) out ...)
+ (keyword? (syntax->datum (syntax slot)))
+ (syntax (begin out ...)))
+ ((_ (slot rest ...) out ...)
+ (identifier? (syntax slot))
+ (syntax (define-class-pre-definitions (rest ...)
+ out ...)))
+ ((_ ((slotname slotopt ...) rest ...) out ...)
+ (syntax (define-class-pre-definitions (rest ...)
+ out ... (define-class-pre-definition (slotopt ...))))))))
+
+(define-syntax define-class
+ (syntax-rules ()
+ ((_ name supers slot ...)
+ (begin
+ (define-class-pre-definitions (slot ...))
+ (if (and (defined? 'name)
+ (is-a? name <class>)
+ (memq <object> (class-precedence-list name)))
+ (class-redefinition name
+ (class supers slot ... #:name 'name))
+ (toplevel-define! 'name (class supers slot ... #:name 'name)))))))
+
+(define-syntax standard-define-class
+ (syntax-rules ()
+ ((_ arg ...) (define-class arg ...))))
;;;
;;; {Generic functions and accessors}
@@ -363,13 +391,13 @@
(else (make <generic> #:name name)))))
;; same semantics as <generic>
-(define-macro (define-accessor name)
- (if (not (symbol? name))
- (goops-error "bad accessor name: ~S" name))
- `(define ,name
- (if (and (defined? ',name) (is-a? ,name <accessor>))
- (make <accessor> #:name ',name)
- (ensure-accessor (if (defined? ',name) ,name #f) ',name))))
+(define-syntax define-accessor
+ (syntax-rules ()
+ ((_ name)
+ (define name
+ (cond ((not (defined? 'name)) (ensure-accessor #f 'name))
+ ((is-a? name <accessor>) (make <accessor> #:name 'name))
+ (else (ensure-accessor name 'name)))))))
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
@@ -424,78 +452,132 @@
;;; {Methods}
;;;
-(define-macro (define-method head . body)
- (if (not (pair? head))
- (goops-error "bad method head: ~S" head))
- (let ((gf (car head)))
- (cond ((and (pair? gf)
- (eq? (car gf) 'setter)
- (pair? (cdr gf))
- (symbol? (cadr gf))
- (null? (cddr gf)))
- ;; named setter method
- (let ((name (cadr gf)))
- (cond ((not (symbol? name))
- `(add-method! (setter ,name)
- (method ,(cdr head) ,@body)))
- (else
- `(begin
- (if (or (not (defined? ',name))
- (not (is-a? ,name <accessor>)))
- (define-accessor ,name))
- (add-method! (setter ,name)
- (method ,(cdr head) ,@body)))))))
- ((not (symbol? gf))
- `(add-method! ,gf (method ,(cdr head) ,@body)))
- (else
- `(begin
- ;; FIXME: this code is how it always was, but it's quite
- ;; cracky: it will only define the generic function if it
- ;; was undefined before (ok), or *was defined to #f*. The
- ;; latter is crack. But there are bootstrap issues about
- ;; fixing this -- change it to (is-a? ,gf <generic>) and
- ;; see.
- (if (or (not (defined? ',gf))
- (not ,gf))
- (define-generic ,gf))
- (add-method! ,gf
- (method ,(cdr head) ,@body)))))))
-
-(define-macro (method args . body)
- (letrec ((specializers
- (lambda (ls)
- (cond ((null? ls) (list (list 'quote '())))
- ((pair? ls) (cons (if (pair? (car ls))
- (cadar ls)
- '<top>)
- (specializers (cdr ls))))
- (else '(<top>)))))
- (formals
- (lambda (ls)
- (if (pair? ls)
- (cons (if (pair? (car ls)) (caar ls) (car ls))
- (formals (cdr ls)))
- ls))))
- (let ((make-proc (compile-make-procedure (formals args)
- (specializers args)
- body)))
- `(make <method>
- #:specializers (cons* ,@(specializers args))
- #:formals ',(formals args)
- #:body ',body
- #:make-procedure ,make-proc
- #:procedure ,(and (not make-proc)
- ;; that is to say: we set #:procedure if
- ;; `compile-make-procedure' returned `#f',
- ;; which is the case if `body' does not
- ;; contain a call to `next-method'
- `(lambda ,(formals args)
- ,@(if (null? body)
- ;; This used to be '((begin)), but
- ;; guile's memoizer doesn't like
- ;; (lambda args (begin)).
- '((if #f #f))
- body)))))))
+(define (toplevel-define! name val)
+ (module-define! (current-module) name val))
+
+(define-syntax define-method
+ (syntax-rules (setter)
+ ((_ ((setter name) . args) body ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (is-a? name <accessor>)))
+ (toplevel-define! 'name
+ (ensure-accessor
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! (setter name) (method args body ...))))
+ ((_ (name . args) body ...)
+ (begin
+ ;; FIXME: this code is how it always was, but it's quite cracky:
+ ;; it will only define the generic function if it was undefined
+ ;; before (ok), or *was defined to #f*. The latter is crack. But
+ ;; there are bootstrap issues about fixing this -- change it to
+ ;; (is-a? name <generic>) and see.
+ (if (or (not (defined? 'name))
+ (not name))
+ (toplevel-define! 'name (make <generic> #:name 'name)))
+ (add-method! name (method args body ...))))))
+
+(define-syntax method
+ (lambda (x)
+ (define (parse-args args)
+ (let lp ((ls args) (formals '()) (specializers '()))
+ (syntax-case ls ()
+ (((f s) . rest)
+ (and (identifier? (syntax f)) (identifier? (syntax s)))
+ (lp (syntax rest)
+ (cons (syntax f) formals)
+ (cons (syntax s) specializers)))
+ ((f . rest)
+ (identifier? (syntax f))
+ (lp (syntax rest)
+ (cons (syntax f) formals)
+ (cons (syntax <top>) specializers)))
+ (()
+ (list (reverse formals)
+ (reverse (cons (syntax '()) specializers))))
+ (tail
+ (identifier? (syntax tail))
+ (list (append (reverse formals) (syntax tail))
+ (reverse (cons (syntax <top>) specializers)))))))
+
+ (define (find-free-id exp referent)
+ (syntax-case exp ()
+ ((x . y)
+ (or (find-free-id (syntax x) referent)
+ (find-free-id (syntax y) referent)))
+ (x
+ (identifier? (syntax x))
+ (let ((id (datum->syntax (syntax x) referent)))
+ (and (free-identifier=? (syntax x) id) id)))
+ (_ #f)))
+
+ (define (compute-procedure formals body)
+ (syntax-case body ()
+ ((body0 ...)
+ (with-syntax ((formals formals))
+ (syntax (lambda formals body0 ...))))))
+
+ (define (->proper args)
+ (let lp ((ls args) (out '()))
+ (syntax-case ls ()
+ ((x . xs) (lp (syntax xs) (cons (syntax x) out)))
+ (() (reverse out))
+ (tail (reverse (cons (syntax tail) out))))))
+
+ (define (compute-make-procedure formals body next-method)
+ (syntax-case body ()
+ ((body ...)
+ (with-syntax ((next-method next-method))
+ (syntax-case formals ()
+ ((formal ...)
+ (syntax
+ (lambda (real-next-method)
+ (lambda (formal ...)
+ (let ((next-method (lambda args
+ (if (null? args)
+ (real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...)))))
+ (formals
+ (with-syntax (((formal ...) (->proper (syntax formals))))
+ (syntax
+ (lambda (real-next-method)
+ (lambda formals
+ (let ((next-method (lambda args
+ (if (null? args)
+ (apply real-next-method formal
...)
+ (apply real-next-method args)))))
+ body ...)))))))))))
+
+ (define (compute-procedures formals body)
+ ;; So, our use of this is broken, because it operates on the
+ ;; pre-expansion source code. It's equivalent to just searching
+ ;; for referent in the datums. Ah well.
+ (let ((id (find-free-id body 'next-method)))
+ (if id
+ ;; return a make-procedure
+ (values (syntax #f)
+ (compute-make-procedure formals body id))
+ (values (compute-procedure formals body)
+ (syntax #f)))))
+
+ (syntax-case x ()
+ ((_ args) (syntax (method args (if #f #f))))
+ ((_ args body0 body1 ...)
+ (with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
+ (call-with-values
+ (lambda ()
+ (compute-procedures (syntax formals) (syntax (body0 body1
...))))
+ (lambda (procedure make-procedure)
+ (with-syntax ((procedure procedure)
+ (make-procedure make-procedure))
+ (syntax
+ (make <method>
+ #:specializers (cons* specializer ...)
+ #:formals 'formals
+ #:body '(body0 body1 ...)
+ #:make-procedure make-procedure
+ #:procedure procedure))))))))))
;;;
;;; {add-method!}
@@ -1046,27 +1128,9 @@
;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
(eval-when (compile)
- (use-modules ((language scheme compile-ghil) :select
(define-scheme-translator))
- ((language ghil) :select (make-ghil-inline make-ghil-call))
- (system base pmatch))
-
- ;; unfortunately, can't use define-inline because these are primitive
- ;; syntaxen.
- (define-scheme-translator @slot-ref
- ((,obj ,index) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-ref
- (list (retrans obj) (retrans index))))
- (else
- (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))
-
- (define-scheme-translator @slot-set!
- ((,obj ,index ,val) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-set
- (list (retrans obj) (retrans index) (retrans val))))
- (else
- (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))))
+ (use-modules ((language tree-il primitives) :select
(add-interesting-primitive!)))
+ (add-interesting-primitive! '@slot-ref)
+ (add-interesting-primitive! '@slot-set!))
(eval-when (eval load compile)
(define num-standard-pre-cache 20))
diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm
index 3962be4..e6b13c4 100644
--- a/module/oop/goops/compile.scm
+++ b/module/oop/goops/compile.scm
@@ -24,7 +24,7 @@
(define-module (oop goops compile)
:use-module (oop goops)
:use-module (oop goops util)
- :export (compute-cmethod compile-make-procedure)
+ :export (compute-cmethod)
:no-backtrace
)
@@ -60,9 +60,7 @@
;;; So, for the reader: there basic idea is that, given that the
;;; semantics of `next-method' depend on the concrete types being
;;; dispatched, why not compile a specific procedure to handle each type
-;;; combination that we see at runtime. There are two compilation
-;;; strategies implemented: one for the memoizer, and one for the VM
-;;; compiler.
+;;; combination that we see at runtime.
;;;
;;; In theory we can do much better than a bytecode compilation, because
;;; we know the *exact* types of the arguments. It's ideal for native
@@ -71,32 +69,6 @@
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
-;;; Temporary solution---return #f if x doesn't refer to `next-method'.
-(define (next-method? x)
- (and (pair? x)
- (or (eq? (car x) 'next-method)
- (next-method? (car x))
- (next-method? (cdr x)))))
-
-;; Called by the `method' macro in goops.scm.
-(define (compile-make-procedure formals specializers body)
- (and (next-method? body)
- (let ((next-method-sym (gensym " next-method"))
- (args-sym (gensym)))
- `(lambda (,next-method-sym)
- (lambda ,formals
- (let ((next-method (lambda ,args-sym
- (if (null? ,args-sym)
- ,(if (list? formals)
- `(,next-method-sym ,@formals)
- `(apply
- ,next-method-sym
- ,@(improper->proper formals)))
- (apply ,next-method-sym ,args-sym)))))
- ,@(if (null? body)
- '((begin))
- body)))))))
-
(define (compile-method methods types)
(let ((make-procedure (slot-ref (car methods) 'make-procedure)))
(if make-procedure
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index a540447..ed9f307 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -209,9 +209,8 @@
;;;
;; Backward compatibility
-(if (not (defined? 'lookup-create-cmethod))
- (define (lookup-create-cmethod gf args)
- (no-applicable-method (car args) (cadr args))))
+(define (lookup-create-cmethod gf args)
+ (no-applicable-method (car args) (cadr args)))
(define (memoize-method! gf args exp)
(if (not (slot-ref gf 'used-by))
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm
index 4d64da8..2aedd76 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -110,9 +110,7 @@
;;; Readables
;;;
-(if (or (not (defined? 'readables))
- (not readables))
- (define readables (make-weak-key-hash-table 61)))
+(define readables (make-weak-key-hash-table 61))
(define-macro (readable exp)
`(make-readable ,exp ',(copy-tree exp)))
diff --git a/module/oop/goops/simple.scm b/module/oop/goops/simple.scm
index 48e76f3..c0cb76f 100644
--- a/module/oop/goops/simple.scm
+++ b/module/oop/goops/simple.scm
@@ -23,6 +23,9 @@
:export (define-class)
:no-backtrace)
-(define define-class define-class-with-accessors-keywords)
+(define-syntax define-class
+ (syntax-rules ()
+ ((_ arg ...)
+ (define-class-with-accessors-keywords arg ...))))
(module-use! %module-public-interface (resolve-interface '(oop goops)))
diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm
index 60ab293..ef943cf 100644
--- a/module/oop/goops/stklos.scm
+++ b/module/oop/goops/stklos.scm
@@ -47,51 +47,30 @@
;;; Enable keyword support (*fixme*---currently this has global effect)
(read-set! keywords 'prefix)
-(define standard-define-class-transformer
- (macro-transformer standard-define-class))
+(define-syntax define-class
+ (syntax-rules ()
+ ((_ name supers (slot ...) rest ...)
+ (standard-define-class name supers slot ... rest ...))))
-(define define-class
- ;; Syntax
- (let ((name cadr)
- (supers caddr)
- (slots cadddr)
- (rest cddddr))
- (procedure->memoizing-macro
- (lambda (exp env)
- (standard-define-class-transformer
- `(define-class ,(name exp) ,(supers exp) ,@(slots exp)
- ,@(rest exp))
- env)))))
+(define (toplevel-define! name val)
+ (module-define! (current-module) name val))
-(define define-method
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp)))
- (if (and (pair? name)
- (eq? (car name) 'setter)
- (pair? (cdr name))
- (null? (cddr name)))
- (let ((name (cadr name)))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
- `(begin
- (if (not (is-a? ,name <generic-with-setter>))
- (define-accessor ,name))
- (add-method! (setter ,name) (method ,@(cddr exp)))))
- (else
- `(begin
- (define-accessor ,name)
- (add-method! (setter ,name) (method ,@(cddr exp)))))))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
- `(begin
- (if (not (or (is-a? ,name <generic>)
- (is-a? ,name <primitive-generic>)))
- (define-generic ,name))
- (add-method! ,name (method ,@(cddr exp)))))
- (else
- `(begin
- (define-generic ,name)
- (add-method! ,name (method ,@(cddr exp)))))))))))
+(define-syntax define-method
+ (syntax-rules (setter)
+ ((_ (setter name) rest ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (is-a? name <generic-with-setter>)))
+ (toplevel-define! 'name
+ (ensure-accessor
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! (setter name) (method rest ...))))
+ ((_ name rest ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (or (is-a? name <generic>)
+ (is-a? name <primitive-generic>))))
+ (toplevel-define! 'name
+ (ensure-generic
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! name (method rest ...))))))
diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm
new file mode 100644
index 0000000..793cbc0
--- /dev/null
+++ b/module/rnrs/bytevector.scm
@@ -0,0 +1,84 @@
+;;;; bytevector.scm --- R6RS bytevector API
+
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Author: Ludovic Courtès <address@hidden>
+
+;;; Commentary:
+;;;
+;;; A "bytevector" is a raw bit string. This module provides procedures to
+;;; manipulate bytevectors and interpret their contents in a number of ways:
+;;; bytevector contents can be accessed as signed or unsigned integer of
+;;; various sizes and endianness, as IEEE-754 floating point numbers, or as
+;;; strings. It is a useful tool to decode binary data.
+;;;
+;;; Code:
+
+(define-module (rnrs bytevector)
+ :export-syntax (endianness)
+ :export (native-endianness bytevector?
+ make-bytevector bytevector-length bytevector=? bytevector-fill!
+ bytevector-copy! bytevector-copy bytevector-u8-ref
+ bytevector-s8-ref
+ bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
+ u8-list->bytevector
+ bytevector-uint-ref bytevector-uint-set!
+ bytevector-sint-ref bytevector-sint-set!
+ bytevector->sint-list bytevector->uint-list
+ uint-list->bytevector sint-list->bytevector
+
+ bytevector-u16-ref bytevector-s16-ref
+ bytevector-u16-set! bytevector-s16-set!
+ bytevector-u16-native-ref bytevector-s16-native-ref
+ bytevector-u16-native-set! bytevector-s16-native-set!
+
+ bytevector-u32-ref bytevector-s32-ref
+ bytevector-u32-set! bytevector-s32-set!
+ bytevector-u32-native-ref bytevector-s32-native-ref
+ bytevector-u32-native-set! bytevector-s32-native-set!
+
+ bytevector-u64-ref bytevector-s64-ref
+ bytevector-u64-set! bytevector-s64-set!
+ bytevector-u64-native-ref bytevector-s64-native-ref
+ bytevector-u64-native-set! bytevector-s64-native-set!
+
+ bytevector-ieee-single-ref
+ bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref
+ bytevector-ieee-single-native-set!
+
+ bytevector-ieee-double-ref
+ bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref
+ bytevector-ieee-double-native-set!
+
+ string->utf8 string->utf16 string->utf32
+ utf8->string utf16->string utf32->string))
+
+
+(load-extension "libguile" "scm_init_bytevectors")
+
+(define-macro (endianness sym)
+ (if (memq sym '(big little))
+ `(quote ,sym)
+ (error "unsupported endianness" sym)))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; bytevector.scm ends here
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
new file mode 100644
index 0000000..73843ee
--- /dev/null
+++ b/module/rnrs/io/ports.scm
@@ -0,0 +1,111 @@
+;;;; ports.scm --- R6RS port API
+
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Author: Ludovic Courtès <address@hidden>
+
+;;; Commentary:
+;;;
+;;; The I/O port API of the R6RS is provided by this module. In many areas
+;;; it complements or refines Guile's own historical port API. For instance,
+;;; it allows for binary I/O with bytevectors.
+;;;
+;;; Code:
+
+(define-module (rnrs io ports)
+ :re-export (eof-object? port? input-port? output-port?)
+ :export (eof-object
+
+ ;; input & output ports
+ port-transcoder binary-port? transcoded-port
+ port-position set-port-position!
+ port-has-port-position? port-has-set-port-position!?
+ call-with-port
+
+ ;; input ports
+ open-bytevector-input-port
+ make-custom-binary-input-port
+
+ ;; binary input
+ get-u8 lookahead-u8
+ get-bytevector-n get-bytevector-n!
+ get-bytevector-some get-bytevector-all
+
+ ;; output ports
+ open-bytevector-output-port
+ make-custom-binary-output-port
+
+ ;; binary output
+ put-u8 put-bytevector))
+
+(load-extension "libguile" "scm_init_r6rs_ports")
+
+
+
+;;;
+;;; Input and output ports.
+;;;
+
+(define (port-transcoder port)
+ (error "port transcoders are not supported" port))
+
+(define (binary-port? port)
+ ;; So far, we don't support transcoders other than the binary transcoder.
+ #t)
+
+(define (transcoded-port port)
+ (error "port transcoders are not supported" port))
+
+(define (port-position port)
+ "Return the offset (an integer) indicating where the next octet will be
+read from/written to in @var{port}."
+
+ ;; FIXME: We should raise an `&assertion' error when not supported.
+ (seek port 0 SEEK_CUR))
+
+(define (set-port-position! port offset)
+ "Set the position where the next octet will be read from/written to
address@hidden"
+
+ ;; FIXME: We should raise an `&assertion' error when not supported.
+ (seek port offset SEEK_SET))
+
+(define (port-has-port-position? port)
+ "Return @code{#t} is @var{port} supports @code{port-position}."
+ (and (false-if-exception (port-position port)) #t))
+
+(define (port-has-set-port-position!? port)
+ "Return @code{#t} is @var{port} supports @code{set-port-position!}."
+ (and (false-if-exception (set-port-position! port (port-position port)))
+ #t))
+
+(define (call-with-port port proc)
+ "Call @var{proc}, passing it @var{port} and closing @var{port} upon exit of
address@hidden Return the return values of @var{proc}."
+ (dynamic-wind
+ (lambda ()
+ #t)
+ (lambda ()
+ (proc port))
+ (lambda ()
+ (close-port port))))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; ports.scm ends here
diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm
index 9e17d66..afa1730 100644
--- a/module/srfi/srfi-11.scm
+++ b/module/srfi/srfi-11.scm
@@ -37,7 +37,6 @@
;;; Code:
(define-module (srfi srfi-11)
- :use-module (ice-9 syncase)
:export-syntax (let-values let*-values))
(cond-expand-provide (current-module) '(srfi-11))
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 925ecb3..dd92079 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -151,8 +151,10 @@
(hashq-set! thread-exception-handlers ct hl)
(handler obj))
(lambda ()
- (let ((r (thunk)))
- (hashq-set! thread-exception-handlers ct hl) r))))))
+ (call-with-values thunk
+ (lambda res
+ (hashq-set! thread-exception-handlers ct hl)
+ (apply values res))))))))
(define (current-exception-handler)
(car (current-handler-stack)))
@@ -249,8 +251,8 @@
(define (wrap thunk)
(lambda (continuation)
(with-exception-handler (lambda (obj)
- (apply (current-exception-handler) (list obj))
- (apply continuation (list)))
+ ((current-exception-handler) obj)
+ (continuation))
thunk)))
;; A pass-thru to cancel-thread that first installs a handler that throws
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 2035466..d7e6a4d 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -1,6 +1,6 @@
;;; srfi-35.scm --- Conditions
-;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -28,6 +28,7 @@
(define-module (srfi srfi-35)
#:use-module (srfi srfi-1)
+ #:use-module (ice-9 syncase)
#:export (make-condition-type condition-type?
make-condition condition? condition-has-type? condition-ref
make-compound-condition extract-condition
@@ -274,37 +275,39 @@ by C."
;;; Syntax.
;;;
-(define-macro (define-condition-type name parent pred . field-specs)
- `(begin
- (define ,name
- (make-condition-type ',name ,parent
- ',(map car field-specs)))
- (define (,pred c)
- (condition-has-type? c ,name))
- ,@(map (lambda (field-spec)
- (let ((field-name (car field-spec))
- (accessor (cadr field-spec)))
- `(define (,accessor c)
- (condition-ref c ',field-name))))
- field-specs)))
-
-(define-macro (condition . type-field-bindings)
- (cond ((null? type-field-bindings)
- (error "`condition' syntax error" type-field-bindings))
- (else
- ;; the poor man's hygienic macro
- (let ((mc (gensym "mc"))
- (mcct (gensym "mcct")))
- `(let ((,mc (@ (srfi srfi-35) make-condition))
- (,mcct (@@ (srfi srfi-35) make-compound-condition-type)))
- (,mc (,mcct 'compound (list ,@(map car type-field-bindings)))
- ,@(append-map (lambda (type-field-binding)
- (append-map (lambda (field+value)
- (let ((f (car field+value))
- (v (cadr field+value)))
- `(',f ,v)))
- (cdr type-field-binding)))
- type-field-bindings)))))))
+(define-syntax define-condition-type
+ (syntax-rules ()
+ ((_ name parent pred (field-name field-accessor) ...)
+ (begin
+ (define name
+ (make-condition-type 'name parent '(field-name ...)))
+ (define (pred c)
+ (condition-has-type? c name))
+ (define (field-accessor c)
+ (condition-ref c 'field-name))
+ ...))))
+
+(define-syntax compound-condition
+ ;; Create a compound condition using `make-compound-condition-type'.
+ (syntax-rules ()
+ ((_ (type ...) (field ...))
+ (condition ((make-compound-condition-type '%compound `(,type ...))
+ field ...)))))
+
+(define-syntax condition-instantiation
+ ;; Build the `(make-condition type ...)' call.
+ (syntax-rules ()
+ ((_ type (out ...))
+ (make-condition type out ...))
+ ((_ type (out ...) (field-name field-value) rest ...)
+ (condition-instantiation type (out ... 'field-name field-value) rest
...))))
+
+(define-syntax condition
+ (syntax-rules ()
+ ((_ (type field ...))
+ (condition-instantiation type () field ...))
+ ((_ (type field ...) ...)
+ (compound-condition (type ...) (field ... ...)))))
;;;
diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm
index 0867511..87154d6 100644
--- a/module/srfi/srfi-39.scm
+++ b/module/srfi/srfi-39.scm
@@ -35,7 +35,6 @@
;;; Code:
(define-module (srfi srfi-39)
- #:use-module (ice-9 syncase)
#:use-module (srfi srfi-16)
#:export (make-parameter)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 7d54947..f6522f7 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -29,7 +29,7 @@
#:export (syntax-error
*current-language*
compiled-file-name compile-file compile-and-load
- compile compile-time-environment
+ compile
decompile)
#:export-syntax (call-with-compile-error-catch))
@@ -107,9 +107,9 @@
port)))
comp))
-(define* (compile-and-load file #:key (to 'value) (opts '()))
- (read-and-compile (open-input-port file)
- #:from lang #:to to #:opts opts))
+(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
+ (read-and-compile (open-input-file file)
+ #:from from #:to to #:opts opts))
(define (compiled-file-name file)
(let ((base (basename file))
@@ -135,11 +135,6 @@
;;; Compiler interface
;;;
-(define (read-file-in file lang)
- (call-with-input-file file
- (or (language-read-file lang)
- (error "language has no #:read-file" lang))))
-
(define (compile-passes from to opts)
(map cdr
(or (lookup-compilation-order from to)
@@ -152,13 +147,6 @@
(receive (x e new-cenv) ((car passes) x e opts)
(lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
-(define (compile-time-environment)
- "A special function known to the compiler that, when compiled, will
-return a representation of the lexical environment in place at compile
-time. Useful for supporting some forms of dynamic compilation. Returns
-#f if called from the interpreter."
- #f)
-
(define (find-language-joint from to)
(let lp ((in (reverse (or (lookup-compilation-order from to)
(error "no way to compile" from "to" to))))
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 649137c..8ae4d96 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -23,7 +23,7 @@
#:use-module (system base syntax)
#:export (define-language language? lookup-language make-language
language-name language-title language-version language-reader
- language-printer language-parser language-read-file
+ language-printer language-parser
language-compilers language-decompilers language-evaluator
language-joiner
@@ -42,7 +42,6 @@
reader
printer
(parser #f)
- (read-file #f)
(compilers '())
(decompilers '())
(evaluator #f)
diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm
index 902fc49..4777431 100644
--- a/module/system/base/pmatch.scm
+++ b/module/system/base/pmatch.scm
@@ -1,5 +1,4 @@
(define-module (system base pmatch)
- #:use-module (ice-9 syncase)
#:export (pmatch))
;; FIXME: shouldn't have to export ppat...
@@ -17,15 +16,15 @@
(let ((v (op arg ...)))
(pmatch v cs ...)))
((_ v) (if #f #f))
- ((_ v (else e0 e ...)) (begin e0 e ...))
+ ((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat
- (if (and g ...) (begin e0 e ...) (fk))
+ (if (and g ...) (let () e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
- (ppat v pat (begin e0 e ...) (fk))))))
+ (ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat
(syntax-rules (_ quote unquote)
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index ebf2b93..0a06e3d 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -89,7 +89,7 @@
(catch #t
(lambda () (%start-stack #t thunk))
default-catch-handler
- pre-unwind-handler-dispatch))
+ default-pre-unwind-handler))
(define-macro (with-backtrace form)
`(call-with-backtrace (lambda () ,form)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 3854d4a..8ac2093 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -26,6 +26,7 @@ SCM_TESTS = tests/alist.test \
tests/arbiters.test \
tests/asm-to-bytecode.test \
tests/bit-operations.test \
+ tests/bytevectors.test \
tests/c-api.test \
tests/chars.test \
tests/common-list.test \
@@ -62,6 +63,7 @@ SCM_TESTS = tests/alist.test \
tests/q.test \
tests/r4rs.test \
tests/r5rs_pitfall.test \
+ tests/r6rs-ports.test \
tests/ramap.test \
tests/reader.test \
tests/receive.test \
@@ -93,6 +95,7 @@ SCM_TESTS = tests/alist.test \
tests/syntax.test \
tests/threads.test \
tests/time.test \
+ tests/tree-il.test \
tests/unif.test \
tests/version.test \
tests/weaks.test
diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index c4ddf9e..3f09ce4 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -317,20 +317,24 @@
(set! run-test local-run-test))
;;; A short form for tests that are expected to pass, taken from Greg.
-(defmacro pass-if (name . rest)
- (if (and (null? rest) (pair? name))
- ;; presume this is a simple test, i.e. (pass-if (even? 2))
- ;; where the body should also be the name.
- `(run-test ',name #t (lambda () ,name))
- `(run-test ,name #t (lambda () ,@rest))))
+(define-syntax pass-if
+ (syntax-rules ()
+ ((_ name)
+ ;; presume this is a simple test, i.e. (pass-if (even? 2))
+ ;; where the body should also be the name.
+ (run-test 'name #t (lambda () name)))
+ ((_ name rest ...)
+ (run-test name #t (lambda () rest ...)))))
;;; A short form for tests that are expected to fail, taken from Greg.
-(defmacro expect-fail (name . rest)
- (if (and (null? rest) (pair? name))
- ;; presume this is a simple test, i.e. (expect-fail (even? 2))
- ;; where the body should also be the name.
- `(run-test ',name #f (lambda () ,name))
- `(run-test ,name #f (lambda () ,@rest))))
+(define-syntax expect-fail
+ (syntax-rules ()
+ ((_ name)
+ ;; presume this is a simple test, i.e. (expect-fail (even? 2))
+ ;; where the body should also be the name.
+ (run-test 'name #f (lambda () name)))
+ ((_ name rest ...)
+ (run-test name #f (lambda () rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
@@ -362,12 +366,16 @@
(apply throw key proc message rest))))))))
;;; A short form for tests that expect a certain exception to be thrown.
-(defmacro pass-if-exception (name exception body . rest)
- `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
+(define-syntax pass-if-exception
+ (syntax-rules ()
+ ((_ name exception body rest ...)
+ (run-test-exception name exception #t (lambda () body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
-(defmacro expect-fail-exception (name exception body . rest)
- `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
+(define-syntax expect-fail-exception
+ (syntax-rules ()
+ ((_ name exception body rest ...)
+ (run-test-exception name exception #f (lambda () body rest ...)))))
;;;; TEST NAMES
diff --git a/test-suite/standalone/test-conversion.c
b/test-suite/standalone/test-conversion.c
index 92835f2..41f99d3 100644
--- a/test-suite/standalone/test-conversion.c
+++ b/test-suite/standalone/test-conversion.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
@@ -680,31 +680,31 @@ test_8u (const char *str, scm_t_uintmax (*func) (SCM),
const char *func_name,
#define DEFSTST(f) static scm_t_intmax tst_##f (SCM x) { return f(x); }
#define DEFUTST(f) static scm_t_uintmax tst_##f (SCM x) { return f(x); }
-DEFSTST (scm_to_schar);
-DEFUTST (scm_to_uchar);
-DEFSTST (scm_to_char);
-DEFSTST (scm_to_short);
-DEFUTST (scm_to_ushort);
-DEFSTST (scm_to_int);
-DEFUTST (scm_to_uint);
-DEFSTST (scm_to_long);
-DEFUTST (scm_to_ulong);
+DEFSTST (scm_to_schar)
+DEFUTST (scm_to_uchar)
+DEFSTST (scm_to_char)
+DEFSTST (scm_to_short)
+DEFUTST (scm_to_ushort)
+DEFSTST (scm_to_int)
+DEFUTST (scm_to_uint)
+DEFSTST (scm_to_long)
+DEFUTST (scm_to_ulong)
#if SCM_SIZEOF_LONG_LONG != 0
-DEFSTST (scm_to_long_long);
-DEFUTST (scm_to_ulong_long);
+DEFSTST (scm_to_long_long)
+DEFUTST (scm_to_ulong_long)
#endif
-DEFSTST (scm_to_ssize_t);
-DEFUTST (scm_to_size_t);
-
-DEFSTST (scm_to_int8);
-DEFUTST (scm_to_uint8);
-DEFSTST (scm_to_int16);
-DEFUTST (scm_to_uint16);
-DEFSTST (scm_to_int32);
-DEFUTST (scm_to_uint32);
+DEFSTST (scm_to_ssize_t)
+DEFUTST (scm_to_size_t)
+
+DEFSTST (scm_to_int8)
+DEFUTST (scm_to_uint8)
+DEFSTST (scm_to_int16)
+DEFUTST (scm_to_uint16)
+DEFSTST (scm_to_int32)
+DEFUTST (scm_to_uint32)
#ifdef SCM_HAVE_T_INT64
-DEFSTST (scm_to_int64);
-DEFUTST (scm_to_uint64);
+DEFSTST (scm_to_int64)
+DEFUTST (scm_to_uint64)
#endif
#define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te)
@@ -818,15 +818,60 @@ test_9 (double val, const char *result)
}
}
+/* The `infinity' and `not-a-number' values. */
+static double guile_Inf, guile_NaN;
+
+/* Initialize GUILE_INF and GUILE_NAN. Taken from `guile_ieee_init ()' in
+ `libguile/numbers.c'. */
+static void
+ieee_init (void)
+{
+#ifdef INFINITY
+ /* C99 INFINITY, when available.
+ FIXME: The standard allows for INFINITY to be something that overflows
+ at compile time. We ought to have a configure test to check for that
+ before trying to use it. (But in practice we believe this is not a
+ problem on any system guile is likely to target.) */
+ guile_Inf = INFINITY;
+#elif HAVE_DINFINITY
+ /* OSF */
+ extern unsigned int DINFINITY[2];
+ guile_Inf = (*((double *) (DINFINITY)));
+#else
+ double tmp = 1e+10;
+ guile_Inf = tmp;
+ for (;;)
+ {
+ guile_Inf *= 1e+10;
+ if (guile_Inf == tmp)
+ break;
+ tmp = guile_Inf;
+ }
+#endif
+
+#ifdef NAN
+ /* C99 NAN, when available */
+ guile_NaN = NAN;
+#elif HAVE_DQNAN
+ {
+ /* OSF */
+ extern unsigned int DQNAN[2];
+ guile_NaN = (*((double *)(DQNAN)));
+ }
+#else
+ guile_NaN = guile_Inf / guile_Inf;
+#endif
+}
+
static void
test_from_double ()
{
test_9 (12, "12.0");
test_9 (0.25, "0.25");
test_9 (0.1, "0.1");
- test_9 (1.0/0.0, "+inf.0");
- test_9 (-1.0/0.0, "-inf.0");
- test_9 (0.0/0.0, "+nan.0");
+ test_9 (guile_Inf, "+inf.0");
+ test_9 (-guile_Inf, "-inf.0");
+ test_9 (guile_NaN, "+nan.0");
}
typedef struct {
@@ -880,8 +925,8 @@ test_to_double ()
test_10 ("12", 12.0, 0);
test_10 ("0.25", 0.25, 0);
test_10 ("1/4", 0.25, 0);
- test_10 ("+inf.0", 1.0/0.0, 0);
- test_10 ("-inf.0", -1.0/0.0, 0);
+ test_10 ("+inf.0", guile_Inf, 0);
+ test_10 ("-inf.0",-guile_Inf, 0);
test_10 ("+1i", 0.0, 1);
}
@@ -1056,6 +1101,7 @@ tests (void *data, int argc, char **argv)
int
main (int argc, char *argv[])
{
+ ieee_init ();
scm_boot_guile (argc, argv, tests, NULL);
return 0;
}
diff --git a/test-suite/standalone/test-round.c
b/test-suite/standalone/test-round.c
index 9725491..1340fff 100644
--- a/test-suite/standalone/test-round.c
+++ b/test-suite/standalone/test-round.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 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
@@ -25,6 +25,13 @@
#if HAVE_FENV_H
#include <fenv.h>
+#elif defined HAVE_MACHINE_FPU_H
+/* On Tru64 5.1b, the declaration of fesetround(3) is in <machine/fpu.h>.
+ On NetBSD, this header has to be included along with <sys/types.h>. */
+# ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+# endif
+# include <machine/fpu.h>
#endif
#include <libguile.h>
diff --git a/test-suite/tests/bytevectors.test
b/test-suite/tests/bytevectors.test
new file mode 100644
index 0000000..b2ae65c
--- /dev/null
+++ b/test-suite/tests/bytevectors.test
@@ -0,0 +1,531 @@
+;;;; bytevectors.test --- Exercise the R6RS bytevector API.
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Ludovic Courtès
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-bytevector)
+ :use-module (test-suite lib)
+ :use-module (rnrs bytevector))
+
+;;; Some of the tests in here are examples taken from the R6RS Standard
+;;; Libraries document.
+
+
+(with-test-prefix "2.2 General Operations"
+
+ (pass-if "native-endianness"
+ (not (not (memq (native-endianness) '(big little)))))
+
+ (pass-if "make-bytevector"
+ (and (bytevector? (make-bytevector 20))
+ (bytevector? (make-bytevector 20 3))))
+
+ (pass-if "bytevector-length"
+ (= (bytevector-length (make-bytevector 20)) 20))
+
+ (pass-if "bytevector=?"
+ (and (bytevector=? (make-bytevector 20 7)
+ (make-bytevector 20 7))
+ (not (bytevector=? (make-bytevector 20 7)
+ (make-bytevector 20 0))))))
+
+
+(with-test-prefix "2.3 Operations on Bytes and Octets"
+
+ (pass-if "bytevector-{u8,s8}-ref"
+ (equal? '(-127 129 -1 255)
+ (let ((b1 (make-bytevector 16 -127))
+ (b2 (make-bytevector 16 255)))
+ (list (bytevector-s8-ref b1 0)
+ (bytevector-u8-ref b1 0)
+ (bytevector-s8-ref b2 0)
+ (bytevector-u8-ref b2 0)))))
+
+ (pass-if "bytevector-{u8,s8}-set!"
+ (equal? '(-126 130 -10 246)
+ (let ((b (make-bytevector 16 -127)))
+
+ (bytevector-s8-set! b 0 -126)
+ (bytevector-u8-set! b 1 246)
+
+ (list (bytevector-s8-ref b 0)
+ (bytevector-u8-ref b 0)
+ (bytevector-s8-ref b 1)
+ (bytevector-u8-ref b 1)))))
+
+ (pass-if "bytevector->u8-list"
+ (let ((lst '(1 2 3 128 150 255)))
+ (equal? lst
+ (bytevector->u8-list
+ (let ((b (make-bytevector 6)))
+ (for-each (lambda (i v)
+ (bytevector-u8-set! b i v))
+ (iota 6)
+ lst)
+ b)))))
+
+ (pass-if "u8-list->bytevector"
+ (let ((lst '(1 2 3 128 150 255)))
+ (equal? lst
+ (bytevector->u8-list (u8-list->bytevector lst)))))
+
+ (pass-if "bytevector-uint-{ref,set!} [small]"
+ (let ((b (make-bytevector 15)))
+ (bytevector-uint-set! b 0 #x1234
+ (endianness little) 2)
+ (equal? (bytevector-uint-ref b 0 (endianness big) 2)
+ #x3412)))
+
+ (pass-if "bytevector-uint-set! [large]"
+ (let ((b (make-bytevector 16)))
+ (bytevector-uint-set! b 0 (- (expt 2 128) 3)
+ (endianness little) 16)
+ (equal? (bytevector->u8-list b)
+ '(253 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 255))))
+
+ (pass-if "bytevector-uint-{ref,set!} [large]"
+ (let ((b (make-bytevector 120)))
+ (bytevector-uint-set! b 0 (- (expt 2 128) 3)
+ (endianness little) 16)
+ (equal? (bytevector-uint-ref b 0 (endianness little) 16)
+ #xfffffffffffffffffffffffffffffffd)))
+
+ (pass-if "bytevector-sint-ref [small]"
+ (let ((b (u8-list->bytevector '(#xff #xf0 #xff))))
+ (equal? (bytevector-sint-ref b 0 (endianness big) 2)
+ (bytevector-sint-ref b 1 (endianness little) 2)
+ -16)))
+
+ (pass-if "bytevector-sint-ref [large]"
+ (let ((b (make-bytevector 50)))
+ (bytevector-uint-set! b 0 (- (expt 2 128) 3)
+ (endianness little) 16)
+ (equal? (bytevector-sint-ref b 0 (endianness little) 16)
+ -3)))
+
+ (pass-if "bytevector-sint-set! [small]"
+ (let ((b (make-bytevector 3)))
+ (bytevector-sint-set! b 0 -16 (endianness big) 2)
+ (bytevector-sint-set! b 1 -16 (endianness little) 2)
+ (equal? (bytevector->u8-list b)
+ '(#xff #xf0 #xff)))))
+
+
+(with-test-prefix "2.4 Operations on Integers of Arbitrary Size"
+
+ (pass-if "bytevector->sint-list"
+ (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
+ (equal? (bytevector->sint-list b (endianness little) 2)
+ '(513 -253 513 513))))
+
+ (pass-if "bytevector->uint-list"
+ (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1))))
+ (equal? (bytevector->uint-list b (endianness big) 2)
+ '(513 65283 513 513))))
+
+ (pass-if "bytevector->uint-list [empty]"
+ (let ((b (make-bytevector 0)))
+ (null? (bytevector->uint-list b (endianness big) 2))))
+
+ (pass-if-exception "bytevector->sint-list [out-of-range]"
+ exception:out-of-range
+ (bytevector->sint-list (make-bytevector 6) (endianness little) 8))
+
+ (pass-if "bytevector->sint-list [off-by-one]"
+ (equal? (bytevector->sint-list (make-bytevector 31 #xff)
+ (endianness little) 8)
+ '(-1 -1 -1)))
+
+ (pass-if "{sint,uint}-list->bytevector"
+ (let ((b1 (sint-list->bytevector '(513 -253 513 513)
+ (endianness little) 2))
+ (b2 (uint-list->bytevector '(513 65283 513 513)
+ (endianness little) 2))
+ (b3 (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
+ (and (bytevector=? b1 b2)
+ (bytevector=? b2 b3))))
+
+ (pass-if "sint-list->bytevector [limits]"
+ (bytevector=? (sint-list->bytevector '(-32768 32767)
+ (endianness big) 2)
+ (let ((bv (make-bytevector 4)))
+ (bytevector-u8-set! bv 0 #x80)
+ (bytevector-u8-set! bv 1 #x00)
+ (bytevector-u8-set! bv 2 #x7f)
+ (bytevector-u8-set! bv 3 #xff)
+ bv)))
+
+ (pass-if-exception "sint-list->bytevector [out-of-range]"
+ exception:out-of-range
+ (sint-list->bytevector (list 0 0 (expt 2 16)) (endianness big)
+ 2))
+
+ (pass-if-exception "uint-list->bytevector [out-of-range]"
+ exception:out-of-range
+ (uint-list->bytevector '(0 -1) (endianness big) 2)))
+
+
+(with-test-prefix "2.5 Operations on 16-Bit Integers"
+
+ (pass-if "bytevector-u16-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-u16-ref b 14 (endianness little))
+ #xfdff)
+ (equal? (bytevector-u16-ref b 14 (endianness big))
+ #xfffd))))
+
+ (pass-if "bytevector-s16-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-s16-ref b 14 (endianness little))
+ -513)
+ (equal? (bytevector-s16-ref b 14 (endianness big))
+ -3))))
+
+ (pass-if "bytevector-s16-ref [unaligned]"
+ (let ((b (u8-list->bytevector '(#xff #xf0 #xff))))
+ (equal? (bytevector-s16-ref b 1 (endianness little))
+ -16)))
+
+ (pass-if "bytevector-{u16,s16}-ref"
+ (let ((b (make-bytevector 2)))
+ (bytevector-u16-set! b 0 44444 (endianness little))
+ (and (equal? (bytevector-u16-ref b 0 (endianness little))
+ 44444)
+ (equal? (bytevector-s16-ref b 0 (endianness little))
+ (- 44444 65536)))))
+
+ (pass-if "bytevector-native-{u16,s16}-{ref,set!}"
+ (let ((b (make-bytevector 2)))
+ (bytevector-u16-native-set! b 0 44444)
+ (and (equal? (bytevector-u16-native-ref b 0)
+ 44444)
+ (equal? (bytevector-s16-native-ref b 0)
+ (- 44444 65536)))))
+
+ (pass-if "bytevector-s16-{ref,set!} [unaligned]"
+ (let ((b (make-bytevector 3)))
+ (bytevector-s16-set! b 1 -77 (endianness little))
+ (equal? (bytevector-s16-ref b 1 (endianness little))
+ -77))))
+
+
+(with-test-prefix "2.6 Operations on 32-bit Integers"
+
+ (pass-if "bytevector-u32-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-u32-ref b 12 (endianness little))
+ #xfdffffff)
+ (equal? (bytevector-u32-ref b 12 (endianness big))
+ #xfffffffd))))
+
+ (pass-if "bytevector-s32-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-s32-ref b 12 (endianness little))
+ -33554433)
+ (equal? (bytevector-s32-ref b 12 (endianness big))
+ -3))))
+
+ (pass-if "bytevector-{u32,s32}-ref"
+ (let ((b (make-bytevector 4)))
+ (bytevector-u32-set! b 0 2222222222 (endianness little))
+ (and (equal? (bytevector-u32-ref b 0 (endianness little))
+ 2222222222)
+ (equal? (bytevector-s32-ref b 0 (endianness little))
+ (- 2222222222 (expt 2 32))))))
+
+ (pass-if "bytevector-{u32,s32}-native-{ref,set!}"
+ (let ((b (make-bytevector 4)))
+ (bytevector-u32-native-set! b 0 2222222222)
+ (and (equal? (bytevector-u32-native-ref b 0)
+ 2222222222)
+ (equal? (bytevector-s32-native-ref b 0)
+ (- 2222222222 (expt 2 32)))))))
+
+
+(with-test-prefix "2.7 Operations on 64-bit Integers"
+
+ (pass-if "bytevector-u64-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-u64-ref b 8 (endianness little))
+ #xfdffffffffffffff)
+ (equal? (bytevector-u64-ref b 8 (endianness big))
+ #xfffffffffffffffd))))
+
+ (pass-if "bytevector-s64-ref"
+ (let ((b (u8-list->bytevector
+ '(255 255 255 255 255 255 255 255
+ 255 255 255 255 255 255 255 253))))
+ (and (equal? (bytevector-s64-ref b 8 (endianness little))
+ -144115188075855873)
+ (equal? (bytevector-s64-ref b 8 (endianness big))
+ -3))))
+
+ (pass-if "bytevector-{u64,s64}-ref"
+ (let ((b (make-bytevector 8))
+ (big 9333333333333333333))
+ (bytevector-u64-set! b 0 big (endianness little))
+ (and (equal? (bytevector-u64-ref b 0 (endianness little))
+ big)
+ (equal? (bytevector-s64-ref b 0 (endianness little))
+ (- big (expt 2 64))))))
+
+ (pass-if "bytevector-{u64,s64}-native-{ref,set!}"
+ (let ((b (make-bytevector 8))
+ (big 9333333333333333333))
+ (bytevector-u64-native-set! b 0 big)
+ (and (equal? (bytevector-u64-native-ref b 0)
+ big)
+ (equal? (bytevector-s64-native-ref b 0)
+ (- big (expt 2 64))))))
+
+ (pass-if "ref/set! with zero"
+ (let ((b (make-bytevector 8)))
+ (bytevector-s64-set! b 0 -1 (endianness big))
+ (bytevector-u64-set! b 0 0 (endianness big))
+ (= 0 (bytevector-u64-ref b 0 (endianness big))))))
+
+
+(with-test-prefix "2.8 Operations on IEEE-754 Representations"
+
+ (pass-if "bytevector-ieee-single-native-{ref,set!}"
+ (let ((b (make-bytevector 4))
+ (number 3.00))
+ (bytevector-ieee-single-native-set! b 0 number)
+ (equal? (bytevector-ieee-single-native-ref b 0)
+ number)))
+
+ (pass-if "bytevector-ieee-single-{ref,set!}"
+ (let ((b (make-bytevector 8))
+ (number 3.14))
+ (bytevector-ieee-single-set! b 0 number (endianness little))
+ (bytevector-ieee-single-set! b 4 number (endianness big))
+ (equal? (bytevector-ieee-single-ref b 0 (endianness little))
+ (bytevector-ieee-single-ref b 4 (endianness big)))))
+
+ (pass-if "bytevector-ieee-single-{ref,set!} [unaligned]"
+ (let ((b (make-bytevector 9))
+ (number 3.14))
+ (bytevector-ieee-single-set! b 1 number (endianness little))
+ (bytevector-ieee-single-set! b 5 number (endianness big))
+ (equal? (bytevector-ieee-single-ref b 1 (endianness little))
+ (bytevector-ieee-single-ref b 5 (endianness big)))))
+
+ (pass-if "bytevector-ieee-double-native-{ref,set!}"
+ (let ((b (make-bytevector 8))
+ (number 3.14))
+ (bytevector-ieee-double-native-set! b 0 number)
+ (equal? (bytevector-ieee-double-native-ref b 0)
+ number)))
+
+ (pass-if "bytevector-ieee-double-{ref,set!}"
+ (let ((b (make-bytevector 16))
+ (number 3.14))
+ (bytevector-ieee-double-set! b 0 number (endianness little))
+ (bytevector-ieee-double-set! b 8 number (endianness big))
+ (equal? (bytevector-ieee-double-ref b 0 (endianness little))
+ (bytevector-ieee-double-ref b 8 (endianness big))))))
+
+
+(define (with-locale locale thunk)
+ ;; Run THUNK under LOCALE.
+ (let ((original-locale (setlocale LC_ALL)))
+ (catch 'system-error
+ (lambda ()
+ (setlocale LC_ALL locale))
+ (lambda (key . args)
+ (throw 'unresolved)))
+
+ (dynamic-wind
+ (lambda ()
+ #t)
+ thunk
+ (lambda ()
+ (setlocale LC_ALL original-locale)))))
+
+(define (with-latin1-locale thunk)
+ ;; Try out several ISO-8859-1 locales and run THUNK under the one that
+ ;; works (if any).
+ (define %locales
+ (map (lambda (name)
+ (string-append name ".ISO-8859-1"))
+ '("fr_FR" "es_ES" "en_GB" "en_US" "de_DE" "pt_PT")))
+
+ (let loop ((locales %locales))
+ (if (null? locales)
+ (throw 'unresolved)
+ (catch 'unresolved
+ (lambda ()
+ (with-locale (car locales) thunk))
+ (lambda (key . args)
+ (loop (cdr locales)))))))
+
+
+;; Default to the C locale for the following tests.
+(setlocale LC_ALL "C")
+
+
+(with-test-prefix "2.9 Operations on Strings"
+
+ (pass-if "string->utf8"
+ (let* ((str "hello, world")
+ (utf8 (string->utf8 str)))
+ (and (bytevector? utf8)
+ (= (bytevector-length utf8)
+ (string-length str))
+ (equal? (string->list str)
+ (map integer->char (bytevector->u8-list utf8))))))
+
+ (pass-if "string->utf8 [latin-1]"
+ (with-latin1-locale
+ (lambda ()
+ (let* ((str "hé, ça va bien ?")
+ (utf8 (string->utf8 str)))
+ (and (bytevector? utf8)
+ (= (bytevector-length utf8)
+ (+ 2 (string-length str))))))))
+
+ (pass-if "string->utf16"
+ (let* ((str "hello, world")
+ (utf16 (string->utf16 str)))
+ (and (bytevector? utf16)
+ (= (bytevector-length utf16)
+ (* 2 (string-length str)))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf16
+ (endianness big) 2))))))
+
+ (pass-if "string->utf16 [little]"
+ (let* ((str "hello, world")
+ (utf16 (string->utf16 str (endianness little))))
+ (and (bytevector? utf16)
+ (= (bytevector-length utf16)
+ (* 2 (string-length str)))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf16
+ (endianness little) 2))))))
+
+
+ (pass-if "string->utf32"
+ (let* ((str "hello, world")
+ (utf32 (string->utf32 str)))
+ (and (bytevector? utf32)
+ (= (bytevector-length utf32)
+ (* 4 (string-length str)))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf32
+ (endianness big) 4))))))
+
+ (pass-if "string->utf32 [little]"
+ (let* ((str "hello, world")
+ (utf32 (string->utf32 str (endianness little))))
+ (and (bytevector? utf32)
+ (= (bytevector-length utf32)
+ (* 4 (string-length str)))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf32
+ (endianness little) 4))))))
+
+ (pass-if "utf8->string"
+ (let* ((utf8 (u8-list->bytevector (map char->integer
+ (string->list "hello, world"))))
+ (str (utf8->string utf8)))
+ (and (string? str)
+ (= (string-length str)
+ (bytevector-length utf8))
+ (equal? (string->list str)
+ (map integer->char (bytevector->u8-list utf8))))))
+
+ (pass-if "utf8->string [latin-1]"
+ (with-latin1-locale
+ (lambda ()
+ (let* ((utf8 (string->utf8 "hé, ça va bien ?"))
+ (str (utf8->string utf8)))
+ (and (string? str)
+ (= (string-length str)
+ (- (bytevector-length utf8) 2)))))))
+
+ (pass-if "utf16->string"
+ (let* ((utf16 (uint-list->bytevector (map char->integer
+ (string->list "hello, world"))
+ (endianness big) 2))
+ (str (utf16->string utf16)))
+ (and (string? str)
+ (= (* 2 (string-length str))
+ (bytevector-length utf16))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf16 (endianness big)
+ 2))))))
+
+ (pass-if "utf16->string [little]"
+ (let* ((utf16 (uint-list->bytevector (map char->integer
+ (string->list "hello, world"))
+ (endianness little) 2))
+ (str (utf16->string utf16 (endianness little))))
+ (and (string? str)
+ (= (* 2 (string-length str))
+ (bytevector-length utf16))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf16 (endianness little)
+ 2))))))
+ (pass-if "utf32->string"
+ (let* ((utf32 (uint-list->bytevector (map char->integer
+ (string->list "hello, world"))
+ (endianness big) 4))
+ (str (utf32->string utf32)))
+ (and (string? str)
+ (= (* 4 (string-length str))
+ (bytevector-length utf32))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf32 (endianness big)
+ 4))))))
+
+ (pass-if "utf32->string [little]"
+ (let* ((utf32 (uint-list->bytevector (map char->integer
+ (string->list "hello, world"))
+ (endianness little) 4))
+ (str (utf32->string utf32 (endianness little))))
+ (and (string? str)
+ (= (* 4 (string-length str))
+ (bytevector-length utf32))
+ (equal? (string->list str)
+ (map integer->char
+ (bytevector->uint-list utf32 (endianness little)
+ 4)))))))
+
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; mode: scheme
+;;; End:
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index d83167f..7324d77 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -18,45 +18,10 @@
(define-module (test-suite tests compiler)
:use-module (test-suite lib)
:use-module (test-suite guile-test)
- :use-module (system vm program))
+ :use-module (system base compile))
-(with-test-prefix "environments"
+(with-test-prefix "basic"
- (pass-if "compile-time-environment in evaluator"
- (eq? (primitive-eval '(compile-time-environment)) #f))
-
- (pass-if "compile-time-environment in compiler"
- (equal? (compile '(compile-time-environment))
- (cons (current-module)
- (cons '() '()))))
-
- (let ((env (compile
- '(let ((x 0)) (set! x 1) (compile-time-environment)))))
- (pass-if "compile-time-environment in compiler, heap-allocated var"
- (equal? env
- (cons (current-module)
- (cons '((x . 0)) '(1)))))
-
- ;; fixme: compiling with #t or module
- (pass-if "recompiling with environment"
- (equal? ((compile '(lambda () x) #:env env))
- 1))
-
- (pass-if "recompiling with environment/2"
- (equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env))
- 2))
-
- (pass-if "recompiling with environment/3"
- (equal? ((compile '(lambda () x) #:env env))
- 2))
- )
-
- (pass-if "compile environment is #f"
- (equal? ((compile '(lambda () 10)))
- 10))
-
- (pass-if "compile environment is a module"
- (equal? ((compile '(lambda () 10) #:env (current-module)))
- 10))
- )
\ No newline at end of file
+ (pass-if "compile to value"
+ (equal? (compile 1) 1)))
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index 7a22f0d..e5ef34b 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -24,6 +24,9 @@
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
+(define exception:failed-match
+ (cons 'syntax-error "failed to match any pattern"))
+
;;;
;;; miscellaneous
@@ -85,17 +88,19 @@
;; Macros are accepted as function parameters.
;; Functions that 'apply' macros are rewritten!!!
- (expect-fail-exception "macro as argument"
- exception:wrong-type-arg
- (let ((f (lambda (p a b) (p a b))))
- (f and #t #t)))
-
- (expect-fail-exception "passing macro as parameter"
- exception:wrong-type-arg
- (let* ((f (lambda (p a b) (p a b)))
- (foo (procedure-source f)))
- (f and #t #t)
- (equal? (procedure-source f) foo)))
+ (pass-if-exception "macro as argument"
+ exception:failed-match
+ (primitive-eval
+ '(let ((f (lambda (p a b) (p a b))))
+ (f and #t #t))))
+
+ (pass-if-exception "passing macro as parameter"
+ exception:failed-match
+ (primitive-eval
+ '(let* ((f (lambda (p a b) (p a b)))
+ (foo (procedure-source f)))
+ (f and #t #t)
+ (equal? (procedure-source f) foo))))
))
diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test
index 1dd2bc7..08bfa7c 100644
--- a/test-suite/tests/popen.test
+++ b/test-suite/tests/popen.test
@@ -73,20 +73,46 @@
(open-input-pipe "echo hello"))))))
#t)
+ (pass-if "open-input-pipe process gets (current-input-port) as stdin"
+ (let* ((p2c (pipe))
+ (port (with-input-from-port (car p2c)
+ (lambda ()
+ (open-input-pipe "read && echo $REPLY")))))
+ (display "hello\n" (cdr p2c))
+ (force-output (cdr p2c))
+ (let ((result (eq? (read port) 'hello)))
+ (close-port (cdr p2c))
+ (close-pipe port)
+ result)))
+
;; After the child closes stdout (which it indicates here by writing
- ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4 and
- ;; earlier a duplicate of stdout existed in the child, meaning eof was not
- ;; seen.
+ ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4
+ ;; and earlier a duplicate of stdout existed in the child, meaning
+ ;; eof was not seen.
+ ;;
+ ;; Note that the objective here is to test that the parent sees EOF
+ ;; while the child is still alive. (It is obvious that the parent
+ ;; must see EOF once the child has died.) The use of the `p2c'
+ ;; pipe, and `echo closed' and `read' in the child, allows us to be
+ ;; sure that we are testing what the parent sees at a point where
+ ;; the child has closed stdout but is still alive.
(pass-if "no duplicate"
- (let* ((pair (pipe))
- (port (with-error-to-port (cdr pair)
+ (let* ((c2p (pipe))
+ (p2c (pipe))
+ (port (with-error-to-port (cdr c2p)
(lambda ()
- (open-input-pipe
- "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null;
sleep 999")))))
- (close-port (cdr pair)) ;; write side
- (and (char? (read-char (car pair))) ;; wait for child to do its thing
- (char-ready? port)
- (eof-object? (read-char port))))))
+ (with-input-from-port (car p2c)
+ (lambda ()
+ (open-input-pipe
+ "exec 1>/dev/null; echo closed 1>&2; exec
2>/dev/null; read")))))))
+ (close-port (cdr c2p)) ;; write side
+ (let ((result (eof-object? (read-char port))))
+ (display "hello!\n" (cdr p2c))
+ (force-output (cdr p2c))
+ (close-pipe port)
+ result)))
+
+ )
;;
;; open-output-pipe
@@ -121,27 +147,47 @@
#t)
;; After the child closes stdin (which it indicates here by writing
- ;; "closed" to stderr), the parent should see a broken pipe. We setup to
- ;; see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4 and earlier a
- ;; duplicate of stdin existed in the child, preventing the broken pipe
- ;; occurring.
+ ;; "closed" to stderr), the parent should see a broken pipe. We
+ ;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4
+ ;; and earlier a duplicate of stdin existed in the child, preventing
+ ;; the broken pipe occurring.
+ ;;
+ ;; Note that the objective here is to test that the parent sees a
+ ;; broken pipe while the child is still alive. (It is obvious that
+ ;; the parent will see a broken pipe once the child has died.) The
+ ;; use of the `c2p' pipe, and the repeated `echo closed' in the
+ ;; child, allows us to be sure that we are testing what the parent
+ ;; sees at a point where the child has closed stdin but is still
+ ;; alive.
+ ;;
+ ;; Note that `with-epipe' must apply only to the parent and not to
+ ;; the child process; we rely on the child getting SIGPIPE, to
+ ;; terminate it (and avoid leaving a zombie).
(pass-if "no duplicate"
- (with-epipe
- (lambda ()
- (let* ((pair (pipe))
- (port (with-error-to-port (cdr pair)
- (lambda ()
- (open-output-pipe
- "exec 0</dev/null; echo closed 1>&2; exec 2>/dev/null;
sleep 999")))))
- (close-port (cdr pair)) ;; write side
- (and (char? (read-char (car pair))) ;; wait for child to do its thing
- (catch 'system-error
- (lambda ()
- (write-char #\x port)
- (force-output port)
- #f)
- (lambda (key name fmt args errno-list)
- (= (car errno-list) EPIPE)))))))))
+ (let* ((c2p (pipe))
+ (port (with-error-to-port (cdr c2p)
+ (lambda ()
+ (open-output-pipe
+ "exec 0</dev/null; while true; do echo closed 1>&2;
done")))))
+ (close-port (cdr c2p)) ;; write side
+ (with-epipe
+ (lambda ()
+ (let ((result
+ (and (char? (read-char (car c2p))) ;; wait for child to do its
thing
+ (catch 'system-error
+ (lambda ()
+ (write-char #\x port)
+ (force-output port)
+ #f)
+ (lambda (key name fmt args errno-list)
+ (= (car errno-list) EPIPE))))))
+ ;; Now close our reading end of the pipe. This should give
+ ;; the child a broken pipe and so allow it to exit.
+ (close-port (car c2p))
+ (close-pipe port)
+ result)))))
+
+ )
;;
;; close-pipe
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
new file mode 100644
index 0000000..204f371
--- /dev/null
+++ b/test-suite/tests/r6rs-ports.test
@@ -0,0 +1,455 @@
+;;;; r6rs-ports.test --- Exercise the R6RS I/O port API.
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Ludovic Courtès
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-io-ports)
+ :use-module (test-suite lib)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-11)
+ :use-module (rnrs io ports)
+ :use-module (rnrs bytevector))
+
+;;; All these tests assume Guile 1.8's port system, where characters are
+;;; treated as octets.
+
+
+(with-test-prefix "7.2.5 End-of-File Object"
+
+ (pass-if "eof-object"
+ (and (eqv? (eof-object) (eof-object))
+ (eq? (eof-object) (eof-object)))))
+
+
+(with-test-prefix "7.2.8 Binary Input"
+
+ (pass-if "get-u8"
+ (let ((port (open-input-string "A")))
+ (and (= (char->integer #\A) (get-u8 port))
+ (eof-object? (get-u8 port)))))
+
+ (pass-if "lookahead-u8"
+ (let ((port (open-input-string "A")))
+ (and (= (char->integer #\A) (lookahead-u8 port))
+ (not (eof-object? port))
+ (= (char->integer #\A) (get-u8 port))
+ (eof-object? (get-u8 port)))))
+
+ (pass-if "get-bytevector-n [short]"
+ (let* ((port (open-input-string "GNU Guile"))
+ (bv (get-bytevector-n port 4)))
+ (and (bytevector? bv)
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list "GNU "))))))
+
+ (pass-if "get-bytevector-n [long]"
+ (let* ((port (open-input-string "GNU Guile"))
+ (bv (get-bytevector-n port 256)))
+ (and (bytevector? bv)
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list "GNU Guile"))))))
+
+ (pass-if-exception "get-bytevector-n with closed port"
+ exception:wrong-type-arg
+
+ (let ((port (%make-void-port "r")))
+
+ (close-port port)
+ (get-bytevector-n port 3)))
+
+ (pass-if "get-bytevector-n! [short]"
+ (let* ((port (open-input-string "GNU Guile"))
+ (bv (make-bytevector 4))
+ (read (get-bytevector-n! port bv 0 4)))
+ (and (equal? read 4)
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list "GNU "))))))
+
+ (pass-if "get-bytevector-n! [long]"
+ (let* ((str "GNU Guile")
+ (port (open-input-string str))
+ (bv (make-bytevector 256))
+ (read (get-bytevector-n! port bv 0 256)))
+ (and (equal? read (string-length str))
+ (equal? (map (lambda (i)
+ (bytevector-u8-ref bv i))
+ (iota read))
+ (map char->integer (string->list str))))))
+
+ (pass-if "get-bytevector-some [simple]"
+ (let* ((str "GNU Guile")
+ (port (open-input-string str))
+ (bv (get-bytevector-some port)))
+ (and (bytevector? bv)
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list str))))))
+
+ (pass-if "get-bytevector-some [only-some]"
+ (let* ((str "GNU Guile")
+ (index 0)
+ (port (make-soft-port
+ (vector #f #f #f
+ (lambda ()
+ (if (>= index (string-length str))
+ (eof-object)
+ (let ((c (string-ref str index)))
+ (set! index (+ index 1))
+ c)))
+ (lambda () #t)
+ (lambda ()
+ ;; Number of readily available octets: falls to
+ ;; zero after 4 octets have been read.
+ (- 4 (modulo index 5))))
+ "r"))
+ (bv (get-bytevector-some port)))
+ (and (bytevector? bv)
+ (= index 4)
+ (= (bytevector-length bv) index)
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list "GNU "))))))
+
+ (pass-if "get-bytevector-all"
+ (let* ((str "GNU Guile")
+ (index 0)
+ (port (make-soft-port
+ (vector #f #f #f
+ (lambda ()
+ (if (>= index (string-length str))
+ (eof-object)
+ (let ((c (string-ref str index)))
+ (set! index (+ index 1))
+ c)))
+ (lambda () #t)
+ (let ((cont? #f))
+ (lambda ()
+ ;; Number of readily available octets: falls to
+ ;; zero after 4 octets have been read and then
+ ;; starts again.
+ (let ((a (if cont?
+ (- (string-length str) index)
+ (- 4 (modulo index 5)))))
+ (if (= 0 a) (set! cont? #t))
+ a))))
+ "r"))
+ (bv (get-bytevector-all port)))
+ (and (bytevector? bv)
+ (= index (string-length str))
+ (= (bytevector-length bv) (string-length str))
+ (equal? (bytevector->u8-list bv)
+ (map char->integer (string->list str)))))))
+
+
+(define (make-soft-output-port)
+ (let* ((bv (make-bytevector 1024))
+ (read-index 0)
+ (write-index 0)
+ (write-char (lambda (chr)
+ (bytevector-u8-set! bv write-index
+ (char->integer chr))
+ (set! write-index (+ 1 write-index)))))
+ (make-soft-port
+ (vector write-char
+ (lambda (str) ;; write-string
+ (for-each write-char (string->list str)))
+ (lambda () #t) ;; flush-output
+ (lambda () ;; read-char
+ (if (>= read-index (bytevector-length bv))
+ (eof-object)
+ (let ((c (bytevector-u8-ref bv read-index)))
+ (set! read-index (+ read-index 1))
+ (integer->char c))))
+ (lambda () #t)) ;; close-port
+ "rw")))
+
+(with-test-prefix "7.2.11 Binary Output"
+
+ (pass-if "put-u8"
+ (let ((port (make-soft-output-port)))
+ (put-u8 port 77)
+ (equal? (get-u8 port) 77)))
+
+ (pass-if "put-bytevector [2 args]"
+ (let ((port (make-soft-output-port))
+ (bv (make-bytevector 256)))
+ (put-bytevector port bv)
+ (equal? (bytevector->u8-list bv)
+ (bytevector->u8-list
+ (get-bytevector-n port (bytevector-length bv))))))
+
+ (pass-if "put-bytevector [3 args]"
+ (let ((port (make-soft-output-port))
+ (bv (make-bytevector 256))
+ (start 10))
+ (put-bytevector port bv start)
+ (equal? (drop (bytevector->u8-list bv) start)
+ (bytevector->u8-list
+ (get-bytevector-n port (- (bytevector-length bv) start))))))
+
+ (pass-if "put-bytevector [4 args]"
+ (let ((port (make-soft-output-port))
+ (bv (make-bytevector 256))
+ (start 10)
+ (count 77))
+ (put-bytevector port bv start count)
+ (equal? (take (drop (bytevector->u8-list bv) start) count)
+ (bytevector->u8-list
+ (get-bytevector-n port count)))))
+
+ (pass-if-exception "put-bytevector with closed port"
+ exception:wrong-type-arg
+
+ (let* ((bv (make-bytevector 4))
+ (port (%make-void-port "w")))
+
+ (close-port port)
+ (put-bytevector port bv))))
+
+
+(with-test-prefix "7.2.7 Input Ports"
+
+ ;; This section appears here so that it can use the binary input
+ ;; primitives.
+
+ (pass-if "open-bytevector-input-port [1 arg]"
+ (let* ((str "Hello Port!")
+ (bv (u8-list->bytevector (map char->integer
+ (string->list str))))
+ (port (open-bytevector-input-port bv))
+ (read-to-string
+ (lambda (port)
+ (let loop ((chr (read-char port))
+ (result '()))
+ (if (eof-object? chr)
+ (apply string (reverse! result))
+ (loop (read-char port)
+ (cons chr result)))))))
+
+ (equal? (read-to-string port) str)))
+
+ (pass-if-exception "bytevector-input-port is read-only"
+ exception:wrong-type-arg
+
+ (let* ((str "Hello Port!")
+ (bv (u8-list->bytevector (map char->integer
+ (string->list str))))
+ (port (open-bytevector-input-port bv #f)))
+
+ (write "hello" port)))
+
+ (pass-if "bytevector input port supports seeking"
+ (let* ((str "Hello Port!")
+ (bv (u8-list->bytevector (map char->integer
+ (string->list str))))
+ (port (open-bytevector-input-port bv #f)))
+
+ (and (port-has-port-position? port)
+ (= 0 (port-position port))
+ (port-has-set-port-position!? port)
+ (begin
+ (set-port-position! port 6)
+ (= 6 (port-position port)))
+ (bytevector=? (get-bytevector-all port)
+ (u8-list->bytevector
+ (map char->integer (string->list "Port!")))))))
+
+ (pass-if-exception "make-custom-binary-input-port [wrong-num-args]"
+ exception:wrong-num-args
+
+ ;; Prior to Guile-R6RS-Libs 0.2, the last 3 arguments were wrongfully
+ ;; optional.
+ (make-custom-binary-input-port "port" (lambda args #t)))
+
+ (pass-if "make-custom-binary-input-port"
+ (let* ((source (make-bytevector 7777))
+ (read! (let ((pos 0)
+ (len (bytevector-length source)))
+ (lambda (bv start count)
+ (let ((amount (min count (- len pos))))
+ (if (> amount 0)
+ (bytevector-copy! source pos
+ bv start amount))
+ (set! pos (+ pos amount))
+ amount))))
+ (port (make-custom-binary-input-port "the port" read!
+ #f #f #f)))
+
+ (bytevector=? (get-bytevector-all port) source)))
+
+ (pass-if "custom binary input port does not support `port-position'"
+ (let* ((str "Hello Port!")
+ (source (open-bytevector-input-port
+ (u8-list->bytevector
+ (map char->integer (string->list str)))))
+ (read! (lambda (bv start count)
+ (let ((r (get-bytevector-n! source bv start count)))
+ (if (eof-object? r)
+ 0
+ r))))
+ (port (make-custom-binary-input-port "the port" read!
+ #f #f #f)))
+ (not (or (port-has-port-position? port)
+ (port-has-set-port-position!? port)))))
+
+ (pass-if "custom binary input port supports `port-position'"
+ (let* ((str "Hello Port!")
+ (source (open-bytevector-input-port
+ (u8-list->bytevector
+ (map char->integer (string->list str)))))
+ (read! (lambda (bv start count)
+ (let ((r (get-bytevector-n! source bv start count)))
+ (if (eof-object? r)
+ 0
+ r))))
+ (get-pos (lambda ()
+ (port-position source)))
+ (set-pos! (lambda (pos)
+ (set-port-position! source pos)))
+ (port (make-custom-binary-input-port "the port" read!
+ get-pos set-pos! #f)))
+
+ (and (port-has-port-position? port)
+ (= 0 (port-position port))
+ (port-has-set-port-position!? port)
+ (begin
+ (set-port-position! port 6)
+ (= 6 (port-position port)))
+ (bytevector=? (get-bytevector-all port)
+ (u8-list->bytevector
+ (map char->integer (string->list "Port!")))))))
+
+ (pass-if "custom binary input port `close-proc' is called"
+ (let* ((closed? #f)
+ (read! (lambda (bv start count) 0))
+ (get-pos (lambda () 0))
+ (set-pos! (lambda (pos) #f))
+ (close! (lambda () (set! closed? #t)))
+ (port (make-custom-binary-input-port "the port" read!
+ get-pos set-pos!
+ close!)))
+
+ (close-port port)
+ closed?)))
+
+
+(with-test-prefix "8.2.10 Output ports"
+
+ (pass-if "open-bytevector-output-port"
+ (let-values (((port get-content)
+ (open-bytevector-output-port #f)))
+ (let ((source (make-bytevector 7777)))
+ (put-bytevector port source)
+ (and (bytevector=? (get-content) source)
+ (bytevector=? (get-content) (make-bytevector 0))))))
+
+ (pass-if "open-bytevector-output-port [put-u8]"
+ (let-values (((port get-content)
+ (open-bytevector-output-port)))
+ (put-u8 port 77)
+ (and (bytevector=? (get-content) (make-bytevector 1 77))
+ (bytevector=? (get-content) (make-bytevector 0)))))
+
+ (pass-if "open-bytevector-output-port [display]"
+ (let-values (((port get-content)
+ (open-bytevector-output-port)))
+ (display "hello" port)
+ (and (bytevector=? (get-content) (string->utf8 "hello"))
+ (bytevector=? (get-content) (make-bytevector 0)))))
+
+ (pass-if "bytevector output port supports `port-position'"
+ (let-values (((port get-content)
+ (open-bytevector-output-port)))
+ (let ((source (make-bytevector 7777))
+ (overwrite (make-bytevector 33)))
+ (and (port-has-port-position? port)
+ (port-has-set-port-position!? port)
+ (begin
+ (put-bytevector port source)
+ (= (bytevector-length source)
+ (port-position port)))
+ (begin
+ (set-port-position! port 10)
+ (= 10 (port-position port)))
+ (begin
+ (put-bytevector port overwrite)
+ (bytevector-copy! overwrite 0 source 10
+ (bytevector-length overwrite))
+ (= (port-position port)
+ (+ 10 (bytevector-length overwrite))))
+ (bytevector=? (get-content) source)
+ (bytevector=? (get-content) (make-bytevector 0))))))
+
+ (pass-if "make-custom-binary-output"
+ (let ((port (make-custom-binary-output-port "cbop"
+ (lambda (x y z) 0)
+ #f #f #f)))
+ (and (output-port? port)
+ (binary-port? port)
+ (not (port-has-port-position? port))
+ (not (port-has-set-port-position!? port)))))
+
+ (pass-if "make-custom-binary-output-port [partial writes]"
+ (let* ((source (uint-list->bytevector (iota 333)
+ (native-endianness) 2))
+ (sink (make-bytevector (bytevector-length source)))
+ (sink-pos 0)
+ (eof? #f)
+ (write! (lambda (bv start count)
+ (if (= 0 count)
+ (begin
+ (set! eof? #t)
+ 0)
+ (let ((u8 (bytevector-u8-ref bv start)))
+ ;; Get one byte at a time.
+ (bytevector-u8-set! sink sink-pos u8)
+ (set! sink-pos (+ 1 sink-pos))
+ 1))))
+ (port (make-custom-binary-output-port "cbop" write!
+ #f #f #f)))
+ (put-bytevector port source)
+ (and (= sink-pos (bytevector-length source))
+ (not eof?)
+ (bytevector=? sink source))))
+
+ (pass-if "make-custom-binary-output-port [full writes]"
+ (let* ((source (uint-list->bytevector (iota 333)
+ (native-endianness) 2))
+ (sink (make-bytevector (bytevector-length source)))
+ (sink-pos 0)
+ (eof? #f)
+ (write! (lambda (bv start count)
+ (if (= 0 count)
+ (begin
+ (set! eof? #t)
+ 0)
+ (begin
+ (bytevector-copy! bv start
+ sink sink-pos
+ count)
+ (set! sink-pos (+ sink-pos count))
+ count))))
+ (port (make-custom-binary-output-port "cbop" write!
+ #f #f #f)))
+ (put-bytevector port source)
+ (and (= sink-pos (bytevector-length source))
+ (not eof?)
+ (bytevector=? sink source)))))
+
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; mode: scheme
+;;; End:
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index b068c71..bd34e4d 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -35,6 +35,8 @@
(cons 'read-error "end of file in string constant$"))
(define exception:illegal-escape
(cons 'read-error "illegal character in escape sequence: .*$"))
+(define exception:missing-expression
+ (cons 'read-error "no expression after #;"))
(define (read-string s)
@@ -165,6 +167,11 @@
(with-read-options '(keywords postfix)
(lambda ()
(read-string "keyword:")))))
+ (pass-if "long postfix keywords"
+ (eq?
#:keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
+ (with-read-options '(keywords postfix)
+ (lambda ()
+ (read-string
"keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789:")))))
(pass-if "`:' is not a postfix keyword (per SRFI-88)"
(eq? ':
(with-read-options '(keywords postfix)
@@ -189,3 +196,36 @@
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 0)))))
+(with-test-prefix "#;"
+ (for-each
+ (lambda (pair)
+ (pass-if (car pair)
+ (equal? (with-input-from-string (car pair) read) (cdr pair))))
+
+ '(("#;foo 10". 10)
+ ("#;(10 20 30) foo" . foo)
+ ("#; (10 20 30) foo" . foo)
+ ("#;\n10\n20" . 20)))
+
+ (pass-if "#;foo"
+ (eof-object? (with-input-from-string "#;foo" read)))
+
+ (pass-if-exception "#;"
+ exception:missing-expression
+ (with-input-from-string "#;" read))
+ (pass-if-exception "#;("
+ exception:eof
+ (with-input-from-string "#;(" read)))
+
+(with-test-prefix "#'"
+ (for-each
+ (lambda (pair)
+ (pass-if (car pair)
+ (equal? (with-input-from-string (car pair) read) (cdr pair))))
+
+ '(("#'foo". (syntax foo))
+ ("#`foo" . (quasisyntax foo))
+ ("#,foo" . (unsyntax foo))
+ ("#,@foo" . (unsyntax-splicing foo)))))
+
+
diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test
index fbacb15..4841f2e 100644
--- a/test-suite/tests/srfi-17.test
+++ b/test-suite/tests/srfi-17.test
@@ -50,6 +50,9 @@
(define %some-variable #f)
+(define exception:bad-quote
+ '(syntax-error . "quote: bad syntax"))
+
(with-test-prefix "set!"
(with-test-prefix "target is not procedure with setter"
@@ -59,7 +62,7 @@
(set! (symbol->string 'x) 1))
(pass-if-exception "(set! '#f 1)"
- exception:bad-variable
+ exception:bad-quote
(eval '(set! '#f 1) (interaction-environment))))
(with-test-prefix "target uses macro"
@@ -72,7 +75,7 @@
;; The `(quote x)' below used to be memoized as an infinite list before
;; Guile 1.8.3.
(pass-if-exception "(set! 'x 1)"
- exception:bad-variable
+ exception:bad-quote
(eval '(set! 'x 1) (interaction-environment)))))
;;
diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
index fa309e6..3c70906 100644
--- a/test-suite/tests/srfi-18.test
+++ b/test-suite/tests/srfi-18.test
@@ -21,8 +21,13 @@
(define-module (test-suite test-srfi-18)
#:use-module (test-suite lib))
-(and (provided? 'threads)
- (use-modules (srfi srfi-18))
+;; two expressions so that the srfi-18 import is in effect for expansion
+;; of the rest
+(if (provided? 'threads)
+ (use-modules (srfi srfi-18)))
+
+(and
+ (provided? 'threads)
(with-test-prefix "current-thread"
diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test
index bd69773..b23d3e2 100644
--- a/test-suite/tests/srfi-31.test
+++ b/test-suite/tests/srfi-31.test
@@ -23,7 +23,7 @@
(with-test-prefix "rec special form"
(pass-if-exception "bogus variable" '(misc-error . ".*")
- (rec #:foo))
+ (sc-expand '(rec #:foo)))
(pass-if "rec expressions"
(let ((ones-list (rec ones (cons 1 (delay ones)))))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 1277e52..aa2e051 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -21,6 +21,11 @@
:use-module (test-suite lib))
+(define exception:generic-syncase-error
+ (cons 'syntax-error "source expression failed to match"))
+(define exception:unexpected-syntax
+ (cons 'syntax-error "unexpected syntax"))
+
(define exception:bad-expression
(cons 'syntax-error "Bad expression"))
@@ -29,22 +34,32 @@
(define exception:missing-expr
(cons 'syntax-error "Missing expression"))
(define exception:missing-body-expr
- (cons 'syntax-error "Missing body expression"))
+ (cons 'syntax-error "no expressions in body"))
(define exception:extra-expr
(cons 'syntax-error "Extra expression"))
(define exception:illegal-empty-combination
(cons 'syntax-error "Illegal empty combination"))
+(define exception:bad-lambda
+ '(syntax-error . "bad lambda"))
+(define exception:bad-let
+ '(syntax-error . "bad let "))
+(define exception:bad-letrec
+ '(syntax-error . "bad letrec "))
+(define exception:bad-set!
+ '(syntax-error . "bad set!"))
+(define exception:bad-quote
+ '(syntax-error . "quote: bad syntax"))
(define exception:bad-bindings
(cons 'syntax-error "Bad bindings"))
(define exception:bad-binding
(cons 'syntax-error "Bad binding"))
(define exception:duplicate-binding
- (cons 'syntax-error "Duplicate binding"))
+ (cons 'syntax-error "duplicate bound variable"))
(define exception:bad-body
(cons 'misc-error "^bad body"))
(define exception:bad-formals
- (cons 'syntax-error "Bad formals"))
+ '(syntax-error . "invalid parameter list"))
(define exception:bad-formal
(cons 'syntax-error "Bad formal"))
(define exception:duplicate-formal
@@ -67,13 +82,13 @@
(with-test-prefix "Bad argument list"
(pass-if-exception "improper argument list of length 1"
- exception:wrong-num-args
+ exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo . 1))
(interaction-environment)))
(pass-if-exception "improper argument list of length 2"
- exception:wrong-num-args
+ exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo 1 . 2))
(interaction-environment))))
@@ -88,7 +103,7 @@
;; Fixed on 2001-3-3
(pass-if-exception "empty parentheses \"()\""
- exception:illegal-empty-combination
+ exception:unexpected-syntax
(eval '()
(interaction-environment)))))
@@ -106,28 +121,32 @@
(with-test-prefix "unquote-splicing"
(pass-if-exception "extra arguments"
- exception:missing/extra-expr
- (quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))
+ '(syntax-error . "unquote-splicing takes exactly one argument")
+ (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
+ (interaction-environment)))))
(with-test-prefix "begin"
(pass-if "legal (begin)"
- (begin)
- #t)
+ (eval '(begin (begin) #t) (interaction-environment)))
(with-test-prefix "unmemoization"
+ ;; FIXME. I have no idea why, but the expander is filling in (if #f
+ ;; #f) as the second arm of the if, if the second arm is missing. I
+ ;; thought I made it not do that. But in the meantime, let's adapt,
+ ;; since that's not what we're testing.
+
(pass-if "normal begin"
- (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))
- (foo) ; make sure, memoization has been performed
+ (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))
(equal? (procedure-source foo)
- '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))))
+ '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))))
(pass-if "redundant nested begin"
- (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))
+ (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))
#f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
- '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))))
+ '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))
#f)))))
(pass-if "redundant begin at start of body"
(let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
@@ -135,10 +154,20 @@
(equal? (procedure-source foo)
'(lambda () (begin (+ 1) (+ 2)))))))
- (expect-fail-exception "illegal (begin)"
- exception:bad-body
- (if #t (begin))
- #t))
+ (pass-if-exception "illegal (begin)"
+ exception:generic-syncase-error
+ (eval '(begin (if #t (begin)) #t) (interaction-environment))))
+
+(define-syntax matches?
+ (syntax-rules (_)
+ ((_ (op arg ...) pat) (let ((x (op arg ...)))
+ (matches? x pat)))
+ ((_ x ()) (null? x))
+ ((_ x (a . b)) (and (pair? x)
+ (matches? (car x) a)
+ (matches? (cdr x) b)))
+ ((_ x _) #t)
+ ((_ x pat) (equal? x 'pat))))
(with-test-prefix "lambda"
@@ -146,30 +175,28 @@
(pass-if "normal lambda"
(let ((foo (lambda () (lambda (x y) (+ x y)))))
- ((foo) 1 2) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (lambda (x y) (+ x y))))))
+ (matches? (procedure-source foo)
+ (lambda () (lambda (_ _) (+ _ _))))))
(pass-if "lambda with documentation"
(let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
- ((foo) 1 2) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (lambda (x y) "docstring" (+ x y)))))))
+ (matches? (procedure-source foo)
+ (lambda () (lambda (_ _) "docstring" (+ _ _)))))))
(with-test-prefix "bad formals"
(pass-if-exception "(lambda)"
- exception:missing-expr
+ exception:bad-lambda
(eval '(lambda)
(interaction-environment)))
(pass-if-exception "(lambda . \"foo\")"
- exception:bad-expression
+ exception:bad-lambda
(eval '(lambda . "foo")
(interaction-environment)))
(pass-if-exception "(lambda \"foo\")"
- exception:missing-expr
+ exception:bad-lambda
(eval '(lambda "foo")
(interaction-environment)))
@@ -179,22 +206,22 @@
(interaction-environment)))
(pass-if-exception "(lambda (x 1) 2)"
- exception:bad-formal
+ exception:bad-formals
(eval '(lambda (x 1) 2)
(interaction-environment)))
(pass-if-exception "(lambda (1 x) 2)"
- exception:bad-formal
+ exception:bad-formals
(eval '(lambda (1 x) 2)
(interaction-environment)))
(pass-if-exception "(lambda (x \"a\") 2)"
- exception:bad-formal
+ exception:bad-formals
(eval '(lambda (x "a") 2)
(interaction-environment)))
(pass-if-exception "(lambda (\"a\" x) 2)"
- exception:bad-formal
+ exception:bad-formals
(eval '(lambda ("a" x) 2)
(interaction-environment))))
@@ -202,20 +229,20 @@
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x) 1)"
- exception:duplicate-formal
+ exception:bad-formals
(eval '(lambda (x x) 1)
(interaction-environment)))
;; Fixed on 2001-3-3
(pass-if-exception "(lambda (x x x) 1)"
- exception:duplicate-formal
+ exception:bad-formals
(eval '(lambda (x x x) 1)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(lambda ())"
- exception:missing-expr
+ exception:bad-lambda
(eval '(lambda ())
(interaction-environment)))))
@@ -225,9 +252,8 @@
(pass-if "normal let"
(let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (let ((i 1) (j 2)) (+ i j)))))))
+ (matches? (procedure-source foo)
+ (lambda () (let ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
@@ -238,42 +264,42 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let)"
- exception:missing-expr
+ exception:bad-let
(eval '(let)
(interaction-environment)))
(pass-if-exception "(let 1)"
- exception:missing-expr
+ exception:bad-let
(eval '(let 1)
(interaction-environment)))
(pass-if-exception "(let (x))"
- exception:missing-expr
+ exception:bad-let
(eval '(let (x))
(interaction-environment)))
(pass-if-exception "(let ((x)))"
- exception:missing-expr
+ exception:bad-let
(eval '(let ((x)))
(interaction-environment)))
(pass-if-exception "(let (x) 1)"
- exception:bad-binding
+ exception:bad-let
(eval '(let (x) 1)
(interaction-environment)))
(pass-if-exception "(let ((x)) 3)"
- exception:bad-binding
+ exception:bad-let
(eval '(let ((x)) 3)
(interaction-environment)))
(pass-if-exception "(let ((x 1) y) x)"
- exception:bad-binding
+ exception:bad-let
(eval '(let ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(let ((1 2)) 3)"
- exception:bad-variable
+ exception:bad-let
(eval '(let ((1 2)) 3)
(interaction-environment))))
@@ -287,12 +313,12 @@
(with-test-prefix "bad body"
(pass-if-exception "(let ())"
- exception:missing-expr
+ exception:bad-let
(eval '(let ())
(interaction-environment)))
(pass-if-exception "(let ((x 1)))"
- exception:missing-expr
+ exception:bad-let
(eval '(let ((x 1)))
(interaction-environment)))))
@@ -307,19 +333,19 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let x (y))"
- exception:missing-expr
+ exception:bad-let
(eval '(let x (y))
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(let x ())"
- exception:missing-expr
+ exception:bad-let
(eval '(let x ())
(interaction-environment)))
(pass-if-exception "(let x ((y 1)))"
- exception:missing-expr
+ exception:bad-let
(eval '(let x ((y 1)))
(interaction-environment)))))
@@ -329,19 +355,16 @@
(pass-if "normal let*"
(let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (let* ((x 1) (y 2)) (+ x y))))))
+ (matches? (procedure-source foo)
+ (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _)))))))
(pass-if "let* without bindings"
(let ((foo (lambda () (let ((x 1) (y 2))
(let* ()
(and (= x 1) (= y 2)))))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (let ((x 1) (y 2))
- (let* ()
- (and (= x 1) (= y 2)))))))))
+ (matches? (procedure-source foo)
+ (lambda () (let ((_ 1) (_ 2))
+ (if (= _ 1) (= _ 2) #f)))))))
(with-test-prefix "bindings"
@@ -361,59 +384,59 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(let*)"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(let*)
(interaction-environment)))
(pass-if-exception "(let* 1)"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(let* 1)
(interaction-environment)))
(pass-if-exception "(let* (x))"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(let* (x))
(interaction-environment)))
(pass-if-exception "(let* (x) 1)"
- exception:bad-binding
+ exception:generic-syncase-error
(eval '(let* (x) 1)
(interaction-environment)))
(pass-if-exception "(let* ((x)) 3)"
- exception:bad-binding
+ exception:generic-syncase-error
(eval '(let* ((x)) 3)
(interaction-environment)))
(pass-if-exception "(let* ((x 1) y) x)"
- exception:bad-binding
+ exception:generic-syncase-error
(eval '(let* ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(let* x ())"
- exception:bad-bindings
+ exception:generic-syncase-error
(eval '(let* x ())
(interaction-environment)))
(pass-if-exception "(let* x (y))"
- exception:bad-bindings
+ exception:generic-syncase-error
(eval '(let* x (y))
(interaction-environment)))
(pass-if-exception "(let* ((1 2)) 3)"
- exception:bad-variable
+ exception:generic-syncase-error
(eval '(let* ((1 2)) 3)
(interaction-environment))))
(with-test-prefix "bad body"
(pass-if-exception "(let* ())"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(let* ())
(interaction-environment)))
(pass-if-exception "(let* ((x 1)))"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(let* ((x 1)))
(interaction-environment)))))
@@ -423,9 +446,8 @@
(pass-if "normal letrec"
(let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (letrec ((i 1) (j 2)) (+ i j)))))))
+ (matches? (procedure-source foo)
+ (lambda () (letrec ((_ 1) (_ 2)) (+ _ _)))))))
(with-test-prefix "bindings"
@@ -437,47 +459,47 @@
(with-test-prefix "bad bindings"
(pass-if-exception "(letrec)"
- exception:missing-expr
+ exception:bad-letrec
(eval '(letrec)
(interaction-environment)))
(pass-if-exception "(letrec 1)"
- exception:missing-expr
+ exception:bad-letrec
(eval '(letrec 1)
(interaction-environment)))
(pass-if-exception "(letrec (x))"
- exception:missing-expr
+ exception:bad-letrec
(eval '(letrec (x))
(interaction-environment)))
(pass-if-exception "(letrec (x) 1)"
- exception:bad-binding
+ exception:bad-letrec
(eval '(letrec (x) 1)
(interaction-environment)))
(pass-if-exception "(letrec ((x)) 3)"
- exception:bad-binding
+ exception:bad-letrec
(eval '(letrec ((x)) 3)
(interaction-environment)))
(pass-if-exception "(letrec ((x 1) y) x)"
- exception:bad-binding
+ exception:bad-letrec
(eval '(letrec ((x 1) y) x)
(interaction-environment)))
(pass-if-exception "(letrec x ())"
- exception:bad-bindings
+ exception:bad-letrec
(eval '(letrec x ())
(interaction-environment)))
(pass-if-exception "(letrec x (y))"
- exception:bad-bindings
+ exception:bad-letrec
(eval '(letrec x (y))
(interaction-environment)))
(pass-if-exception "(letrec ((1 2)) 3)"
- exception:bad-variable
+ exception:bad-letrec
(eval '(letrec ((1 2)) 3)
(interaction-environment))))
@@ -491,12 +513,12 @@
(with-test-prefix "bad body"
(pass-if-exception "(letrec ())"
- exception:missing-expr
+ exception:bad-letrec
(eval '(letrec ())
(interaction-environment)))
(pass-if-exception "(letrec ((x 1)))"
- exception:missing-expr
+ exception:bad-letrec
(eval '(letrec ((x 1)))
(interaction-environment)))))
@@ -508,17 +530,17 @@
(let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (if x (+ 1) (+ 2))))))
+ (matches? (procedure-source foo)
+ (lambda (_) (if _ (+ 1) (+ 2))))))
- (pass-if "if without else"
+ (expect-fail "if without else"
(let ((foo (lambda (x) (if x (+ 1)))))
(foo #t) ; make sure, memoization has been performed
(foo #f) ; make sure, memoization has been performed
(equal? (procedure-source foo)
'(lambda (x) (if x (+ 1))))))
- (pass-if "if #f without else"
+ (expect-fail "if #f without else"
(let ((foo (lambda () (if #f #f))))
(foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
@@ -527,12 +549,12 @@
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(if)"
- exception:missing/extra-expr
+ exception:generic-syncase-error
(eval '(if)
(interaction-environment)))
(pass-if-exception "(if 1 2 3 4)"
- exception:missing/extra-expr
+ exception:generic-syncase-error
(eval '(if 1 2 3 4)
(interaction-environment)))))
@@ -594,78 +616,77 @@
(eq? 'ok (cond (#t identity =>) (else #f)))))
(pass-if-exception "missing recipient"
- '(syntax-error . "Missing recipient")
+ '(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity =>)))
(pass-if-exception "extra recipient"
- '(syntax-error . "Extra expression")
+ '(syntax-error . "cond: wrong number of receiver expressions")
(cond (#t identity => identity identity))))
(with-test-prefix "unmemoization"
+ ;; FIXME: the (if #f #f) is a hack!
(pass-if "normal clauses"
- (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
- (foo 1) ; make sure, memoization has been performed
- (foo 2) ; make sure, memoization has been performed
+ (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
(equal? (procedure-source foo)
- '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
+ '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f)))))))
(pass-if "else"
(let ((foo (lambda () (cond (else 'bar)))))
- (foo) ; make sure, memoization has been performed
(equal? (procedure-source foo)
- '(lambda () (cond (else 'bar))))))
+ '(lambda () 'bar))))
+ ;; FIXME: the (if #f #f) is a hack!
(pass-if "=>"
(let ((foo (lambda () (cond (#t => identity)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (cond (#t => identity)))))))
+ (matches? (procedure-source foo)
+ (lambda () (let ((_ #t))
+ (if _ (identity _) (if #f #f))))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(cond)"
- exception:missing-clauses
+ exception:generic-syncase-error
(eval '(cond)
(interaction-environment)))
(pass-if-exception "(cond #t)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond #t)
(interaction-environment)))
(pass-if-exception "(cond 1)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond 1)
(interaction-environment)))
(pass-if-exception "(cond 1 2)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond 1 2)
(interaction-environment)))
(pass-if-exception "(cond 1 2 3)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond 1 2 3)
(interaction-environment)))
(pass-if-exception "(cond 1 2 3 4)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond 1 2 3 4)
(interaction-environment)))
(pass-if-exception "(cond ())"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond ())
(interaction-environment)))
(pass-if-exception "(cond () 1)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond () 1)
(interaction-environment)))
(pass-if-exception "(cond (1) 1)"
- exception:bad-cond-clause
+ exception:generic-syncase-error
(eval '(cond (1) 1)
(interaction-environment))))
@@ -683,7 +704,7 @@
(with-test-prefix "case is hygienic"
(pass-if-exception "bound 'else is handled correctly"
- exception:bad-case-labels
+ exception:generic-syncase-error
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
@@ -691,79 +712,83 @@
(pass-if "normal clauses"
(let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
- (foo 1) ; make sure, memoization has been performed
- (foo 2) ; make sure, memoization has been performed
- (foo 3) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))
+ (matches? (procedure-source foo)
+ (lambda (_)
+ (if ((@@ (guile) memv) _ '(1))
+ 'bar
+ (if ((@@ (guile) memv) _ '(2))
+ 'baz
+ 'foobar))))))
(pass-if "empty labels"
(let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
- (foo 1) ; make sure, memoization has been performed
- (foo 2) ; make sure, memoization has been performed
- (foo 3) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))
+ (matches? (procedure-source foo)
+ (lambda (_)
+ (if ((@@ (guile) memv) _ '(1))
+ 'bar
+ (if ((@@ (guile) memv) _ '())
+ 'baz
+ 'foobar)))))))
(with-test-prefix "bad or missing clauses"
(pass-if-exception "(case)"
- exception:missing-clauses
+ exception:generic-syncase-error
(eval '(case)
(interaction-environment)))
(pass-if-exception "(case . \"foo\")"
- exception:bad-expression
+ exception:generic-syncase-error
(eval '(case . "foo")
(interaction-environment)))
(pass-if-exception "(case 1)"
- exception:missing-clauses
+ exception:generic-syncase-error
(eval '(case 1)
(interaction-environment)))
(pass-if-exception "(case 1 . \"foo\")"
- exception:bad-expression
+ exception:generic-syncase-error
(eval '(case 1 . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 \"foo\")"
- exception:bad-case-clause
+ exception:generic-syncase-error
(eval '(case 1 "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ())"
- exception:bad-case-clause
+ exception:generic-syncase-error
(eval '(case 1 ())
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\"))"
- exception:bad-case-clause
+ exception:generic-syncase-error
(eval '(case 1 ("foo"))
(interaction-environment)))
(pass-if-exception "(case 1 (\"foo\" \"bar\"))"
- exception:bad-case-labels
+ exception:generic-syncase-error
(eval '(case 1 ("foo" "bar"))
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
- exception:bad-expression
+ exception:generic-syncase-error
(eval '(case 1 ((2) "bar") . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 ((2) \"bar\") (else))"
- exception:bad-case-clause
+ exception:generic-syncase-error
(eval '(case 1 ((2) "bar") (else))
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) . \"foo\")"
- exception:bad-expression
+ exception:generic-syncase-error
(eval '(case 1 (else #f) . "foo")
(interaction-environment)))
(pass-if-exception "(case 1 (else #f) ((1) #t))"
- exception:misplaced-else-clause
+ exception:generic-syncase-error
(eval '(case 1 (else #f) ((1) #t))
(interaction-environment)))))
@@ -780,14 +805,6 @@
(eval '(define round round) m)
(eq? (module-ref m 'round) round)))
- (with-test-prefix "currying"
-
- (pass-if "(define ((foo)) #f)"
- (eval '(begin
- (define ((foo)) #t)
- ((foo)))
- (interaction-environment))))
-
(with-test-prefix "unmemoization"
(pass-if "definition unmemoized without prior execution"
@@ -809,7 +826,7 @@
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(define)"
- exception:missing-expr
+ exception:generic-syncase-error
(eval '(define)
(interaction-environment)))))
@@ -886,34 +903,10 @@
'ok)
(bar))
(foo)
- (equal?
+ (matches?
(procedure-source foo)
- '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
- (interaction-environment))))
-
-(with-test-prefix "do"
-
- (with-test-prefix "unmemoization"
-
- (pass-if "normal case"
- (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2))
- ((> i 9) (+ i j))
- (identity i)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (do ((i 1 (+ i 1)) (j 2))
- ((> i 9) (+ i j))
- (identity i))))))
-
- (pass-if "reduced case"
- (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j
- ((> i 9) (+ i j))
- (identity i)))))
- (foo) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here
- ((> i 9) (+ i j))
- (identity i))))))))
+ (lambda () (letrec ((_ (lambda () (quote ok)))) (_)))))
+ (current-module))))
(with-test-prefix "set!"
@@ -922,50 +915,50 @@
(pass-if "normal set!"
(let ((foo (lambda (x) (set! x (+ 1 x)))))
(foo 1) ; make sure, memoization has been performed
- (equal? (procedure-source foo)
- '(lambda (x) (set! x (+ 1 x)))))))
+ (matches? (procedure-source foo)
+ (lambda (_) (set! _ (+ 1 _)))))))
(with-test-prefix "missing or extra expressions"
(pass-if-exception "(set!)"
- exception:missing/extra-expr
+ exception:bad-set!
(eval '(set!)
(interaction-environment)))
(pass-if-exception "(set! 1)"
- exception:missing/extra-expr
+ exception:bad-set!
(eval '(set! 1)
(interaction-environment)))
(pass-if-exception "(set! 1 2 3)"
- exception:missing/extra-expr
+ exception:bad-set!
(eval '(set! 1 2 3)
(interaction-environment))))
(with-test-prefix "bad variable"
(pass-if-exception "(set! \"\" #t)"
- exception:bad-variable
+ exception:bad-set!
(eval '(set! "" #t)
(interaction-environment)))
(pass-if-exception "(set! 1 #t)"
- exception:bad-variable
+ exception:bad-set!
(eval '(set! 1 #t)
(interaction-environment)))
(pass-if-exception "(set! #t #f)"
- exception:bad-variable
+ exception:bad-set!
(eval '(set! #t #f)
(interaction-environment)))
(pass-if-exception "(set! #f #t)"
- exception:bad-variable
+ exception:bad-set!
(eval '(set! #f #t)
(interaction-environment)))
(pass-if-exception "(set! #\\space #f)"
- exception:bad-variable
+ exception:bad-set!
(eval '(set! #\space #f)
(interaction-environment)))))
@@ -974,12 +967,12 @@
(with-test-prefix "missing or extra expression"
(pass-if-exception "(quote)"
- exception:missing/extra-expr
+ exception:bad-quote
(eval '(quote)
(interaction-environment)))
(pass-if-exception "(quote a b)"
- exception:missing/extra-expr
+ exception:bad-quote
(eval '(quote a b)
(interaction-environment)))))
@@ -1010,46 +1003,27 @@
(do ((n 0 (1+ n)))
((> n 5))
(pass-if n
- (let ((cond (make-iterations-cond n)))
- (while (cond)))
- #t)))
+ (eval `(letrec ((make-iterations-cond
+ (lambda (n)
+ (lambda ()
+ (cond ((not n)
+ (error "oops, condition re-tested after
giving false"))
+ ((= 0 n)
+ (set! n #f)
+ #f)
+ (else
+ (set! n (1- n))
+ #t))))))
+ (let ((cond (make-iterations-cond ,n)))
+ (while (cond))
+ #t))
+ (interaction-environment)))))
(pass-if "initially false"
(while #f
(unreachable))
#t)
- (with-test-prefix "in empty environment"
-
- ;; an environment with no bindings at all
- (define empty-environment
- (make-module 1))
-
- ;; these tests are 'unresolved because to work with ice-9 syncase it was
- ;; necessary to drop the unquote from `do' in the implementation, and
- ;; unfortunately that makes `while' depend on its evaluation environment
-
- (pass-if "empty body"
- (throw 'unresolved)
- (eval `(,while #f)
- empty-environment)
- #t)
-
- (pass-if "initially false"
- (throw 'unresolved)
- (eval `(,while #f
- #f)
- empty-environment)
- #t)
-
- (pass-if "iterating"
- (throw 'unresolved)
- (let ((cond (make-iterations-cond 3)))
- (eval `(,while (,cond)
- 123 456)
- empty-environment))
- #t))
-
(with-test-prefix "iterations"
(do ((n 0 (1+ n)))
((> n 5))
@@ -1063,8 +1037,9 @@
(with-test-prefix "break"
(pass-if-exception "too many args" exception:wrong-num-args
- (while #t
- (break 1)))
+ (eval '(while #t
+ (break 1))
+ (interaction-environment)))
(with-test-prefix "from cond"
(pass-if "first"
@@ -1135,8 +1110,9 @@
(with-test-prefix "continue"
(pass-if-exception "too many args" exception:wrong-num-args
- (while #t
- (continue 1)))
+ (eval '(while #t
+ (continue 1))
+ (interaction-environment)))
(with-test-prefix "from cond"
(do ((n 0 (1+ n)))
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index caace7f..6400d2d 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -21,6 +21,20 @@
:use-module (ice-9 threads)
:use-module (test-suite lib))
+(define (asyncs-still-working?)
+ (let ((a #f))
+ (system-async-mark (lambda ()
+ (set! a #t)))
+ ;; The point of the following (equal? ...) is to go through
+ ;; primitive code (scm_equal_p) that includes a SCM_TICK call and
+ ;; hence gives system asyncs a chance to run. Of course the
+ ;; evaluator (eval.i.c) also calls SCM_TICK regularly, but in the
+ ;; near future we may be using the VM instead of the traditional
+ ;; compiler, and then we will still want asyncs-still-working? to
+ ;; work. (The VM should probably have SCM_TICK calls too, but
+ ;; let's not rely on that here.)
+ (equal? '(a b c) '(a b c))
+ a))
(if (provided? 'threads)
(begin
@@ -101,6 +115,9 @@
(with-test-prefix "n-for-each-par-map"
+ (pass-if "asyncs are still working 2"
+ (asyncs-still-working?))
+
(pass-if "0 in limit 10"
(n-for-each-par-map 10 noop noop '())
#t)
@@ -143,12 +160,18 @@
(with-test-prefix "lock-mutex"
+ (pass-if "asyncs are still working 3"
+ (asyncs-still-working?))
+
(pass-if "timed locking fails if timeout exceeded"
(let ((m (make-mutex)))
(lock-mutex m)
(let ((t (begin-thread (lock-mutex m (+ (current-time) 1)))))
(not (join-thread t)))))
+ (pass-if "asyncs are still working 6"
+ (asyncs-still-working?))
+
(pass-if "timed locking succeeds if mutex unlocked within timeout"
(let* ((m (make-mutex))
(c (make-condition-variable))
@@ -164,7 +187,12 @@
(unlock-mutex cm)
(sleep 1)
(unlock-mutex m)
- (join-thread t)))))
+ (join-thread t))))
+
+ (pass-if "asyncs are still working 7"
+ (asyncs-still-working?))
+
+ )
;;
;; timed mutex unlocking
@@ -172,12 +200,18 @@
(with-test-prefix "unlock-mutex"
+ (pass-if "asyncs are still working 5"
+ (asyncs-still-working?))
+
(pass-if "timed unlocking returns #f if timeout exceeded"
(let ((m (make-mutex))
(c (make-condition-variable)))
(lock-mutex m)
(not (unlock-mutex m c (current-time)))))
+ (pass-if "asyncs are still working 4"
+ (asyncs-still-working?))
+
(pass-if "timed unlocking returns #t if condition signaled"
(let ((m1 (make-mutex))
(m2 (make-mutex))
@@ -226,7 +260,36 @@
(pass-if "timed joining succeeds if thread exits within timeout"
(let ((t (begin-thread (begin (sleep 1) #t))))
- (join-thread t (+ (current-time) 2)))))
+ (join-thread t (+ (current-time) 2))))
+
+ (pass-if "asyncs are still working 1"
+ (asyncs-still-working?))
+
+ ;; scm_join_thread_timed has a SCM_TICK in the middle of it,
+ ;; to allow asyncs to run (including signal delivery). We
+ ;; used to have a bug whereby if the joined thread terminated
+ ;; at the same time as the joining thread is in this SCM_TICK,
+ ;; scm_join_thread_timed would not notice and would hang
+ ;; forever. So in this test we are setting up the following
+ ;; sequence of events.
+ ;; T=0 other thread is created and starts running
+ ;; T=2 main thread sets up an async that will sleep for 10 seconds
+ ;; T=2 main thread calls join-thread, which will...
+ ;; T=2 ...call the async, which starts sleeping
+ ;; T=5 other thread finishes its work and terminates
+ ;; T=7 async completes, main thread continues inside join-thread.
+ (pass-if "don't hang when joined thread terminates in SCM_TICK"
+ (let ((other-thread (make-thread sleep 5)))
+ (letrec ((delay-count 10)
+ (aproc (lambda ()
+ (set! delay-count (- delay-count 1))
+ (if (zero? delay-count)
+ (sleep 5)
+ (system-async-mark aproc)))))
+ (sleep 2)
+ (system-async-mark aproc)
+ (join-thread other-thread)))
+ #t))
;;
;; thread cancellation
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
new file mode 100644
index 0000000..18b67d6
--- /dev/null
+++ b/test-suite/tests/tree-il.test
@@ -0,0 +1,467 @@
+;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
+;;;; Andy Wingo <address@hidden> --- May 2009
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-suite tree-il)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system base pmatch)
+ #:use-module (language tree-il)
+ #:use-module (language glil))
+
+;; Of course, the GLIL that is emitted depends on the source info of the
+;; input. Here we're not concerned about that, so we strip source
+;; information from the incoming tree-il.
+
+(define (strip-source x)
+ (post-order! (lambda (x) (set! (tree-il-src x) #f))
+ x))
+
+(define-syntax assert-scheme->glil
+ (syntax-rules ()
+ ((_ in out)
+ (let ((tree-il (strip-source
+ (compile 'in #:from 'scheme #:to 'tree-il))))
+ (pass-if 'in
+ (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to
'glil))
+ 'out))))))
+
+(define-syntax assert-tree-il->glil
+ (syntax-rules ()
+ ((_ in out)
+ (pass-if 'in
+ (let ((tree-il (strip-source (parse-tree-il 'in))))
+ (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to
'glil))
+ 'out))))))
+
+(define-syntax assert-tree-il->glil/pmatch
+ (syntax-rules ()
+ ((_ in pat test ...)
+ (let ((exp 'in))
+ (pass-if 'in
+ (let ((glil (unparse-glil
+ (compile (strip-source (parse-tree-il exp))
+ #:from 'tree-il #:to 'glil))))
+ (pmatch glil
+ (pat (guard test ...) #t)
+ (else #f))))))))
+
+(with-test-prefix "void"
+ (assert-tree-il->glil
+ (void)
+ (program 0 0 0 0 () (void) (call return 1)))
+ (assert-tree-il->glil
+ (begin (void) (const 1))
+ (program 0 0 0 0 () (const 1) (call return 1)))
+ (assert-tree-il->glil
+ (apply (primitive +) (void) (const 1))
+ (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
+
+(with-test-prefix "application"
+ (assert-tree-il->glil
+ (apply (toplevel foo) (const 1))
+ (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
+ (assert-tree-il->glil/pmatch
+ (begin (apply (toplevel foo) (const 1)) (void))
+ (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+ (call drop 1) (branch br ,l2)
+ (label ,l3) (mv-bind () #f) (unbind)
+ (label ,l4)
+ (void) (call return 1))
+ (and (eq? l1 l3) (eq? l2 l4)))
+ (assert-tree-il->glil
+ (apply (toplevel foo) (apply (toplevel bar)))
+ (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
+ (call goto/args 1))))
+
+(with-test-prefix "conditional"
+ (assert-tree-il->glil/pmatch
+ (if (const #t) (const 1) (const 2))
+ (program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (const 1) (call return 1)
+ (label ,l2) (const 2) (call return 1))
+ (eq? l1 l2))
+
+ (assert-tree-il->glil/pmatch
+ (begin (if (const #t) (const 1) (const 2)) (const #f))
+ (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
+ (label ,l3) (label ,l4) (const #f) (call return 1))
+ (eq? l1 l3) (eq? l2 l4))
+
+ (assert-tree-il->glil/pmatch
+ (apply (primitive null?) (if (const #t) (const 1) (const 2)))
+ (program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
+ (const 1) (branch br ,l2)
+ (label ,l3) (const 2) (label ,l4)
+ (call null? 1) (call return 1))
+ (eq? l1 l3) (eq? l2 l4)))
+
+(with-test-prefix "primitive-ref"
+ (assert-tree-il->glil
+ (primitive +)
+ (program 0 0 0 0 () (toplevel ref +) (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (primitive +) (const #f))
+ (program 0 0 0 0 () (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (primitive +))
+ (program 0 0 0 0 () (toplevel ref +) (call null? 1)
+ (call return 1))))
+
+(with-test-prefix "lexical refs"
+ (assert-tree-il->glil
+ (let (x) (y) ((const 1)) (lexical x y))
+ (program 0 0 1 0 ()
+ (const 1) (bind (x local 0)) (local set 0)
+ (local ref 0) (call return 1)
+ (unbind)))
+
+ (assert-tree-il->glil
+ (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
+ (program 0 0 1 0 ()
+ (const 1) (bind (x local 0)) (local set 0)
+ (const #f) (call return 1)
+ (unbind)))
+
+ (assert-tree-il->glil
+ (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
+ (program 0 0 1 0 ()
+ (const 1) (bind (x local 0)) (local set 0)
+ (local ref 0) (call null? 1) (call return 1)
+ (unbind))))
+
+(with-test-prefix "lexical sets"
+ (assert-tree-il->glil
+ (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
+ (program 0 0 0 1 ()
+ (const 1) (bind (x external 0)) (external set 0 0)
+ (const 2) (external set 0 0) (void) (call return 1)
+ (unbind)))
+
+ (assert-tree-il->glil
+ (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
+ (program 0 0 0 1 ()
+ (const 1) (bind (x external 0)) (external set 0 0)
+ (const 2) (external set 0 0) (const #f) (call return 1)
+ (unbind)))
+
+ (assert-tree-il->glil
+ (let (x) (y) ((const 1))
+ (apply (primitive null?) (set! (lexical x y) (const 2))))
+ (program 0 0 0 1 ()
+ (const 1) (bind (x external 0)) (external set 0 0)
+ (const 2) (external set 0 0) (void) (call null? 1) (call return 1)
+ (unbind))))
+
+(with-test-prefix "module refs"
+ (assert-tree-il->glil
+ (@ (foo) bar)
+ (program 0 0 0 0 ()
+ (module public ref (foo) bar)
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (@ (foo) bar) (const #f))
+ (program 0 0 0 0 ()
+ (module public ref (foo) bar) (call drop 1)
+ (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (@ (foo) bar))
+ (program 0 0 0 0 ()
+ (module public ref (foo) bar)
+ (call null? 1) (call return 1)))
+
+ (assert-tree-il->glil
+ (@@ (foo) bar)
+ (program 0 0 0 0 ()
+ (module private ref (foo) bar)
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (@@ (foo) bar) (const #f))
+ (program 0 0 0 0 ()
+ (module private ref (foo) bar) (call drop 1)
+ (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (@@ (foo) bar))
+ (program 0 0 0 0 ()
+ (module private ref (foo) bar)
+ (call null? 1) (call return 1))))
+
+(with-test-prefix "module sets"
+ (assert-tree-il->glil
+ (set! (@ (foo) bar) (const 2))
+ (program 0 0 0 0 ()
+ (const 2) (module public set (foo) bar)
+ (void) (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (set! (@ (foo) bar) (const 2)) (const #f))
+ (program 0 0 0 0 ()
+ (const 2) (module public set (foo) bar)
+ (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
+ (program 0 0 0 0 ()
+ (const 2) (module public set (foo) bar)
+ (void) (call null? 1) (call return 1)))
+
+ (assert-tree-il->glil
+ (set! (@@ (foo) bar) (const 2))
+ (program 0 0 0 0 ()
+ (const 2) (module private set (foo) bar)
+ (void) (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (set! (@@ (foo) bar) (const 2)) (const #f))
+ (program 0 0 0 0 ()
+ (const 2) (module private set (foo) bar)
+ (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
+ (program 0 0 0 0 ()
+ (const 2) (module private set (foo) bar)
+ (void) (call null? 1) (call return 1))))
+
+(with-test-prefix "toplevel refs"
+ (assert-tree-il->glil
+ (toplevel bar)
+ (program 0 0 0 0 ()
+ (toplevel ref bar)
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (toplevel bar) (const #f))
+ (program 0 0 0 0 ()
+ (toplevel ref bar) (call drop 1)
+ (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (toplevel bar))
+ (program 0 0 0 0 ()
+ (toplevel ref bar)
+ (call null? 1) (call return 1))))
+
+(with-test-prefix "toplevel sets"
+ (assert-tree-il->glil
+ (set! (toplevel bar) (const 2))
+ (program 0 0 0 0 ()
+ (const 2) (toplevel set bar)
+ (void) (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (set! (toplevel bar) (const 2)) (const #f))
+ (program 0 0 0 0 ()
+ (const 2) (toplevel set bar)
+ (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (set! (toplevel bar) (const 2)))
+ (program 0 0 0 0 ()
+ (const 2) (toplevel set bar)
+ (void) (call null? 1) (call return 1))))
+
+(with-test-prefix "toplevel defines"
+ (assert-tree-il->glil
+ (define bar (const 2))
+ (program 0 0 0 0 ()
+ (const 2) (toplevel define bar)
+ (void) (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (define bar (const 2)) (const #f))
+ (program 0 0 0 0 ()
+ (const 2) (toplevel define bar)
+ (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (define bar (const 2)))
+ (program 0 0 0 0 ()
+ (const 2) (toplevel define bar)
+ (void) (call null? 1) (call return 1))))
+
+(with-test-prefix "constants"
+ (assert-tree-il->glil
+ (const 2)
+ (program 0 0 0 0 ()
+ (const 2) (call return 1)))
+
+ (assert-tree-il->glil
+ (begin (const 2) (const #f))
+ (program 0 0 0 0 ()
+ (const #f) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (const 2))
+ (program 0 0 0 0 ()
+ (const 2) (call null? 1) (call return 1))))
+
+(with-test-prefix "lambda"
+ (assert-tree-il->glil
+ (lambda (x) (y) () (const 2))
+ (program 0 0 0 0 ()
+ (program 1 0 0 0 ()
+ (bind (x local 0))
+ (const 2) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda (x x1) (y y1) () (const 2))
+ (program 0 0 0 0 ()
+ (program 2 0 0 0 ()
+ (bind (x local 0) (x1 local 1))
+ (const 2) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda x y () (const 2))
+ (program 0 0 0 0 ()
+ (program 1 1 0 0 ()
+ (bind (x local 0))
+ (const 2) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda (x . x1) (y . y1) () (const 2))
+ (program 0 0 0 0 ()
+ (program 2 1 0 0 ()
+ (bind (x local 0) (x1 local 1))
+ (const 2) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda (x . x1) (y . y1) () (lexical x y))
+ (program 0 0 0 0 ()
+ (program 2 1 0 0 ()
+ (bind (x local 0) (x1 local 1))
+ (local ref 0) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda (x . x1) (y . y1) () (lexical x1 y1))
+ (program 0 0 0 0 ()
+ (program 2 1 0 0 ()
+ (bind (x local 0) (x1 local 1))
+ (local ref 1) (call return 1))
+ (call return 1)))
+
+ (assert-tree-il->glil
+ (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
+ (program 0 0 0 0 ()
+ (program 1 0 0 1 ()
+ (bind (x external 0))
+ (local ref 0) (external set 0 0)
+ (program 1 0 0 0 ()
+ (bind (y local 0))
+ (external ref 1 0) (call return 1))
+ (call return 1))
+ (call return 1))))
+
+(with-test-prefix "sequence"
+ (assert-tree-il->glil
+ (begin (begin (const 2) (const #f)) (const #t))
+ (program 0 0 0 0 ()
+ (const #t) (call return 1)))
+
+ (assert-tree-il->glil
+ (apply (primitive null?) (begin (const #f) (const 2)))
+ (program 0 0 0 0 ()
+ (const 2) (call null? 1) (call return 1))))
+
+;; FIXME: binding info for or-hacked locals might bork the disassembler,
+;; and could be tightened in any case
+(with-test-prefix "the or hack"
+ (assert-tree-il->glil/pmatch
+ (let (x) (y) ((const 1))
+ (if (lexical x y)
+ (lexical x y)
+ (let (a) (b) ((const 2))
+ (lexical a b))))
+ (program 0 0 1 0 ()
+ (const 1) (bind (x local 0)) (local set 0)
+ (local ref 0) (branch br-if-not ,l1)
+ (local ref 0) (call return 1)
+ (label ,l2)
+ (const 2) (bind (a local 0)) (local set 0)
+ (local ref 0) (call return 1)
+ (unbind)
+ (unbind))
+ (eq? l1 l2))
+
+ (assert-tree-il->glil/pmatch
+ (let (x) (y) ((const 1))
+ (if (lexical x y)
+ (lexical x y)
+ (let (a) (b) ((const 2))
+ (lexical x y))))
+ (program 0 0 2 0 ()
+ (const 1) (bind (x local 0)) (local set 0)
+ (local ref 0) (branch br-if-not ,l1)
+ (local ref 0) (call return 1)
+ (label ,l2)
+ (const 2) (bind (a local 1)) (local set 1)
+ (local ref 0) (call return 1)
+ (unbind)
+ (unbind))
+ (eq? l1 l2)))
+
+(with-test-prefix "apply"
+ (assert-tree-il->glil
+ (apply (primitive @apply) (toplevel foo) (toplevel bar))
+ (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply
2)))
+ (assert-tree-il->glil/pmatch
+ (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
+ (program 0 0 0 0 ()
+ (toplevel ref apply) (toplevel ref foo) (toplevel ref bar)
(mv-call 2 ,l1)
+ (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+ (label ,l4)
+ (void) (call return 1))
+ (and (eq? l1 l3) (eq? l2 l4)))
+ (assert-tree-il->glil
+ (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel
baz)))
+ (program 0 0 0 0 ()
+ (toplevel ref foo)
+ (toplevel ref bar) (toplevel ref baz) (call apply 2)
+ (call goto/args 1))))
+
+(with-test-prefix "call/cc"
+ (assert-tree-il->glil
+ (apply (primitive @call-with-current-continuation) (toplevel foo))
+ (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
+ (assert-tree-il->glil/pmatch
+ (begin (apply (primitive @call-with-current-continuation) (toplevel foo))
(void))
+ (program 0 0 0 0 ()
+ (toplevel ref call-with-current-continuation) (toplevel ref foo)
(mv-call 1 ,l1)
+ (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+ (label ,l4)
+ (void) (call return 1))
+ (and (eq? l1 l3) (eq? l2 l4)))
+ (assert-tree-il->glil
+ (apply (toplevel foo)
+ (apply (toplevel @call-with-current-continuation) (toplevel bar)))
+ (program 0 0 0 0 ()
+ (toplevel ref foo)
+ (toplevel ref bar) (call call/cc 1)
+ (call goto/args 1))))
+
diff --git a/testsuite/t-match.scm b/testsuite/t-match.scm
index 4b85f30..ed56ae7 100644
--- a/testsuite/t-match.scm
+++ b/testsuite/t-match.scm
@@ -12,7 +12,7 @@
(define (matches? obj)
; (format #t "matches? ~a~%" obj)
(match obj
- (($ stuff) => #t)
+ (($ stuff) #t)
; (blurps #t)
("hello" #t)
(else #f)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. 938d46a35d39ec5d7b5fa858a8783136ce24d10d,
Andy Wingo <=