|
| From: | Chris K. Jester-Young |
| Subject: | [Guile-commits] GNU Guile branch, srfi-41, updated. v2.0.6-2-g6bced51 |
| Date: | Tue, 11 Sep 2012 05:13:33 +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=6bced51e2a8338ef3e634d4e96d48735e77db0fb
The branch, srfi-41 has been updated
via 6bced51e2a8338ef3e634d4e96d48735e77db0fb (commit)
via 1321a36ed61deb9431b41768dc92cb7230c9afa1 (commit)
via d7a33b64598fb1869832fae7220b1e23811ab567 (commit)
via 5e3f05fcd2dbb8692a2857d615c77f9d9f2cfac5 (commit)
via 7e0ee59c601388e89d3d51ff9986290955ea9945 (commit)
via ad4eb036dc02de47615dcbb392eb29109c916eaf (commit)
via 015b7087957c56f9d3322f0dfb1b8bbb4df35299 (commit)
via 407d13dddc2ecd5fef317520529f3ddff28a9213 (commit)
via 235c280489cea3cc1272f9c9b0f6966791274712 (commit)
via 005de2e8273853e155c21767b1c8bdb4f3f3ca53 (commit)
via 32299e49e83b941082bee348c993630bb455a324 (commit)
via 64ead01db7d5110e94be5d6d984aaa8ead4e5e8c (commit)
via 312e79f8d5bc5a70fccb0dc8b13260acf688493b (commit)
via 8210c8538a6efb48d8adaf402546f30a8b249bcb (commit)
via 5f8d67ad09d21263d1ea2d537afcc5464d922dc5 (commit)
via 581bd72a7d8346d32d02379d64b3012fdd6eef31 (commit)
via 2921f537609547e7c9ee0df555a840407313eabd (commit)
via 0bb1353a6b618f1b355da13b6b7c3b56b201a2dc (commit)
via 66b1dbf649c82e34aa6d62a982cae3218419d160 (commit)
via d192791373b79e905eb02f9c0b01413051a7b2f8 (commit)
via 5d312f3c2c5db3a7677a9c8ec4306feabce8445f (commit)
via 24dd9f6fe1449fa4de81d95ca659283c15e16931 (commit)
via ded42750d65cf976b8ff2874fcca5de91b2526cb (commit)
via 826ce16e29822ed062b7f97a9b2ab3c589134b7c (commit)
via e1fb0e811bb1ca867a297d81fd82dd60f750bc19 (commit)
via 5e33d0aa37ec4de6414dad032ab1ca4fbc5ff583 (commit)
via 3fabb2d2be8379ba61d0b4ab742c0a1e63638b69 (commit)
via 81e7210f1427d5209357cbcb241e22ce278dd73e (commit)
via 274e2eecf18a726280802230ab50774fa11e1107 (commit)
via d540a1d648d9f7532e3e870b48184fa2b7949f9a (commit)
via fc835b1b14a38f61150557ab531de51f98239739 (commit)
via 5558cdaa302aba6ba493612fbea1fdac09db7d96 (commit)
via fc30e14ffe550cfb088cf9f8b388b276663f6297 (commit)
via baeb727bcfcf8aa0c2061c2d8ebb788eaa6d4c90 (commit)
via eca586b489e5c2d07e86114d4b76da81289cec75 (commit)
via 3b6e61982466d2a4b5cc7de6c83c4a553ffab72c (commit)
via 13e3d3d95dcb6c9cb4b3d69129d6b5fd9ad2e65a (commit)
via b8a5606b1018578f5fd887e30adc9d6dd1160137 (commit)
via 997ed30070b0c6559abf6dc748a27ae286179dd4 (commit)
via 37081d5d4b2d5093a339ee33f94d9e47deb1c346 (commit)
via 3d2bcd2c350384ffaf96b79fa6096c9d77ea113e (commit)
via c0cfa9ef07aad3afef822d1afe1786eb655bd121 (commit)
via 21b83fb7953fd2b5e40ca9206a0a72ec3cb2489e (commit)
via 8898f43cb2044df4f0c1125028f472b47df20828 (commit)
via e1c80e6b30eb665c74276af377b3861e91a32594 (commit)
via 467be245cbd8992b69c53b9fafeb2828fe816a0b (commit)
via d2e3579363c5f4c3ddc0eb993fad03eeac055491 (commit)
via d0491c9a160006e4b8e4cda8ef23f5ac4558c77e (commit)
via b5f262593344bbf053fb81123d37549d8b5df142 (commit)
via 98aa6f5bde9e7e12bff7e98d6c5eaffa9ebe007c (commit)
via a8215aedad433a15abf87c2310a41c684dfcef97 (commit)
via bfdbea1f204f4c382a4b399469ca7dcc6cfacb28 (commit)
via 162d9025f8ab7a6abc24dfab735c432a155b7c69 (commit)
via e862ae1cebe006f0bac967c016f259c13d314387 (commit)
via 6922d92f966a593e01dded92020a132ab15a71f6 (commit)
via bd5dea489bd02caa503ba57e1b799c90fa409fe9 (commit)
via 2874f66017b7bfae256e85af84689d00ecc418ab (commit)
via 5cfa385db721222069aa5a74421cbac6e6cee26a (commit)
via 4d1ae112792cb8faaa1f42b5c7332e9de05001ee (commit)
via 378daa5fa51f1d193f7236c2691acba59e9af539 (commit)
via 03fcf93bff9f02a3d12ab86be4e67b996310aad4 (commit)
via ecb48dccbac6b8fdd969f50a23351ef7f4b91ce5 (commit)
via 2cb363622d03b18402d6ee15c8c87d8fee9bfc32 (commit)
via f3b312a19d70293d7a3407fc4ef479183edd7cca (commit)
via 6b5e918e4f3cf011713e699c6af1c4e364bfae36 (commit)
via e80494083aa3e9dc40a7ae5da12f0e90db550889 (commit)
via 0a3ac81a1c1017d3c71e9eac8f0dd3407563632b (commit)
via 27ea5c3f31cd353b71e4691211082e8a8e36e730 (commit)
via d3a1a74cb8764cf1f60e3d0eb0b5369cb05cf6b3 (commit)
via 9f6e3f5a997f484548bd03e7e7573c38a95c8d09 (commit)
via b22e94db7c91d7661204e33f3bc2bfead002c9b7 (commit)
via 478848cb706b23bcc4c2afe9a4ad33c595bc33f6 (commit)
via 1a6ff60da8d824230e186a8c8bef8c21b23ae377 (commit)
via 2de74cb56e3af44ce624638facfa061603d39c0d (commit)
via 3f48638c8c82d7839b75204e475af691fcd67c33 (commit)
via 62e15979b5d773dda79c4f44c07e919b5d0f6e18 (commit)
via 15bb587f45b718f08756993fec9274212cc7df58 (commit)
via 6ccc66789695b5a09ce9b16c8c121f521df296e6 (commit)
via 95e4ab26653ef76d78f7e5d4efae4dfca366b409 (commit)
via 20e2d6380426088c21d0c7bd8211f2bee780a26c (commit)
via 2ae7b7b6c3e049aaba43c884d5c1d0c5f741cd16 (commit)
via 4eaf64cd462ef7730e17299e60f578100ff9c032 (commit)
via 63216d80def079922016fc9084c0ee57af3af383 (commit)
via 83bd53abb697dd9597f3b78e13e74344b0b676e6 (commit)
via 86e4479abb89d26840d6ba3afe9df611fbeb4b98 (commit)
via dc1ee62046c130c6b26a96ca862663406ecbc7b1 (commit)
via 9b1750ed4250c6ad3bcf764b4d2bdeec6ca2c79e (commit)
via f49fd9afd698706bd7ff474412b7db0586ad0a56 (commit)
via 1fb39dc55fd55476a0e7be6d483f705d9bf8fead (commit)
via 3742d778fbc6ea879437c19aeebe09179dceffdf (commit)
via 8a74ffe88a445220f9399cc49d4808baf51651c2 (commit)
via 2c5f0bdb0e4d59c8a49925f75dd4793c19ebe08a (commit)
via 4c98474782d11ad02046c87af148e29d14afbc29 (commit)
via da874e5415f2d9438e66b9989086465b6cbf578c (commit)
via 7aa43cde6a73dedfb47e29cb0da495626bff6862 (commit)
via 67b699cc77d5e2f74daca77aa26b1ba8af0d0808 (commit)
via 33672b071118f54ee637afa00349f2a4404a84da (commit)
via e8b21eecb11d261eeecbc7a14fa7f7c16e819a3d (commit)
via 0eba699d12f638c624efcdc2b617b0aa9099ee1f (commit)
via 520850ad2768dbc0fe16254b90a52b16bfad1f14 (commit)
via be52f329b68e5427c25247d0d97d8dfef79e7820 (commit)
via 4cec6c221aef72825a05963c95eb633af9a43fcf (commit)
via ff4d3672757fec3c8509e26bc60abf95f9e8f51a (commit)
via 5bbd632fc36b14f59d51e4ba2d8e189fd3cc0f76 (commit)
via 7be3c2fcbfe2335d069a5c13b0ddf74b69383c46 (commit)
via 82171a2ea4d81d1dd2f71142ed6021ab383d836b (commit)
via e9c898bf24c2faf86d3d2f61361bc52ff3abc8b2 (commit)
via b662b7e971423934b897f925ccc3061fc640e996 (commit)
via 53bdfcf03418c4709127140d64f12ede970c174b (commit)
via 7dbc03498a763ca6a45e26aabfa74e8c317b55bf (commit)
via c15defef7f1de408f35066d2f2883c110724b2f9 (commit)
via 4bd53c1ba39ba1c2d51ff895104f27cf4bb69e4e (commit)
via 985702f7131e11c7c13aa75db19d10525c34fecd (commit)
via f6a554a6aa0832432cec9c9c18b99fad56008997 (commit)
via 299ce911f986c7f9a6a4887ca3b72e5748e126f7 (commit)
via 73001b06f60206edfa4ae4ec6a8b5c8f65d272c2 (commit)
via 3db8f60977e966522e3c05cc554c99382c968b55 (commit)
via 036c366dc2fbbeeb04d8984bb0819df28d9d455f (commit)
via b3f25e62695315ab632d2e3a66d31bb490c82100 (commit)
via f7d8efc630ce45f5d82aae5b2682d261e5541d5f (commit)
via 9068f4f52772397c5d4408f585ccdf1017869a3e (commit)
via f66cbb99ee096186837536885d3436bb334df34d (commit)
via 1cd63115be7a25d0ea18aaa0e1eff5658d8db77a (commit)
via a36e7870c31322fd300c7478df24dbf559a0d67b (commit)
via da9b2b71f76644abcc2eec2cc1478379df1e9025 (commit)
via de1eb420a5a95b17e85b19c4d98c869036e9ecb0 (commit)
via 5deea34d0eb3d2ec5db421eb79516e747eed5841 (commit)
via 7e822b32d2a165a027fd1de4d59fdfae568599bf (commit)
via b064d565141ca777778fa38e0fe98c0aed834eb9 (commit)
via d10f7b572c0ca1ccef87f9c46069daa30946e0cf (commit)
via 7a4188c4492736f7afd7304a01eaebc3474ccdee (commit)
via 398446c7428b3d98d168fcc3ff170829d3e09f9a (commit)
via fd07759b7d4c9d631090b04855ab81b6a2109e9e (commit)
via d8fe367a31d15ea64c43c80c4e4819ef393696ef (commit)
via 0f6dd25023da59bcfefb080c66a2d2650d955ffa (commit)
via 5ef102cc93a4f2eba0f5dad94a7306085b353000 (commit)
via bbb9f000ad52282ee1a0518b65437baf20c3d17c (commit)
via 51853eee69ca5811ae0661eb91868121c6ad1d74 (commit)
via e26da7a24e79cf3a9d3052e78228a9dfed3c4f3d (commit)
via 2c1b79513b7b5826db48b6e5e1d7f4dc7731d13b (commit)
via a8004dcb4d7148ec66cbaa109a18715d757700eb (commit)
via da03005a2a362847db2ac7e876cd9e31b20f9c73 (commit)
via 1be6c7d34d7e1e40e78c8983bd8b40b3fbf7d01c (commit)
via 47153f29b02cee6324aec523cfa44b48e1cb29b9 (commit)
via c05805a4ea764dec5a0559edefcdfb9761191d07 (commit)
via 89d45e850725e232ae685803ee476da5b046c2b0 (commit)
via 02360ed6050833d5436ea4f1b9b4f10f3783491b (commit)
via 9adbf27f4e0656f489c8c9fa941da023ee4201ec (commit)
via f740445a9b5bf0a5e5090f0a2ddaffb2b803bab7 (commit)
via 75ba64d6797f5857cc9885eb753126119a8c8b68 (commit)
via 7b327550e20967b0a8f89182bcf9a04543db3a0f (commit)
via c46fee438cf9f4a3449e8d04e7a54805517fd092 (commit)
via 42d691ee16c7f6fd102d93f9e76d436f14198f2c (commit)
via 46163e52e5513cf882dafe2bbd05ffbd2b03a755 (commit)
via be79627c21ba0848af3ac7bea25293170fec6480 (commit)
via da35d2eaa9dbc1d3cf098c9a1c9bc62dcb2515bd (commit)
via 3658a3744bcc7c75db24143db1dae1bd13554515 (commit)
via 1fa0fde4955e39891142eb5d09bb195b37409937 (commit)
via 1a4d765381904a3b8afeec1a6d0f746626a49967 (commit)
via 07bc8e7c339fb43664e17a6e016702bc13760a14 (commit)
via 3fafc52afbfc9ef398946a7ec4d96d01adc02aa1 (commit)
via 1948b38d8818d2154f4f9292adfc53537a843126 (commit)
via 1af6d2a717f499564fbbc297c79e00ac14b0dcf9 (commit)
via 72ee0ef71b9a0514874976cdcf3ea9d5333db4b1 (commit)
via 8c43b28a1136aba186fd211b0f6037cf0c35f006 (commit)
via 9120f130a8ccd237d31806f381a1a1a25f5d930a (commit)
via dab48cc567f931b275ad647db1e47135b63c6675 (commit)
via eebcacf41c4fe58ad8c9388d516a99f59212b223 (commit)
via 542aa859dede56545538fd90e6ee5b2abe3f5f25 (commit)
via 20337139d20d0587ebf78c05a7efa6db2337d2e6 (commit)
via e082b13b662309021c73bae1561fb5c6d191d258 (commit)
via ef405f8ba73fc57706d7155a2e008352416debcf (commit)
via d316047326fde9d63ca52c0051fbf09124ef297e (commit)
via a850c3ccc4bebe07dba2298c5ed0bc86bb64f172 (commit)
via 006163e02febaf5569bd42b362957a99c01c4528 (commit)
via a2e946f1ef83cd1fd8c87412cc49f6c6d1e0ac61 (commit)
from faaedb406d42d9793caf0b1ff2959ba7945652ca (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 6bced51e2a8338ef3e634d4e96d48735e77db0fb
Merge: faaedb4 1321a36
Author: Chris K. Jester-Young <address@hidden>
Date: Tue Sep 11 01:12:03 2012 -0400
Merge tag 'v2.0.6' into srfi-41
GNU Guile 2.0.6.
-----------------------------------------------------------------------
Summary of changes:
.gitignore | 2 +
GNUmakefile | 14 +-
GUILE-VERSION | 6 +-
Makefile.am | 18 +-
NEWS | 175 +
THANKS | 4 +
acinclude.m4 | 39 -
benchmark-guile.in | 1 +
benchmark-suite/Makefile.am | 3 +-
benchmark-suite/{ => benchmark-suite}/lib.scm | 442 +-
benchmark-suite/benchmarks/arithmetic.bm | 14 +-
benchmark-suite/benchmarks/ports.bm | 84 +-
benchmark-suite/benchmarks/r6rs-arithmetic.bm | 8 +-
benchmark-suite/benchmarks/read.bm | 15 +-
build-aux/announce-gen | 54 +-
build-aux/config.rpath | 2 +-
build-aux/git-version-gen | 22 +-
build-aux/gitlog-to-changelog | 44 +-
build-aux/gnu-web-doc-update | 89 +-
build-aux/gnupload | 30 +-
build-aux/snippet/_Noreturn.h | 2 +-
check-guile.in | 1 +
configure.ac | 17 +-
doc/ref/api-compound.texi | 18 +-
doc/ref/api-control.texi | 21 +-
doc/ref/api-data.texi | 10 -
doc/ref/api-foreign.texi | 16 +
doc/ref/api-io.texi | 15 +
doc/ref/api-modules.texi | 11 +
doc/ref/api-procedures.texi | 9 +-
doc/ref/api-utility.texi | 9 +-
doc/ref/vm.texi | 7 -
doc/ref/web.texi | 81 +-
gnulib-local/build-aux/git-version-gen.diff | 62 +
gnulib-local/lib/localcharset.c.diff | 6 +-
gnulib-local/m4/canonicalize.m4.diff | 67 +
gnulib-local/m4/clock_time.m4.diff | 28 +
lib/Makefile.am | 209 +-
lib/alignof.h | 3 +-
lib/alloca.in.h | 13 +-
lib/arpa_inet.in.h | 3 +-
lib/asnprintf.c | 3 +-
lib/binary-io.h | 41 +-
lib/c-ctype.c | 3 +-
lib/c-ctype.h | 3 +-
lib/c-strcase.h | 3 +-
lib/c-strcasecmp.c | 3 +-
lib/c-strncasecmp.c | 3 +-
lib/canonicalize-lgpl.c | 23 +-
lib/ceil.c | 6 +
lib/config.charset | 5 +-
lib/dirent.in.h | 9 +
lib/errno.in.h | 51 +-
lib/fcntl.in.h | 4 +
lib/float+.h | 3 +-
lib/floor.c | 6 +
lib/fstat.c | 6 +
lib/gai_strerror.c | 3 +-
lib/getaddrinfo.c | 3 +-
lib/gettext.h | 3 +-
lib/iconv.c | 3 +-
lib/iconv.in.h | 3 +-
lib/iconv_close.c | 3 +-
lib/iconv_open.c | 5 +-
lib/inet_ntop.c | 3 +-
lib/isinf.c | 3 +-
lib/langinfo.in.h | 3 +-
lib/localcharset.c | 5 +-
lib/localcharset.h | 3 +-
lib/locale.in.h | 107 +-
lib/localeconv.c | 103 +
lib/{btowc.c => log.c} | 33 +-
lib/log1p.c | 518 +
lib/malloc.c | 3 +-
lib/malloca.c | 9 +-
lib/malloca.h | 3 +-
lib/math.in.h | 969 +-
lib/mbrtowc.c | 22 +-
lib/msvc-inval.c | 3 +-
lib/msvc-inval.h | 3 +-
lib/msvc-nothrow.c | 3 +-
lib/msvc-nothrow.h | 3 +-
lib/netdb.in.h | 3 +-
lib/netinet_in.in.h | 3 +-
lib/nproc.c | 9 +-
lib/nproc.h | 3 +-
lib/pathmax.h | 3 +-
lib/pipe2.c | 3 +-
lib/printf-args.c | 3 +-
lib/printf-args.h | 3 +-
lib/printf-parse.c | 5 +-
lib/printf-parse.h | 3 +-
lib/ref-add.sin | 3 +-
lib/ref-del.sin | 3 +-
lib/regcomp.c | 169 +-
lib/regex.c | 17 +-
lib/regex.h | 179 +-
lib/regex_internal.c | 61 +-
lib/regex_internal.h | 43 +-
lib/regexec.c | 72 +-
lib/round.c | 174 +
lib/safe-read.h | 2 +-
lib/safe-write.h | 2 +-
lib/signal.in.h | 12 +-
lib/size_max.h | 3 +-
lib/snprintf.c | 3 +-
lib/stat.c | 15 +
lib/stdalign.in.h | 3 +-
lib/stdbool.in.h | 3 +-
lib/stddef.in.h | 3 +-
lib/stdint.in.h | 65 +-
lib/stdio.in.h | 33 +-
lib/stdlib.in.h | 16 +-
lib/strcasecmp.c | 63 -
lib/streq.h | 8 +-
lib/strftime.c | 2 +-
lib/string.in.h | 26 +-
lib/strings.in.h | 123 -
lib/strncasecmp.c | 63 -
lib/sys_file.in.h | 3 +-
lib/sys_socket.in.h | 5 +-
lib/sys_stat.in.h | 63 +-
lib/sys_time.in.h | 17 +-
lib/sys_types.in.h | 15 +-
lib/sys_uio.in.h | 3 +-
lib/time.in.h | 3 +-
lib/time_r.c | 3 +-
lib/trunc.c | 6 +
lib/unistd.in.h | 23 +-
lib/unistr.in.h | 174 +-
lib/unitypes.in.h | 22 +-
lib/vasnprintf.c | 9 +-
lib/vasnprintf.h | 3 +-
lib/vsnprintf.c | 3 +-
lib/w32sock.h | 4 +-
lib/wchar.in.h | 70 +-
lib/wctype.in.h | 3 +-
lib/xsize.h | 3 +-
libguile.h | 3 +-
libguile/Makefile.am | 9 +-
libguile/__scm.h | 61 +-
libguile/_scm.h | 5 +
libguile/bdw-gc.h | 8 +-
libguile/bytevectors.c | 71 +-
libguile/deprecated.c | 205 +-
libguile/deprecated.h | 29 +
libguile/deprecation.c | 6 -
libguile/eval.h | 6 +-
libguile/expand.c | 27 +-
libguile/filesys.c | 58 +-
libguile/finalizers.c | 182 +
libguile/{debug-malloc.h => finalizers.h} | 30 +-
libguile/foreign.c | 31 +-
libguile/fports.c | 27 +-
libguile/frames.c | 28 +-
libguile/gc.c | 14 +-
libguile/gc.h | 108 +
libguile/gdbint.c | 5 +-
libguile/gen-scmconfig.c | 19 +-
libguile/goops.c | 12 +-
libguile/guardians.c | 11 +-
libguile/hashtab.c | 6 +-
libguile/ieee-754.h | 90 -
libguile/init.c | 6 +-
libguile/inline.c | 7 +-
libguile/inline.h | 216 +-
libguile/macros.c | 6 +-
libguile/modules.c | 204 +-
libguile/modules.h | 21 +-
libguile/numbers.c | 10 +-
libguile/ports.c | 195 +-
libguile/ports.h | 16 +-
libguile/posix.c | 208 +
libguile/print.c | 21 +-
libguile/procprop.c | 12 +-
libguile/read.c | 142 +-
libguile/smob.c | 430 +-
libguile/smob.h | 173 +-
libguile/sort.c | 11 +-
libguile/srfi-13.c | 11 +-
libguile/stacks.c | 3 +-
libguile/strings.c | 97 +-
libguile/strports.c | 36 +-
libguile/struct.c | 29 +-
libguile/struct.h | 3 +-
libguile/threads.c | 3 +
libguile/values.c | 29 +-
libguile/values.h | 6 +-
libguile/vectors.c | 15 +-
libguile/vm-engine.c | 252 +-
libguile/vm-engine.h | 41 +-
libguile/vm-i-loader.c | 9 +-
libguile/vm-i-scheme.c | 26 +-
libguile/vm-i-system.c | 293 +-
libguile/vm.c | 295 +-
libguile/vports.c | 20 +-
libguile/weaks.c | 17 +-
m4/canonicalize.m4 | 53 +-
m4/ceil.m4 | 11 +-
m4/check-math-lib.m4 | 5 +-
m4/clock_time.m4 | 38 +
m4/errno_h.m4 | 11 +-
m4/exponentd.m4 | 5 +-
m4/extensions.m4 | 4 +-
m4/floor.m4 | 11 +-
m4/fpieee.m4 | 6 +-
m4/frexp.m4 | 4 +-
m4/fstat.m4 | 19 +-
m4/gnulib-cache.m4 | 3 +-
m4/gnulib-common.m4 | 7 +-
m4/gnulib-comp.m4 | 57 +-
m4/largefile.m4 | 45 +
m4/locale-fr.m4 | 18 +-
m4/locale-ja.m4 | 8 +-
m4/locale-zh.m4 | 8 +-
m4/locale_h.m4 | 48 +-
m4/localeconv.m4 | 22 +
m4/log.m4 | 107 +
m4/log1p.m4 | 94 +
m4/lstat.m4 | 33 +-
m4/malloc.m4 | 40 +-
m4/math_h.m4 | 247 +-
m4/mathfunc.m4 | 4 +-
m4/mmap-anon.m4 | 12 +-
m4/multiarch.m4 | 4 +-
m4/nocrash.m4 | 4 +-
m4/off_t.m4 | 18 +
m4/printf.m4 | 29 +-
m4/putenv.m4 | 20 +-
m4/readlink.m4 | 30 +-
m4/regex.m4 | 5 +-
m4/rename.m4 | 94 +-
m4/rmdir.m4 | 20 +-
m4/round.m4 | 142 +
m4/setenv.m4 | 38 +-
m4/stat.m4 | 15 +-
m4/stdalign.m4 | 16 +-
m4/stdio_h.m4 | 12 +-
m4/strcase.m4 | 45 -
m4/strings_h.m4 | 52 -
m4/sys_stat_h.m4 | 15 +-
m4/sys_time_h.m4 | 36 +-
m4/sys_types_h.m4 | 5 +-
m4/time_h.m4 | 4 +-
m4/time_r.m4 | 2 +-
m4/trunc.m4 | 11 +-
m4/unistd_h.m4 | 6 +-
m4/vasnprintf.m4 | 6 +-
m4/visibility.m4 | 4 +-
m4/warn-on-use.m4 | 6 +-
m4/warnings.m4 | 58 +-
m4/wctype_h.m4 | 14 +-
maint.mk | 100 +-
meta/Makefile.am | 11 +-
meta/uninstalled-env.in | 12 +-
module/Makefile.am | 10 +-
module/ice-9/boot-9.scm | 98 +-
module/ice-9/command-line.scm | 2 +-
module/ice-9/compile-psyntax.scm | 80 +-
module/ice-9/deprecated.scm | 19 +-
module/ice-9/eval.scm | 9 +-
module/ice-9/ftw.scm | 19 +-
module/ice-9/match.scm | 4 +-
module/ice-9/match.upstream.scm | 4 +-
module/ice-9/popen.scm | 101 +-
module/ice-9/pretty-print.scm | 23 +-
module/ice-9/psyntax-pp.scm |29720 +++---------------------
module/ice-9/psyntax.scm | 92 +-
module/ice-9/r4rs.scm | 4 +-
module/ice-9/r6rs-libraries.scm | 2 +-
module/ice-9/session.scm | 22 +-
module/ice-9/vlist.scm | 377 +-
module/language/ecmascript/base.scm | 6 +-
module/language/ecmascript/compile-tree-il.scm | 27 +-
module/language/glil/compile-assembly.scm | 1 +
module/language/scheme/decompile-tree-il.scm | 795 +-
module/language/tree-il.scm | 224 +-
module/language/tree-il/analyze.scm | 45 +-
module/language/tree-il/canonicalize.scm | 10 +-
module/language/tree-il/cse.scm | 578 +
module/language/tree-il/effects.scm | 376 +
module/language/tree-il/fix-letrec.scm | 56 +-
module/language/tree-il/optimize.scm | 16 +-
module/language/tree-il/peval.scm | 357 +-
module/language/tree-il/primitives.scm | 178 +-
module/oop/goops/dispatch.scm | 16 +-
module/oop/goops/util.scm | 21 +-
module/srfi/srfi-35.scm | 16 +-
module/srfi/srfi-4.scm | 6 +-
module/srfi/srfi-4/gnu.scm | 5 +-
module/srfi/srfi-6.scm | 18 +-
module/srfi/srfi-9.scm | 12 +-
module/system/base/pmatch.scm | 16 +-
module/system/repl/command.scm | 7 +-
module/system/vm/frame.scm | 21 +-
module/texinfo.scm | 62 +-
module/texinfo/docbook.scm | 12 +-
module/texinfo/serialize.scm | 17 +-
module/web/http.scm | 172 +-
module/web/request.scm | 13 +-
module/web/response.scm | 18 +-
module/web/server/http.scm | 16 +-
module/web/uri.scm | 20 +-
test-suite/Makefile.am | 6 +-
test-suite/standalone/test-conversion.c | 69 +
test-suite/{ => test-suite}/lib.scm | 57 +-
test-suite/tests/asm-to-bytecode.test | 2 +-
test-suite/tests/brainfuck.test | 2 +-
test-suite/tests/bytevectors.test | 30 +-
test-suite/tests/compiler.test | 4 +-
test-suite/tests/coverage.test | 12 +-
test-suite/tests/cse.test | 295 +
test-suite/tests/foreign.test | 24 +
test-suite/tests/ftw.test | 17 +-
test-suite/tests/gc.test | 2 +-
test-suite/tests/match.test | 4 +-
test-suite/tests/peval.test | 1078 +
test-suite/tests/ports.test | 135 +-
test-suite/tests/r6rs-ports.test | 11 +-
test-suite/tests/rnrs-libraries.test | 16 +-
test-suite/tests/rnrs-test-a.scm | 4 +-
test-suite/tests/session.test | 73 +-
test-suite/tests/srfi-18.test | 863 +-
test-suite/tests/srfi-4.test | 25 +
test-suite/tests/srfi-6.test | 26 +-
test-suite/tests/srfi-9.test | 11 +-
test-suite/tests/sxml.match.test | 4 +-
test-suite/tests/syncase.test | 16 +-
test-suite/tests/texinfo.test | 20 +-
test-suite/tests/tree-il.test | 984 +-
test-suite/tests/web-http.test | 20 +
test-suite/tests/web-response.test | 24 +
test-suite/tests/web-uri.test | 60 +-
333 files changed, 15832 insertions(+), 32754 deletions(-)
rename benchmark-suite/{ => benchmark-suite}/lib.scm (51%)
create mode 100644 gnulib-local/build-aux/git-version-gen.diff
create mode 100644 gnulib-local/m4/canonicalize.m4.diff
create mode 100644 gnulib-local/m4/clock_time.m4.diff
create mode 100644 lib/localeconv.c
copy lib/{btowc.c => log.c} (63%)
create mode 100644 lib/log1p.c
create mode 100644 lib/round.c
delete mode 100644 lib/strcasecmp.c
delete mode 100644 lib/strings.in.h
delete mode 100644 lib/strncasecmp.c
create mode 100644 libguile/finalizers.c
copy libguile/{debug-malloc.h => finalizers.h} (55%)
delete mode 100644 libguile/ieee-754.h
create mode 100644 m4/clock_time.m4
create mode 100644 m4/localeconv.m4
create mode 100644 m4/log.m4
create mode 100644 m4/log1p.m4
create mode 100644 m4/off_t.m4
create mode 100644 m4/round.m4
delete mode 100644 m4/strcase.m4
delete mode 100644 m4/strings_h.m4
create mode 100644 module/language/tree-il/cse.scm
create mode 100644 module/language/tree-il/effects.scm
rename test-suite/{ => test-suite}/lib.scm (95%)
create mode 100644 test-suite/tests/cse.test
create mode 100644 test-suite/tests/peval.test
diff --git a/.gitignore b/.gitignore
index f13d753..4ff958e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -148,3 +148,5 @@ INSTALL
/lib/signal.h
/lib/sys/types.h
/lib/dirent.h
+/lib/langinfo.h
+/lib/wctype.h
diff --git a/GNUmakefile b/GNUmakefile
index d0fd3e8..58f2ead 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -20,20 +20,10 @@
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
-# Systems where /bin/sh is not the default shell need this. The $(shell)
-# command below won't work with e.g. stock DOS/Windows shells.
-ifeq ($(wildcard /bin/s[h]),/bin/sh)
-SHELL = /bin/sh
-else
-# will be used only with the next shell-test line, then overwritten
-# by a configured-in value
-SHELL = sh
-endif
-
# If the user runs GNU make but has not yet run ./configure,
# give them a diagnostic.
-_have-Makefile := $(shell test -f Makefile && echo yes)
-ifeq ($(_have-Makefile),yes)
+_gl-Makefile := $(wildcard [M]akefile)
+ifneq ($(_gl-Makefile),)
# Make tar archive easier to reproduce.
export TAR_OPTIONS = --owner=0 --group=0 --numeric-owner
diff --git a/GUILE-VERSION b/GUILE-VERSION
index 2d73c5b..b31fa72 100644
--- a/GUILE-VERSION
+++ b/GUILE-VERSION
@@ -3,7 +3,7 @@
# Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'.
GUILE_MAJOR_VERSION=2
GUILE_MINOR_VERSION=0
-GUILE_MICRO_VERSION=5
+GUILE_MICRO_VERSION=6
GUILE_EFFECTIVE_VERSION=2.0
@@ -18,7 +18,7 @@ GUILE_EFFECTIVE_VERSION=2.0
# See libtool info pages for more information on how and when to
# change these.
-LIBGUILE_INTERFACE_CURRENT=26
+LIBGUILE_INTERFACE_CURRENT=27
LIBGUILE_INTERFACE_REVISION=0
-LIBGUILE_INTERFACE_AGE=4
+LIBGUILE_INTERFACE_AGE=5
LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}"
diff --git a/Makefile.am b/Makefile.am
index c62950a..446bb3c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,7 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007,
-## 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+## 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -42,12 +42,16 @@ SUBDIRS = \
libguileincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION)
libguileinclude_HEADERS = libguile.h
-EXTRA_DIST = LICENSE HACKING GUILE-VERSION \
- m4/ChangeLog-2008 \
- ChangeLog-2008 \
- .version \
- gnulib-local/lib/localcharset.h.diff \
- gnulib-local/lib/localcharset.c.diff
+EXTRA_DIST = LICENSE HACKING GUILE-VERSION \
+ m4/ChangeLog-2008 \
+ m4/gnulib-cache.m4 \
+ ChangeLog-2008 \
+ .version \
+ gnulib-local/lib/localcharset.h.diff \
+ gnulib-local/lib/localcharset.c.diff \
+ gnulib-local/m4/clock_time.m4.diff \
+ gnulib-local/m4/canonicalize.m4.diff \
+ gnulib-local/build-aux/git-version-gen.diff
TESTS = check-guile
TESTS_ENVIRONMENT = @LOCALCHARSET_TESTS_ENVIRONMENT@
diff --git a/NEWS b/NEWS
index c1589a1..64d374d 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,181 @@ See the end for copying conditions.
Please send Guile bug reports to address@hidden
+Changes in 2.0.6 (since 2.0.5):
+
+* Notable changes
+
+** New optimization pass: common subexpression elimination (CSE)
+
+Guile's optimizer will now run a CSE pass after partial evaluation.
+This pass propagates static information about branches taken, bound
+lexicals, and effects from an expression's dominators. It can replace
+common subexpressions with their boolean values (potentially enabling
+dead code elimination), equivalent bound lexicals, or it can elide them
+entirely, depending on the context in which they are executed. This
+pass is especially useful in removing duplicate type checks, such as
+those produced by SRFI-9 record accessors.
+
+** Improvements to the partial evaluator
+
+Peval can now hoist tests that are common to both branches of a
+conditional into the test. This can help with long chains of
+conditionals, such as those generated by the `match' macro. Peval can
+now do simple beta-reductions of procedures with rest arguments. It
+also avoids residualizing degenerate lexical aliases, even when full
+inlining is not possible. Finally, peval now uses the effects analysis
+introduced for the CSE pass. More precise effects analysis allows peval
+to move more code.
+
+** Run finalizers asynchronously in asyncs
+
+Finalizers are now run asynchronously, via an async. See Asyncs in the
+manual. This allows Guile and user code to safely allocate memory while
+holding a mutex.
+
+** Update SRFI-14 character sets to Unicode 6.1
+
+Note that this update causes the Latin-1 characters `§' and `¶' to be
+reclassified as punctuation. They were previously considered to be part
+of `char-set:symbol'.
+
+** Better source information for datums
+
+When the `positions' reader option is on, as it is by default, Guile's
+reader will record source information for more kinds of datums.
+
+** Improved error and warning messages
+
+`syntax-violation' errors now prefer `subform' for source info, with
+`form' as fallback. Syntactic errors in `cond' and `case' now produce
+better errors. `case' can now warn on duplicate datums, or datums that
+cannot be usefully compared with `eqv?'. `-Warity-mismatch' now handles
+applicable structs. `-Wformat' is more robust in the presence of
+`gettext'. Finally, various exceptions thrown by the Web modules now
+define appropriate exception printers.
+
+** A few important bug fixes in the HTTP modules.
+
+Guile's web server framework now checks if an application returns a body
+where it is not permitted, for example in response to a HEAD request,
+and warn or truncate the response as appropriate. Bad requests now
+cause a 400 Bad Request response to be printed before closing the port.
+Finally, some date-printing and URL-parsing bugs were fixed.
+
+** Pretty-print improvements
+
+When Guile needs to pretty-print Tree-IL, it will try to reconstruct
+`cond', `or`, and other derived syntax forms from the primitive tree-IL
+forms. It also uses the original names instead of the fresh unique
+names, when it is unambiguous to do so. This can be seen in the output
+of REPL commands like `,optimize'.
+
+Also, the `pretty-print' procedure has a new keyword argument,
+`#:max-expr-width'.
+
+** Fix memory leak involving applicable SMOBs
+
+At some point in the 1.9.x series, Guile began leaking any applicable
+SMOB that was actually applied. (There was a weak-key map from SMOB to
+trampoline functions, where the value had a strong reference on the
+key.) This has been fixed. There was much rejoicing!
+
+** Support for HTTP/1.1 chunked transfer coding
+
+See "Transfer Codings" in the manual, for more.
+
+** Micro-optimizations
+
+A pile of micro-optimizations: the `string-trim' function when called
+with `char-set:whitespace'; the `(web http)' parsers; SMOB application;
+conversion of raw UTF-8 and UTF-32 data to and from SCM strings; vlists
+and vhashes; `read' when processing string literals.
+
+** Incompatible change to `scandir'
+
+As was the original intention, `scandir' now runs the `select?'
+procedure on all items, including subdirectories and the `.' and `..'
+entries. It receives the basename of the file in question instead of
+the full name. We apologize for this incompatible change to this
+function introduced in the 2.0.4 release.
+
+* Manual updates
+
+The manual has been made much more consistent in its naming conventions
+with regards to formal parameters of functions. Thanks to Bake Timmons.
+
+* New interfaces
+
+** New C function: `scm_to_pointer'
+** New C inline functions: `scm_new_smob', `scm_new_double_smob'
+** (ice-9 format): Add ~h specifier for localized number output.
+** (web response): New procedure: `response-must-not-include-body?'
+** New predicate: 'supports-source-properties?'
+** New C helpers: `scm_c_values', `scm_c_nvalues'
+** Newly public inline C function: `scm_unget_byte'
+** (language tree-il): New functions: `tree-il=?', `tree-il-hash'
+** New fluid: `%default-port-conversion-strategy'
+** New syntax: `=>' within `case'
+** (web http): `make-chunked-input-port', `make-chunked-output-port'
+** (web http): `declare-opaque-header!'
+
+Search the manual for these identifiers, for more information.
+
+* New deprecations
+
+** `close-io-port' deprecated
+
+Use `close-port'.
+
+** `scm_sym2var' deprecated
+
+In most cases, replace with `scm_lookup' or `scm_module_variable'. Use
+`scm_define' or `scm_module_ensure_local_variable' if the second
+argument is nonzero. See "Accessing Modules from C" in the manual, for
+full details.
+
+** Lookup closures deprecated
+
+These were never documented. See "Module System Reflection" in the
+manual for replacements.
+
+* Build fixes
+
+** Fix compilation against uninstalled Guile on non-GNU platforms.
+** Fix `SCM_I_ERROR' definition for MinGW without networking.
+** Fix compilation with the Sun C compiler.
+** Fix check for `clock_gettime' on OpenBSD and some other systems.
+** Fix build with --enable-debug-malloc.
+** Honor $(program_transform_name) for the `guile-tools' symlink.
+** Fix cross-compilation of GOOPS-using code.
+
+* Bug fixes
+
+** Fix use of unitialized stat buffer in search-path of absolute paths.
+** Avoid calling `freelocale' with a NULL argument.
+** Work around erroneous tr_TR locale in Darwin 8 in tests.
+** Fix `getaddrinfo' test for Darwin 8.
+** Use Gnulib's `regex' module for better regex portability.
+** `source-properties' and friends work on any object
+** Rewrite open-process in C, for robustness related to threads and fork
+** Fix <TAG>vector-length when applied to other uniform vector types
+** Fix escape-only prompt optimization (was disabled previously)
+** Fix a segfault when /dev/urandom is not accessible
+** Fix flush on soft ports, so that it actually runs.
+** Better compatibility of SRFI-9 records with core records
+** Fix and clarify documentation of `sorted?'.
+** Fix IEEE-754 endianness conversion in bytevectors.
+** Correct thunk check in the `wind' instruction.
+** Add @acronym support to texinfo modules
+** Fix docbook->texi for <ulink> without URL
+** Fix `setvbuf' to leave the line/column number unchanged.
+** Add missing public declaration for `scm_take_from_input_buffers'.
+** Fix relative file name canonicalization with empty %LOAD-PATH entries.
+** Import newer (ice-9 match) from Chibi-Scheme.
+** Fix unbound variables and unbound values in ECMAScript runtime.
+** Make SRFI-6 string ports Unicode-capable.
+
+
Changes in 2.0.5 (since 2.0.4):
This release fixes the binary interface information (SONAME) of
diff --git a/THANKS b/THANKS
index a06ba4a..a3d15de 100644
--- a/THANKS
+++ b/THANKS
@@ -60,6 +60,7 @@ For fixes or providing information which led to a fix:
Clinton Ebadi
David Fang
Barry Fishman
+ Kevin J. Fletcher
Charles Gagnon
Fu-gangqiang
Aidan Gauland
@@ -88,6 +89,7 @@ For fixes or providing information which led to a fix:
Peter Ivanyi
Wolfgang Jaehrling
Aubrey Jaffer
+ David Jaquay
Paul Jarc
Steve Juranich
Richard Kim
@@ -101,6 +103,7 @@ For fixes or providing information which led to a fix:
Daniel Llorens del RÃo
Jeff Long
Marco Maggi
+ Bogdan A. Marinescu
Gregory Marton
Kjetil S. Matheussen
Antoine Mathys
@@ -140,6 +143,7 @@ For fixes or providing information which led to a fix:
Daniel Skarda
Dale Smith
Cesar Strauss
+ Klaus Stehle
Rainer Tammer
Richard Todd
Issac Trotts
diff --git a/acinclude.m4 b/acinclude.m4
index 0edd4b8..8ef6e99 100644
--- a/acinclude.m4
+++ b/acinclude.m4
@@ -583,42 +583,3 @@ AC_DEFUN([GUILE_CHECK_GUILE_FOR_BUILD], [
dnl Declare file $1 to be a script that needs configuring,
dnl and arrange to make it executable in the process.
AC_DEFUN([GUILE_CONFIG_SCRIPT],[AC_CONFIG_FILES([$1],[chmod +x $1])])
-
-
-dnl Copyright (C) 2002-2006, 2009-2011 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.
-
-# Check for clock_gettime and clock_settime, and set LIB_CLOCK_GETTIME.
-# For a program named, say foo, you should add a line like the following
-# in the corresponding Makefile.am file:
-# foo_LDADD = $(LDADD) $(LIB_CLOCK_GETTIME)
-
-AC_DEFUN([gl_CLOCK_TIME],
-[
- dnl Persuade glibc and Solaris <time.h> to declare these functions.
- AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
-
- # Solaris 2.5.1 needs -lposix4 to get the clock_gettime function.
- # Solaris 7 prefers the library name -lrt to the obsolescent name -lposix4.
-
- # Save and restore LIBS so e.g., -lrt, isn't added to it. Otherwise, *all*
- # programs in the package would end up linked with that potentially-shared
- # library, inducing unnecessary run-time overhead.
- LIB_CLOCK_GETTIME=
- AC_SUBST([LIB_CLOCK_GETTIME])
- gl_saved_libs=$LIBS
- AC_SEARCH_LIBS([clock_gettime], [rt posix4],
- [if test "$ac_cv_search_clock_gettime" = "none required";
then
- AC_SEARCH_LIBS([clock_getcpuclockid], [rt posix4],
- [test "$ac_cv_search_clock_getcpuclockid"
= "none required" \
- ||
LIB_CLOCK_GETTIME=$ac_cv_search_clock_getcpuclockid],
- [test "$ac_cv_search_clock_gettime" =
"none required" \
- ||
LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime])
- else
- LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime
- fi])
- AC_CHECK_FUNCS([clock_gettime clock_settime clock_getcpuclockid])
- LIBS=$gl_saved_libs
-])
diff --git a/benchmark-guile.in b/benchmark-guile.in
index 572e008..8378e9d 100644
--- a/benchmark-guile.in
+++ b/benchmark-guile.in
@@ -41,6 +41,7 @@ if [ ! -f guile-procedures.txt ] ; then
fi
exec $guile \
+ -L "$BENCHMARK_SUITE_DIR" \
-e main -s "$BENCHMARK_SUITE_DIR/guile-benchmark" \
--benchmark-suite "$BENCHMARK_SUITE_DIR/benchmarks" \
--log-file benchmark-guile.log "$@"
diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am
index f29743f..9fa5568 100644
--- a/benchmark-suite/Makefile.am
+++ b/benchmark-suite/Makefile.am
@@ -18,5 +18,6 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/write.bm \
benchmarks/strings.bm
-EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \
+EXTRA_DIST = guile-benchmark benchmark-suite/lib.scm \
+ $(SCM_BENCHMARKS) \
ChangeLog-2008
diff --git a/benchmark-suite/lib.scm b/benchmark-suite/benchmark-suite/lib.scm
similarity index 51%
rename from benchmark-suite/lib.scm
rename to benchmark-suite/benchmark-suite/lib.scm
index 4ba0e3e..ae57cc0 100644
--- a/benchmark-suite/lib.scm
+++ b/benchmark-suite/benchmark-suite/lib.scm
@@ -1,5 +1,5 @@
;;;; benchmark-suite/lib.scm --- generic support for benchmarking
-;;;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2002, 2006, 2011, 2012 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
@@ -17,31 +17,33 @@
;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (benchmark-suite lib)
- :export (
-
- ;; Controlling the execution.
- iteration-factor
- scale-iterations
-
- ;; Running benchmarks.
- run-benchmark
- benchmark
-
- ;; Naming groups of benchmarks in a regular fashion.
- with-benchmark-prefix with-benchmark-prefix* current-benchmark-prefix
- format-benchmark-name
-
- ;; Computing timing results
- benchmark-time-base
- benchmark-total-time benchmark-user-time benchmark-system-time
- benchmark-frame-time benchmark-core-time
- benchmark-user-time\interpreter benchmark-core-time\interpreter
-
- ;; Reporting results in various ways.
- register-reporter unregister-reporter reporter-registered?
- make-log-reporter
- full-reporter
- user-reporter))
+ #:use-module (srfi srfi-9)
+ #:export (;; Controlling the execution.
+ iteration-factor
+ scale-iterations
+
+ ;; Running benchmarks.
+ run-benchmark
+ benchmark
+
+ ;; Naming groups of benchmarks in a regular fashion.
+ with-benchmark-prefix with-benchmark-prefix*
+ current-benchmark-prefix format-benchmark-name
+
+ ;; <benchmark-result> accessors
+ benchmark-result:name
+ benchmark-result:iterations
+ benchmark-result:real-time
+ benchmark-result:run-time
+ benchmark-result:gc-time
+ benchmark-result:core-time
+
+ ;; Reporting results in various ways.
+ report current-reporter
+ register-reporter unregister-reporter reporter-registered?
+ make-log-reporter
+ full-reporter
+ user-reporter))
;;;; If you're using Emacs's Scheme mode:
@@ -214,81 +216,71 @@
;;;; TIME CALCULATION
;;;;
-;;;; The library uses the guile functions (times) and (gc-run-time) to
-;;;; determine the execution time for a single benchmark. Based on these
-;;;; functions, the values of BEFORE, AFTER and GC-TIME are computed, which
-;;;; are then passed to the reporter functions. All three values BEFORE,
-;;;; AFTER and GC-TIME include the time needed to executed the benchmark code
-;;;; itself, but also the surrounding code that implements the loop to run the
-;;;; benchmark code for the given number of times. This is undesirable, since
-;;;; one would prefer to only get the timing data for the benchmarking code.
+;;;; The library uses the guile functions `get-internal-run-time',
+;;;; `get-internal-real-time', and `gc-run-time' to determine the
+;;;; execution time for a single benchmark. Based on these functions,
+;;;; Guile makes a <benchmark-result>, a record containing the elapsed
+;;;; run time, real time, gc time, and possibly other metrics. These
+;;;; times include the time needed to executed the benchmark code
+;;;; itself, but also the surrounding code that implements the loop to
+;;;; run the benchmark code for the given number of times. This is
+;;;; undesirable, since one would prefer to only get the timing data for
+;;;; the benchmarking code.
;;;;
;;;; To cope with this, the benchmarking framework uses a trick: During
-;;;; initialization of the library, the time for executing an empty benchmark
-;;;; is measured and stored. This is an estimate for the time needed by the
-;;;; benchmarking framework itself. For later benchmarks, this time can then
-;;;; be subtracted from the measured execution times.
-;;;;
-;;;; In order to simplify the time calculation for users who want to write
-;;;; their own reporters, benchmarking framework provides the following
-;;;; definitions:
-;;;;
-;;;; benchmark-time-base : This variable holds the number of time units that
-;;;; make up a second. By deviding the results of each of the functions
-;;;; below by this value, you get the corresponding time in seconds. For
-;;;; example (/ (benchmark-total-time before after) benchmark-time-base)
-;;;; will give you the total time in seconds.
-;;;; benchmark-total-time : this function takes two arguments BEFORE and AFTER
-;;;; and computes the total time between the two timestamps. The result
-;;;; of this function is what the time command of the unix command line
-;;;; would report as real time.
-;;;; benchmark-user-time : this function takes two arguments BEFORE and AFTER
-;;;; and computes the time spent in the benchmarking process between the
-;;;; two timestamps. That means, the time consumed by other processes
-;;;; running on the same machine is not part of the resulting time,
-;;;; neither is time spent within the operating system. The result of
-;;;; this function is what the time command of the unix command line would
-;;;; report as user time.
-;;;; benchmark-system-time : similar to benchmark-user-time, but here the time
-;;;; spent within the operating system is given. The result of this
-;;;; function is what the time command of the unix command line would
-;;;; report as system time.
-;;;; benchmark-frame-time : this function takes the argument ITERATIONS. It
-;;;; reports the part of the user time that is consumed by the
-;;;; benchmarking framework itself to run some benchmark for the given
-;;;; number of iterations. You can think of this as the time that would
-;;;; still be consumed, even if the benchmarking code itself was empty.
-;;;; This value does not include any time for garbage collection, even if
-;;;; it is the benchmarking framework which is responsible for causing a
-;;;; garbage collection.
-;;;; benchmark-core-time : this function takes three arguments ITERATIONS,
-;;;; BEFORE and AFTER. It reports the part of the user time that is
-;;;; actually spent within the benchmarking code. That is, the time
-;;;; needed for the benchmarking framework is subtracted from the user
-;;;; time. This value, however, includes all garbage collection times,
-;;;; even if some part of the gc-time had actually to be attributed to the
-;;;; benchmarking framework.
-;;;; benchmark-user-time\interpreter : this function takes three arguments
-;;;; BEFORE AFTER and GC-TIME. It reports the part of the user time that
-;;;; is spent in the interpreter (and not in garbage collection).
-;;;; benchmark-core-time\interpreter : this function takes four arguments
-;;;; ITERATIONS, BEFORE, AFTER. and GC-TIME. It reports the part of the
-;;;; benchmark-core-time that is spent in the interpreter (and not in
-;;;; garbage collection). This value is most probably the one you are
-;;;; interested in, except if you are doing some garbage collection
-;;;; checks.
-;;;;
-;;;; There is no function to calculate the garbage-collection time, since the
-;;;; garbage collection time is already passed as an argument GC-TIME to the
-;;;; reporter functions.
+;;;; initialization of the library, the time for executing an empty
+;;;; benchmark is measured and stored. This is an estimate for the time
+;;;; needed by the benchmarking framework itself. For later benchmarks,
+;;;; this time can then be subtracted from the measured execution times.
+;;;; Note that for very short benchmarks, this may result in a negative
+;;;; number.
+;;;;
+;;;; The benchmarking framework provides the following accessors for
+;;;; <benchmark-result> values. Note that all time values are in
+;;;; internal time units; divide by internal-time-units-per-second to
+;;;; get seconds.
+;;;;
+;;;; benchmark-result:name : Return the name of the benchmark.
+;;;;
+;;;; benchmark-result:iterations : Return the number of iterations that
+;;;; this benchmark ran for.
+;;;;
+;;;; benchmark-result:real-time : Return the clock time elapsed while
+;;;; this benchmark executed.
+;;;;
+;;;; benchmark-result:run-time : Return the CPU time elapsed while this
+;;;; benchmark executed, both in user and kernel space.
+;;;;
+;;;; benchmark-result:gc-time : Return the approximate amount of time
+;;;; spent in garbage collection while this benchmark executed, both
+;;;; in user and kernel space.
+;;;;
+;;;; benchmark-result:core-time : Like benchmark-result:run-time, but
+;;;; also estimates the time spent by the framework for the number
+;;;; of iterations, and subtracts off that time from the result.
+;;;;
+
+;;;; This module is used when benchmarking different Guiles, and so it
+;;;; should run on all the Guiles of interest. Currently this set
+;;;; includes Guile 1.8, so be careful with introducing features that
+;;;; only Guile 2.0 supports.
;;;; MISCELLANEOUS
;;;;
+(define-record-type <benchmark-result>
+ (make-benchmark-result name iterations real-time run-time gc-time)
+ benchmark-result?
+ (name benchmark-result:name)
+ (iterations benchmark-result:iterations)
+ (real-time benchmark-result:real-time)
+ (run-time benchmark-result:run-time)
+ (gc-time benchmark-result:gc-time))
+
;;; Perform a division and convert the result to inexact.
-(define (i/ a b)
- (exact->inexact (/ a b)))
+(define (->seconds time)
+ (/ time 1.0 internal-time-units-per-second))
;;; Scale the number of iterations according to the given scaling factor.
(define iteration-factor 1)
@@ -296,36 +288,49 @@
(let* ((i (inexact->exact (round (* iterations iteration-factor)))))
(if (< i 1) 1 i)))
+;;; Parameters.
+(cond-expand
+ (srfi-39 #t)
+ (else (use-modules (srfi srfi-39))))
;;;; CORE FUNCTIONS
;;;;
;;; The central routine for executing benchmarks.
;;; The idea is taken from Greg, the GNUstep regression test environment.
-(define run-benchmark #f)
-(let ((benchmark-running #f))
- (define (local-run-benchmark name iterations thunk)
- (if benchmark-running
- (error "Nested calls to run-benchmark are not permitted.")
- (let ((benchmark-name (full-name name))
- (iterations (scale-iterations iterations)))
- (set! benchmark-running #t)
- (let ((before #f) (after #f) (gc-time #f))
- (gc)
- (set! gc-time (gc-run-time))
- (set! before (times))
- (do ((i 0 (+ i 1)))
- ((= i iterations))
- (thunk))
- (set! after (times))
- (set! gc-time (- (gc-run-time) gc-time))
- (report benchmark-name iterations before after gc-time))
- (set! benchmark-running #f))))
- (set! run-benchmark local-run-benchmark))
+(define benchmark-running? (make-parameter #f))
+(define (run-benchmark name iterations thunk)
+ (if (benchmark-running?)
+ (error "Nested calls to run-benchmark are not permitted."))
+ (if (not (and (integer? iterations) (exact? iterations)))
+ (error "Expected exact integral number of iterations"))
+ (parameterize ((benchmark-running? #t))
+ ;; Warm up the benchmark first. This will resolve any toplevel-ref
+ ;; forms.
+ (thunk)
+ (gc)
+ (let* ((before-gc-time (gc-run-time))
+ (before-real-time (get-internal-real-time))
+ (before-run-time (get-internal-run-time)))
+ (do ((i iterations (1- i)))
+ ((zero? i))
+ (thunk))
+ (let ((after-run-time (get-internal-run-time))
+ (after-real-time (get-internal-real-time))
+ (after-gc-time (gc-run-time)))
+ (report (make-benchmark-result (full-name name) iterations
+ (- after-real-time before-real-time)
+ (- after-run-time before-run-time)
+ (- after-gc-time before-gc-time)))))))
;;; A short form for benchmarks.
-(defmacro benchmark (name iterations body . rest)
- `(run-benchmark ,name ,iterations (lambda () ,body ,@rest)))
+(cond-expand
+ (guile-2
+ (define-syntax-rule (benchmark name iterations body body* ...)
+ (run-benchmark name iterations (lambda () body body* ...))))
+ (else
+ (defmacro benchmark (name iterations body . rest)
+ `(run-benchmark ,name ,iterations (lambda () ,body ,@rest)))))
;;;; BENCHMARK NAMES
@@ -333,31 +338,21 @@
;;;; Turn a benchmark name into a nice human-readable string.
(define (format-benchmark-name name)
- (call-with-output-string
- (lambda (port)
- (let loop ((name name)
- (separator ""))
- (if (pair? name)
- (begin
- (display separator port)
- (display (car name) port)
- (loop (cdr name) ": ")))))))
+ (string-join name ": "))
;;;; For a given benchmark-name, deliver the full name including all prefixes.
(define (full-name name)
(append (current-benchmark-prefix) (list name)))
-;;; A fluid containing the current benchmark prefix, as a list.
-(define prefix-fluid (make-fluid '()))
-(define (current-benchmark-prefix)
- (fluid-ref prefix-fluid))
+;;; A parameter containing the current benchmark prefix, as a list.
+(define current-benchmark-prefix
+ (make-parameter '()))
;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
;;; The name prefix is only changed within the dynamic scope of the
;;; call to with-benchmark-prefix*. Return the value returned by THUNK.
(define (with-benchmark-prefix* prefix thunk)
- (with-fluids ((prefix-fluid
- (append (fluid-ref prefix-fluid) (list prefix))))
+ (parameterize ((current-benchmark-prefix (full-name prefix)))
(thunk)))
;;; (with-benchmark-prefix PREFIX BODY ...)
@@ -365,77 +360,58 @@
;;; The name prefix is only changed within the dynamic scope of the
;;; with-benchmark-prefix expression. Return the value returned by the last
;;; BODY expression.
-(defmacro with-benchmark-prefix (prefix . body)
- `(with-benchmark-prefix* ,prefix (lambda () ,@body)))
+(cond-expand
+ (guile-2
+ (define-syntax-rule (with-benchmark-prefix prefix body body* ...)
+ (with-benchmark-prefix* prefix (lambda () body body* ...))))
+ (else
+ (defmacro with-benchmark-prefix (prefix . body)
+ `(with-benchmark-prefix* ,prefix (lambda () ,@body)))))
-;;;; TIME CALCULATION
+;;;; Benchmark results
;;;;
-(define benchmark-time-base
- internal-time-units-per-second)
-
-(define time-base ;; short-cut, not exported
- benchmark-time-base)
-
-(define frame-time/iteration
+(define *calibration-result*
"<will be set during initialization>")
-(define (benchmark-total-time before after)
- (- (tms:clock after) (tms:clock before)))
-
-(define (benchmark-user-time before after)
- (- (tms:utime after) (tms:utime before)))
+(define (benchmark-overhead iterations accessor)
+ (* (/ iterations 1.0 (benchmark-result:iterations *calibration-result*))
+ (accessor *calibration-result*)))
-(define (benchmark-system-time before after)
- (- (tms:stime after) (tms:stime before)))
-
-(define (benchmark-frame-time iterations)
- (* iterations frame-time/iteration))
-
-(define (benchmark-core-time iterations before after)
- (- (benchmark-user-time before after) (benchmark-frame-time iterations)))
-
-(define (benchmark-user-time\interpreter before after gc-time)
- (- (benchmark-user-time before after) gc-time))
-
-(define (benchmark-core-time\interpreter iterations before after gc-time)
- (- (benchmark-core-time iterations before after) gc-time))
+(define (benchmark-result:core-time result)
+ (- (benchmark-result:run-time result)
+ (benchmark-overhead (benchmark-result:iterations result)
+ benchmark-result:run-time)))
;;;; REPORTERS
;;;;
-;;; The global list of reporters.
-(define reporters '())
+;;; The global set of reporters.
+(define report-hook (make-hook 1))
+
+(define (default-reporter result)
+ (if (hook-empty? report-hook)
+ (user-reporter result)
+ (run-hook report-hook result)))
-;;; The default reporter, to be used only if no others exist.
-(define default-reporter #f)
+(define current-reporter
+ (make-parameter default-reporter))
-;;; Add the procedure REPORTER to the current set of reporter functions.
-;;; Signal an error if that reporter procedure object is already registered.
(define (register-reporter reporter)
- (if (memq reporter reporters)
- (error "register-reporter: reporter already registered: " reporter))
- (set! reporters (cons reporter reporters)))
+ (add-hook! report-hook reporter))
-;;; Remove the procedure REPORTER from the current set of reporter
-;;; functions. Signal an error if REPORTER is not currently registered.
(define (unregister-reporter reporter)
- (if (memq reporter reporters)
- (set! reporters (delq! reporter reporters))
- (error "unregister-reporter: reporter not registered: " reporter)))
+ (remove-hook! report-hook reporter))
;;; Return true iff REPORTER is in the current set of reporter functions.
(define (reporter-registered? reporter)
- (if (memq reporter reporters) #t #f))
+ (if (memq reporter (hook->list report-hook)) #t #f))
;;; Send RESULT to all currently registered reporter functions.
-(define (report . args)
- (if (pair? reporters)
- (for-each (lambda (reporter) (apply reporter args))
- reporters)
- (apply default-reporter args)))
+(define (report result)
+ ((current-reporter) result))
;;;; Some useful standard reporters:
@@ -444,26 +420,22 @@
;;;; User reporters write some interesting results to the standard output.
;;; Display a single benchmark result to the given port
-(define (print-result port name iterations before after gc-time)
- (let* ((name (format-benchmark-name name))
- (total-time (benchmark-total-time before after))
- (user-time (benchmark-user-time before after))
- (system-time (benchmark-system-time before after))
- (frame-time (benchmark-frame-time iterations))
- (benchmark-time (benchmark-core-time iterations before after))
- (user-time\interpreter
- (benchmark-user-time\interpreter before after gc-time))
- (benchmark-core-time\interpreter
- (benchmark-core-time\interpreter iterations before after gc-time)))
+(define (print-result port result)
+ (let ((name (format-benchmark-name (benchmark-result:name result)))
+ (iterations (benchmark-result:iterations result))
+ (real-time (benchmark-result:real-time result))
+ (run-time (benchmark-result:run-time result))
+ (gc-time (benchmark-result:gc-time result))
+ (core-time (benchmark-result:core-time result)))
(write (list name iterations
- 'total (i/ total-time time-base)
- 'user (i/ user-time time-base)
- 'system (i/ system-time time-base)
- 'frame (i/ frame-time time-base)
- 'benchmark (i/ benchmark-time time-base)
- 'user/interp (i/ user-time\interpreter time-base)
- 'bench/interp (i/ benchmark-core-time\interpreter time-base)
- 'gc (i/ gc-time time-base))
+ 'total (->seconds real-time)
+ 'user (->seconds run-time)
+ 'system 0
+ 'frame (->seconds (- run-time core-time))
+ 'benchmark (->seconds core-time)
+ 'user/interp (->seconds (- run-time gc-time))
+ 'bench/interp (->seconds (- core-time gc-time))
+ 'gc (->seconds gc-time))
port)
(newline port)))
@@ -472,58 +444,50 @@
(define (make-log-reporter file)
(let ((port (if (output-port? file) file
(open-output-file file))))
- (lambda args
- (apply print-result port args)
+ (lambda (result)
+ (print-result port result)
(force-output port))))
;;; A reporter that reports all results to the user.
-(define (full-reporter . args)
- (apply print-result (current-output-port) args))
+(define (full-reporter result)
+ (print-result (current-output-port) result))
;;; Display interesting results of a single benchmark to the given port
-(define (print-user-result port name iterations before after gc-time)
- (let* ((name (format-benchmark-name name))
- (user-time (benchmark-user-time before after))
- (benchmark-time (benchmark-core-time iterations before after))
- (benchmark-core-time\interpreter
- (benchmark-core-time\interpreter iterations before after gc-time)))
- (write (list name iterations
- 'user (i/ user-time time-base)
- 'benchmark (i/ benchmark-time time-base)
- 'bench/interp (i/ benchmark-core-time\interpreter time-base)
- 'gc (i/ gc-time time-base))
+(define (print-user-result port result)
+ (let ((name (format-benchmark-name (benchmark-result:name result)))
+ (iterations (benchmark-result:iterations result))
+ (real-time (benchmark-result:real-time result))
+ (run-time (benchmark-result:run-time result))
+ (gc-time (benchmark-result:gc-time result))
+ (core-time (benchmark-result:core-time result)))
+ (write (list name iterations
+ 'real (->seconds real-time)
+ 'real/iteration (->seconds (/ real-time iterations))
+ 'run/iteration (->seconds (/ run-time iterations))
+ 'core/iteration (->seconds (/ core-time iterations))
+ 'gc (->seconds gc-time))
port)
(newline port)))
;;; A reporter that reports interesting results to the user.
-(define (user-reporter . args)
- (apply print-user-result (current-output-port) args))
+(define (user-reporter result)
+ (print-user-result (current-output-port) result))
;;;; Initialize the benchmarking system:
;;;;
-;;; First, display version information
-(display ";; running guile version " (current-output-port))
-(display (version) (current-output-port))
-(newline (current-output-port))
-
-;;; Second, make sure the benchmarking routines are compiled.
-(define (null-reporter . args) #t)
-(set! default-reporter null-reporter)
-(benchmark "empty initialization benchmark" 2 #t)
-
-;;; Third, initialize the system constants
-(display ";; calibrating the benchmarking framework..." (current-output-port))
-(newline (current-output-port))
-(define (initialization-reporter name iterations before after gc-time)
- (let* ((frame-time (- (tms:utime after) (tms:utime before) gc-time 3)))
- (set! frame-time/iteration (/ frame-time iterations))
- (display ";; framework time per iteration: " (current-output-port))
- (display (i/ frame-time/iteration time-base) (current-output-port))
- (newline (current-output-port))))
-(set! default-reporter initialization-reporter)
-(benchmark "empty initialization benchmark" 524288 #t)
-
-;;; Finally, set the default reporter
-(set! default-reporter user-reporter)
+(define (calibrate-benchmark-framework)
+ (display ";; running guile version ")
+ (display (version))
+ (newline)
+ (display ";; calibrating the benchmarking framework...")
+ (newline)
+ (parameterize ((current-reporter
+ (lambda (result)
+ (set! *calibration-result* result)
+ (display ";; calibration: ")
+ (print-user-result (current-output-port) result))))
+ (benchmark "empty initialization benchmark" 10000000 #t)))
+
+(calibrate-benchmark-framework)
diff --git a/benchmark-suite/benchmarks/arithmetic.bm
b/benchmark-suite/benchmarks/arithmetic.bm
index c64f6c2..e0a9bf3 100644
--- a/benchmark-suite/benchmarks/arithmetic.bm
+++ b/benchmark-suite/benchmarks/arithmetic.bm
@@ -1,7 +1,7 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;; Integer arithmetic.
;;;
-;;; Copyright 2010 Free Software Foundation, Inc.
+;;; Copyright 2010, 2012 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
@@ -48,20 +48,20 @@
(with-benchmark-prefix "fixnum"
- (benchmark "1+" 1e7
+ (benchmark "1+" #e1e7
(repeat (1+ <>) 2 100))
- (benchmark "1-" 1e7
+ (benchmark "1-" #e1e7
(repeat (1- <>) 2 100))
- (benchmark "+" 1e7
+ (benchmark "+" #e1e7
(repeat (+ 2 <>) 7 100))
- (benchmark "-" 1e7
+ (benchmark "-" #e1e7
(repeat (- 2 <>) 7 100))
- (benchmark "*" 1e7
+ (benchmark "*" #e1e7
(repeat (* 1 <>) 1 100))
- (benchmark "/" 1e7
+ (benchmark "/" #e1e7
(repeat (/ 2 <>) 1 100)))
diff --git a/benchmark-suite/benchmarks/ports.bm
b/benchmark-suite/benchmarks/ports.bm
index 166cfa5..630ece2 100644
--- a/benchmark-suite/benchmarks/ports.bm
+++ b/benchmark-suite/benchmarks/ports.bm
@@ -1,6 +1,6 @@
;;; ports.bm --- Port I/O. -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011, 2012 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
@@ -21,68 +21,72 @@
#:use-module (ice-9 rdelim)
#:use-module (benchmark-suite lib))
+(define-syntax sequence
+ (lambda (s)
+ ;; Create a sequence `(begin EXPR ...)' with COUNT occurrences of EXPR.
+ (syntax-case s ()
+ ((_ expr count)
+ (number? (syntax->datum #'count))
+ (cons #'begin
+ (make-list (syntax->datum #'count) #'expr))))))
+
+(define (large-string s)
+ (string-concatenate (make-list (* iteration-factor 10000) s)))
+
(define %latin1-port
(with-fluids ((%default-port-encoding #f))
- (open-input-string "hello, world")))
+ (open-input-string (large-string "hello, world"))))
(define %utf8/ascii-port
(with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "hello, world")))
+ (open-input-string (large-string "hello, world"))))
(define %utf8/wide-port
(with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "ìë
íì¸ì")))
+ (open-input-string (large-string "ìë
íì¸ì"))))
(with-benchmark-prefix "peek-char"
- (benchmark "latin-1 port" 700000
- (peek-char %latin1-port))
+ (benchmark "latin-1 port" 700
+ (sequence (peek-char %latin1-port) 1000))
- (benchmark "utf-8 port, ascii character" 700000
- (peek-char %utf8/ascii-port))
+ (benchmark "utf-8 port, ascii character" 700
+ (sequence (peek-char %utf8/ascii-port) 1000))
- (benchmark "utf-8 port, Korean character" 700000
- (peek-char %utf8/wide-port)))
+ (benchmark "utf-8 port, Korean character" 700
+ (sequence (peek-char %utf8/wide-port) 1000)))
-(with-benchmark-prefix "read-char"
+(with-benchmark-prefix "char-ready?"
- (benchmark "latin-1 port" 10000000
- (read-char %latin1-port))
+ (benchmark "latin-1 port" 10000
+ (sequence (char-ready? %latin1-port) 1000))
- (benchmark "utf-8 port, ascii character" 10000000
- (read-char %utf8/ascii-port))
+ (benchmark "utf-8 port, ascii character" 10000
+ (sequence (char-ready? %utf8/ascii-port) 1000))
- (benchmark "utf-8 port, Korean character" 10000000
- (read-char %utf8/wide-port)))
+ (benchmark "utf-8 port, Korean character" 10000
+ (sequence (char-ready? %utf8/wide-port) 1000)))
-(with-benchmark-prefix "char-ready?"
+;; Keep the `read-char' benchmarks last as they consume input from the
+;; ports.
+
+(with-benchmark-prefix "read-char"
- (benchmark "latin-1 port" 10000000
- (char-ready? %latin1-port))
+ (benchmark "latin-1 port" 10000
+ (sequence (read-char %latin1-port) 1000))
- (benchmark "utf-8 port, ascii character" 10000000
- (char-ready? %utf8/ascii-port))
+ (benchmark "utf-8 port, ascii character" 10000
+ (sequence (read-char %utf8/ascii-port) 1000))
- (benchmark "utf-8 port, Korean character" 10000000
- (char-ready? %utf8/wide-port)))
+ (benchmark "utf-8 port, Korean character" 10000
+ (sequence (read-char %utf8/wide-port) 1000)))
(with-benchmark-prefix "rdelim"
- (let-syntax ((sequence (lambda (s)
- ;; Create a sequence `(begin EXPR ...)' with
- ;; COUNT occurrences of EXPR.
- (syntax-case s ()
- ((_ expr count)
- (number? (syntax->datum #'count))
- (cons #'begin
- (make-list
- (syntax->datum #'count)
- #'expr)))))))
- (let ((str (string-concatenate
- (make-list 1000 "one line\n"))))
- (benchmark "read-line" 1000
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string str))))
- (sequence (read-line port) 1000))))))
+ (let ((str (string-concatenate (make-list 1000 "one line\n"))))
+ (benchmark "read-line" 1000
+ (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-input-string str))))
+ (sequence (read-line port) 1000)))))
diff --git a/benchmark-suite/benchmarks/r6rs-arithmetic.bm
b/benchmark-suite/benchmarks/r6rs-arithmetic.bm
index 4c9b8e6..309f066 100644
--- a/benchmark-suite/benchmarks/r6rs-arithmetic.bm
+++ b/benchmark-suite/benchmarks/r6rs-arithmetic.bm
@@ -1,7 +1,7 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;; R6RS-specific arithmetic benchmarks
;;;
-;;; Copyright (C) 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -24,12 +24,12 @@
(with-benchmark-prefix "fixnum"
- (benchmark "fixnum? [yes]" 1e7
+ (benchmark "fixnum? [yes]" #e1e7
(fixnum? 10000))
(let ((n (+ most-positive-fixnum 100)))
- (benchmark "fixnum? [no]" 1e7
+ (benchmark "fixnum? [no]" #e1e7
(fixnum? n)))
- (benchmark "fxxor [2]" 1e7
+ (benchmark "fxxor [2]" #e1e7
(fxxor 3 8)))
diff --git a/benchmark-suite/benchmarks/read.bm
b/benchmark-suite/benchmarks/read.bm
index e5cf7de..f0b25f5 100644
--- a/benchmark-suite/benchmarks/read.bm
+++ b/benchmark-suite/benchmarks/read.bm
@@ -1,6 +1,6 @@
;;; read.bm --- Exercise the reader. -*- Scheme -*-
;;;
-;;; Copyright (C) 2008, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2008, 2010, 2012 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
@@ -43,6 +43,11 @@
(load-file-with-reader file read buffering))
%files-to-load))
+(define small "\"hello, world!\"")
+(define large (string-append "\"" (make-string 1234 #\A) "\""))
+
+(fluid-set! %default-port-encoding "UTF-8") ; for string ports
+
(with-benchmark-prefix "read"
@@ -59,4 +64,10 @@
(exercise-read (list _IOFBF 8192)))
(benchmark "_IOFBF 16384" 10
- (exercise-read (list _IOFBF 16384))))
+ (exercise-read (list _IOFBF 16384)))
+
+ (benchmark "small strings" 100000
+ (call-with-input-string small read))
+
+ (benchmark "large strings" 100000
+ (call-with-input-string large read)))
diff --git a/build-aux/announce-gen b/build-aux/announce-gen
index 3ca90a9..ec7c22a 100755
--- a/build-aux/announce-gen
+++ b/build-aux/announce-gen
@@ -3,7 +3,7 @@ eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}'
if 0;
# Generate a release announcement message.
-my $VERSION = '2012-01-06 07:46'; # UTC
+my $VERSION = '2012-06-08 06:53'; # UTC
# The definition above must lie within the first 8 lines in order
# for the Emacs time-stamp write hook (at end) to update it.
# If you change this file with Emacs, please let the write hook
@@ -30,13 +30,15 @@ use strict;
use Getopt::Long;
use Digest::MD5;
-use Digest::SHA1;
+eval { require Digest::SHA; }
+ or eval 'use Digest::SHA1';
use POSIX qw(strftime);
(my $ME = $0) =~ s|.*/||;
my %valid_release_types = map {$_ => 1} qw (alpha beta stable);
my @archive_suffixes = ('tar.gz', 'tar.bz2', 'tar.lzma', 'tar.xz');
+my $srcdir = '.';
sub usage ($)
{
@@ -51,7 +53,7 @@ sub usage ($)
my @types = sort keys %valid_release_types;
print $STREAM <<EOF;
Usage: $ME [OPTIONS]
-Generate an announcement message.
+Generate an announcement message. Run this from builddir.
OPTIONS:
@@ -66,7 +68,9 @@ These options must be specified:
The following are optional:
- --news=NEWS_FILE
+ --news=NEWS_FILE include the NEWS section about this release
+ from this NEWS_FILE; accumulates.
+ --srcdir=DIR where to find the NEWS_FILEs (default: $srcdir)
--bootstrap-tools=TOOL_LIST a comma-separated list of tools, e.g.,
autoconf,automake,bison,gnulib
--gnulib-version=VERSION report VERSION as the gnulib version, where
@@ -102,13 +106,13 @@ sub sizes (@)
my %res;
foreach my $f (@file)
{
- my $cmd = "du --human $f";
+ my $cmd = "du -h $f";
my $t = `$cmd`;
# FIXME-someday: give a better diagnostic, a la $PROCESS_STATUS
$@
- and (warn "$ME: command failed: '$cmd'\n"), $fail = 1;
+ and (warn "command failed: '$cmd'\n"), $fail = 1;
chomp $t;
- $t =~ s/^([\d.]+[MkK]).*/${1}B/;
+ $t =~ s/^\s*([\d.]+[MkK]).*/${1}B/;
$res{$f} = $t;
}
return $fail ? undef : %res;
@@ -181,7 +185,7 @@ sub print_news_deltas ($$$)
my ($news_file, $prev_version, $curr_version) = @_;
my $news_name = $news_file;
- $news_name =~ s|^\./||;
+ $news_name =~ s|^\Q$srcdir\E/||;
print "\n$news_name\n\n";
@@ -310,7 +314,7 @@ sub print_changelog_deltas ($$)
# The exit code should be 1.
# Allow in case there are no modified ChangeLog entries.
$? == 256 || $? == 128
- or warn "$ME: warning: '$cmd' had unexpected exit code or signal ($?)\n";
+ or warn "warning: '$cmd' had unexpected exit code or signal ($?)\n";
}
sub get_tool_versions ($$)
@@ -340,7 +344,7 @@ sub get_tool_versions ($$)
{
defined $first_line
and $first_line = '';
- warn "$ME: $t: unexpected --version output\n:$first_line";
+ warn "$t: unexpected --version output\n:$first_line";
$fail = 1;
}
}
@@ -368,6 +372,15 @@ sub get_tool_versions ($$)
my $gnulib_version;
my $print_checksums_p = 1;
+ # Reformat the warnings before displaying them.
+ local $SIG{__WARN__} = sub
+ {
+ my ($msg) = @_;
+ # Warnings from GetOptions.
+ $msg =~ s/Option (\w)/option --$1/;
+ warn "$ME: $msg";
+ };
+
GetOptions
(
'mail-headers=s' => \$mail_headers,
@@ -378,6 +391,7 @@ sub get_tool_versions ($$)
'gpg-key-id=s' => \$gpg_key_id,
'url-directory=s' => address@hidden,
'news=s' => address@hidden,
+ 'srcdir=s' => \$srcdir,
'bootstrap-tools=s' => \$bootstrap_tools,
'gnulib-version=s' => \$gnulib_version,
'print-checksums!' => \$print_checksums_p,
@@ -388,32 +402,32 @@ sub get_tool_versions ($$)
) or usage 1;
my $fail = 0;
- # Ensure that sure each required option is specified.
+ # Ensure that each required option is specified.
$release_type
- or (warn "$ME: release type not specified\n"), $fail = 1;
+ or (warn "release type not specified\n"), $fail = 1;
$package_name
- or (warn "$ME: package name not specified\n"), $fail = 1;
+ or (warn "package name not specified\n"), $fail = 1;
$prev_version
- or (warn "$ME: previous version string not specified\n"), $fail = 1;
+ or (warn "previous version string not specified\n"), $fail = 1;
$curr_version
- or (warn "$ME: current version string not specified\n"), $fail = 1;
+ or (warn "current version string not specified\n"), $fail = 1;
$gpg_key_id
- or (warn "$ME: GnuPG key ID not specified\n"), $fail = 1;
+ or (warn "GnuPG key ID not specified\n"), $fail = 1;
@url_dir_list
- or (warn "$ME: URL directory name(s) not specified\n"), $fail = 1;
+ or (warn "URL directory name(s) not specified\n"), $fail = 1;
my @tool_list = split ',', $bootstrap_tools;
grep (/^gnulib$/, @tool_list) ^ defined $gnulib_version
- and (warn "$ME: when specifying gnulib as a tool, you must also specify\n"
+ and (warn "when specifying gnulib as a tool, you must also specify\n"
. "--gnulib-version=V, where V is the result of running git describe\n"
. "in the gnulib source directory.\n"), $fail = 1;
exists $valid_release_types{$release_type}
- or (warn "$ME: '$release_type': invalid release type\n"), $fail = 1;
+ or (warn "'$release_type': invalid release type\n"), $fail = 1;
@ARGV
- and (warn "$ME: too many arguments:\n", join ("\n", @ARGV), "\n"),
+ and (warn "too many arguments:\n", join ("\n", @ARGV), "\n"),
$fail = 1;
$fail
and usage 1;
diff --git a/build-aux/config.rpath b/build-aux/config.rpath
index c0d31f9..1a07018 100755
--- a/build-aux/config.rpath
+++ b/build-aux/config.rpath
@@ -25,7 +25,7 @@
# known workaround is to choose shorter directory names for the build
# directory and/or the installation directory.
-# All known linkers require a `.a' archive for static linking (except MSVC,
+# All known linkers require a '.a' archive for static linking (except MSVC,
# which needs '.lib').
libext=a
shrext=.so
diff --git a/build-aux/git-version-gen b/build-aux/git-version-gen
index d5542a2..0b51154 100755
--- a/build-aux/git-version-gen
+++ b/build-aux/git-version-gen
@@ -1,6 +1,6 @@
#!/bin/sh
# Print a version string.
-scriptversion=2012-01-06.07; # UTC
+scriptversion=2012-07-06.14; # UTC
# Copyright (C) 2007-2012 Free Software Foundation, Inc.
#
@@ -85,18 +85,25 @@ Print a version string.
Options:
- --prefix prefix of git tags (default 'v')
+ --prefix prefix of git tags to strip from version (default 'v')
+ --match pattern for git tags to match (default: '\$prefix*')
- --help display this help and exit
- --version output version information and exit
+ --help display this help and exit
+ --version output version information and exit
-Running without arguments will suffice in most cases."
+Running without arguments will suffice in most cases. If no --match
+argument is given, only match tags that begin with the --prefix."
+
+prefix=v
+unset match
+unset tag_sed_script
while test $# -gt 0; do
case $1 in
--help) echo "$usage"; exit 0;;
--version) echo "$version"; exit 0;;
--prefix) shift; prefix="$1";;
+ --match) shift; match="$1";;
-*)
echo "$0: Unknown option '$1'." >&2
echo "$0: Try '--help' for more information." >&2
@@ -119,8 +126,8 @@ if test -z "$tarball_version_file"; then
exit 1
fi
+match="${match:-$prefix*}"
tag_sed_script="${tag_sed_script:-s/x/x/}"
-prefix="${prefix:-v}"
nl='
'
@@ -150,8 +157,7 @@ then
# directory, and "git describe" output looks sensible, use that to
# derive a version string.
elif test "`git log -1 --pretty=format:x . 2>&1`" = x \
- && v=`git describe --abbrev=4 --match="$prefix*" HEAD 2>/dev/null \
- || git describe --abbrev=4 HEAD 2>/dev/null` \
+ && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null` \
&& v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \
&& case $v in
$prefix[0-9]*) ;;
diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog
index 0efedb0..17c4562 100755
--- a/build-aux/gitlog-to-changelog
+++ b/build-aux/gitlog-to-changelog
@@ -3,7 +3,7 @@ eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}'
if 0;
# Convert git log output to ChangeLog format.
-my $VERSION = '2012-01-06 07:14'; # UTC
+my $VERSION = '2012-05-22 09:40'; # UTC
# The definition above must lie within the first 8 lines in order
# for the Emacs time-stamp write hook (at end) to update it.
# If you change this file with Emacs, please let the write hook
@@ -64,12 +64,19 @@ OPTIONS:
makes a change to SHA1's commit log text or metadata.
--append-dot append a dot to the first line of each commit message if
there is no other punctuation or blank at the end.
+ --no-cluster never cluster commit messages under the same date/author
+ header; the default is to cluster adjacent commit messages
+ if their headers are the same and neither commit message
+ contains multiple paragraphs.
--since=DATE convert only the logs since DATE;
the default is to convert all log entries.
--format=FMT set format string for commit subject and body;
see 'man git-log' for the list of format metacharacters;
the default is '%s%n%b%n'
-
+ --strip-tab remove one additional leading TAB from commit message lines.
+ --strip-cherry-pick remove data inserted by "git cherry-pick";
+ this includes the "cherry picked from commit ..." line,
+ and the possible final "Conflicts:" paragraph.
--help display this help and exit
--version output version information and exit
@@ -190,6 +197,9 @@ sub parse_amend_file($)
my $format_string = '%s%n%b%n';
my $amend_file;
my $append_dot = 0;
+ my $cluster = 1;
+ my $strip_tab = 0;
+ my $strip_cherry_pick = 0;
GetOptions
(
help => sub { usage 0 },
@@ -198,6 +208,9 @@ sub parse_amend_file($)
'format=s' => \$format_string,
'amend=s' => \$amend_file,
'append-dot' => \$append_dot,
+ 'cluster!' => \$cluster,
+ 'strip-tab' => \$strip_tab,
+ 'strip-cherry-pick' => \$strip_cherry_pick,
) or usage 1;
@@ -257,6 +270,13 @@ sub parse_amend_file($)
$rest = $_;
}
+ # Remove lines inserted by "git cherry-pick".
+ if ($strip_cherry_pick)
+ {
+ $rest =~ s/^\s*Conflicts:\n.*//sm;
+ $rest =~ s/^\s*\(cherry picked from commit [\da-f]+\)\n//m;
+ }
+
my @line = split "\n", $rest;
my $author_line = shift @line;
defined $author_line
@@ -302,13 +322,15 @@ sub parse_amend_file($)
. substr ($_, 5) . "\n";
}
- # If this header would be different from the previous date/name/email/
- # coauthors header, or if this or the previous entry consists of two
- # or more paragraphs, then print the header.
- if ($date_line ne $prev_date_line
- or "@coauthors" ne "@prev_coauthors"
- or $multi_paragraph
- or $prev_multi_paragraph)
+ # If clustering of commit messages has been disabled, if this header
+ # would be different from the previous date/name/email/coauthors header,
+ # or if this or the previous entry consists of two or more paragraphs,
+ # then print the header.
+ if ( ! $cluster
+ || $date_line ne $prev_date_line
+ || "@coauthors" ne "@prev_coauthors"
+ || $multi_paragraph
+ || $prev_multi_paragraph)
{
$prev_date_line eq ''
or print "\n";
@@ -339,6 +361,10 @@ sub parse_amend_file($)
}
}
+ # Remove one additional leading TAB from each line.
+ $strip_tab
+ and map { s/^\t// } @line;
+
# Prefix each non-empty line with a TAB.
@line = map { length $_ ? "\t$_" : '' } @line;
diff --git a/build-aux/gnu-web-doc-update b/build-aux/gnu-web-doc-update
index 7a43049..851f8b8 100755
--- a/build-aux/gnu-web-doc-update
+++ b/build-aux/gnu-web-doc-update
@@ -27,59 +27,80 @@ VERSION=2009-07-21.16; # UTC
# Requirements: everything required to bootstrap your package,
# plus these: git, cvs, cvsu, rsync, mktemp
-ME=`basename "$0"`
+ME=$(basename "$0")
warn() { printf '%s: %s\n' "$ME" "$*" >&2; }
die() { warn "$*"; exit 1; }
-help_version()
+help()
{
- case $1 in
- --help) cat <<EOF
+ cat <<EOF
Usage: $ME
-Run this script (no options or arguments) after each non-alpha release,
-to update the web documentation at http://www.gnu.org/software/\$pkg/manual/
-Run it from your project's the top-level directory.
+Run this script from top_srcdir (no options or arguments) after each
+non-alpha release, to update the web documentation at
+http://www.gnu.org/software/\$pkg/manual/ Run it from your project's
+the top-level directory.
Options:
- --help print this help, then exit
- --version print version number, then exit
+ -C, --builddir=DIR location of (configured) Makefile (default: .)
+ --help print this help, then exit
+ --version print version number, then exit
Report bugs and patches to <address@hidden>.
EOF
- exit ;;
+ exit
+}
- --version)
- year=`echo "$VERSION" | sed 's/[^0-9].*//'`
- cat <<EOF
+version()
+{
+ year=$(echo "$VERSION" | sed 's/[^0-9].*//')
+ cat <<EOF
$ME $VERSION
Copyright (C) $year Free Software Foundation, Inc,
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.
EOF
- exit ;;
+ exit
+}
+
+builddir=.
+while test $# != 0
+do
+ # Handle --option=value by splitting apart and putting back on argv.
+ case $1 in
+ --*=*)
+ opt=$(echo "$1" | sed -e 's/=.*//')
+ val=$(echo "$1" | sed -e 's/[^=]*=//')
+ shift
+ set dummy "$opt" "$val" ${1+"$@"}; shift
+ ;;
+ esac
- *) die "unrecognized option: $1";;
+ case $1 in
+ --help|--version) ${1#--};;
+ -C|--builddir) shift; builddir=$1; shift ;;
+ --*) die "unrecognized option: $1";;
+ *) break;;
esac
-}
+done
-case $# in
- 0) ;;
- 1) help_version $1 ;;
- *) die "$ME: too many options" ;;
-esac
+test $# = 0 \
+ || die "$ME: too many arguments"
prev=.prev-version
version=$(cat $prev) || die "$ME: no $prev file?"
-pkg=$(sed -n 's/^PACKAGE = \(.*\)/\1/p' Makefile) || die "$ME: no Makefile?"
+pkg=$(sed -n 's/^PACKAGE = \(.*\)/\1/p' $builddir/Makefile) \
+ || die "$ME: no Makefile?"
tmp_branch=web-doc-$version-$$
+current_branch=$(git branch | sed -ne '/^\* /{s///;p;q;}')
cleanup()
{
- __st=$?;
+ __st=$?
rm -rf "$tmp"
- git checkout master
+ git checkout "$current_branch"
+ git submodule update --recursive
git branch -d $tmp_branch
exit $__st
}
@@ -89,15 +110,23 @@ trap 'exit $?' 1 2 13 15
# We must build using sources for which --version reports the
# just-released version number, not some string like 7.6.18-20761.
# That version string propagates into all documentation.
+set -e
git checkout -b $tmp_branch v$version
-ok=0
-./bootstrap && ./configure && make && make web-manual && ok=1
-test $ok = 1 || exit 1
-
-tmp=$(mktemp -d --tmpdir=. web-doc-update.XXXXXX) || exit 1
+git submodule update --recursive
+./bootstrap
+srcdir=$(pwd)
+cd "$builddir"
+ ./config.status --recheck
+ ./config.status
+ make
+ make web-manual
+cd "$srcdir"
+set +e
+
+tmp=$(mktemp -d web-doc-update.XXXXXX) || exit 1
( cd $tmp \
&& cvs -d address@hidden:/webcvs/$pkg co $pkg )
-rsync -avP doc/manual/ $tmp/$pkg/manual
+rsync -avP "$builddir"/doc/manual/ $tmp/$pkg/manual
(
cd $tmp/$pkg/manual
diff --git a/build-aux/gnupload b/build-aux/gnupload
index eb450a0..a0e5c7b 100755
--- a/build-aux/gnupload
+++ b/build-aux/gnupload
@@ -1,9 +1,9 @@
#!/bin/sh
# Sign files and upload them.
-scriptversion=2012-01-15.15; # UTC
+scriptversion=2012-06-11.00; # UTC
-# Copyright (C) 2004-2010, 2012 Free Software Foundation, Inc.
+# Copyright (C) 2004-2012 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
@@ -28,6 +28,7 @@ GPG='gpg --batch --no-tty'
conffile=.gnuploadrc
to=
dry_run=false
+replace=
symlink_files=
delete_files=
delete_symlinks=
@@ -53,8 +54,10 @@ Options:
--to DEST specify one destination for FILES
(multiple --to options are allowed)
--user NAME sign with key NAME
+ --replace allow replacements of existing files
--symlink-regex[=EXPR] use sed script EXPR to compute symbolic link names
--dry-run do nothing, show what would have been done
+ (including the constructed directive file)
--version output version information and exit
If --symlink-regex is given without EXPR, then the link target name
@@ -146,6 +149,9 @@ while test -n "$1"; do
--delete)
collect_var=delete_files
;;
+ --replace)
+ replace="replace: true"
+ ;;
--rmsymlink)
collect_var=delete_symlinks
;;
@@ -243,11 +249,13 @@ unset passphrase
# listings with their arguments...).
# Remember this script runs with 'set -e', so if echo is not built-in
# it will exit now.
-PATH=/empty echo -n "Enter GPG passphrase: "
-stty -echo
-read -r passphrase
-stty echo
-echo
+if $dry_run; then :; else
+ PATH=/empty echo -n "Enter GPG passphrase: "
+ stty -echo
+ read -r passphrase
+ stty echo
+ echo
+fi
if test $# -ne 0; then
for file
@@ -270,7 +278,7 @@ filename: $3$stmt"
fi
cat >${2}.directive<<EOF
-version: 1.1
+version: 1.2
directory: $1
comment: gnupload v. $scriptversion$stmt
EOF
@@ -393,6 +401,12 @@ do
do
echo "Uploading $file to $dest ..."
stmt=
+ #
+ # allowing file replacement is all or nothing.
+ if test -n "$replace"; then stmt="$stmt
+$replace"
+ fi
+ #
files="$file $file.sig"
destdir=`echo $dest | sed 's/[^:]*://'`
if test -n "$symlink_expr"; then
diff --git a/build-aux/snippet/_Noreturn.h b/build-aux/snippet/_Noreturn.h
index 1a7b4da..c44ad89 100644
--- a/build-aux/snippet/_Noreturn.h
+++ b/build-aux/snippet/_Noreturn.h
@@ -1,4 +1,4 @@
-#ifndef _Noreturn
+#if !defined _Noreturn && __STDC_VERSION__ < 201112
# if (3 <= __GNUC__ || (__GNUC__ == 2 && 8 <= __GNUC_MINOR__) \
|| 0x5110 <= __SUNPRO_C)
# define _Noreturn __attribute__ ((__noreturn__))
diff --git a/check-guile.in b/check-guile.in
index 995199d..214deec 100644
--- a/check-guile.in
+++ b/check-guile.in
@@ -43,6 +43,7 @@ fi
exec $guile \
--debug \
+ -L "$TEST_SUITE_DIR" \
--no-auto-compile -e main -s "$TEST_SUITE_DIR/guile-test" \
--test-suite "$TEST_SUITE_DIR/tests" \
--log-file check-guile.log "$@"
diff --git a/configure.ac b/configure.ac
index 66d735e..32a6760 100644
--- a/configure.ac
+++ b/configure.ac
@@ -29,7 +29,7 @@ Floor, Boston, MA 02110-1301, USA.
AC_PREREQ(2.61)
AC_INIT([GNU Guile],
- m4_esyscmd([build-aux/git-version-gen .tarball-version]),
+ m4_esyscmd([build-aux/git-version-gen --match v2.0.\*
.tarball-version]),
address@hidden)
AC_CONFIG_AUX_DIR([build-aux])
AC_CONFIG_MACRO_DIR([m4])
@@ -64,15 +64,10 @@ AC_PROG_CPP
AC_PROG_SED
AC_PROG_AWK
AC_PROG_LN_S
+AM_PROG_AR
dnl Gnulib.
gl_INIT
-dnl FIXME: remove me and the acinclude.m4 code when clock-gettime is
-dnl fixed for clock_getcpuclockid and can be imported normally from
-dnl gnulib. See
-dnl <http://lists.gnu.org/archive/html/bug-gnulib/2011-06/msg00227.html>
-dnl for details.
-gl_CLOCK_TIME
AC_PROG_CC_C89
@@ -756,7 +751,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# utimensat: posix.1-2008
# sched_getaffinity, sched_setaffinity: GNU extensions (glibc)
#
-AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround
ftime ftruncate fchown getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat
mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename rmdir
select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64
strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid
strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent
kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy
rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale
utimensat sched_getaffinity sched_setaffinity])
+AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround
ftime ftruncate fchown fchmod getcwd geteuid getsid gettimeofday gmtime_r ioctl
lstat mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename
rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt
stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname
waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent
getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index
bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l
newlocale utimensat sched_getaffinity sched_setaffinity])
# Reasons for testing:
# netdb.h - not in mingw
@@ -1232,7 +1227,7 @@ save_LIBS="$LIBS"
LIBS="$BDW_GC_LIBS $LIBS"
CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
-AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit
GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask
GC_set_start_callback GC_get_heap_usage_safe GC_get_free_space_divisor
GC_gcollect_and_unmap GC_get_unmapped_bytes])
+AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit
GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask
GC_set_start_callback GC_get_heap_usage_safe GC_get_free_space_divisor
GC_gcollect_and_unmap GC_get_unmapped_bytes GC_set_finalizer_notifier
GC_set_finalize_on_demand])
# Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
# declared, and has a different type (returning void instead of
@@ -1495,8 +1490,6 @@ case "$GCC" in
## We had -Wstrict-prototypes in here for a bit, but Guile does too
## much stuff with generic function pointers for that to really be
## less than exasperating.
- ## -Wpointer-arith was here too, but something changed in gcc/glibc
- ## and it became equally exasperating (gcc 2.95 and/or glibc 2.1.2).
## -Wundef was removed because Gnulib prevented it (see
## <http://thread.gmane.org/gmane.lisp.guile.bugs/5329>.)
@@ -1505,7 +1498,7 @@ case "$GCC" in
## <http://lists.gnu.org/archive/html/guile-devel/2012-01/msg00487.html>.
POTENTIAL_GCC_CFLAGS="-Wall -Wmissing-prototypes \
- -Wdeclaration-after-statement \
+ -Wdeclaration-after-statement -Wpointer-arith \
-Wswitch-enum -fno-strict-aliasing"
# Do this here so we don't screw up any of the tests above that might
# not be "warning free"
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 6fc5b2e..78d6789 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
address@hidden 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
address@hidden 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Compound Data Types
@@ -2372,7 +2372,7 @@ to be stored along side usual Scheme @code{SCM} values.
* Vtable Vtables::
@end menu
address@hidden Vtables, Structure Basics, Structures, Structures
address@hidden Vtables
@subsubsection Vtables
A vtable is a structure type, specifying its layout, and other
@@ -2460,7 +2460,7 @@ structure.
@end deffn
address@hidden Structure Basics, Vtable Contents, Vtables, Structures
address@hidden Structure Basics
@subsubsection Structure Basics
This section describes the basic procedures for working with
@@ -2542,7 +2542,7 @@ This can be used to examine the layout of an unknown
structure, see
@end deffn
address@hidden Vtable Contents, Vtable Vtables, Structure Basics, Structures
address@hidden Vtable Contents
@subsubsection Vtable Contents
A vtable is itself a structure, with particular fields that hold
@@ -2614,16 +2614,8 @@ from @var{vtable}.
@end example
@end deffn
address@hidden {Scheme Procedure} struct-vtable-tag vtable
address@hidden {C Function} scm_struct_vtable_tag (vtable)
-Return the tag of the given @var{vtable}.
address@hidden
address@hidden FIXME: what can be said about what this means?
address@hidden
address@hidden deffn
-
address@hidden Vtable Vtables, , Vtable Contents, Structures
address@hidden Vtable Vtables
@subsubsection Vtable Vtables
As noted above, a vtable is a structure and that structure is itself
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index ca7ad4a..95c4925 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -838,12 +838,27 @@ the current implementation that object shares structure
with
@var{args}, so @var{args} should not be modified subsequently.
@end deffn
address@hidden {C Function} scm_c_value_ref (values, idx)
address@hidden {C Function} SCM scm_c_values (SCM *base, size_t n)
address@hidden is an alternative to @code{scm_values}. It creates
+a new values object, and copies into it the @var{n} values starting from
address@hidden
+
+Currently this creates a list and passes it to @code{scm_values}, but we
+expect that in the future we will be able to use more a efficient
+representation.
address@hidden deftypefn
+
address@hidden {C Function} size_t scm_c_nvalues (SCM obj)
+If @var{obj} is a multiple-values object, returns the number of values
+it contains. Otherwise returns 1.
address@hidden deftypefn
+
address@hidden {C Function} SCM scm_c_value_ref (SCM obj, size_t idx)
Returns the value at the position specified by @var{idx} in
address@hidden Note that @var{values} will ordinarily be a
address@hidden Note that @var{obj} will ordinarily be a
multiple-values object, but it need not be. Any other object
represents a single value (itself), and is handled appropriately.
address@hidden deffn
address@hidden deftypefn
@rnindex call-with-values
@deffn {Scheme Procedure} call-with-values producer consumer
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 4fc11c8..39c9790 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -3405,7 +3405,6 @@ i18n)} module}, for locale-dependent string comparison.
@rnindex string=?
@deffn {Scheme Procedure} string=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_equal_p (s1, s2, rest)
Lexicographic equality predicate; return @code{#t} if all strings are
the same length and contain the same characters in the same positions,
otherwise return @code{#f}.
@@ -3418,7 +3417,6 @@ characters.
@rnindex string<?
@deffn {Scheme Procedure} string<? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_less_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically less than @var{str_i+1}.
@@ -3426,7 +3424,6 @@ lexicographically less than @var{str_i+1}.
@rnindex string<=?
@deffn {Scheme Procedure} string<=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_leq_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically less than or equal to @var{str_i+1}.
@@ -3434,7 +3431,6 @@ lexicographically less than or equal to @var{str_i+1}.
@rnindex string>?
@deffn {Scheme Procedure} string>? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_gr_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically greater than @var{str_i+1}.
@@ -3442,7 +3438,6 @@ lexicographically greater than @var{str_i+1}.
@rnindex string>=?
@deffn {Scheme Procedure} string>=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_geq_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically greater than or equal to @var{str_i+1}.
@@ -3450,7 +3445,6 @@ lexicographically greater than or equal to @var{str_i+1}.
@rnindex string-ci=?
@deffn {Scheme Procedure} string-ci=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_ci_equal_p (s1, s2, rest)
Case-insensitive string equality predicate; return @code{#t} if
all strings are the same length and their component
characters match (ignoring case) at each position; otherwise
@@ -3459,7 +3453,6 @@ return @code{#f}.
@rnindex string-ci<?
@deffn {Scheme Procedure} string-ci<? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_ci_less_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically less than @var{str_i+1}
@@ -3468,7 +3461,6 @@ regardless of case.
@rnindex string<=?
@deffn {Scheme Procedure} string-ci<=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_ci_leq_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically less than or equal to
@@ -3477,7 +3469,6 @@ for every pair of consecutive string arguments
@var{str_i} and
@rnindex string-ci>?
@deffn {Scheme Procedure} string-ci>? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_ci_gr_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically greater than
@@ -3486,7 +3477,6 @@ for every pair of consecutive string arguments
@var{str_i} and
@rnindex string-ci>=?
@deffn {Scheme Procedure} string-ci>=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_ci_geq_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically greater than or equal to
diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi
index 3097a52..57cf884 100644
--- a/doc/ref/api-foreign.texi
+++ b/doc/ref/api-foreign.texi
@@ -582,6 +582,22 @@ Unsafely cast @var{pointer} to a Scheme object.
Cross your fingers!
@end deffn
+Sometimes you want to give C extensions access to the dynamic FFI. At
+that point, the names get confusing, because ``pointer'' can refer to a
address@hidden object that wraps a pointer, or to a @code{void*} value. We
+will try to use ``pointer object'' to refer to Scheme objects, and
+``pointer value'' to refer to @code{void *} values.
+
address@hidden {C Function} SCM scm_from_pointer (void *ptr, void (*finalizer)
(void*))
+Create a pointer object from a pointer value.
+
+If @var{finalizer} is non-null, Guile arranges to call it on the pointer
+value at some point after the pointer object becomes collectable.
address@hidden deftypefn
+
address@hidden {C Function} void* scm_to_pointer (SCM obj)
+Unpack the pointer value from a pointer object.
address@hidden deftypefn
@node Void Pointers and Byte Access
@subsubsection Void Pointers and Byte Access
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 24c2706..de3684c 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -166,6 +166,21 @@ returned. New ports will have this default behavior when
they are
created.
@end deffn
address@hidden {Scheme Variable} %default-port-conversion-strategy
+The fluid that defines the conversion strategy for newly created ports,
+and for other conversion routines such as @code{scm_to_stringn},
address@hidden, @code{string->pointer}, and
address@hidden>string}.
+
+Its value must be one of the symbols described above, with the same
+semantics: @code{'error}, @code{'substitute}, or @code{'escape}.
+
+When Guile starts, its value is @code{'substitute}.
+
+Note that @code{(set-port-conversion-strategy! #f @var{sym})} is
+equivalent to @code{(fluid-set! %default-port-conversion-strategy
address@hidden)}.
address@hidden deffn
@node Reading
diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi
index c91c2d4..17ab462 100644
--- a/doc/ref/api-modules.texi
+++ b/doc/ref/api-modules.texi
@@ -1008,6 +1008,17 @@ Like @code{scm_c_define} and @code{scm_define}, but the
specified
module is used instead of the current one.
@end deftypefn
+In some rare cases, you may need to access the variable that
address@hidden would have accessed, without changing the
+binding of the existing variable, if one is present. In that case, use
address@hidden:
+
address@hidden {C Function} SCM scm_module_ensure_local_variable (SCM
@var{module}, SCM @var{sym})
+Like @code{scm_module_define}, but if the @var{sym} is already locally
+bound in that module, the variable's existing binding is not reset.
+Returns a variable.
address@hidden deftypefn
+
@deftypefn {C Function} SCM scm_module_reverse_lookup (SCM @var{module}, SCM
@var{variable})
Find the symbol that is bound to @var{variable} in @var{module}. When no such
binding is found, return @code{#f}.
@end deftypefn
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index 0e0ad15..02d7771 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -643,10 +643,8 @@ properties interface.
The first group of procedures in this meta-interface are predicates to
test whether a Scheme object is a procedure, or a special procedure,
-respectively. @code{procedure?} is the most general predicates, it
-returns @code{#t} for any kind of procedure. @code{closure?} does not
-return @code{#t} for primitive procedures, and @code{thunk?} only
-returns @code{#t} for procedures which do not accept any arguments.
+respectively. @code{procedure?} is the most general predicates, it
+returns @code{#t} for any kind of procedure.
@rnindex procedure?
@deffn {Scheme Procedure} procedure? obj
@@ -656,7 +654,8 @@ Return @code{#t} if @var{obj} is a procedure.
@deffn {Scheme Procedure} thunk? obj
@deffnx {C Function} scm_thunk_p (obj)
-Return @code{#t} if @var{obj} is a thunk.
+Return @code{#t} if @var{obj} is a thunk---a procedure that does
+not accept arguments.
@end deffn
@cindex procedure properties
diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi
index 9ab1eee..17694ec 100644
--- a/doc/ref/api-utility.texi
+++ b/doc/ref/api-utility.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011,
2012
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -308,9 +308,10 @@ input.
@deffn {Scheme Procedure} sorted? items less
@deffnx {C Function} scm_sorted_p (items, less)
-Return @code{#t} iff @var{items} is a list or a vector such that
-for all 1 <= i <= m, the predicate @var{less} returns true when
-applied to all elements i - 1 and i
+Return @code{#t} iff @var{items} is a list or vector such that,
+for each element @var{x} and the next element @var{y} of
address@hidden, @code{(@var{less} @var{y} @var{x})} returns
address@hidden
@end deffn
@deffn {Scheme Procedure} sort items less
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index c0ba4dd..03356c7 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -862,13 +862,6 @@ arguments from the stack. Return the resulting value to
the calling
procedure.
@end deffn
address@hidden Instruction smob-call nargs
-Pop off the smob object from the stack (which should have been pushed on
-by the trampoline), and call its descriptor's @code{apply} function with
-the @var{nargs} arguments from the stack. Return the resulting value or
-values to the calling procedure.
address@hidden deffn
-
@deffn Instruction continuation-call
Pop off an internal continuation object (which should have been pushed
on by the trampoline), and reinstate that continuation. All of the
diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index 8bb99e2..161a28d 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -37,6 +37,7 @@ back.
* URIs:: Universal Resource Identifiers.
* HTTP:: The Hyper-Text Transfer Protocol.
* HTTP Headers:: How Guile represents specific header values.
+* Transfer Codings:: HTTP Transfer Codings.
* Requests:: HTTP requests.
* Responses:: HTTP responses.
* Web Client:: Accessing web resources over HTTP.
@@ -178,10 +179,10 @@ URI := scheme ":" ["//" [userinfo "@@"] host [":" port]]
path \
For example, in the URI, @indicateurl{http://www.gnu.org/help/}, the
scheme is @code{http}, the host is @code{www.gnu.org}, the path is
address@hidden/help/}, and there is no userinfo, port, query, or path. All URIs
-have a scheme and a path (though the path might be empty). Some URIs
-have a host, and some of those have ports and userinfo. Any URI might
-have a query part or a fragment.
address@hidden/help/}, and there is no userinfo, port, query, or fragment. All
+URIs have a scheme and a path (though the path might be empty). Some
+URIs have a host, and some of those have ports and userinfo. Any URI
+might have a query part or a fragment.
Userinfo is something of an abstraction, as some legacy URI schemes
allowed userinfo of the form @address@hidden:@var{passwd}}. But
@@ -397,6 +398,11 @@ HTTP stack like this:
(display (inet-ntoa ip) port)))
@end example
address@hidden {Scheme Procedure} declare-opaque-header! name
+A specialised version of @code{declare-header!} for the case in which
+you want a header's value to be returned/written ``as-is''.
address@hidden deffn
+
@deffn {Scheme Procedure} valid-header? sym val
Return a true value iff @var{val} is a valid Scheme value for the header
with name @var{sym}.
@@ -665,7 +671,7 @@ A list of allowed methods on a given resource, as symbols.
A list of content codings, as symbols.
@example
(parse-header 'content-encoding "gzip")
address@hidden (GET HEAD)
address@hidden (gzip)
@end example
@end deftypevr
@@ -1020,6 +1026,71 @@ A list of challenges to a user, indicating the need for
authentication.
@end example
@end deftypevr
address@hidden Transfer Codings
address@hidden Transfer Codings
+
+HTTP 1.1 allows for various transfer codings to be applied to message
+bodies. These include various types of compression, and HTTP chunked
+encoding. Currently, only chunked encoding is supported by guile.
+
+Chunked coding is an optional coding that may be applied to message
+bodies, to allow messages whose length is not known beforehand to be
+returned. Such messages can be split into chunks, terminated by a final
+zero length chunk.
+
+In order to make dealing with encodings more simple, guile provides
+procedures to create ports that ``wrap'' existing ports, applying
+transformations transparently under the hood.
+
+These procedures are in the @code{(web http)} module.
+
address@hidden
+(use-modules (web http))
address@hidden example
+
address@hidden {Scheme Procedure} make-chunked-input-port port
[#:keep-alive?=#f]
+Returns a new port, that transparently reads and decodes chunk-encoded
+data from @var{port}. If no more chunk-encoded data is available, it
+returns the end-of-file object. When the port is closed, @var{port} will
+also be closed, unless @var{keep-alive?} is true.
address@hidden deffn
+
address@hidden
+(use-modules (ice-9 rdelim))
+
+(define s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n")
+(define p (make-chunked-input-port (open-input-string s)))
+(read-line s)
address@hidden "First line"
+(read-line s)
address@hidden "Second line"
address@hidden example
+
address@hidden {Scheme Procedure} make-chunked-output-port port
[#:keep-alive?=#f]
+Returns a new port, which transparently encodes data as chunk-encoded
+before writing it to @var{port}. Whenever a write occurs on this port,
+it buffers it, until the port is flushed, at which point it writes a
+chunk containing all the data written so far. When the port is closed,
+the data remaining is written to @var{port}, as is the terminating zero
+chunk. It also causes @var{port} to be closed, unless @var{keep-alive?}
+is true.
+
+Note. Forcing a chunked output port when there is no data is buffered
+does not write a zero chunk, as this would cause the data to be
+interpreted incorrectly by the client.
address@hidden deffn
+
address@hidden
+(call-with-output-string
+ (lambda (out)
+ (define out* (make-chunked-output-port out #:keep-alive? #t))
+ (display "first chunk" out*)
+ (force-output out*)
+ (force-output out*) ; note this does not write a zero chunk
+ (display "second chunk" out*)
+ (close-port out*)))
address@hidden "b\r\nfirst chunk\r\nc\r\nsecond chunk\r\n0\r\n"
address@hidden example
@node Requests
@subsection HTTP Requests
diff --git a/gnulib-local/build-aux/git-version-gen.diff
b/gnulib-local/build-aux/git-version-gen.diff
new file mode 100644
index 0000000..c222a99
--- /dev/null
+++ b/gnulib-local/build-aux/git-version-gen.diff
@@ -0,0 +1,62 @@
+This patch is being discussed
+at <http://lists.gnu.org/archive/html/bug-gnulib/2012-07/msg00079.html>.
+Remove when integrated in Gnulib.
+
+--- a/build-aux/git-version-gen 2012-06-12 21:25:48.000000000 +0200
++++ b/build-aux/git-version-gen 2012-07-07 01:52:08.000000000 +0200
+@@ -1,6 +1,6 @@
+ #!/bin/sh
+ # Print a version string.
+-scriptversion=2012-03-18.17; # UTC
++scriptversion=2012-07-06.14; # UTC
+
+ # Copyright (C) 2007-2012 Free Software Foundation, Inc.
+ #
+@@ -85,20 +85,25 @@
+
+ Options:
+
+- --prefix prefix of git tags (default 'v')
++ --prefix prefix of git tags to strip from version (default 'v')
++ --match pattern for git tags to match (default: '\$prefix*')
+
+- --help display this help and exit
+- --version output version information and exit
++ --help display this help and exit
++ --version output version information and exit
+
+-Running without arguments will suffice in most cases."
++Running without arguments will suffice in most cases. If no --match
++argument is given, only match tags that begin with the --prefix."
+
+ prefix=v
++unset match
++unset tag_sed_script
+
+ while test $# -gt 0; do
+ case $1 in
+ --help) echo "$usage"; exit 0;;
+ --version) echo "$version"; exit 0;;
+ --prefix) shift; prefix="$1";;
++ --match) shift; match="$1";;
+ -*)
+ echo "$0: Unknown option '$1'." >&2
+ echo "$0: Try '--help' for more information." >&2
+@@ -121,6 +126,7 @@
+ exit 1
+ fi
+
++match="${match:-$prefix*}"
+ tag_sed_script="${tag_sed_script:-s/x/x/}"
+
+ nl='
+@@ -151,8 +157,7 @@
+ # directory, and "git describe" output looks sensible, use that to
+ # derive a version string.
+ elif test "`git log -1 --pretty=format:x . 2>&1`" = x \
+- && v=`git describe --abbrev=4 --match="$prefix*" HEAD 2>/dev/null \
+- || git describe --abbrev=4 HEAD 2>/dev/null` \
++ && v=`git describe --abbrev=4 --match="$match" HEAD 2>/dev/null` \
+ && v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \
+ && case $v in
+ $prefix[0-9]*) ;;
diff --git a/gnulib-local/lib/localcharset.c.diff
b/gnulib-local/lib/localcharset.c.diff
index 6f216ad..b1c249c 100644
--- a/gnulib-local/lib/localcharset.c.diff
+++ b/gnulib-local/lib/localcharset.c.diff
@@ -3,9 +3,9 @@ information from the environment. See
http://lists.gnu.org/archive/html/guile-devel/2011-11/msg00040.html for the
rationale.
---- a/lib/localcharset.c 2011-12-14 23:10:58.000000000 +0100
-+++ b/lib/localcharset.c 2011-12-15 00:45:12.000000000 +0100
-@@ -545,3 +545,74 @@ locale_charset (void)
+--- a/lib/localcharset.c
++++ b/lib/localcharset.c
+@@ -544,3 +544,73 @@ locale_charset (void)
return codeset;
}
diff --git a/gnulib-local/m4/canonicalize.m4.diff
b/gnulib-local/m4/canonicalize.m4.diff
new file mode 100644
index 0000000..57f4472
--- /dev/null
+++ b/gnulib-local/m4/canonicalize.m4.diff
@@ -0,0 +1,67 @@
+Fix `canonicalize_file_name' replacement handling when cross-compiling.
+Without this patch, we end up with:
+
+ ./.libs/libguile-2.0.so: undefined reference to `rpl_canonicalize_file_name'
+
+See <http://hydra.nixos.org/build/2765567> for details.
+
+index 69b3f4c..3c4c5ee 100644
+--- a/m4/canonicalize.m4
++++ b/m4/canonicalize.m4
+@@ -16,8 +16,11 @@ AC_DEFUN([gl_FUNC_CANONICALIZE_FILENAME_MODE],
+ AC_REQUIRE([gl_FUNC_REALPATH_WORKS])
+ if test $ac_cv_func_canonicalize_file_name = no; then
+ HAVE_CANONICALIZE_FILE_NAME=0
+- elif test "$gl_cv_func_realpath_works" != yes; then
+- REPLACE_CANONICALIZE_FILE_NAME=1
++ else
++ case "$gl_cv_func_realpath_works" in
++ *yes) ;;
++ *) REPLACE_CANONICALIZE_FILE_NAME=1 ;;
++ esac
+ fi
+ ])
+
+@@ -30,12 +33,21 @@ AC_DEFUN([gl_CANONICALIZE_LGPL],
+ HAVE_CANONICALIZE_FILE_NAME=0
+ if test $ac_cv_func_realpath = no; then
+ HAVE_REALPATH=0
+- elif test "$gl_cv_func_realpath_works" != yes; then
+- REPLACE_REALPATH=1
++ else
++ case "$gl_cv_func_realpath_works" in
++ *yes) ;;
++ *) REPLACE_REALPATH=1 ;;
++ esac
+ fi
+- elif test "$gl_cv_func_realpath_works" != yes; then
+- REPLACE_CANONICALIZE_FILE_NAME=1
+- REPLACE_REALPATH=1
++ else
++ case "$gl_cv_func_realpath_works" in
++ *yes)
++ ;;
++ *)
++ REPLACE_CANONICALIZE_FILE_NAME=1
++ REPLACE_REALPATH=1
++ ;;
++ esac
+ fi
+ ])
+
+
+Now, work around a second bug: fix default value when cross-compiling
+for GNU/Hurd.
+
+index 69b3f4c..111ddf8 100644
+--- a/m4/canonicalize.m4
++++ b/m4/canonicalize.m4
+@@ -95,7 +95,7 @@ AC_DEFUN([gl_FUNC_REALPATH_WORKS],
+ [gl_cv_func_realpath_works=no],
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+- *-gnu*) gl_cv_func_realpath_works="guessing yes" ;;
++ *gnu*) gl_cv_func_realpath_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_realpath_works="guessing no" ;;
+ esac
diff --git a/gnulib-local/m4/clock_time.m4.diff
b/gnulib-local/m4/clock_time.m4.diff
new file mode 100644
index 0000000..57d34e1
--- /dev/null
+++ b/gnulib-local/m4/clock_time.m4.diff
@@ -0,0 +1,28 @@
+Remove when clock-gettime is fixed for clock_getcpuclockid.
+
+See <http://lists.gnu.org/archive/html/bug-gnulib/2011-06/msg00227.html>
+for details.
+
+diff --git a/m4/clock_time.m4 b/m4/clock_time.m4
+index 0bec0ef..fb3a17a 100644
+--- a/m4/clock_time.m4
++++ b/m4/clock_time.m4
+@@ -24,8 +24,15 @@ AC_DEFUN([gl_CLOCK_TIME],
+ AC_SUBST([LIB_CLOCK_GETTIME])
+ gl_saved_libs=$LIBS
+ AC_SEARCH_LIBS([clock_gettime], [rt posix4],
+- [test "$ac_cv_search_clock_gettime" = "none required" ||
+- LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime])
+- AC_CHECK_FUNCS([clock_gettime clock_settime])
++ [if test "$ac_cv_search_clock_gettime" = "none required";
then
++ AC_SEARCH_LIBS([clock_getcpuclockid], [rt posix4],
++ [test
"$ac_cv_search_clock_getcpuclockid" = "none required" \
++ ||
LIB_CLOCK_GETTIME=$ac_cv_search_clock_getcpuclockid],
++ [test "$ac_cv_search_clock_gettime" =
"none required" \
++ ||
LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime])
++ else
++ LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime
++ fi])
++ AC_CHECK_FUNCS([clock_gettime clock_settime clock_getcpuclockid])
+ LIBS=$gl_saved_libs
+ ])
diff --git a/lib/Makefile.am b/lib/Makefile.am
index ab5f2d1..8602e13 100644
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -21,7 +21,7 @@
# the same distribution terms as the rest of that program.
#
# Generated by gnulib-tool.
-# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local
--lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap canonicalize-lgpl ceil close connect dirfd duplocale
environ extensions flock floor fpieee frexp full-read full-write func gendocs
getaddrinfo getpeername getsockname getsockopt git-version-gen
gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf
inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility
libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu
malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename send
sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh
string sys_stat trunc verify vsnprintf warnings wchar
+# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local
--lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd
duplocale environ extensions flock floor fpieee frexp full-read full-write func
gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen
gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf
inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility
libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu
malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename send
sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh
string sys_stat trunc verify vsnprintf warnings wchar
AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
@@ -61,10 +61,13 @@ libgnu_la_LDFLAGS += $(ISNANF_LIBM)
libgnu_la_LDFLAGS += $(ISNANL_LIBM)
libgnu_la_LDFLAGS += $(LDEXP_LIBM)
libgnu_la_LDFLAGS += $(LIBSOCKET)
+libgnu_la_LDFLAGS += $(LIB_CLOCK_GETTIME)
libgnu_la_LDFLAGS += $(LOG1P_LIBM)
+libgnu_la_LDFLAGS += $(LOG_LIBM)
libgnu_la_LDFLAGS += $(LTLIBICONV)
libgnu_la_LDFLAGS += $(LTLIBINTL)
libgnu_la_LDFLAGS += $(LTLIBUNISTRING)
+libgnu_la_LDFLAGS += $(ROUND_LIBM)
libgnu_la_LDFLAGS += $(SERVENT_LIB)
libgnu_la_LDFLAGS += $(TRUNC_LIBM)
@@ -279,7 +282,7 @@ configmake.h: Makefile
echo '#define PKGINCLUDEDIR "$(pkgincludedir)"'; \
echo '#define PKGLIBDIR "$(pkglibdir)"'; \
echo '#define PKGLIBEXECDIR "$(pkglibexecdir)"'; \
- } | sed '/""/d' > address@hidden
+ } | sed '/""/d' > address@hidden && \
mv -f address@hidden $@
BUILT_SOURCES += configmake.h
@@ -911,12 +914,15 @@ locale.h: locale.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
-e 's|@''NEXT_LOCALE_H''@|$(NEXT_LOCALE_H)|g' \
+ -e 's/@''GNULIB_LOCALECONV''@/$(GNULIB_LOCALECONV)/g' \
-e 's/@''GNULIB_SETLOCALE''@/$(GNULIB_SETLOCALE)/g' \
-e 's/@''GNULIB_DUPLOCALE''@/$(GNULIB_DUPLOCALE)/g' \
-e 's|@''HAVE_DUPLOCALE''@|$(HAVE_DUPLOCALE)|g' \
-e 's|@''HAVE_XLOCALE_H''@|$(HAVE_XLOCALE_H)|g' \
+ -e 's|@''REPLACE_LOCALECONV''@|$(REPLACE_LOCALECONV)|g' \
-e 's|@''REPLACE_SETLOCALE''@|$(REPLACE_SETLOCALE)|g' \
-e 's|@''REPLACE_DUPLOCALE''@|$(REPLACE_DUPLOCALE)|g' \
+ -e 's|@''REPLACE_STRUCT_LCONV''@|$(REPLACE_STRUCT_LCONV)|g' \
-e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
-e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
-e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
@@ -929,6 +935,33 @@ EXTRA_DIST += locale.in.h
## end gnulib module locale
+## begin gnulib module localeconv
+
+
+EXTRA_DIST += localeconv.c
+
+EXTRA_libgnu_la_SOURCES += localeconv.c
+
+## end gnulib module localeconv
+
+## begin gnulib module log
+
+
+EXTRA_DIST += log.c
+
+EXTRA_libgnu_la_SOURCES += log.c
+
+## end gnulib module log
+
+## begin gnulib module log1p
+
+
+EXTRA_DIST += log1p.c
+
+EXTRA_libgnu_la_SOURCES += log1p.c
+
+## end gnulib module log1p
+
## begin gnulib module lstat
@@ -991,6 +1024,9 @@ math.h: math.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's/@''GNULIB_ATANF''@/$(GNULIB_ATANF)/g' \
-e 's/@''GNULIB_ATANL''@/$(GNULIB_ATANL)/g' \
-e 's/@''GNULIB_ATAN2F''@/$(GNULIB_ATAN2F)/g' \
+ -e 's/@''GNULIB_CBRT''@/$(GNULIB_CBRT)/g' \
+ -e 's/@''GNULIB_CBRTF''@/$(GNULIB_CBRTF)/g' \
+ -e 's/@''GNULIB_CBRTL''@/$(GNULIB_CBRTL)/g' \
-e 's/@''GNULIB_CEIL''@/$(GNULIB_CEIL)/g' \
-e 's/@''GNULIB_CEILF''@/$(GNULIB_CEILF)/g' \
-e 's/@''GNULIB_CEILL''@/$(GNULIB_CEILL)/g' \
@@ -1002,17 +1038,33 @@ math.h: math.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's/@''GNULIB_COSHF''@/$(GNULIB_COSHF)/g' \
-e 's/@''GNULIB_EXPF''@/$(GNULIB_EXPF)/g' \
-e 's/@''GNULIB_EXPL''@/$(GNULIB_EXPL)/g' \
+ -e 's/@''GNULIB_EXP2''@/$(GNULIB_EXP2)/g' \
+ -e 's/@''GNULIB_EXP2F''@/$(GNULIB_EXP2F)/g' \
+ -e 's/@''GNULIB_EXP2L''@/$(GNULIB_EXP2L)/g' \
+ -e 's/@''GNULIB_EXPM1''@/$(GNULIB_EXPM1)/g' \
+ -e 's/@''GNULIB_EXPM1F''@/$(GNULIB_EXPM1F)/g' \
+ -e 's/@''GNULIB_EXPM1L''@/$(GNULIB_EXPM1L)/g' \
-e 's/@''GNULIB_FABSF''@/$(GNULIB_FABSF)/g' \
+ -e 's/@''GNULIB_FABSL''@/$(GNULIB_FABSL)/g' \
-e 's/@''GNULIB_FLOOR''@/$(GNULIB_FLOOR)/g' \
-e 's/@''GNULIB_FLOORF''@/$(GNULIB_FLOORF)/g' \
-e 's/@''GNULIB_FLOORL''@/$(GNULIB_FLOORL)/g' \
-e 's/@''GNULIB_FMA''@/$(GNULIB_FMA)/g' \
-e 's/@''GNULIB_FMAF''@/$(GNULIB_FMAF)/g' \
-e 's/@''GNULIB_FMAL''@/$(GNULIB_FMAL)/g' \
+ -e 's/@''GNULIB_FMOD''@/$(GNULIB_FMOD)/g' \
-e 's/@''GNULIB_FMODF''@/$(GNULIB_FMODF)/g' \
+ -e 's/@''GNULIB_FMODL''@/$(GNULIB_FMODL)/g' \
-e 's/@''GNULIB_FREXPF''@/$(GNULIB_FREXPF)/g' \
-e 's/@''GNULIB_FREXP''@/$(GNULIB_FREXP)/g' \
-e 's/@''GNULIB_FREXPL''@/$(GNULIB_FREXPL)/g' \
+ -e 's/@''GNULIB_HYPOT''@/$(GNULIB_HYPOT)/g' \
+ -e 's/@''GNULIB_HYPOTF''@/$(GNULIB_HYPOTF)/g' \
+ -e 's/@''GNULIB_HYPOTL''@/$(GNULIB_HYPOTL)/g' \
+ < $(srcdir)/math.in.h | \
+ sed -e 's/@''GNULIB_ILOGB''@/$(GNULIB_ILOGB)/g' \
+ -e 's/@''GNULIB_ILOGBF''@/$(GNULIB_ILOGBF)/g' \
+ -e 's/@''GNULIB_ILOGBL''@/$(GNULIB_ILOGBL)/g' \
-e 's/@''GNULIB_ISFINITE''@/$(GNULIB_ISFINITE)/g' \
-e 's/@''GNULIB_ISINF''@/$(GNULIB_ISINF)/g' \
-e 's/@''GNULIB_ISNAN''@/$(GNULIB_ISNAN)/g' \
@@ -1021,12 +1073,28 @@ math.h: math.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's/@''GNULIB_ISNANL''@/$(GNULIB_ISNANL)/g' \
-e 's/@''GNULIB_LDEXPF''@/$(GNULIB_LDEXPF)/g' \
-e 's/@''GNULIB_LDEXPL''@/$(GNULIB_LDEXPL)/g' \
- -e 's/@''GNULIB_LOGB''@/$(GNULIB_LOGB)/g' \
+ -e 's/@''GNULIB_LOG''@/$(GNULIB_LOG)/g' \
-e 's/@''GNULIB_LOGF''@/$(GNULIB_LOGF)/g' \
-e 's/@''GNULIB_LOGL''@/$(GNULIB_LOGL)/g' \
+ -e 's/@''GNULIB_LOG10''@/$(GNULIB_LOG10)/g' \
-e 's/@''GNULIB_LOG10F''@/$(GNULIB_LOG10F)/g' \
+ -e 's/@''GNULIB_LOG10L''@/$(GNULIB_LOG10L)/g' \
+ -e 's/@''GNULIB_LOG1P''@/$(GNULIB_LOG1P)/g' \
+ -e 's/@''GNULIB_LOG1PF''@/$(GNULIB_LOG1PF)/g' \
+ -e 's/@''GNULIB_LOG1PL''@/$(GNULIB_LOG1PL)/g' \
+ -e 's/@''GNULIB_LOG2''@/$(GNULIB_LOG2)/g' \
+ -e 's/@''GNULIB_LOG2F''@/$(GNULIB_LOG2F)/g' \
+ -e 's/@''GNULIB_LOG2L''@/$(GNULIB_LOG2L)/g' \
+ -e 's/@''GNULIB_LOGB''@/$(GNULIB_LOGB)/g' \
+ -e 's/@''GNULIB_LOGBF''@/$(GNULIB_LOGBF)/g' \
+ -e 's/@''GNULIB_LOGBL''@/$(GNULIB_LOGBL)/g' \
+ -e 's/@''GNULIB_MODF''@/$(GNULIB_MODF)/g' \
-e 's/@''GNULIB_MODFF''@/$(GNULIB_MODFF)/g' \
+ -e 's/@''GNULIB_MODFL''@/$(GNULIB_MODFL)/g' \
-e 's/@''GNULIB_POWF''@/$(GNULIB_POWF)/g' \
+ -e 's/@''GNULIB_REMAINDER''@/$(GNULIB_REMAINDER)/g' \
+ -e 's/@''GNULIB_REMAINDERF''@/$(GNULIB_REMAINDERF)/g' \
+ -e 's/@''GNULIB_REMAINDERL''@/$(GNULIB_REMAINDERL)/g' \
-e 's/@''GNULIB_RINT''@/$(GNULIB_RINT)/g' \
-e 's/@''GNULIB_RINTF''@/$(GNULIB_RINTF)/g' \
-e 's/@''GNULIB_RINTL''@/$(GNULIB_RINTL)/g' \
@@ -1045,7 +1113,7 @@ math.h: math.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's/@''GNULIB_TRUNC''@/$(GNULIB_TRUNC)/g' \
-e 's/@''GNULIB_TRUNCF''@/$(GNULIB_TRUNCF)/g' \
-e 's/@''GNULIB_TRUNCL''@/$(GNULIB_TRUNCL)/g' \
- < $(srcdir)/math.in.h | \
+ | \
sed -e 's|@''HAVE_ACOSF''@|$(HAVE_ACOSF)|g' \
-e 's|@''HAVE_ACOSL''@|$(HAVE_ACOSL)|g' \
-e 's|@''HAVE_ASINF''@|$(HAVE_ASINF)|g' \
@@ -1053,20 +1121,31 @@ math.h: math.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's|@''HAVE_ATANF''@|$(HAVE_ATANF)|g' \
-e 's|@''HAVE_ATANL''@|$(HAVE_ATANL)|g' \
-e 's|@''HAVE_ATAN2F''@|$(HAVE_ATAN2F)|g' \
+ -e 's|@''HAVE_CBRT''@|$(HAVE_CBRT)|g' \
+ -e 's|@''HAVE_CBRTF''@|$(HAVE_CBRTF)|g' \
+ -e 's|@''HAVE_CBRTL''@|$(HAVE_CBRTL)|g' \
-e 's|@''HAVE_COPYSIGN''@|$(HAVE_COPYSIGN)|g' \
- -e 's|@''HAVE_COPYSIGNF''@|$(HAVE_COPYSIGNF)|g' \
-e 's|@''HAVE_COPYSIGNL''@|$(HAVE_COPYSIGNL)|g' \
-e 's|@''HAVE_COSF''@|$(HAVE_COSF)|g' \
-e 's|@''HAVE_COSL''@|$(HAVE_COSL)|g' \
-e 's|@''HAVE_COSHF''@|$(HAVE_COSHF)|g' \
-e 's|@''HAVE_EXPF''@|$(HAVE_EXPF)|g' \
-e 's|@''HAVE_EXPL''@|$(HAVE_EXPL)|g' \
+ -e 's|@''HAVE_EXPM1''@|$(HAVE_EXPM1)|g' \
+ -e 's|@''HAVE_EXPM1F''@|$(HAVE_EXPM1F)|g' \
-e 's|@''HAVE_FABSF''@|$(HAVE_FABSF)|g' \
+ -e 's|@''HAVE_FABSL''@|$(HAVE_FABSL)|g' \
-e 's|@''HAVE_FMA''@|$(HAVE_FMA)|g' \
-e 's|@''HAVE_FMAF''@|$(HAVE_FMAF)|g' \
-e 's|@''HAVE_FMAL''@|$(HAVE_FMAL)|g' \
-e 's|@''HAVE_FMODF''@|$(HAVE_FMODF)|g' \
+ -e 's|@''HAVE_FMODL''@|$(HAVE_FMODL)|g' \
-e 's|@''HAVE_FREXPF''@|$(HAVE_FREXPF)|g' \
+ -e 's|@''HAVE_HYPOTF''@|$(HAVE_HYPOTF)|g' \
+ -e 's|@''HAVE_HYPOTL''@|$(HAVE_HYPOTL)|g' \
+ -e 's|@''HAVE_ILOGB''@|$(HAVE_ILOGB)|g' \
+ -e 's|@''HAVE_ILOGBF''@|$(HAVE_ILOGBF)|g' \
+ -e 's|@''HAVE_ILOGBL''@|$(HAVE_ILOGBL)|g' \
-e 's|@''HAVE_ISNANF''@|$(HAVE_ISNANF)|g' \
-e 's|@''HAVE_ISNAND''@|$(HAVE_ISNAND)|g' \
-e 's|@''HAVE_ISNANL''@|$(HAVE_ISNANL)|g' \
@@ -1074,10 +1153,18 @@ math.h: math.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's|@''HAVE_LOGF''@|$(HAVE_LOGF)|g' \
-e 's|@''HAVE_LOGL''@|$(HAVE_LOGL)|g' \
-e 's|@''HAVE_LOG10F''@|$(HAVE_LOG10F)|g' \
+ -e 's|@''HAVE_LOG10L''@|$(HAVE_LOG10L)|g' \
+ -e 's|@''HAVE_LOG1P''@|$(HAVE_LOG1P)|g' \
+ -e 's|@''HAVE_LOG1PF''@|$(HAVE_LOG1PF)|g' \
+ -e 's|@''HAVE_LOG1PL''@|$(HAVE_LOG1PL)|g' \
+ -e 's|@''HAVE_LOGBF''@|$(HAVE_LOGBF)|g' \
+ -e 's|@''HAVE_LOGBL''@|$(HAVE_LOGBL)|g' \
-e 's|@''HAVE_MODFF''@|$(HAVE_MODFF)|g' \
+ -e 's|@''HAVE_MODFL''@|$(HAVE_MODFL)|g' \
-e 's|@''HAVE_POWF''@|$(HAVE_POWF)|g' \
+ -e 's|@''HAVE_REMAINDER''@|$(HAVE_REMAINDER)|g' \
+ -e 's|@''HAVE_REMAINDERF''@|$(HAVE_REMAINDERF)|g' \
-e 's|@''HAVE_RINT''@|$(HAVE_RINT)|g' \
- -e 's|@''HAVE_RINTF''@|$(HAVE_RINTF)|g' \
-e 's|@''HAVE_RINTL''@|$(HAVE_RINTL)|g' \
-e 's|@''HAVE_SINF''@|$(HAVE_SINF)|g' \
-e 's|@''HAVE_SINL''@|$(HAVE_SINL)|g' \
@@ -1090,16 +1177,30 @@ math.h: math.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's|@''HAVE_DECL_ACOSL''@|$(HAVE_DECL_ACOSL)|g' \
-e 's|@''HAVE_DECL_ASINL''@|$(HAVE_DECL_ASINL)|g' \
-e 's|@''HAVE_DECL_ATANL''@|$(HAVE_DECL_ATANL)|g' \
+ -e 's|@''HAVE_DECL_CBRTF''@|$(HAVE_DECL_CBRTF)|g' \
+ -e 's|@''HAVE_DECL_CBRTL''@|$(HAVE_DECL_CBRTL)|g' \
-e 's|@''HAVE_DECL_CEILF''@|$(HAVE_DECL_CEILF)|g' \
-e 's|@''HAVE_DECL_CEILL''@|$(HAVE_DECL_CEILL)|g' \
+ -e 's|@''HAVE_DECL_COPYSIGNF''@|$(HAVE_DECL_COPYSIGNF)|g' \
-e 's|@''HAVE_DECL_COSL''@|$(HAVE_DECL_COSL)|g' \
-e 's|@''HAVE_DECL_EXPL''@|$(HAVE_DECL_EXPL)|g' \
+ -e 's|@''HAVE_DECL_EXP2''@|$(HAVE_DECL_EXP2)|g' \
+ -e 's|@''HAVE_DECL_EXP2F''@|$(HAVE_DECL_EXP2F)|g' \
+ -e 's|@''HAVE_DECL_EXP2L''@|$(HAVE_DECL_EXP2L)|g' \
+ -e 's|@''HAVE_DECL_EXPM1L''@|$(HAVE_DECL_EXPM1L)|g' \
-e 's|@''HAVE_DECL_FLOORF''@|$(HAVE_DECL_FLOORF)|g' \
-e 's|@''HAVE_DECL_FLOORL''@|$(HAVE_DECL_FLOORL)|g' \
-e 's|@''HAVE_DECL_FREXPL''@|$(HAVE_DECL_FREXPL)|g' \
-e 's|@''HAVE_DECL_LDEXPL''@|$(HAVE_DECL_LDEXPL)|g' \
- -e 's|@''HAVE_DECL_LOGB''@|$(HAVE_DECL_LOGB)|g' \
-e 's|@''HAVE_DECL_LOGL''@|$(HAVE_DECL_LOGL)|g' \
+ -e 's|@''HAVE_DECL_LOG10L''@|$(HAVE_DECL_LOG10L)|g' \
+ -e 's|@''HAVE_DECL_LOG2''@|$(HAVE_DECL_LOG2)|g' \
+ -e 's|@''HAVE_DECL_LOG2F''@|$(HAVE_DECL_LOG2F)|g' \
+ -e 's|@''HAVE_DECL_LOG2L''@|$(HAVE_DECL_LOG2L)|g' \
+ -e 's|@''HAVE_DECL_LOGB''@|$(HAVE_DECL_LOGB)|g' \
+ -e 's|@''HAVE_DECL_REMAINDER''@|$(HAVE_DECL_REMAINDER)|g' \
+ -e 's|@''HAVE_DECL_REMAINDERL''@|$(HAVE_DECL_REMAINDERL)|g' \
+ -e 's|@''HAVE_DECL_RINTF''@|$(HAVE_DECL_RINTF)|g' \
-e 's|@''HAVE_DECL_ROUND''@|$(HAVE_DECL_ROUND)|g' \
-e 's|@''HAVE_DECL_ROUNDF''@|$(HAVE_DECL_ROUNDF)|g' \
-e 's|@''HAVE_DECL_ROUNDL''@|$(HAVE_DECL_ROUNDL)|g' \
@@ -1110,30 +1211,67 @@ math.h: math.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's|@''HAVE_DECL_TRUNCF''@|$(HAVE_DECL_TRUNCF)|g' \
-e 's|@''HAVE_DECL_TRUNCL''@|$(HAVE_DECL_TRUNCL)|g' \
| \
- sed -e 's|@''REPLACE_CEIL''@|$(REPLACE_CEIL)|g' \
+ sed -e 's|@''REPLACE_CBRTF''@|$(REPLACE_CBRTF)|g' \
+ -e 's|@''REPLACE_CBRTL''@|$(REPLACE_CBRTL)|g' \
+ -e 's|@''REPLACE_CEIL''@|$(REPLACE_CEIL)|g' \
-e 's|@''REPLACE_CEILF''@|$(REPLACE_CEILF)|g' \
-e 's|@''REPLACE_CEILL''@|$(REPLACE_CEILL)|g' \
+ -e 's|@''REPLACE_EXPM1''@|$(REPLACE_EXPM1)|g' \
+ -e 's|@''REPLACE_EXPM1F''@|$(REPLACE_EXPM1F)|g' \
+ -e 's|@''REPLACE_EXP2''@|$(REPLACE_EXP2)|g' \
+ -e 's|@''REPLACE_EXP2L''@|$(REPLACE_EXP2L)|g' \
+ -e 's|@''REPLACE_FABSL''@|$(REPLACE_FABSL)|g' \
-e 's|@''REPLACE_FLOOR''@|$(REPLACE_FLOOR)|g' \
-e 's|@''REPLACE_FLOORF''@|$(REPLACE_FLOORF)|g' \
-e 's|@''REPLACE_FLOORL''@|$(REPLACE_FLOORL)|g' \
-e 's|@''REPLACE_FMA''@|$(REPLACE_FMA)|g' \
-e 's|@''REPLACE_FMAF''@|$(REPLACE_FMAF)|g' \
-e 's|@''REPLACE_FMAL''@|$(REPLACE_FMAL)|g' \
+ -e 's|@''REPLACE_FMOD''@|$(REPLACE_FMOD)|g' \
+ -e 's|@''REPLACE_FMODF''@|$(REPLACE_FMODF)|g' \
+ -e 's|@''REPLACE_FMODL''@|$(REPLACE_FMODL)|g' \
-e 's|@''REPLACE_FREXPF''@|$(REPLACE_FREXPF)|g' \
-e 's|@''REPLACE_FREXP''@|$(REPLACE_FREXP)|g' \
-e 's|@''REPLACE_FREXPL''@|$(REPLACE_FREXPL)|g' \
-e 's|@''REPLACE_HUGE_VAL''@|$(REPLACE_HUGE_VAL)|g' \
+ -e 's|@''REPLACE_HYPOT''@|$(REPLACE_HYPOT)|g' \
+ -e 's|@''REPLACE_HYPOTF''@|$(REPLACE_HYPOTF)|g' \
+ -e 's|@''REPLACE_HYPOTL''@|$(REPLACE_HYPOTL)|g' \
+ -e 's|@''REPLACE_ILOGB''@|$(REPLACE_ILOGB)|g' \
+ -e 's|@''REPLACE_ILOGBF''@|$(REPLACE_ILOGBF)|g' \
-e 's|@''REPLACE_ISFINITE''@|$(REPLACE_ISFINITE)|g' \
-e 's|@''REPLACE_ISINF''@|$(REPLACE_ISINF)|g' \
-e 's|@''REPLACE_ISNAN''@|$(REPLACE_ISNAN)|g' \
-e 's|@''REPLACE_ITOLD''@|$(REPLACE_ITOLD)|g' \
-e 's|@''REPLACE_LDEXPL''@|$(REPLACE_LDEXPL)|g' \
+ -e 's|@''REPLACE_LOG''@|$(REPLACE_LOG)|g' \
+ -e 's|@''REPLACE_LOGF''@|$(REPLACE_LOGF)|g' \
+ -e 's|@''REPLACE_LOGL''@|$(REPLACE_LOGL)|g' \
+ -e 's|@''REPLACE_LOG10''@|$(REPLACE_LOG10)|g' \
+ -e 's|@''REPLACE_LOG10F''@|$(REPLACE_LOG10F)|g' \
+ -e 's|@''REPLACE_LOG10L''@|$(REPLACE_LOG10L)|g' \
+ -e 's|@''REPLACE_LOG1P''@|$(REPLACE_LOG1P)|g' \
+ -e 's|@''REPLACE_LOG1PF''@|$(REPLACE_LOG1PF)|g' \
+ -e 's|@''REPLACE_LOG1PL''@|$(REPLACE_LOG1PL)|g' \
+ -e 's|@''REPLACE_LOG2''@|$(REPLACE_LOG2)|g' \
+ -e 's|@''REPLACE_LOG2F''@|$(REPLACE_LOG2F)|g' \
+ -e 's|@''REPLACE_LOG2L''@|$(REPLACE_LOG2L)|g' \
+ -e 's|@''REPLACE_LOGB''@|$(REPLACE_LOGB)|g' \
+ -e 's|@''REPLACE_LOGBF''@|$(REPLACE_LOGBF)|g' \
+ -e 's|@''REPLACE_LOGBL''@|$(REPLACE_LOGBL)|g' \
+ -e 's|@''REPLACE_MODF''@|$(REPLACE_MODF)|g' \
+ -e 's|@''REPLACE_MODFF''@|$(REPLACE_MODFF)|g' \
+ -e 's|@''REPLACE_MODFL''@|$(REPLACE_MODFL)|g' \
-e 's|@''REPLACE_NAN''@|$(REPLACE_NAN)|g' \
+ -e 's|@''REPLACE_REMAINDER''@|$(REPLACE_REMAINDER)|g' \
+ -e 's|@''REPLACE_REMAINDERF''@|$(REPLACE_REMAINDERF)|g' \
+ -e 's|@''REPLACE_REMAINDERL''@|$(REPLACE_REMAINDERL)|g' \
-e 's|@''REPLACE_ROUND''@|$(REPLACE_ROUND)|g' \
-e 's|@''REPLACE_ROUNDF''@|$(REPLACE_ROUNDF)|g' \
-e 's|@''REPLACE_ROUNDL''@|$(REPLACE_ROUNDL)|g' \
-e 's|@''REPLACE_SIGNBIT''@|$(REPLACE_SIGNBIT)|g' \
-e
's|@''REPLACE_SIGNBIT_USING_GCC''@|$(REPLACE_SIGNBIT_USING_GCC)|g' \
+ -e 's|@''REPLACE_SQRTL''@|$(REPLACE_SQRTL)|g' \
-e 's|@''REPLACE_TRUNC''@|$(REPLACE_TRUNC)|g' \
-e 's|@''REPLACE_TRUNCF''@|$(REPLACE_TRUNCF)|g' \
-e 's|@''REPLACE_TRUNCL''@|$(REPLACE_TRUNCL)|g' \
@@ -1387,6 +1525,15 @@ EXTRA_libgnu_la_SOURCES += rmdir.c
## end gnulib module rmdir
+## begin gnulib module round
+
+
+EXTRA_DIST += round.c
+
+EXTRA_libgnu_la_SOURCES += round.c
+
+## end gnulib module round
+
## begin gnulib module safe-read
libgnu_la_SOURCES += safe-read.c
@@ -1817,7 +1964,6 @@ stdio.h: stdio.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H)
-e 's/@''GNULIB_GETCHAR''@/$(GNULIB_GETCHAR)/g' \
-e 's/@''GNULIB_GETDELIM''@/$(GNULIB_GETDELIM)/g' \
-e 's/@''GNULIB_GETLINE''@/$(GNULIB_GETLINE)/g' \
- -e 's/@''GNULIB_GETS''@/$(GNULIB_GETS)/g' \
-e 's/@''GNULIB_OBSTACK_PRINTF''@/$(GNULIB_OBSTACK_PRINTF)/g' \
-e
's/@''GNULIB_OBSTACK_PRINTF_POSIX''@/$(GNULIB_OBSTACK_PRINTF_POSIX)/g' \
-e 's/@''GNULIB_PCLOSE''@/$(GNULIB_PCLOSE)/g' \
@@ -2008,15 +2154,6 @@ EXTRA_DIST += stdlib.in.h
## end gnulib module stdlib
-## begin gnulib module strcase
-
-
-EXTRA_DIST += strcasecmp.c strncasecmp.c
-
-EXTRA_libgnu_la_SOURCES += strcasecmp.c strncasecmp.c
-
-## end gnulib module strcase
-
## begin gnulib module streq
@@ -2143,37 +2280,6 @@ EXTRA_DIST += string.in.h
## end gnulib module string
-## begin gnulib module strings
-
-BUILT_SOURCES += strings.h
-
-# We need the following in order to create <strings.h> when the system
-# doesn't have one that works with the given compiler.
-strings.h: strings.in.h $(top_builddir)/config.status $(CXXDEFS_H)
$(WARN_ON_USE_H) $(ARG_NONNULL_H)
- $(AM_V_GEN)rm -f address@hidden $@ && \
- { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \
- sed -e 's|@''GUARD_PREFIX''@|GL|g' \
- -e 's|@''HAVE_STRINGS_H''@|$(HAVE_STRINGS_H)|g' \
- -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \
- -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
- -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
- -e 's|@''NEXT_STRINGS_H''@|$(NEXT_STRINGS_H)|g' \
- -e 's|@''GNULIB_FFS''@|$(GNULIB_FFS)|g' \
- -e 's|@''HAVE_FFS''@|$(HAVE_FFS)|g' \
- -e 's|@''HAVE_STRCASECMP''@|$(HAVE_STRCASECMP)|g' \
- -e 's|@''HAVE_DECL_STRNCASECMP''@|$(HAVE_DECL_STRNCASECMP)|g' \
- -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
- -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
- -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
- < $(srcdir)/strings.in.h; \
- } > address@hidden && \
- mv address@hidden $@
-MOSTLYCLEANFILES += strings.h strings.h-t
-
-EXTRA_DIST += strings.in.h
-
-## end gnulib module strings
-
## begin gnulib module sys_file
BUILT_SOURCES += sys/file.h
@@ -2269,6 +2375,7 @@ sys/stat.h: sys_stat.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNU
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
-e 's|@''NEXT_SYS_STAT_H''@|$(NEXT_SYS_STAT_H)|g' \
+ -e 's|@''WINDOWS_64_BIT_ST_SIZE''@|$(WINDOWS_64_BIT_ST_SIZE)|g' \
-e 's/@''GNULIB_FCHMODAT''@/$(GNULIB_FCHMODAT)/g' \
-e 's/@''GNULIB_FSTAT''@/$(GNULIB_FSTAT)/g' \
-e 's/@''GNULIB_FSTATAT''@/$(GNULIB_FSTATAT)/g' \
@@ -2336,6 +2443,7 @@ sys/time.h: sys_time.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNU
-e 's/@''HAVE_GETTIMEOFDAY''@/$(HAVE_GETTIMEOFDAY)/g' \
-e 's/@''HAVE_STRUCT_TIMEVAL''@/$(HAVE_STRUCT_TIMEVAL)/g' \
-e 's/@''REPLACE_GETTIMEOFDAY''@/$(REPLACE_GETTIMEOFDAY)/g' \
+ -e 's/@''REPLACE_STRUCT_TIMEVAL''@/$(REPLACE_STRUCT_TIMEVAL)/g' \
-e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
-e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
-e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \
@@ -2363,6 +2471,7 @@ sys/types.h: sys_types.in.h $(top_builddir)/config.status
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
-e 's|@''NEXT_SYS_TYPES_H''@|$(NEXT_SYS_TYPES_H)|g' \
+ -e 's|@''WINDOWS_64_BIT_OFF_T''@|$(WINDOWS_64_BIT_OFF_T)|g' \
< $(srcdir)/sys_types.in.h; \
} > address@hidden && \
mv address@hidden $@
@@ -2473,6 +2582,7 @@ unistd.h: unistd.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \
-e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \
-e 's|@''NEXT_UNISTD_H''@|$(NEXT_UNISTD_H)|g' \
+ -e 's|@''WINDOWS_64_BIT_OFF_T''@|$(WINDOWS_64_BIT_OFF_T)|g' \
-e 's/@''GNULIB_CHDIR''@/$(GNULIB_CHDIR)/g' \
-e 's/@''GNULIB_CHOWN''@/$(GNULIB_CHOWN)/g' \
-e 's/@''GNULIB_CLOSE''@/$(GNULIB_CLOSE)/g' \
@@ -2571,6 +2681,7 @@ unistd.h: unistd.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''REPLACE_DUP''@|$(REPLACE_DUP)|g' \
-e 's|@''REPLACE_DUP2''@|$(REPLACE_DUP2)|g' \
-e 's|@''REPLACE_FCHOWNAT''@|$(REPLACE_FCHOWNAT)|g' \
+ -e 's|@''REPLACE_FTRUNCATE''@|$(REPLACE_FTRUNCATE)|g' \
-e 's|@''REPLACE_GETCWD''@|$(REPLACE_GETCWD)|g' \
-e 's|@''REPLACE_GETDOMAINNAME''@|$(REPLACE_GETDOMAINNAME)|g' \
-e 's|@''REPLACE_GETLOGIN_R''@|$(REPLACE_GETLOGIN_R)|g' \
diff --git a/lib/alignof.h b/lib/alignof.h
index 17942ea..b6d8666 100644
--- a/lib/alignof.h
+++ b/lib/alignof.h
@@ -12,8 +12,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _ALIGNOF_H
#define _ALIGNOF_H
diff --git a/lib/alloca.in.h b/lib/alloca.in.h
index fe95954..c36bdf9 100644
--- a/lib/alloca.in.h
+++ b/lib/alloca.in.h
@@ -14,9 +14,9 @@
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. */
+ License along with this program; if not, see
+ <http://www.gnu.org/licenses/>.
+ */
/* Avoid using the symbol _ALLOCA_H here, as Bison assumes _ALLOCA_H
means there is a real alloca function. */
@@ -44,6 +44,13 @@
# define alloca _alloca
# elif defined __DECC && defined __VMS
# define alloca __ALLOCA
+# elif defined __TANDEM && defined _TNS_E_TARGET
+# ifdef __cplusplus
+extern "C"
+# endif
+void *_alloca (unsigned short);
+# pragma intrinsic (_alloca)
+# define alloca _alloca
# else
# include <stddef.h>
# ifdef __cplusplus
diff --git a/lib/arpa_inet.in.h b/lib/arpa_inet.in.h
index 4295f67..e580723 100644
--- a/lib/arpa_inet.in.h
+++ b/lib/arpa_inet.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef address@hidden@_ARPA_INET_H
diff --git a/lib/asnprintf.c b/lib/asnprintf.c
index 1120bed..778068f 100644
--- a/lib/asnprintf.c
+++ b/lib/asnprintf.c
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/binary-io.h b/lib/binary-io.h
index 00a78f0..77cbd4e 100644
--- a/lib/binary-io.h
+++ b/lib/binary-io.h
@@ -25,28 +25,41 @@
so we include it here first. */
#include <stdio.h>
-/* SET_BINARY (fd);
- changes the file descriptor fd to perform binary I/O. */
+/* set_binary_mode (fd, mode)
+ sets the binary/text I/O mode of file descriptor fd to the given mode
+ (must be O_BINARY or O_TEXT) and returns the previous mode. */
#if O_BINARY
# if defined __EMX__ || defined __DJGPP__ || defined __CYGWIN__
# include <io.h> /* declares setmode() */
+# define set_binary_mode setmode
# else
-# define setmode _setmode
+# define set_binary_mode _setmode
# undef fileno
# define fileno _fileno
# endif
-# ifdef __DJGPP__
-# include <unistd.h> /* declares isatty() */
- /* Avoid putting stdin/stdout in binary mode if it is connected to
- the console, because that would make it impossible for the user
- to interrupt the program through Ctrl-C or Ctrl-Break. */
-# define SET_BINARY(fd) ((void) (!isatty (fd) ? (setmode (fd, O_BINARY), 0) :
0))
-# else
-# define SET_BINARY(fd) ((void) setmode (fd, O_BINARY))
-# endif
#else
- /* On reasonable systems, binary I/O is the default. */
-# define SET_BINARY(fd) /* do nothing */ ((void) 0)
+ /* On reasonable systems, binary I/O is the only choice. */
+ /* Use an inline function rather than a macro, to avoid gcc warnings
+ "warning: statement with no effect". */
+static inline int
+set_binary_mode (int fd, int mode)
+{
+ (void) fd;
+ (void) mode;
+ return O_BINARY;
+}
+#endif
+
+/* SET_BINARY (fd);
+ changes the file descriptor fd to perform binary I/O. */
+#ifdef __DJGPP__
+# include <unistd.h> /* declares isatty() */
+ /* Avoid putting stdin/stdout in binary mode if it is connected to
+ the console, because that would make it impossible for the user
+ to interrupt the program through Ctrl-C or Ctrl-Break. */
+# define SET_BINARY(fd) ((void) (!isatty (fd) ? (set_binary_mode (fd,
O_BINARY), 0) : 0))
+#else
+# define SET_BINARY(fd) ((void) set_binary_mode (fd, O_BINARY))
#endif
#endif /* _BINARY_H */
diff --git a/lib/c-ctype.c b/lib/c-ctype.c
index 512bcdc..6b388fa 100644
--- a/lib/c-ctype.c
+++ b/lib/c-ctype.c
@@ -13,8 +13,7 @@ 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. */
+along with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/c-ctype.h b/lib/c-ctype.h
index aa3c964..6ef0550 100644
--- a/lib/c-ctype.h
+++ b/lib/c-ctype.h
@@ -18,8 +18,7 @@ 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. */
+along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef C_CTYPE_H
#define C_CTYPE_H
diff --git a/lib/c-strcase.h b/lib/c-strcase.h
index 3b92ba9..4d8b60c 100644
--- a/lib/c-strcase.h
+++ b/lib/c-strcase.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef C_STRCASE_H
#define C_STRCASE_H
diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c
index c8e0706..6983195 100644
--- a/lib/c-strcasecmp.c
+++ b/lib/c-strcasecmp.c
@@ -12,8 +12,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c
index 32ced38..dbec89e 100644
--- a/lib/c-strncasecmp.c
+++ b/lib/c-strncasecmp.c
@@ -12,8 +12,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c
index 9b03dc6..16550cf 100644
--- a/lib/canonicalize-lgpl.c
+++ b/lib/canonicalize-lgpl.c
@@ -156,8 +156,12 @@ __realpath (const char *name, char *resolved)
{
rpath[0] = '/';
dest = rpath + 1;
- if (DOUBLE_SLASH_IS_DISTINCT_ROOT && name[1] == '/')
- *dest++ = '/';
+ if (DOUBLE_SLASH_IS_DISTINCT_ROOT)
+ {
+ if (name[1] == '/' && name[2] != '/')
+ *dest++ = '/';
+ *dest = '\0';
+ }
}
for (start = end = name; *start; start = end)
@@ -187,7 +191,7 @@ __realpath (const char *name, char *resolved)
if (dest > rpath + 1)
while ((--dest)[-1] != '/');
if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1
- && *dest == '/')
+ && *dest == '/' && dest[1] != '/')
dest++;
}
else
@@ -298,8 +302,12 @@ __realpath (const char *name, char *resolved)
if (buf[0] == '/')
{
dest = rpath + 1; /* It's an absolute symlink */
- if (DOUBLE_SLASH_IS_DISTINCT_ROOT && buf[1] == '/')
- *dest++ = '/';
+ if (DOUBLE_SLASH_IS_DISTINCT_ROOT)
+ {
+ if (buf[1] == '/' && buf[2] != '/')
+ *dest++ = '/';
+ *dest = '\0';
+ }
}
else
{
@@ -308,7 +316,7 @@ __realpath (const char *name, char *resolved)
if (dest > rpath + 1)
while ((--dest)[-1] != '/');
if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1
- && *dest == '/')
+ && *dest == '/' && dest[1] != '/')
dest++;
}
}
@@ -321,7 +329,8 @@ __realpath (const char *name, char *resolved)
}
if (dest > rpath + 1 && dest[-1] == '/')
--dest;
- if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1 && *dest == '/')
+ if (DOUBLE_SLASH_IS_DISTINCT_ROOT && dest == rpath + 1
+ && *dest == '/' && dest[1] != '/')
dest++;
*dest = '\0';
diff --git a/lib/ceil.c b/lib/ceil.c
index 58c3adf..810179c 100644
--- a/lib/ceil.c
+++ b/lib/ceil.c
@@ -54,6 +54,12 @@
# define MINUS_ZERO L_(-0.0)
#endif
+/* MSVC with option -fp:strict refuses to compile constant initializers that
+ contain floating-point operations. Pacify this compiler. */
+#ifdef _MSC_VER
+# pragma fenv_access (off)
+#endif
+
/* 2^(MANT_DIG-1). */
static const DOUBLE TWO_MANT_DIG =
/* Assume MANT_DIG <= 5 * 31.
diff --git a/lib/config.charset b/lib/config.charset
index d771048..58ac759 100644
--- a/lib/config.charset
+++ b/lib/config.charset
@@ -14,8 +14,7 @@
# 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.
+# with this program; if not, see <http://www.gnu.org/licenses/>.
#
# The table consists of lines of the form
# ALIAS CANONICAL
@@ -30,7 +29,7 @@
# The current list of GNU canonical charset names is as follows.
#
# name MIME? used by which systems
-# (darwin = MacOS X, woe32 = native Windows)
+# (darwin = Mac OS X, woe32 = native
Windows)
#
# ASCII, ANSI_X3.4-1968 glibc solaris freebsd netbsd darwin cygwin
# ISO-8859-1 Y glibc aix hpux irix osf solaris freebsd netbsd
openbsd darwin cygwin
diff --git a/lib/dirent.in.h b/lib/dirent.in.h
index ff27059..8882415 100644
--- a/lib/dirent.in.h
+++ b/lib/dirent.in.h
@@ -55,6 +55,14 @@ typedef struct gl_directory DIR;
# endif
#endif
+/* The __attribute__ feature is available in gcc versions 2.5 and later.
+ The attribute __pure__ was added in gcc 2.96. */
+#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96)
+# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__))
+#else
+# define _GL_ATTRIBUTE_PURE /* empty */
+#endif
+
/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
/* The definition of _GL_ARG_NONNULL is copied here. */
@@ -229,6 +237,7 @@ _GL_WARN_ON_USE (scandir, "scandir is unportable - "
# if address@hidden@
_GL_FUNCDECL_SYS (alphasort, int,
(const struct dirent **, const struct dirent **)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2)));
# endif
/* Need to cast, because on glibc systems, the parameters are
diff --git a/lib/errno.in.h b/lib/errno.in.h
index 7135f28..21ba05b 100644
--- a/lib/errno.in.h
+++ b/lib/errno.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef address@hidden@_ERRNO_H
@@ -85,6 +84,16 @@
# define GNULIB_defined_ECANCELED 1
# endif
+# ifndef EOWNERDEAD
+# define EOWNERDEAD 133
+# define GNULIB_defined_EOWNERDEAD 1
+# endif
+
+# ifndef ENOTRECOVERABLE
+# define ENOTRECOVERABLE 127
+# define GNULIB_defined_ENOTRECOVERABLE 1
+# endif
+
# ifndef EINPROGRESS
# define EINPROGRESS 112
# define EALREADY 103
@@ -109,15 +118,17 @@
# define ELOOP 114
# define EHOSTUNREACH 110
# define EWOULDBLOCK 140
+# define GNULIB_defined_ESOCK 1
+# endif
+
+# ifndef ETXTBSY
# define ETXTBSY 139
# define ENODATA 120 /* not required by POSIX */
# define ENOSR 124 /* not required by POSIX */
# define ENOSTR 125 /* not required by POSIX */
-# define ENOTRECOVERABLE 127 /* not required by POSIX */
-# define EOWNERDEAD 133 /* not required by POSIX */
# define ETIME 137 /* not required by POSIX */
# define EOTHER 131 /* not required by POSIX */
-# define GNULIB_defined_ESOCK 1
+# define GNULIB_defined_ESTREAMS 1
# endif
/* These are intentionally the same values as the WSA* error numbers, defined
@@ -228,6 +239,36 @@
# define GNULIB_defined_ECANCELED 1
# endif
+/* On many platforms, the macros EOWNERDEAD and ENOTRECOVERABLE are not
+ defined. */
+
+# ifndef EOWNERDEAD
+# if defined __sun
+ /* Use the same values as defined for Solaris >= 8, for
+ interoperability. */
+# define EOWNERDEAD 58
+# define ENOTRECOVERABLE 59
+# elif (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+ /* We have a conflict here: pthreads-win32 defines these values
+ differently than MSVC 10. It's hairy to decide which one to use. */
+# if defined __MINGW32__ && !defined USE_WINDOWS_THREADS
+ /* Use the same values as defined by pthreads-win32, for
+ interoperability. */
+# define EOWNERDEAD 43
+# define ENOTRECOVERABLE 44
+# else
+ /* Use the same values as defined by MSVC 10, for
+ interoperability. */
+# define EOWNERDEAD 133
+# define ENOTRECOVERABLE 127
+# endif
+# else
+# define EOWNERDEAD 2013
+# define ENOTRECOVERABLE 2014
+# endif
+# define GNULIB_defined_EOWNERDEAD 1
+# define GNULIB_defined_ENOTRECOVERABLE 1
+# endif
#endif /* address@hidden@_ERRNO_H */
#endif /* address@hidden@_ERRNO_H */
diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h
index 56a1f0d..f39dfe5 100644
--- a/lib/fcntl.in.h
+++ b/lib/fcntl.in.h
@@ -25,6 +25,8 @@
#if defined __need_system_fcntl_h
/* Special invocation convention. */
+/* Needed before <sys/stat.h>.
+ May also define off_t to a 64-bit type on native Windows. */
#include <sys/types.h>
/* On some systems other than glibc, <sys/stat.h> is a prerequisite of
<fcntl.h>. On glibc systems, we would like to avoid namespace pollution.
@@ -42,6 +44,8 @@
#ifndef address@hidden@_FCNTL_H
+/* Needed before <sys/stat.h>.
+ May also define off_t to a 64-bit type on native Windows. */
#include <sys/types.h>
/* On some systems other than glibc, <sys/stat.h> is a prerequisite of
<fcntl.h>. On glibc systems, we would like to avoid namespace pollution.
diff --git a/lib/float+.h b/lib/float+.h
index bcb9566..fd4a9ed 100644
--- a/lib/float+.h
+++ b/lib/float+.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _FLOATPLUS_H
#define _FLOATPLUS_H
diff --git a/lib/floor.c b/lib/floor.c
index c6311c8..7efbe9e 100644
--- a/lib/floor.c
+++ b/lib/floor.c
@@ -42,6 +42,12 @@
# define L_(literal) literal##f
#endif
+/* MSVC with option -fp:strict refuses to compile constant initializers that
+ contain floating-point operations. Pacify this compiler. */
+#ifdef _MSC_VER
+# pragma fenv_access (off)
+#endif
+
/* 2^(MANT_DIG-1). */
static const DOUBLE TWO_MANT_DIG =
/* Assume MANT_DIG <= 5 * 31.
diff --git a/lib/fstat.c b/lib/fstat.c
index e0ed800..3f49e9b 100644
--- a/lib/fstat.c
+++ b/lib/fstat.c
@@ -23,6 +23,12 @@
/* Get the original definition of fstat. It might be defined as a macro. */
#include <sys/types.h>
#include <sys/stat.h>
+#if _GL_WINDOWS_64_BIT_ST_SIZE
+# undef stat /* avoid warning on mingw64 with _FILE_OFFSET_BITS=64 */
+# define stat _stati64
+# undef fstat /* avoid warning on mingw64 with _FILE_OFFSET_BITS=64 */
+# define fstat _fstati64
+#endif
#undef __need_system_sys_stat_h
static inline int
diff --git a/lib/gai_strerror.c b/lib/gai_strerror.c
index 41ad0b2..8b36694 100644
--- a/lib/gai_strerror.c
+++ b/lib/gai_strerror.c
@@ -14,8 +14,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _LIBC
# include <config.h>
diff --git a/lib/getaddrinfo.c b/lib/getaddrinfo.c
index 8a34ede..e53a69b 100644
--- a/lib/getaddrinfo.c
+++ b/lib/getaddrinfo.c
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/gettext.h b/lib/gettext.h
index 53ea28e..c7d9740 100644
--- a/lib/gettext.h
+++ b/lib/gettext.h
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _LIBGETTEXT_H
#define _LIBGETTEXT_H 1
diff --git a/lib/iconv.c b/lib/iconv.c
index 8695fe4..de2fb31 100644
--- a/lib/iconv.c
+++ b/lib/iconv.c
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/iconv.in.h b/lib/iconv.in.h
index e492fcc..e150947 100644
--- a/lib/iconv.in.h
+++ b/lib/iconv.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef address@hidden@_ICONV_H
diff --git a/lib/iconv_close.c b/lib/iconv_close.c
index 881e111..d8b027a 100644
--- a/lib/iconv_close.c
+++ b/lib/iconv_close.c
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/iconv_open.c b/lib/iconv_open.c
index 9e4183b..c011241 100644
--- a/lib/iconv_open.c
+++ b/lib/iconv_open.c
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
@@ -57,7 +56,7 @@ rpl_iconv_open (const char *tocode, const char *fromcode)
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.
+ conversion through 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. */
diff --git a/lib/inet_ntop.c b/lib/inet_ntop.c
index c21281b..0ccd997 100644
--- a/lib/inet_ntop.c
+++ b/lib/inet_ntop.c
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/*
* Copyright (c) 1996-1999 by Internet Software Consortium.
diff --git a/lib/isinf.c b/lib/isinf.c
index 8621bfc..5efaa9d 100644
--- a/lib/isinf.c
+++ b/lib/isinf.c
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Ben Pfaff <address@hidden>, 2008. */
diff --git a/lib/langinfo.in.h b/lib/langinfo.in.h
index 807b245..63b92fd 100644
--- a/lib/langinfo.in.h
+++ b/lib/langinfo.in.h
@@ -12,8 +12,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/*
* POSIX <langinfo.h> for platforms that lack it or have an incomplete one.
diff --git a/lib/localcharset.c b/lib/localcharset.c
index 2c06328..ad28ec6 100644
--- a/lib/localcharset.c
+++ b/lib/localcharset.c
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Bruno Haible <address@hidden>. */
@@ -30,7 +29,7 @@
#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 */
+# define DARWIN7 /* Darwin 7 or newer, i.e. Mac OS X 10.3 or newer */
#endif
#if defined _WIN32 || defined __WIN32__
diff --git a/lib/localcharset.h b/lib/localcharset.h
index e7543fe..b4467f6 100644
--- a/lib/localcharset.h
+++ b/lib/localcharset.h
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _LOCALCHARSET_H
#define _LOCALCHARSET_H
diff --git a/lib/locale.in.h b/lib/locale.in.h
index 9d25ae3..89b6745 100644
--- a/lib/locale.in.h
+++ b/lib/locale.in.h
@@ -30,7 +30,7 @@
/* NetBSD 5.0 mis-defines NULL. */
#include <stddef.h>
-/* MacOS X 10.5 defines the locale_t type in <xlocale.h>. */
+/* Mac OS X 10.5 defines the locale_t type in <xlocale.h>. */
#if @HAVE_XLOCALE_H@
# include <xlocale.h>
#endif
@@ -47,6 +47,111 @@
# define LC_MESSAGES 1729
#endif
+/* Bionic libc's 'struct lconv' is just a dummy. */
+#if @REPLACE_STRUCT_LCONV@
+# define lconv rpl_lconv
+struct lconv
+{
+ /* All 'char *' are actually 'const char *'. */
+
+ /* Members that depend on the LC_NUMERIC category of the locale. See
+
<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap07.html#tag_07_03_04>
*/
+
+ /* Symbol used as decimal point. */
+ char *decimal_point;
+ /* Symbol used to separate groups of digits to the left of the decimal
+ point. */
+ char *thousands_sep;
+ /* Definition of the size of groups of digits to the left of the decimal
+ point. */
+ char *grouping;
+
+ /* Members that depend on the LC_MONETARY category of the locale. See
+
<http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap07.html#tag_07_03_03>
*/
+
+ /* Symbol used as decimal point. */
+ char *mon_decimal_point;
+ /* Symbol used to separate groups of digits to the left of the decimal
+ point. */
+ char *mon_thousands_sep;
+ /* Definition of the size of groups of digits to the left of the decimal
+ point. */
+ char *mon_grouping;
+ /* Sign used to indicate a value >= 0. */
+ char *positive_sign;
+ /* Sign used to indicate a value < 0. */
+ char *negative_sign;
+
+ /* For formatting local currency. */
+ /* Currency symbol (3 characters) followed by separator (1 character). */
+ char *currency_symbol;
+ /* Number of digits after the decimal point. */
+ char frac_digits;
+ /* For values >= 0: 1 if the currency symbol precedes the number, 0 if it
+ comes after the number. */
+ char p_cs_precedes;
+ /* For values >= 0: Position of the sign. */
+ char p_sign_posn;
+ /* For values >= 0: Placement of spaces between currency symbol, sign, and
+ number. */
+ char p_sep_by_space;
+ /* For values < 0: 1 if the currency symbol precedes the number, 0 if it
+ comes after the number. */
+ char n_cs_precedes;
+ /* For values < 0: Position of the sign. */
+ char n_sign_posn;
+ /* For values < 0: Placement of spaces between currency symbol, sign, and
+ number. */
+ char n_sep_by_space;
+
+ /* For formatting international currency. */
+ /* Currency symbol (3 characters) followed by separator (1 character). */
+ char *int_curr_symbol;
+ /* Number of digits after the decimal point. */
+ char int_frac_digits;
+ /* For values >= 0: 1 if the currency symbol precedes the number, 0 if it
+ comes after the number. */
+ char int_p_cs_precedes;
+ /* For values >= 0: Position of the sign. */
+ char int_p_sign_posn;
+ /* For values >= 0: Placement of spaces between currency symbol, sign, and
+ number. */
+ char int_p_sep_by_space;
+ /* For values < 0: 1 if the currency symbol precedes the number, 0 if it
+ comes after the number. */
+ char int_n_cs_precedes;
+ /* For values < 0: Position of the sign. */
+ char int_n_sign_posn;
+ /* For values < 0: Placement of spaces between currency symbol, sign, and
+ number. */
+ char int_n_sep_by_space;
+};
+#endif
+
+#if @GNULIB_LOCALECONV@
+# if @REPLACE_LOCALECONV@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef localeconv
+# define localeconv rpl_localeconv
+# endif
+_GL_FUNCDECL_RPL (localeconv, struct lconv *, (void));
+_GL_CXXALIAS_RPL (localeconv, struct lconv *, (void));
+# else
+_GL_CXXALIAS_SYS (localeconv, struct lconv *, (void));
+# endif
+_GL_CXXALIASWARN (localeconv);
+#elif @REPLACE_STRUCT_LCONV@
+# undef localeconv
+# define localeconv localeconv_used_without_requesting_gnulib_module_localeconv
+#elif defined GNULIB_POSIXCHECK
+# undef localeconv
+# if HAVE_RAW_DECL_LOCALECONV
+_GL_WARN_ON_USE (localeconv,
+ "localeconv returns too few information on some platforms - "
+ "use gnulib module localeconv for portability");
+# endif
+#endif
+
#if @GNULIB_SETLOCALE@
# if @REPLACE_SETLOCALE@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
diff --git a/lib/localeconv.c b/lib/localeconv.c
new file mode 100644
index 0000000..c22860c
--- /dev/null
+++ b/lib/localeconv.c
@@ -0,0 +1,103 @@
+/* Query locale dependent information for formatting numbers.
+ Copyright (C) 2012 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/>. */
+
+#include <config.h>
+
+/* Specification. */
+#include <locale.h>
+
+#if HAVE_STRUCT_LCONV_DECIMAL_POINT
+
+/* Override for platforms where 'struct lconv' lacks the int_p_*, int_n_*
+ members. */
+
+struct lconv *
+localeconv (void)
+{
+ static struct lconv result;
+# undef lconv
+# undef localeconv
+ struct lconv *sys_result = localeconv ();
+
+ result.decimal_point = sys_result->decimal_point;
+ result.thousands_sep = sys_result->thousands_sep;
+ result.grouping = sys_result->grouping;
+ result.mon_decimal_point = sys_result->mon_decimal_point;
+ result.mon_thousands_sep = sys_result->mon_thousands_sep;
+ result.mon_grouping = sys_result->mon_grouping;
+ result.positive_sign = sys_result->positive_sign;
+ result.negative_sign = sys_result->negative_sign;
+ result.currency_symbol = sys_result->currency_symbol;
+ result.frac_digits = sys_result->frac_digits;
+ result.p_cs_precedes = sys_result->p_cs_precedes;
+ result.p_sign_posn = sys_result->p_sign_posn;
+ result.p_sep_by_space = sys_result->p_sep_by_space;
+ result.n_cs_precedes = sys_result->n_cs_precedes;
+ result.n_sign_posn = sys_result->n_sign_posn;
+ result.n_sep_by_space = sys_result->n_sep_by_space;
+ result.int_curr_symbol = sys_result->int_curr_symbol;
+ result.int_frac_digits = sys_result->int_frac_digits;
+ result.int_p_cs_precedes = sys_result->p_cs_precedes;
+ result.int_p_sign_posn = sys_result->p_sign_posn;
+ result.int_p_sep_by_space = sys_result->p_sep_by_space;
+ result.int_n_cs_precedes = sys_result->n_cs_precedes;
+ result.int_n_sign_posn = sys_result->n_sign_posn;
+ result.int_n_sep_by_space = sys_result->n_sep_by_space;
+
+ return &result;
+}
+
+#else
+
+/* Override for platforms where 'struct lconv' is a dummy. */
+
+# include <limits.h>
+
+struct lconv *
+localeconv (void)
+{
+ static /*const*/ struct lconv result =
+ {
+ /* decimal_point */ ".",
+ /* thousands_sep */ "",
+ /* grouping */ "",
+ /* mon_decimal_point */ "",
+ /* mon_thousands_sep */ "",
+ /* mon_grouping */ "",
+ /* positive_sign */ "",
+ /* negative_sign */ "",
+ /* currency_symbol */ "",
+ /* frac_digits */ CHAR_MAX,
+ /* p_cs_precedes */ CHAR_MAX,
+ /* p_sign_posn */ CHAR_MAX,
+ /* p_sep_by_space */ CHAR_MAX,
+ /* n_cs_precedes */ CHAR_MAX,
+ /* n_sign_posn */ CHAR_MAX,
+ /* n_sep_by_space */ CHAR_MAX,
+ /* int_curr_symbol */ "",
+ /* int_frac_digits */ CHAR_MAX,
+ /* int_p_cs_precedes */ CHAR_MAX,
+ /* int_p_sign_posn */ CHAR_MAX,
+ /* int_p_sep_by_space */ CHAR_MAX,
+ /* int_n_cs_precedes */ CHAR_MAX,
+ /* int_n_sign_posn */ CHAR_MAX,
+ /* int_n_sep_by_space */ CHAR_MAX
+ };
+
+ return &result;
+}
+
+#endif
diff --git a/lib/btowc.c b/lib/log.c
similarity index 63%
copy from lib/btowc.c
copy to lib/log.c
index 485e995..9ec5eae 100644
--- a/lib/btowc.c
+++ b/lib/log.c
@@ -1,6 +1,5 @@
-/* Convert unibyte character to wide character.
- Copyright (C) 2008, 2010-2012 Free Software Foundation, Inc.
- Written by Bruno Haible <address@hidden>, 2008.
+/* Logarithm.
+ Copyright (C) 2012 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
@@ -18,22 +17,22 @@
#include <config.h>
/* Specification. */
-#include <wchar.h>
+#include <math.h>
-#include <stdio.h>
-#include <stdlib.h>
-
-wint_t
-btowc (int c)
+double
+log (double x)
+#undef log
{
- if (c != EOF)
+ if (x <= 0.0)
{
- char buf[1];
- wchar_t wc;
-
- buf[0] = c;
- if (mbtowc (&wc, buf, 1) >= 0)
- return wc;
+ /* Work around the OSF/1 5.1 bug. */
+ if (x == 0.0)
+ /* Return -Infinity. */
+ return -1.0 / 0.0;
+ /* Work around the NetBSD 5.1, Solaris 11 2011-11 bug. */
+ else /* x < 0.0 */
+ /* Return NaN. */
+ return 0.0 / 0.0;
}
- return WEOF;
+ return log (x);
}
diff --git a/lib/log1p.c b/lib/log1p.c
new file mode 100644
index 0000000..397b140
--- /dev/null
+++ b/lib/log1p.c
@@ -0,0 +1,518 @@
+/* Natural logarithm of 1 plus argument.
+ Copyright (C) 2012 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/>. */
+
+#include <config.h>
+
+/* Specification. */
+#include <math.h>
+
+double
+log1p (double x)
+{
+ if (isnand (x))
+ return x;
+
+ if (x <= -1.0)
+ {
+ if (x == -1.0)
+ /* Return -Infinity. */
+ return - HUGE_VAL;
+ else
+ {
+ /* Return NaN. */
+#if defined _MSC_VER || (defined __sgi && !defined __GNUC__)
+ static double zero;
+ return zero / zero;
+#else
+ return 0.0 / 0.0;
+#endif
+ }
+ }
+
+ if (x < -0.5 || x > 1.0)
+ return log (1.0 + x);
+ /* Here -0.5 <= x <= 1.0. */
+
+ if (x == 0.0)
+ /* Return a zero with the same sign as x. */
+ return x;
+
+ /* Decompose x into
+ 1 + x = (1 + m/256) * (1 + y)
+ where
+ m is an integer, -128 <= m <= 256,
+ y is a number, |y| <= 1/256.
+ y is computed as
+ y = (256 * x - m) / (256 + m).
+ Then
+ log(1+x) = log(m/256) + log(1+y)
+ The first summand is a table lookup.
+ The second summand is computed
+ - either through the power series
+ log(1+y) = y
+ - 1/2 * y^2
+ + 1/3 * y^3
+ - 1/4 * y^4
+ + 1/5 * y^5
+ - 1/6 * y^6
+ + 1/7 * y^7
+ - 1/8 * y^8
+ + 1/9 * y^9
+ - 1/10 * y^10
+ + 1/11 * y^11
+ - 1/12 * y^12
+ + 1/13 * y^13
+ - 1/14 * y^14
+ + 1/15 * y^15
+ - ...
+ - or as log(1+y) = log((1+z)/(1-z)) = 2 * atanh(z)
+ where z = y/(2+y)
+ and atanh(z) is computed through its power series:
+ atanh(z) = z
+ + 1/3 * z^3
+ + 1/5 * z^5
+ + 1/7 * z^7
+ + 1/9 * z^9
+ + 1/11 * z^11
+ + 1/13 * z^13
+ + 1/15 * z^15
+ + ...
+ Since |z| <= 1/511 < 0.002, the relative contribution of the z^9
+ term is < 1/9*0.002^8 < 2^-60 <= 2^-DBL_MANT_DIG, therefore we
+ can truncate the series after the z^7 term. */
+
+ {
+ double m = round (x * 256.0);
+ double y = ((x * 256.0) - m) / (m + 256.0);
+ double z = y / (2.0 + y);
+
+/* Coefficients of the power series for atanh(z). */
+#define ATANH_COEFF_1 1.0
+#define ATANH_COEFF_3 0.333333333333333333333333333333333333334
+#define ATANH_COEFF_5 0.2
+#define ATANH_COEFF_7 0.142857142857142857142857142857142857143
+#define ATANH_COEFF_9 0.1111111111111111111111111111111111111113
+#define ATANH_COEFF_11 0.090909090909090909090909090909090909091
+#define ATANH_COEFF_13 0.076923076923076923076923076923076923077
+#define ATANH_COEFF_15 0.066666666666666666666666666666666666667
+
+ double z2 = z * z;
+ double atanh_z =
+ (((ATANH_COEFF_7
+ * z2 + ATANH_COEFF_5)
+ * z2 + ATANH_COEFF_3)
+ * z2 + ATANH_COEFF_1)
+ * z;
+
+ /* log_table[i] = log((i + 128) / 256).
+ Computed in GNU clisp through
+ (setf (long-float-digits) 128)
+ (setq a 0L0)
+ (setf (long-float-digits) 256)
+ (dotimes (i 385)
+ (format t " ~D,~%"
+ (float (log (* (/ (+ i 128) 256) 1L0)) a))) */
+ static const double log_table[385] =
+ {
+ -0.693147180559945309417232121458176568075,
+ -0.6853650401178903604697692213970398044,
+ -0.677642994023980055266378075415729732197,
+ -0.669980121278410931188432960495886651496,
+ -0.662375521893191621046203913861404403985,
+ -0.65482831625780871022347679633437927773,
+ -0.647337644528651106250552853843513225963,
+ -0.639902666041133026551361927671647791137,
+ -0.632522558743510466836625989417756304788,
+ -0.625196518651437560022666843685547154042,
+ -0.617923759322357783718626781474514153438,
+ -0.61070351134887071814907205278986876216,
+ -0.60353502187025817679728065207969203929,
+ -0.59641755410139419712166106497071313106,
+ -0.58935038687830174459117031769420187977,
+ -0.582332814219655195222425952134964639978,
+ -0.575364144903561854878438011987654863008,
+ -0.568443702058988073553825606077313299585,
+ -0.561570822771226036828515992768693405624,
+ -0.554744857700826173731906247856527380683,
+ -0.547965170715447412135297057717612244552,
+ -0.541231138534103334345428696561292056747,
+ -0.534542150383306725323860946832334992828,
+ -0.527897607664638146541620672180936254347,
+ -0.52129692363328608707713317540302930314,
+ -0.514739523087127012297831879947234599722,
+ -0.50822484206593331675332852879892694707,
+ -0.50175232756031585480793331389686769463,
+ -0.495321437230025429054660050261215099,
+ -0.488931639131254417913411735261937295862,
+ -0.482582411452595671747679308725825054355,
+ -0.476273242259330949798142595713829069596,
+ -0.470003629245735553650937031148342064701,
+ -0.463773079495099479425751396412036696525,
+ -0.457581109247178400339643902517133157939,
+ -0.451427243672800141272924605544662667972,
+ -0.445311016655364052636629355711651820077,
+ -0.43923197057898186527990882355156990061,
+ -0.4331896561230192424451526269158655235,
+ -0.427183632062807368078106194920633178807,
+ -0.421213465076303550585562626925177406092,
+ -0.415278729556489003230882088534775334993,
+ -0.409379007429300711070330899107921801414,
+ -0.403513887976902632538339065932507598071,
+ -0.397682967666109433030550215403212372894,
+ -0.391885849981783528404356583224421075418,
+ -0.386122145265033447342107580922798666387,
+ -0.380391470556048421030985561769857535915,
+ -0.374693449441410693606984907867576972481,
+ -0.369027711905733333326561361023189215893,
+ -0.363393894187477327602809309537386757124,
+ -0.357791638638807479160052541644010369001,
+ -0.352220593589352099112142921677820359633,
+ -0.346680413213736728498769933032403617363,
+ -0.341170757402767124761784665198737642087,
+ -0.33569129163814153519122263131727209364,
+ -0.330241686870576856279407775480686721935,
+ -0.324821619401237656369001967407777741178,
+ -0.31943077076636122859621528874235306143,
+ -0.314068827624975851026378775827156709194,
+ -0.308735481649613269682442058976885699557,
+ -0.303430429419920096046768517454655701024,
+ -0.298153372319076331310838085093194799765,
+ -0.292904016432932602487907019463045397996,
+ -0.287682072451780927439219005993827431504,
+ -0.282487255574676923482925918282353780414,
+ -0.277319285416234343803903228503274262719,
+ -0.272177885915815673288364959951380595626,
+ -0.267062785249045246292687241862699949179,
+ -0.261973715741573968558059642502581569596,
+ -0.256910413785027239068190798397055267412,
+ -0.251872619755070079927735679796875342712,
+ -0.2468600779315257978846419408385075613265,
+ -0.24187253642048672427253973837916408939,
+ -0.2369097470783577150364265832942468196375,
+ -0.2319714654377751430492321958603212094726,
+ -0.2270574506353460848586128739534071682175,
+ -0.222167465341154296870334265401817316702,
+ -0.2173012756899813951520225351537951559,
+ -0.212458651214193401740613666010165016867,
+ -0.2076393647782445016154410442673876674964,
+ -0.202843192514751471266885961812429707545,
+ -0.1980699137620937948192675366153429027185,
+ -0.193319311003495979595900706211132426563,
+ -0.188591169807550022358923589720001638093,
+ -0.183885278770137362613157202229852743197,
+ -0.179201429457710992616226033183958974965,
+ -0.174539416351899677264255125093377869519,
+ -0.169899036795397472900424896523305726435,
+ -0.165280090939102924303339903679875604517,
+ -0.160682381690473465543308397998034325468,
+ -0.156105714663061654850502877304344269052,
+ -0.1515498981272009378406898175577424691056,
+ -0.1470147429618096590348349122269674042104,
+ -0.142500062607283030157283942253263107981,
+ -0.1380056730194437167017517619422725179055,
+ -0.1335313926245226231463436209313499745895,
+ -0.129077042275142343345847831367985856258,
+ -0.124642445207276597338493356591214304499,
+ -0.1202274269981598003244753948319154994493,
+ -0.115831815525121705099120059938680166568,
+ -0.1114554409253228268966213677328042273655,
+ -0.1070981355563671005131126851708522185606,
+ -0.1027597339577689347753154133345778104976,
+ -0.098440072813252519902888574928971234883,
+ -0.094138990913861910035632096996525066015,
+ -0.0898563291218610470766469347968659624282,
+ -0.0855919303354035139161469686670511961825,
+ -0.0813456394539524058873423550293617843895,
+ -0.077117303344431289769666193261475917783,
+ -0.072906770808087780565737488890929711303,
+ -0.0687138925480518083746933774035034481663,
+ -0.064538521137571171672923915683992928129,
+ -0.0603805109889074798714456529545968095868,
+ -0.0562397183228760777967376942769773768851,
+ -0.0521160011390140183616307870527840213665,
+ -0.0480092191863606077520036253234446621373,
+ -0.0439192339348354905263921515528654458042,
+ -0.0398459085471996706586162402473026835046,
+ -0.0357891078515852792753420982122404025613,
+ -0.0317486983145803011569962827485256299276,
+ -0.0277245480148548604671395114515163869272,
+ -0.0237165266173160421183468505286730579517,
+ -0.0197245053477785891192717326571593033246,
+ -0.015748356968139168607549511460828269521,
+ -0.0117879557520422404691605618900871263399,
+ -0.0078431774610258928731840424909435816546,
+ -0.00391389932113632909231778364357266484272,
+ 0.0,
+ 0.00389864041565732301393734309584290701073,
+ 0.00778214044205494894746290006113676367813,
+ 0.01165061721997527413559144280921434893315,
+ 0.0155041865359652541508540460424468358779,
+ 0.01934296284313093463590553454155047018545,
+ 0.0231670592815343782287991609622899165794,
+ 0.0269765876982020757480692925396595457815,
+ 0.0307716586667536883710282075967721640917,
+ 0.0345523815066597334073715005898328652816,
+ 0.038318864302136599193755325123797290346,
+ 0.042071213920687054375203805926962379448,
+ 0.045809536031294203166679267614663342114,
+ 0.049533935122276630882096208829824573267,
+ 0.0532445145188122828658701937865287769396,
+ 0.0569413764001384247590131015404494943015,
+ 0.0606246218164348425806061320404202632862,
+ 0.0642943507053972572162284502656114944857,
+ 0.0679506619085077493945652777726294140346,
+ 0.071593653187008817925605272752092034269,
+ 0.075223421237587525698605339983662414637,
+ 0.078840061707776024531540577859198294559,
+ 0.082443669211074591268160068668307805914,
+ 0.086034337341803153381797826721996075141,
+ 0.0896121586896871326199514693784845287854,
+ 0.093177224854183289768781353027759396216,
+ 0.096729626458551112295571056487463437015,
+ 0.1002694531636751493081301751297276601964,
+ 0.1037967936816435648260618037639746883066,
+ 0.1073117357890880506671750303711543368066,
+ 0.1108143663402901141948061693232119280986,
+ 0.1143047712800586336342591448151747734094,
+ 0.1177830356563834545387941094705217050686,
+ 0.1212492436328696851612122640808405265723,
+ 0.1247034785009572358634065153808632684918,
+ 0.128145822691930038174109886961074873852,
+ 0.1315763577887192725887161286894831624516,
+ 0.134995164537504830601983291147085645626,
+ 0.138402322859119135685325873601649187393,
+ 0.1417979118602573498789527352804727189846,
+ 0.1451820098444978972819350637405643235226,
+ 0.1485546943231371429098223170672938691604,
+ 0.151916042025841975071803424896884511328,
+ 0.1552661289111239515223833017101021786436,
+ 0.1586050301766385840933711746258415752456,
+ 0.161932820269313253240338285123614220592,
+ 0.165249572895307162875611449277240313729,
+ 0.1685553610298066669415865321701023169345,
+ 0.171850256926659222340098946055147264935,
+ 0.1751343321278491480142914649863898412374,
+ 0.1784076574728182971194002415109419683545,
+ 0.181670303107634678260605595617079739242,
+ 0.184922338494011992663903592659249621006,
+ 0.1881638324181829868259905803105539806714,
+ 0.191394852999629454609298807561308873447,
+ 0.194615467699671658858138593767269731516,
+ 0.1978257433299198803625720711969614690756,
+ 0.201025746060590741340908337591797808969,
+ 0.204215541428690891503820386196239272214,
+ 0.2073951943460705871587455788490062338536,
+ 0.210564769107349637669552812732351513721,
+ 0.2137243293977181388619051976331987647734,
+ 0.216873938300614359619089525744347498479,
+ 0.220013658305282095907358638661628360712,
+ 0.2231435513142097557662950903098345033745,
+ 0.226263678650453389361787082280390161607,
+ 0.229374101064845829991480725046139871551,
+ 0.232474878743094064920705078095567528222,
+ 0.235566071312766909077588218941043410137,
+ 0.2386477378501750099171491363522813392526,
+ 0.241719936887145168144307515913513900104,
+ 0.244782726417690916434704717466314811104,
+ 0.247836163904581256780602765746524747999,
+ 0.25088030628580941658844644154994089393,
+ 0.253915209980963444137323297906606667466,
+ 0.256940930897500425446759867911224262093,
+ 0.259957524436926066972079494542311044577,
+ 0.26296504550088135182072917321108602859,
+ 0.265963548497137941339125926537543389269,
+ 0.268953087345503958932974357924497845489,
+ 0.271933715483641758831669494532999161983,
+ 0.274905485872799249167009582983018668293,
+ 0.277868451003456306186350032923401233082,
+ 0.280822662900887784639519758873134832073,
+ 0.28376817313064459834690122235025476666,
+ 0.286705032803954314653250930842073965668,
+ 0.289633292583042676878893055525668970004,
+ 0.292553002686377439978201258664126644308,
+ 0.295464212893835876386681906054964195182,
+ 0.298366972551797281464900430293496918012,
+ 0.301261330578161781012875538233755492657,
+ 0.304147335467296717015819874720446989991,
+ 0.30702503529491186207512454053537790169,
+ 0.309894477722864687861624550833227164546,
+ 0.31275571000389688838624655968831903216,
+ 0.315608778986303334901366180667483174144,
+ 0.318453731118534615810247213590599595595,
+ 0.321290612453734292057863145522557457887,
+ 0.324119468654211976090670760434987352183,
+ 0.326940344995853320592356894073809191681,
+ 0.329753286372467981814422811920789810952,
+ 0.332558337300076601412275626573419425269,
+ 0.335355541921137830257179579814166199074,
+ 0.338144944008716397710235913939267433111,
+ 0.340926586970593210305089199780356208443,
+ 0.34370051385331844468019789211029452987,
+ 0.346466767346208580918462188425772950712,
+ 0.349225389785288304181275421187371759687,
+ 0.35197642315717818465544745625943892599,
+ 0.354719909102929028355011218999317665826,
+ 0.357455888921803774226009490140904474434,
+ 0.360184403575007796281574967493016620926,
+ 0.362905493689368453137824345977489846141,
+ 0.365619199560964711319396875217046453067,
+ 0.368325561158707653048230154050398826898,
+ 0.371024618127872663911964910806824955394,
+ 0.373716409793584080821016832715823506644,
+ 0.376400975164253065997877633436251593315,
+ 0.379078352934969458390853345631019858882,
+ 0.38174858149084833985966626493567607862,
+ 0.384411698910332039734790062481290868519,
+ 0.387067742968448287898902502261817665695,
+ 0.38971675114002521337046360400352086705,
+ 0.392358760602863872479379611988215363485,
+ 0.39499380824086897810639403636498176831,
+ 0.397621930647138489104829072973405554918,
+ 0.40024316412701270692932510199513117008,
+ 0.402857544701083514655197565487057707577,
+ 0.405465108108164381978013115464349136572,
+ 0.408065889808221748430198682969084124381,
+ 0.410659924985268385934306203175822787661,
+ 0.41324724855021933092547601552548590025,
+ 0.415827895143710965613328892954902305356,
+ 0.418401899138883817510763261966760106515,
+ 0.42096929464412963612886716150679597245,
+ 0.423530115505803295718430478017910109426,
+ 0.426084395310900063124544879595476618897,
+ 0.428632167389698760206812276426639053152,
+ 0.43117346481837134085917247895559499848,
+ 0.433708320421559393435847903042186017095,
+ 0.436236766774918070349041323061121300663,
+ 0.438758836207627937745575058511446738878,
+ 0.441274560804875229489496441661301225362,
+ 0.443783972410300981171768440588146426918,
+ 0.446287102628419511532590180619669006749,
+ 0.448783982827006710512822115683937186274,
+ 0.451274644139458585144692383079012478686,
+ 0.453759117467120506644794794442263270651,
+ 0.456237433481587594380805538163929748437,
+ 0.458709622626976664843883309250877913511,
+ 0.461175715122170166367999925597855358603,
+ 0.463635740963032513092182277331163919118,
+ 0.466089729924599224558619247504769399859,
+ 0.468537711563239270375665237462973542708,
+ 0.470979715218791012546897856056359251373,
+ 0.473415770016672131372578393236978550606,
+ 0.475845904869963914265209586304381412175,
+ 0.478270148481470280383546145497464809096,
+ 0.480688529345751907676618455448011551209,
+ 0.48310107575113582273837458485214554795,
+ 0.485507815781700807801791077190788900579,
+ 0.487908777319238973246173184132656942487,
+ 0.490303988045193838150346159645746860531,
+ 0.492693475442575255695076950020077845328,
+ 0.495077266797851514597964584842833665358,
+ 0.497455389202818942250859256731684928918,
+ 0.499827869556449329821331415247044141512,
+ 0.502194734566715494273584171951812573586,
+ 0.504556010752395287058308531738174929982,
+ 0.506911724444854354113196312660089270034,
+ 0.509261901789807946804074919228323824878,
+ 0.51160656874906207851888487520338193135,
+ 0.51394575110223431680100608827421759311,
+ 0.51627947444845449617281928478756106467,
+ 0.518607764208045632152976996364798698556,
+ 0.520930645624185312409809834659637709188,
+ 0.52324814376454783651680722493487084164,
+ 0.525560283522927371382427602307131424923,
+ 0.527867089620842385113892217778300963557,
+ 0.530168586609121617841419630845212405063,
+ 0.532464798869471843873923723460142242606,
+ 0.534755750616027675477923292032637111077,
+ 0.537041465896883654566729244153832299024,
+ 0.539321968595608874655355158077341155752,
+ 0.54159728243274437157654230390043409897,
+ 0.543867430967283517663338989065998323965,
+ 0.546132437598135650382397209231209163864,
+ 0.548392325565573162748150286179863158565,
+ 0.550647117952662279259948179204913460093,
+ 0.552896837686677737580717902230624314327,
+ 0.55514150754050159271548035951590405017,
+ 0.557381150134006357049816540361233647898,
+ 0.559615787935422686270888500526826593487,
+ 0.561845443262691817915664819160697456814,
+ 0.564070138284802966071384290090190711817,
+ 0.566289895023115872590849979337124343595,
+ 0.568504735352668712078738764866962263577,
+ 0.5707146810034715448536245647415894503,
+ 0.572919753561785509092756726626261068625,
+ 0.575119974471387940421742546569273429365,
+ 0.577315365034823604318112061519496401506,
+ 0.579505946414642223855274409488070989814,
+ 0.58169173963462248252061075372537234071,
+ 0.583872765580982679097413356975291104927,
+ 0.586049045003578208904119436287324349516,
+ 0.588220598517086043034868221609113995052,
+ 0.590387446602176374641916708123598757576,
+ 0.59254960960667159874199020959329739696,
+ 0.594707107746692789514343546529205333192,
+ 0.59685996110779383658731192302565801002,
+ 0.59900818964608339938160002446165150206,
+ 0.601151813189334836191674317068856441547,
+ 0.603290851438084262340585186661310605647,
+ 0.6054253239667168894375677681414899356,
+ 0.607555250224541795501085152791125371894,
+ 0.609680649536855273481833501660588408785,
+ 0.611801541105992903529889766428814783686,
+ 0.613917944012370492196929119645563790777,
+ 0.616029877215514019647565928196700650293,
+ 0.618137359555078733872689126674816271683,
+ 0.620240409751857528851494632567246856773,
+ 0.62233904640877874159710264120869663505,
+ 0.62443328801189350104253874405467311991,
+ 0.626523152931352759778820859734204069282,
+ 0.628608659422374137744308205774183639946,
+ 0.6306898256261987050837261409313532241,
+ 0.63276666957103782954578646850357975849,
+ 0.634839209173010211969493840510489008123,
+ 0.63690746223706923162049442718119919119,
+ 0.63897144645792072137962398326473680873,
+ 0.64103117942093129105560133440539254671,
+ 0.643086678603027315392053859585132960477,
+ 0.645137961373584701665228496134731905937,
+ 0.647185044995309550122320631377863036675,
+ 0.64922794662510981889083996990531112227,
+ 0.651266683314958103396333353349672108398,
+ 0.653301272012745638758615881210873884572,
+ 0.65533172956312763209494967856962559648,
+ 0.657358072708360030141890023245936165513,
+ 0.659380318089127826115336413370955804038,
+ 0.661398482245365008260235838709650938148,
+ 0.66341258161706625109695030429080128179,
+ 0.665422632545090448950092610006660181147,
+ 0.667428651271956189947234166318980478403,
+ 0.669430653942629267298885270929503510123,
+ 0.67142865660530232331713904200189252584,
+ 0.67342267521216672029796038880101726475,
+ 0.67541272562017673108090414397019748722,
+ 0.677398823591806140809682609997348298556,
+ 0.67938098479579735014710062847376425181,
+ 0.681359224807903068948071559568089441735,
+ 0.683333559111620688164363148387750369654,
+ 0.68530400309891941654404807896723298642,
+ 0.687270572070960267497006884394346103924,
+ 0.689233281238808980324914337814603903233,
+ 0.691192145724141958859604629216309755938,
+ 0.693147180559945309417232121458176568075
+ };
+ return log_table[128 + (int)m] + 2.0 * atanh_z;
+ }
+}
diff --git a/lib/malloc.c b/lib/malloc.c
index 7a6f3d1..109c65c 100644
--- a/lib/malloc.c
+++ b/lib/malloc.c
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* written by Jim Meyering and Bruno Haible */
diff --git a/lib/malloca.c b/lib/malloca.c
index eca5598..2d4c479 100644
--- a/lib/malloca.c
+++ b/lib/malloca.c
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#define _GL_USE_STDLIB_ALLOC 1
#include <config.h>
@@ -22,6 +21,8 @@
/* Specification. */
#include "malloca.h"
+#include <stdint.h>
+
#include "verify.h"
/* The speed critical point in this file is freea() applied to an alloca()
@@ -85,7 +86,7 @@ mmalloca (size_t n)
((int *) p)[-1] = MAGIC_NUMBER;
/* Enter p into the hash table. */
- slot = (unsigned long) p % HASH_TABLE_SIZE;
+ slot = (uintptr_t) p % HASH_TABLE_SIZE;
((struct header *) (p - HEADER_SIZE))->next = mmalloca_results[slot];
mmalloca_results[slot] = p;
@@ -118,7 +119,7 @@ freea (void *p)
{
/* Looks like a mmalloca() result. To see whether it really is one,
perform a lookup in the hash table. */
- size_t slot = (unsigned long) p % HASH_TABLE_SIZE;
+ size_t slot = (uintptr_t) p % HASH_TABLE_SIZE;
void **chain = &mmalloca_results[slot];
for (; *chain != NULL;)
{
diff --git a/lib/malloca.h b/lib/malloca.h
index cb39cea..c9bc15b 100644
--- a/lib/malloca.h
+++ b/lib/malloca.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _MALLOCA_H
#define _MALLOCA_H
diff --git a/lib/math.in.h b/lib/math.in.h
index 9d62603..ee0fc95 100644
--- a/lib/math.in.h
+++ b/lib/math.in.h
@@ -141,8 +141,64 @@ _NaN ()
/* Solaris 10 defines HUGE_VAL, but as a function pointer rather
than a floating point constant. */
#if @REPLACE_HUGE_VAL@
+# undef HUGE_VALF
+# define HUGE_VALF (1.0f / 0.0f)
# undef HUGE_VAL
# define HUGE_VAL (1.0 / 0.0)
+# undef HUGE_VALL
+# define HUGE_VALL (1.0L / 0.0L)
+#endif
+
+/* HUGE_VALF is a 'float' Infinity. */
+#ifndef HUGE_VALF
+# if defined _MSC_VER
+/* The Microsoft MSVC 9 compiler chokes on the expression 1.0f / 0.0f. */
+# define HUGE_VALF (1e25f * 1e25f)
+# else
+# define HUGE_VALF (1.0f / 0.0f)
+# endif
+#endif
+
+/* HUGE_VAL is a 'double' Infinity. */
+#ifndef HUGE_VAL
+# if defined _MSC_VER
+/* The Microsoft MSVC 9 compiler chokes on the expression 1.0 / 0.0. */
+# define HUGE_VAL (1e250 * 1e250)
+# else
+# define HUGE_VAL (1.0 / 0.0)
+# endif
+#endif
+
+/* HUGE_VALL is a 'long double' Infinity. */
+#ifndef HUGE_VALL
+# if defined _MSC_VER
+/* The Microsoft MSVC 9 compiler chokes on the expression 1.0L / 0.0L. */
+# define HUGE_VALL (1e250L * 1e250L)
+# else
+# define HUGE_VALL (1.0L / 0.0L)
+# endif
+#endif
+
+
+/* Ensure FP_ILOGB0 and FP_ILOGBNAN are defined. */
+#if !(defined FP_ILOGB0 && defined FP_ILOGBNAN)
+# if defined __NetBSD__ || defined __sgi
+ /* NetBSD, IRIX 6.5: match what ilogb() does */
+# define FP_ILOGB0 (- 2147483647 - 1) /* INT_MIN */
+# define FP_ILOGBNAN (- 2147483647 - 1) /* INT_MIN */
+# elif defined _AIX
+ /* AIX 5.1: match what ilogb() does in AIX >= 5.2 */
+# define FP_ILOGB0 (- 2147483647 - 1) /* INT_MIN */
+# define FP_ILOGBNAN 2147483647 /* INT_MAX */
+# elif defined __sun
+ /* Solaris 9: match what ilogb() does */
+# define FP_ILOGB0 (- 2147483647) /* - INT_MAX */
+# define FP_ILOGBNAN 2147483647 /* INT_MAX */
+# else
+ /* Gnulib defined values. */
+# define FP_ILOGB0 (- 2147483647) /* - INT_MAX */
+# define FP_ILOGBNAN (- 2147483647 - 1) /* INT_MIN */
+# endif
#endif
@@ -163,6 +219,7 @@ _GL_WARN_ON_USE (acosf, "acosf is unportable - "
#if @GNULIB_ACOSL@
# if address@hidden@ || address@hidden@
+# undef acosl
_GL_FUNCDECL_SYS (acosl, long double, (long double x));
# endif
_GL_CXXALIAS_SYS (acosl, long double, (long double x));
@@ -171,7 +228,7 @@ _GL_CXXALIASWARN (acosl);
# undef acosl
# if HAVE_RAW_DECL_ACOSL
_GL_WARN_ON_USE (acosl, "acosl is unportable - "
- "use gnulib module mathl for portability");
+ "use gnulib module acosl for portability");
# endif
#endif
@@ -193,6 +250,7 @@ _GL_WARN_ON_USE (asinf, "asinf is unportable - "
#if @GNULIB_ASINL@
# if address@hidden@ || address@hidden@
+# undef asinl
_GL_FUNCDECL_SYS (asinl, long double, (long double x));
# endif
_GL_CXXALIAS_SYS (asinl, long double, (long double x));
@@ -201,7 +259,7 @@ _GL_CXXALIASWARN (asinl);
# undef asinl
# if HAVE_RAW_DECL_ASINL
_GL_WARN_ON_USE (asinl, "asinl is unportable - "
- "use gnulib module mathl for portability");
+ "use gnulib module asinl for portability");
# endif
#endif
@@ -223,6 +281,7 @@ _GL_WARN_ON_USE (atanf, "atanf is unportable - "
#if @GNULIB_ATANL@
# if address@hidden@ || address@hidden@
+# undef atanl
_GL_FUNCDECL_SYS (atanl, long double, (long double x));
# endif
_GL_CXXALIAS_SYS (atanl, long double, (long double x));
@@ -231,7 +290,7 @@ _GL_CXXALIASWARN (atanl);
# undef atanl
# if HAVE_RAW_DECL_ATANL
_GL_WARN_ON_USE (atanl, "atanl is unportable - "
- "use gnulib module mathl for portability");
+ "use gnulib module atanl for portability");
# endif
#endif
@@ -252,6 +311,67 @@ _GL_WARN_ON_USE (atan2f, "atan2f is unportable - "
#endif
+#if @GNULIB_CBRTF@
+# if @REPLACE_CBRTF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef cbrtf
+# define cbrtf rpl_cbrtf
+# endif
+_GL_FUNCDECL_RPL (cbrtf, float, (float x));
+_GL_CXXALIAS_RPL (cbrtf, float, (float x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (cbrtf, float, (float x));
+# endif
+_GL_CXXALIAS_SYS (cbrtf, float, (float x));
+# endif
+_GL_CXXALIASWARN (cbrtf);
+#elif defined GNULIB_POSIXCHECK
+# undef cbrtf
+# if HAVE_RAW_DECL_CBRTF
+_GL_WARN_ON_USE (cbrtf, "cbrtf is unportable - "
+ "use gnulib module cbrtf for portability");
+# endif
+#endif
+
+#if @GNULIB_CBRT@
+# if address@hidden@
+_GL_FUNCDECL_SYS (cbrt, double, (double x));
+# endif
+_GL_CXXALIAS_SYS (cbrt, double, (double x));
+_GL_CXXALIASWARN (cbrt);
+#elif defined GNULIB_POSIXCHECK
+# undef cbrt
+# if HAVE_RAW_DECL_CBRT
+_GL_WARN_ON_USE (cbrt, "cbrt is unportable - "
+ "use gnulib module cbrt for portability");
+# endif
+#endif
+
+#if @GNULIB_CBRTL@
+# if @REPLACE_CBRTL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef cbrtl
+# define cbrtl rpl_cbrtl
+# endif
+_GL_FUNCDECL_RPL (cbrtl, long double, (long double x));
+_GL_CXXALIAS_RPL (cbrtl, long double, (long double x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (cbrtl, long double, (long double x));
+# endif
+_GL_CXXALIAS_SYS (cbrtl, long double, (long double x));
+# endif
+_GL_CXXALIASWARN (cbrtl);
+#elif defined GNULIB_POSIXCHECK
+# undef cbrtl
+# if HAVE_RAW_DECL_CBRTL
+_GL_WARN_ON_USE (cbrtl, "cbrtl is unportable - "
+ "use gnulib module cbrtl for portability");
+# endif
+#endif
+
+
#if @GNULIB_CEILF@
# if @REPLACE_CEILF@
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
@@ -262,6 +382,7 @@ _GL_FUNCDECL_RPL (ceilf, float, (float x));
_GL_CXXALIAS_RPL (ceilf, float, (float x));
# else
# if address@hidden@
+# undef ceilf
_GL_FUNCDECL_SYS (ceilf, float, (float x));
# endif
_GL_CXXALIAS_SYS (ceilf, float, (float x));
@@ -298,6 +419,7 @@ _GL_FUNCDECL_RPL (ceill, long double, (long double x));
_GL_CXXALIAS_RPL (ceill, long double, (long double x));
# else
# if address@hidden@
+# undef ceill
_GL_FUNCDECL_SYS (ceill, long double, (long double x));
# endif
_GL_CXXALIAS_SYS (ceill, long double, (long double x));
@@ -313,7 +435,7 @@ _GL_WARN_ON_USE (ceill, "ceill is unportable - "
#if @GNULIB_COPYSIGNF@
-# if address@hidden@
+# if address@hidden@
_GL_FUNCDECL_SYS (copysignf, float, (float x, float y));
# endif
_GL_CXXALIAS_SYS (copysignf, float, (float x, float y));
@@ -372,6 +494,7 @@ _GL_WARN_ON_USE (cosf, "cosf is unportable - "
#if @GNULIB_COSL@
# if address@hidden@ || address@hidden@
+# undef cosl
_GL_FUNCDECL_SYS (cosl, long double, (long double x));
# endif
_GL_CXXALIAS_SYS (cosl, long double, (long double x));
@@ -380,7 +503,7 @@ _GL_CXXALIASWARN (cosl);
# undef cosl
# if HAVE_RAW_DECL_COSL
_GL_WARN_ON_USE (cosl, "cosl is unportable - "
- "use gnulib module mathl for portability");
+ "use gnulib module cosl for portability");
# endif
#endif
@@ -418,6 +541,7 @@ _GL_WARN_ON_USE (expf, "expf is unportable - "
#if @GNULIB_EXPL@
# if address@hidden@ || address@hidden@
+# undef expl
_GL_FUNCDECL_SYS (expl, long double, (long double x));
# endif
_GL_CXXALIAS_SYS (expl, long double, (long double x));
@@ -426,7 +550,131 @@ _GL_CXXALIASWARN (expl);
# undef expl
# if HAVE_RAW_DECL_EXPL
_GL_WARN_ON_USE (expl, "expl is unportable - "
- "use gnulib module mathl for portability");
+ "use gnulib module expl for portability");
+# endif
+#endif
+
+
+#if @GNULIB_EXP2F@
+# if address@hidden@
+_GL_FUNCDECL_SYS (exp2f, float, (float x));
+# endif
+_GL_CXXALIAS_SYS (exp2f, float, (float x));
+_GL_CXXALIASWARN (exp2f);
+#elif defined GNULIB_POSIXCHECK
+# undef exp2f
+# if HAVE_RAW_DECL_EXP2F
+_GL_WARN_ON_USE (exp2f, "exp2f is unportable - "
+ "use gnulib module exp2f for portability");
+# endif
+#endif
+
+#if @GNULIB_EXP2@
+# if @REPLACE_EXP2@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef exp2
+# define exp2 rpl_exp2
+# endif
+_GL_FUNCDECL_RPL (exp2, double, (double x));
+_GL_CXXALIAS_RPL (exp2, double, (double x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (exp2, double, (double x));
+# endif
+_GL_CXXALIAS_SYS (exp2, double, (double x));
+# endif
+_GL_CXXALIASWARN (exp2);
+#elif defined GNULIB_POSIXCHECK
+# undef exp2
+# if HAVE_RAW_DECL_EXP2
+_GL_WARN_ON_USE (exp2, "exp2 is unportable - "
+ "use gnulib module exp2 for portability");
+# endif
+#endif
+
+#if @GNULIB_EXP2L@
+# if @REPLACE_EXP2L@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef exp2l
+# define exp2l rpl_exp2l
+# endif
+_GL_FUNCDECL_RPL (exp2l, long double, (long double x));
+_GL_CXXALIAS_RPL (exp2l, long double, (long double x));
+# else
+# if address@hidden@
+# undef exp2l
+_GL_FUNCDECL_SYS (exp2l, long double, (long double x));
+# endif
+_GL_CXXALIAS_SYS (exp2l, long double, (long double x));
+# endif
+_GL_CXXALIASWARN (exp2l);
+#elif defined GNULIB_POSIXCHECK
+# undef exp2l
+# if HAVE_RAW_DECL_EXP2L
+_GL_WARN_ON_USE (exp2l, "exp2l is unportable - "
+ "use gnulib module exp2l for portability");
+# endif
+#endif
+
+
+#if @GNULIB_EXPM1F@
+# if @REPLACE_EXPM1F@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef expm1f
+# define expm1f rpl_expm1f
+# endif
+_GL_FUNCDECL_RPL (expm1f, float, (float x));
+_GL_CXXALIAS_RPL (expm1f, float, (float x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (expm1f, float, (float x));
+# endif
+_GL_CXXALIAS_SYS (expm1f, float, (float x));
+# endif
+_GL_CXXALIASWARN (expm1f);
+#elif defined GNULIB_POSIXCHECK
+# undef expm1f
+# if HAVE_RAW_DECL_EXPM1F
+_GL_WARN_ON_USE (expm1f, "expm1f is unportable - "
+ "use gnulib module expm1f for portability");
+# endif
+#endif
+
+#if @GNULIB_EXPM1@
+# if @REPLACE_EXPM1@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef expm1
+# define expm1 rpl_expm1
+# endif
+_GL_FUNCDECL_RPL (expm1, double, (double x));
+_GL_CXXALIAS_RPL (expm1, double, (double x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (expm1, double, (double x));
+# endif
+_GL_CXXALIAS_SYS (expm1, double, (double x));
+# endif
+_GL_CXXALIASWARN (expm1);
+#elif defined GNULIB_POSIXCHECK
+# undef expm1
+# if HAVE_RAW_DECL_EXPM1
+_GL_WARN_ON_USE (expm1, "expm1 is unportable - "
+ "use gnulib module expm1 for portability");
+# endif
+#endif
+
+#if @GNULIB_EXPM1L@
+# if address@hidden@
+# undef expm1l
+_GL_FUNCDECL_SYS (expm1l, long double, (long double x));
+# endif
+_GL_CXXALIAS_SYS (expm1l, long double, (long double x));
+_GL_CXXALIASWARN (expm1l);
+#elif defined GNULIB_POSIXCHECK
+# undef expm1l
+# if HAVE_RAW_DECL_EXPM1L
+_GL_WARN_ON_USE (expm1l, "expm1l is unportable - "
+ "use gnulib module expm1l for portability");
# endif
#endif
@@ -446,6 +694,30 @@ _GL_WARN_ON_USE (fabsf, "fabsf is unportable - "
# endif
#endif
+#if @GNULIB_FABSL@
+# if @REPLACE_FABSL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fabsl
+# define fabsl rpl_fabsl
+# endif
+_GL_FUNCDECL_RPL (fabsl, long double, (long double x));
+_GL_CXXALIAS_RPL (fabsl, long double, (long double x));
+# else
+# if address@hidden@
+# undef fabsl
+_GL_FUNCDECL_SYS (fabsl, long double, (long double x));
+# endif
+_GL_CXXALIAS_SYS (fabsl, long double, (long double x));
+# endif
+_GL_CXXALIASWARN (fabsl);
+#elif defined GNULIB_POSIXCHECK
+# undef fabsl
+# if HAVE_RAW_DECL_FABSL
+_GL_WARN_ON_USE (fabsl, "fabsl is unportable - "
+ "use gnulib module fabsl for portability");
+# endif
+#endif
+
#if @GNULIB_FLOORF@
# if @REPLACE_FLOORF@
@@ -457,6 +729,7 @@ _GL_FUNCDECL_RPL (floorf, float, (float x));
_GL_CXXALIAS_RPL (floorf, float, (float x));
# else
# if address@hidden@
+# undef floorf
_GL_FUNCDECL_SYS (floorf, float, (float x));
# endif
_GL_CXXALIAS_SYS (floorf, float, (float x));
@@ -493,6 +766,7 @@ _GL_FUNCDECL_RPL (floorl, long double, (long double x));
_GL_CXXALIAS_RPL (floorl, long double, (long double x));
# else
# if address@hidden@
+# undef floorl
_GL_FUNCDECL_SYS (floorl, long double, (long double x));
# endif
_GL_CXXALIAS_SYS (floorl, long double, (long double x));
@@ -565,6 +839,7 @@ _GL_CXXALIAS_RPL (fmal, long double,
(long double x, long double y, long double z));
# else
# if address@hidden@
+# undef fmal
_GL_FUNCDECL_SYS (fmal, long double,
(long double x, long double y, long double z));
# endif
@@ -582,11 +857,20 @@ _GL_WARN_ON_USE (fmal, "fmal is unportable - "
#if @GNULIB_FMODF@
-# if address@hidden@
-# undef fmodf
+# if @REPLACE_FMODF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fmodf
+# define fmodf rpl_fmodf
+# endif
+_GL_FUNCDECL_RPL (fmodf, float, (float x, float y));
+_GL_CXXALIAS_RPL (fmodf, float, (float x, float y));
+# else
+# if address@hidden@
+# undef fmodf
_GL_FUNCDECL_SYS (fmodf, float, (float x, float y));
-# endif
+# endif
_GL_CXXALIAS_SYS (fmodf, float, (float x, float y));
+# endif
_GL_CXXALIASWARN (fmodf);
#elif defined GNULIB_POSIXCHECK
# undef fmodf
@@ -596,6 +880,50 @@ _GL_WARN_ON_USE (fmodf, "fmodf is unportable - "
# endif
#endif
+#if @GNULIB_FMOD@
+# if @REPLACE_FMOD@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fmod
+# define fmod rpl_fmod
+# endif
+_GL_FUNCDECL_RPL (fmod, double, (double x, double y));
+_GL_CXXALIAS_RPL (fmod, double, (double x, double y));
+# else
+_GL_CXXALIAS_SYS (fmod, double, (double x, double y));
+# endif
+_GL_CXXALIASWARN (fmod);
+#elif defined GNULIB_POSIXCHECK
+# undef fmod
+# if HAVE_RAW_DECL_FMOD
+_GL_WARN_ON_USE (fmod, "fmod has portability problems - "
+ "use gnulib module fmod for portability");
+# endif
+#endif
+
+#if @GNULIB_FMODL@
+# if @REPLACE_FMODL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef fmodl
+# define fmodl rpl_fmodl
+# endif
+_GL_FUNCDECL_RPL (fmodl, long double, (long double x, long double y));
+_GL_CXXALIAS_RPL (fmodl, long double, (long double x, long double y));
+# else
+# if address@hidden@
+# undef fmodl
+_GL_FUNCDECL_SYS (fmodl, long double, (long double x, long double y));
+# endif
+_GL_CXXALIAS_SYS (fmodl, long double, (long double x, long double y));
+# endif
+_GL_CXXALIASWARN (fmodl);
+#elif defined GNULIB_POSIXCHECK
+# undef fmodl
+# if HAVE_RAW_DECL_FMODL
+_GL_WARN_ON_USE (fmodl, "fmodl is unportable - "
+ "use gnulib module fmodl for portability");
+# endif
+#endif
+
/* Write x as
x = mantissa * 2^exp
@@ -689,6 +1017,137 @@ _GL_WARN_ON_USE (frexpl, "frexpl is unportable - "
#endif
+/* Return sqrt(x^2+y^2). */
+#if @GNULIB_HYPOTF@
+# if @REPLACE_HYPOTF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef hypotf
+# define hypotf rpl_hypotf
+# endif
+_GL_FUNCDECL_RPL (hypotf, float, (float x, float y));
+_GL_CXXALIAS_RPL (hypotf, float, (float x, float y));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (hypotf, float, (float x, float y));
+# endif
+_GL_CXXALIAS_SYS (hypotf, float, (float x, float y));
+# endif
+_GL_CXXALIASWARN (hypotf);
+#elif defined GNULIB_POSIXCHECK
+# undef hypotf
+# if HAVE_RAW_DECL_HYPOTF
+_GL_WARN_ON_USE (hypotf, "hypotf is unportable - "
+ "use gnulib module hypotf for portability");
+# endif
+#endif
+
+/* Return sqrt(x^2+y^2). */
+#if @GNULIB_HYPOT@
+# if @REPLACE_HYPOT@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef hypot
+# define hypot rpl_hypot
+# endif
+_GL_FUNCDECL_RPL (hypot, double, (double x, double y));
+_GL_CXXALIAS_RPL (hypot, double, (double x, double y));
+# else
+_GL_CXXALIAS_SYS (hypot, double, (double x, double y));
+# endif
+_GL_CXXALIASWARN (hypot);
+#elif defined GNULIB_POSIXCHECK
+# undef hypot
+# if HAVE_RAW_DECL_HYPOT
+_GL_WARN_ON_USE (hypotf, "hypot has portability problems - "
+ "use gnulib module hypot for portability");
+# endif
+#endif
+
+/* Return sqrt(x^2+y^2). */
+#if @GNULIB_HYPOTL@
+# if @REPLACE_HYPOTL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef hypotl
+# define hypotl rpl_hypotl
+# endif
+_GL_FUNCDECL_RPL (hypotl, long double, (long double x, long double y));
+_GL_CXXALIAS_RPL (hypotl, long double, (long double x, long double y));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (hypotl, long double, (long double x, long double y));
+# endif
+_GL_CXXALIAS_SYS (hypotl, long double, (long double x, long double y));
+# endif
+_GL_CXXALIASWARN (hypotl);
+#elif defined GNULIB_POSIXCHECK
+# undef hypotl
+# if HAVE_RAW_DECL_HYPOTL
+_GL_WARN_ON_USE (hypotl, "hypotl is unportable - "
+ "use gnulib module hypotl for portability");
+# endif
+#endif
+
+
+#if @GNULIB_ILOGBF@
+# if @REPLACE_ILOGBF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef ilogbf
+# define ilogbf rpl_ilogbf
+# endif
+_GL_FUNCDECL_RPL (ilogbf, int, (float x));
+_GL_CXXALIAS_RPL (ilogbf, int, (float x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (ilogbf, int, (float x));
+# endif
+_GL_CXXALIAS_SYS (ilogbf, int, (float x));
+# endif
+_GL_CXXALIASWARN (ilogbf);
+#elif defined GNULIB_POSIXCHECK
+# undef ilogbf
+# if HAVE_RAW_DECL_ILOGBF
+_GL_WARN_ON_USE (ilogbf, "ilogbf is unportable - "
+ "use gnulib module ilogbf for portability");
+# endif
+#endif
+
+#if @GNULIB_ILOGB@
+# if @REPLACE_ILOGB@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef ilogb
+# define ilogb rpl_ilogb
+# endif
+_GL_FUNCDECL_RPL (ilogb, int, (double x));
+_GL_CXXALIAS_RPL (ilogb, int, (double x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (ilogb, int, (double x));
+# endif
+_GL_CXXALIAS_SYS (ilogb, int, (double x));
+# endif
+_GL_CXXALIASWARN (ilogb);
+#elif defined GNULIB_POSIXCHECK
+# undef ilogb
+# if HAVE_RAW_DECL_ILOGB
+_GL_WARN_ON_USE (ilogb, "ilogb is unportable - "
+ "use gnulib module ilogb for portability");
+# endif
+#endif
+
+#if @GNULIB_ILOGBL@
+# if address@hidden@
+_GL_FUNCDECL_SYS (ilogbl, int, (long double x));
+# endif
+_GL_CXXALIAS_SYS (ilogbl, int, (long double x));
+_GL_CXXALIASWARN (ilogbl);
+#elif defined GNULIB_POSIXCHECK
+# undef ilogbl
+# if HAVE_RAW_DECL_ILOGBL
+_GL_WARN_ON_USE (ilogbl, "ilogbl is unportable - "
+ "use gnulib module ilogbl for portability");
+# endif
+#endif
+
+
/* Return x * 2^exp. */
#if @GNULIB_LDEXPF@
# if address@hidden@
@@ -733,25 +1192,21 @@ _GL_WARN_ON_USE (ldexpl, "ldexpl is unportable - "
#endif
-#if @GNULIB_LOGB@
-# if address@hidden@
-_GL_EXTERN_C double logb (double x);
-# endif
-#elif defined GNULIB_POSIXCHECK
-# undef logb
-# if HAVE_RAW_DECL_LOGB
-_GL_WARN_ON_USE (logb, "logb is unportable - "
- "use gnulib module logb for portability");
-# endif
-#endif
-
-
#if @GNULIB_LOGF@
-# if address@hidden@
-# undef logf
+# if @REPLACE_LOGF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef logf
+# define logf rpl_logf
+# endif
+_GL_FUNCDECL_RPL (logf, float, (float x));
+_GL_CXXALIAS_RPL (logf, float, (float x));
+# else
+# if address@hidden@
+# undef logf
_GL_FUNCDECL_SYS (logf, float, (float x));
-# endif
+# endif
_GL_CXXALIAS_SYS (logf, float, (float x));
+# endif
_GL_CXXALIASWARN (logf);
#elif defined GNULIB_POSIXCHECK
# undef logf
@@ -761,27 +1216,66 @@ _GL_WARN_ON_USE (logf, "logf is unportable - "
# endif
#endif
+#if @GNULIB_LOG@
+# if @REPLACE_LOG@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef log
+# define log rpl_log
+# endif
+_GL_FUNCDECL_RPL (log, double, (double x));
+_GL_CXXALIAS_RPL (log, double, (double x));
+# else
+_GL_CXXALIAS_SYS (log, double, (double x));
+# endif
+_GL_CXXALIASWARN (log);
+#elif defined GNULIB_POSIXCHECK
+# undef log
+# if HAVE_RAW_DECL_LOG
+_GL_WARN_ON_USE (log, "log has portability problems - "
+ "use gnulib module log for portability");
+# endif
+#endif
+
#if @GNULIB_LOGL@
-# if address@hidden@ || address@hidden@
+# if @REPLACE_LOGL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef logl
+# define logl rpl_logl
+# endif
+_GL_FUNCDECL_RPL (logl, long double, (long double x));
+_GL_CXXALIAS_RPL (logl, long double, (long double x));
+# else
+# if address@hidden@ || address@hidden@
+# undef logl
_GL_FUNCDECL_SYS (logl, long double, (long double x));
-# endif
+# endif
_GL_CXXALIAS_SYS (logl, long double, (long double x));
+# endif
_GL_CXXALIASWARN (logl);
#elif defined GNULIB_POSIXCHECK
# undef logl
# if HAVE_RAW_DECL_LOGL
_GL_WARN_ON_USE (logl, "logl is unportable - "
- "use gnulib module mathl for portability");
+ "use gnulib module logl for portability");
# endif
#endif
#if @GNULIB_LOG10F@
-# if address@hidden@
-# undef log10f
+# if @REPLACE_LOG10F@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef log10f
+# define log10f rpl_log10f
+# endif
+_GL_FUNCDECL_RPL (log10f, float, (float x));
+_GL_CXXALIAS_RPL (log10f, float, (float x));
+# else
+# if address@hidden@
+# undef log10f
_GL_FUNCDECL_SYS (log10f, float, (float x));
-# endif
+# endif
_GL_CXXALIAS_SYS (log10f, float, (float x));
+# endif
_GL_CXXALIASWARN (log10f);
#elif defined GNULIB_POSIXCHECK
# undef log10f
@@ -791,13 +1285,278 @@ _GL_WARN_ON_USE (log10f, "log10f is unportable - "
# endif
#endif
+#if @GNULIB_LOG10@
+# if @REPLACE_LOG10@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef log10
+# define log10 rpl_log10
+# endif
+_GL_FUNCDECL_RPL (log10, double, (double x));
+_GL_CXXALIAS_RPL (log10, double, (double x));
+# else
+_GL_CXXALIAS_SYS (log10, double, (double x));
+# endif
+_GL_CXXALIASWARN (log10);
+#elif defined GNULIB_POSIXCHECK
+# undef log10
+# if HAVE_RAW_DECL_LOG10
+_GL_WARN_ON_USE (log10, "log10 has portability problems - "
+ "use gnulib module log10 for portability");
+# endif
+#endif
+
+#if @GNULIB_LOG10L@
+# if @REPLACE_LOG10L@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef log10l
+# define log10l rpl_log10l
+# endif
+_GL_FUNCDECL_RPL (log10l, long double, (long double x));
+_GL_CXXALIAS_RPL (log10l, long double, (long double x));
+# else
+# if address@hidden@ || address@hidden@
+# undef log10l
+_GL_FUNCDECL_SYS (log10l, long double, (long double x));
+# endif
+_GL_CXXALIAS_SYS (log10l, long double, (long double x));
+# endif
+_GL_CXXALIASWARN (log10l);
+#elif defined GNULIB_POSIXCHECK
+# undef log10l
+# if HAVE_RAW_DECL_LOG10L
+_GL_WARN_ON_USE (log10l, "log10l is unportable - "
+ "use gnulib module log10l for portability");
+# endif
+#endif
+
+
+#if @GNULIB_LOG1PF@
+# if @REPLACE_LOG1PF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef log1pf
+# define log1pf rpl_log1pf
+# endif
+_GL_FUNCDECL_RPL (log1pf, float, (float x));
+_GL_CXXALIAS_RPL (log1pf, float, (float x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (log1pf, float, (float x));
+# endif
+_GL_CXXALIAS_SYS (log1pf, float, (float x));
+# endif
+_GL_CXXALIASWARN (log1pf);
+#elif defined GNULIB_POSIXCHECK
+# undef log1pf
+# if HAVE_RAW_DECL_LOG1PF
+_GL_WARN_ON_USE (log1pf, "log1pf is unportable - "
+ "use gnulib module log1pf for portability");
+# endif
+#endif
+
+#if @GNULIB_LOG1P@
+# if @REPLACE_LOG1P@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef log1p
+# define log1p rpl_log1p
+# endif
+_GL_FUNCDECL_RPL (log1p, double, (double x));
+_GL_CXXALIAS_RPL (log1p, double, (double x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (log1p, double, (double x));
+# endif
+_GL_CXXALIAS_SYS (log1p, double, (double x));
+# endif
+_GL_CXXALIASWARN (log1p);
+#elif defined GNULIB_POSIXCHECK
+# undef log1p
+# if HAVE_RAW_DECL_LOG1P
+_GL_WARN_ON_USE (log1p, "log1p has portability problems - "
+ "use gnulib module log1p for portability");
+# endif
+#endif
+
+#if @GNULIB_LOG1PL@
+# if @REPLACE_LOG1PL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef log1pl
+# define log1pl rpl_log1pl
+# endif
+_GL_FUNCDECL_RPL (log1pl, long double, (long double x));
+_GL_CXXALIAS_RPL (log1pl, long double, (long double x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (log1pl, long double, (long double x));
+# endif
+_GL_CXXALIAS_SYS (log1pl, long double, (long double x));
+# endif
+_GL_CXXALIASWARN (log1pl);
+#elif defined GNULIB_POSIXCHECK
+# undef log1pl
+# if HAVE_RAW_DECL_LOG1PL
+_GL_WARN_ON_USE (log1pl, "log1pl has portability problems - "
+ "use gnulib module log1pl for portability");
+# endif
+#endif
+
+
+#if @GNULIB_LOG2F@
+# if @REPLACE_LOG2F@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef log2f
+# define log2f rpl_log2f
+# endif
+_GL_FUNCDECL_RPL (log2f, float, (float x));
+_GL_CXXALIAS_RPL (log2f, float, (float x));
+# else
+# if address@hidden@
+# undef log2f
+_GL_FUNCDECL_SYS (log2f, float, (float x));
+# endif
+_GL_CXXALIAS_SYS (log2f, float, (float x));
+# endif
+_GL_CXXALIASWARN (log2f);
+#elif defined GNULIB_POSIXCHECK
+# undef log2f
+# if HAVE_RAW_DECL_LOG2F
+_GL_WARN_ON_USE (log2f, "log2f is unportable - "
+ "use gnulib module log2f for portability");
+# endif
+#endif
+
+#if @GNULIB_LOG2@
+# if @REPLACE_LOG2@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef log2
+# define log2 rpl_log2
+# endif
+_GL_FUNCDECL_RPL (log2, double, (double x));
+_GL_CXXALIAS_RPL (log2, double, (double x));
+# else
+# if address@hidden@
+# undef log2
+_GL_FUNCDECL_SYS (log2, double, (double x));
+# endif
+_GL_CXXALIAS_SYS (log2, double, (double x));
+# endif
+_GL_CXXALIASWARN (log2);
+#elif defined GNULIB_POSIXCHECK
+# undef log2
+# if HAVE_RAW_DECL_LOG2
+_GL_WARN_ON_USE (log2, "log2 is unportable - "
+ "use gnulib module log2 for portability");
+# endif
+#endif
+
+#if @GNULIB_LOG2L@
+# if @REPLACE_LOG2L@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef log2l
+# define log2l rpl_log2l
+# endif
+_GL_FUNCDECL_RPL (log2l, long double, (long double x));
+_GL_CXXALIAS_RPL (log2l, long double, (long double x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (log2l, long double, (long double x));
+# endif
+_GL_CXXALIAS_SYS (log2l, long double, (long double x));
+# endif
+_GL_CXXALIASWARN (log2l);
+#elif defined GNULIB_POSIXCHECK
+# undef log2l
+# if HAVE_RAW_DECL_LOG2L
+_GL_WARN_ON_USE (log2l, "log2l is unportable - "
+ "use gnulib module log2l for portability");
+# endif
+#endif
+
+
+#if @GNULIB_LOGBF@
+# if @REPLACE_LOGBF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef logbf
+# define logbf rpl_logbf
+# endif
+_GL_FUNCDECL_RPL (logbf, float, (float x));
+_GL_CXXALIAS_RPL (logbf, float, (float x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (logbf, float, (float x));
+# endif
+_GL_CXXALIAS_SYS (logbf, float, (float x));
+# endif
+_GL_CXXALIASWARN (logbf);
+#elif defined GNULIB_POSIXCHECK
+# undef logbf
+# if HAVE_RAW_DECL_LOGBF
+_GL_WARN_ON_USE (logbf, "logbf is unportable - "
+ "use gnulib module logbf for portability");
+# endif
+#endif
+
+#if @GNULIB_LOGB@
+# if @REPLACE_LOGB@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef logb
+# define logb rpl_logb
+# endif
+_GL_FUNCDECL_RPL (logb, double, (double x));
+_GL_CXXALIAS_RPL (logb, double, (double x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (logb, double, (double x));
+# endif
+_GL_CXXALIAS_SYS (logb, double, (double x));
+# endif
+_GL_CXXALIASWARN (logb);
+#elif defined GNULIB_POSIXCHECK
+# undef logb
+# if HAVE_RAW_DECL_LOGB
+_GL_WARN_ON_USE (logb, "logb is unportable - "
+ "use gnulib module logb for portability");
+# endif
+#endif
+
+#if @GNULIB_LOGBL@
+# if @REPLACE_LOGBL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef logbl
+# define logbl rpl_logbl
+# endif
+_GL_FUNCDECL_RPL (logbl, long double, (long double x));
+_GL_CXXALIAS_RPL (logbl, long double, (long double x));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (logbl, long double, (long double x));
+# endif
+_GL_CXXALIAS_SYS (logbl, long double, (long double x));
+# endif
+_GL_CXXALIASWARN (logbl);
+#elif defined GNULIB_POSIXCHECK
+# undef logbl
+# if HAVE_RAW_DECL_LOGBL
+_GL_WARN_ON_USE (logbl, "logbl is unportable - "
+ "use gnulib module logbl for portability");
+# endif
+#endif
+
#if @GNULIB_MODFF@
-# if address@hidden@
-# undef modff
+# if @REPLACE_MODFF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef modff
+# define modff rpl_modff
+# endif
+_GL_FUNCDECL_RPL (modff, float, (float x, float *iptr) _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (modff, float, (float x, float *iptr));
+# else
+# if address@hidden@
+# undef modff
_GL_FUNCDECL_SYS (modff, float, (float x, float *iptr) _GL_ARG_NONNULL ((2)));
-# endif
+# endif
_GL_CXXALIAS_SYS (modff, float, (float x, float *iptr));
+# endif
_GL_CXXALIASWARN (modff);
#elif defined GNULIB_POSIXCHECK
# undef modff
@@ -807,6 +1566,52 @@ _GL_WARN_ON_USE (modff, "modff is unportable - "
# endif
#endif
+#if @GNULIB_MODF@
+# if @REPLACE_MODF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef modf
+# define modf rpl_modf
+# endif
+_GL_FUNCDECL_RPL (modf, double, (double x, double *iptr) _GL_ARG_NONNULL
((2)));
+_GL_CXXALIAS_RPL (modf, double, (double x, double *iptr));
+# else
+_GL_CXXALIAS_SYS (modf, double, (double x, double *iptr));
+# endif
+_GL_CXXALIASWARN (modf);
+#elif defined GNULIB_POSIXCHECK
+# undef modf
+# if HAVE_RAW_DECL_MODF
+_GL_WARN_ON_USE (modf, "modf has portability problems - "
+ "use gnulib module modf for portability");
+# endif
+#endif
+
+#if @GNULIB_MODFL@
+# if @REPLACE_MODFL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef modfl
+# define modfl rpl_modfl
+# endif
+_GL_FUNCDECL_RPL (modfl, long double, (long double x, long double *iptr)
+ _GL_ARG_NONNULL ((2)));
+_GL_CXXALIAS_RPL (modfl, long double, (long double x, long double *iptr));
+# else
+# if address@hidden@
+# undef modfl
+_GL_FUNCDECL_SYS (modfl, long double, (long double x, long double *iptr)
+ _GL_ARG_NONNULL ((2)));
+# endif
+_GL_CXXALIAS_SYS (modfl, long double, (long double x, long double *iptr));
+# endif
+_GL_CXXALIASWARN (modfl);
+#elif defined GNULIB_POSIXCHECK
+# undef modfl
+# if HAVE_RAW_DECL_MODFL
+_GL_WARN_ON_USE (modfl, "modfl is unportable - "
+ "use gnulib module modfl for portability");
+# endif
+#endif
+
#if @GNULIB_POWF@
# if address@hidden@
@@ -824,8 +1629,79 @@ _GL_WARN_ON_USE (powf, "powf is unportable - "
#endif
+#if @GNULIB_REMAINDERF@
+# if @REPLACE_REMAINDERF@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef remainderf
+# define remainderf rpl_remainderf
+# endif
+_GL_FUNCDECL_RPL (remainderf, float, (float x, float y));
+_GL_CXXALIAS_RPL (remainderf, float, (float x, float y));
+# else
+# if address@hidden@
+_GL_FUNCDECL_SYS (remainderf, float, (float x, float y));
+# endif
+_GL_CXXALIAS_SYS (remainderf, float, (float x, float y));
+# endif
+_GL_CXXALIASWARN (remainderf);
+#elif defined GNULIB_POSIXCHECK
+# undef remainderf
+# if HAVE_RAW_DECL_REMAINDERF
+_GL_WARN_ON_USE (remainderf, "remainderf is unportable - "
+ "use gnulib module remainderf for portability");
+# endif
+#endif
+
+#if @GNULIB_REMAINDER@
+# if @REPLACE_REMAINDER@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef remainder
+# define remainder rpl_remainder
+# endif
+_GL_FUNCDECL_RPL (remainder, double, (double x, double y));
+_GL_CXXALIAS_RPL (remainder, double, (double x, double y));
+# else
+# if address@hidden@ || address@hidden@
+_GL_FUNCDECL_SYS (remainder, double, (double x, double y));
+# endif
+_GL_CXXALIAS_SYS (remainder, double, (double x, double y));
+# endif
+_GL_CXXALIASWARN (remainder);
+#elif defined GNULIB_POSIXCHECK
+# undef remainder
+# if HAVE_RAW_DECL_REMAINDER
+_GL_WARN_ON_USE (remainder, "remainder is unportable - "
+ "use gnulib module remainder for portability");
+# endif
+#endif
+
+#if @GNULIB_REMAINDERL@
+# if @REPLACE_REMAINDERL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef remainderl
+# define remainderl rpl_remainderl
+# endif
+_GL_FUNCDECL_RPL (remainderl, long double, (long double x, long double y));
+_GL_CXXALIAS_RPL (remainderl, long double, (long double x, long double y));
+# else
+# if address@hidden@
+# undef remainderl
+_GL_FUNCDECL_SYS (remainderl, long double, (long double x, long double y));
+# endif
+_GL_CXXALIAS_SYS (remainderl, long double, (long double x, long double y));
+# endif
+_GL_CXXALIASWARN (remainderl);
+#elif defined GNULIB_POSIXCHECK
+# undef remainderl
+# if HAVE_RAW_DECL_REMAINDERL
+_GL_WARN_ON_USE (remainderl, "remainderl is unportable - "
+ "use gnulib module remainderl for portability");
+# endif
+#endif
+
+
#if @GNULIB_RINTF@
-# if address@hidden@
+# if address@hidden@
_GL_FUNCDECL_SYS (rintf, float, (float x));
# endif
_GL_CXXALIAS_SYS (rintf, float, (float x));
@@ -923,6 +1799,7 @@ _GL_FUNCDECL_RPL (roundl, long double, (long double x));
_GL_CXXALIAS_RPL (roundl, long double, (long double x));
# else
# if address@hidden@
+# undef roundl
_GL_FUNCDECL_SYS (roundl, long double, (long double x));
# endif
_GL_CXXALIAS_SYS (roundl, long double, (long double x));
@@ -954,6 +1831,7 @@ _GL_WARN_ON_USE (sinf, "sinf is unportable - "
#if @GNULIB_SINL@
# if address@hidden@ || address@hidden@
+# undef sinl
_GL_FUNCDECL_SYS (sinl, long double, (long double x));
# endif
_GL_CXXALIAS_SYS (sinl, long double, (long double x));
@@ -962,7 +1840,7 @@ _GL_CXXALIASWARN (sinl);
# undef sinl
# if HAVE_RAW_DECL_SINL
_GL_WARN_ON_USE (sinl, "sinl is unportable - "
- "use gnulib module mathl for portability");
+ "use gnulib module sinl for portability");
# endif
#endif
@@ -999,16 +1877,26 @@ _GL_WARN_ON_USE (sqrtf, "sqrtf is unportable - "
#endif
#if @GNULIB_SQRTL@
-# if address@hidden@ || address@hidden@
+# if @REPLACE_SQRTL@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef sqrtl
+# define sqrtl rpl_sqrtl
+# endif
+_GL_FUNCDECL_RPL (sqrtl, long double, (long double x));
+_GL_CXXALIAS_RPL (sqrtl, long double, (long double x));
+# else
+# if address@hidden@ || address@hidden@
+# undef sqrtl
_GL_FUNCDECL_SYS (sqrtl, long double, (long double x));
-# endif
+# endif
_GL_CXXALIAS_SYS (sqrtl, long double, (long double x));
+# endif
_GL_CXXALIASWARN (sqrtl);
#elif defined GNULIB_POSIXCHECK
# undef sqrtl
# if HAVE_RAW_DECL_SQRTL
_GL_WARN_ON_USE (sqrtl, "sqrtl is unportable - "
- "use gnulib module mathl for portability");
+ "use gnulib module sqrtl for portability");
# endif
#endif
@@ -1030,6 +1918,7 @@ _GL_WARN_ON_USE (tanf, "tanf is unportable - "
#if @GNULIB_TANL@
# if address@hidden@ || address@hidden@
+# undef tanl
_GL_FUNCDECL_SYS (tanl, long double, (long double x));
# endif
_GL_CXXALIAS_SYS (tanl, long double, (long double x));
@@ -1038,7 +1927,7 @@ _GL_CXXALIASWARN (tanl);
# undef tanl
# if HAVE_RAW_DECL_TANL
_GL_WARN_ON_USE (tanl, "tanl is unportable - "
- "use gnulib module mathl for portability");
+ "use gnulib module tanl for portability");
# endif
#endif
diff --git a/lib/mbrtowc.c b/lib/mbrtowc.c
index 05fb148..5f2ec07 100644
--- a/lib/mbrtowc.c
+++ b/lib/mbrtowc.c
@@ -128,7 +128,7 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t
*ps)
{
const char *encoding = locale_charset ();
- if (STREQ (encoding, "UTF-8", 'U', 'T', 'F', '-', '8', 0, 0, 0, 0))
+ if (STREQ_OPT (encoding, "UTF-8", 'U', 'T', 'F', '-', '8', 0, 0, 0, 0))
{
/* Cf. unistr/u8-mblen.c. */
unsigned char c = (unsigned char) p[0];
@@ -185,7 +185,8 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t
*ps)
/* As a reference for this code, you can use the GNU libiconv
implementation. Look for uses of the RET_TOOFEW macro. */
- if (STREQ (encoding, "EUC-JP", 'E', 'U', 'C', '-', 'J', 'P', 0, 0, 0))
+ if (STREQ_OPT (encoding,
+ "EUC-JP", 'E', 'U', 'C', '-', 'J', 'P', 0, 0, 0))
{
if (m == 1)
{
@@ -208,9 +209,12 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t
*ps)
}
goto invalid;
}
- if (STREQ (encoding, "EUC-KR", 'E', 'U', 'C', '-', 'K', 'R', 0, 0, 0)
- || STREQ (encoding, "GB2312", 'G', 'B', '2', '3', '1', '2', 0, 0,
0)
- || STREQ (encoding, "BIG5", 'B', 'I', 'G', '5', 0, 0, 0, 0, 0))
+ if (STREQ_OPT (encoding,
+ "EUC-KR", 'E', 'U', 'C', '-', 'K', 'R', 0, 0, 0)
+ || STREQ_OPT (encoding,
+ "GB2312", 'G', 'B', '2', '3', '1', '2', 0, 0, 0)
+ || STREQ_OPT (encoding,
+ "BIG5", 'B', 'I', 'G', '5', 0, 0, 0, 0, 0))
{
if (m == 1)
{
@@ -221,7 +225,8 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t
*ps)
}
goto invalid;
}
- if (STREQ (encoding, "EUC-TW", 'E', 'U', 'C', '-', 'T', 'W', 0, 0, 0))
+ if (STREQ_OPT (encoding,
+ "EUC-TW", 'E', 'U', 'C', '-', 'T', 'W', 0, 0, 0))
{
if (m == 1)
{
@@ -239,7 +244,8 @@ 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 (STREQ_OPT (encoding,
+ "GB18030", 'G', 'B', '1', '8', '0', '3', '0', 0, 0))
{
if (m == 1)
{
@@ -272,7 +278,7 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t
*ps)
}
goto invalid;
}
- if (STREQ (encoding, "SJIS", 'S', 'J', 'I', 'S', 0, 0, 0, 0, 0))
+ if (STREQ_OPT (encoding, "SJIS", 'S', 'J', 'I', 'S', 0, 0, 0, 0, 0))
{
if (m == 1)
{
diff --git a/lib/msvc-inval.c b/lib/msvc-inval.c
index 4efa611..7da3541 100644
--- a/lib/msvc-inval.c
+++ b/lib/msvc-inval.c
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/msvc-inval.h b/lib/msvc-inval.h
index bb78aac..ce6fcee 100644
--- a/lib/msvc-inval.h
+++ b/lib/msvc-inval.h
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _MSVC_INVAL_H
#define _MSVC_INVAL_H
diff --git a/lib/msvc-nothrow.c b/lib/msvc-nothrow.c
index 7198311..3e791c3 100644
--- a/lib/msvc-nothrow.c
+++ b/lib/msvc-nothrow.c
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/msvc-nothrow.h b/lib/msvc-nothrow.h
index beb3ac9..573bc8e 100644
--- a/lib/msvc-nothrow.h
+++ b/lib/msvc-nothrow.h
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _MSVC_NOTHROW_H
#define _MSVC_NOTHROW_H
diff --git a/lib/netdb.in.h b/lib/netdb.in.h
index cdf356a..63ebd2d 100644
--- a/lib/netdb.in.h
+++ b/lib/netdb.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* This file is supposed to be used on platforms that lack <netdb.h>.
It is intended to provide definitions and prototypes needed by an
diff --git a/lib/netinet_in.in.h b/lib/netinet_in.in.h
index 8bf37a6..a93dcdf 100644
--- a/lib/netinet_in.in.h
+++ b/lib/netinet_in.in.h
@@ -12,8 +12,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef address@hidden@_NETINET_IN_H
diff --git a/lib/nproc.c b/lib/nproc.c
index 6932ac9..c4b151a 100644
--- a/lib/nproc.c
+++ b/lib/nproc.c
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Glen Lenker and Bruno Haible. */
@@ -257,7 +256,7 @@ num_processors (enum nproc_query query)
}
#if defined _SC_NPROCESSORS_ONLN
- { /* This works on glibc, MacOS X 10.5, FreeBSD, AIX, OSF/1, Solaris,
+ { /* This works on glibc, Mac OS X 10.5, FreeBSD, AIX, OSF/1, Solaris,
Cygwin, Haiku. */
long int nprocs = sysconf (_SC_NPROCESSORS_ONLN);
if (nprocs > 0)
@@ -268,7 +267,7 @@ num_processors (enum nproc_query query)
else /* query == NPROC_ALL */
{
#if defined _SC_NPROCESSORS_CONF
- { /* This works on glibc, MacOS X 10.5, FreeBSD, AIX, OSF/1, Solaris,
+ { /* This works on glibc, Mac OS X 10.5, FreeBSD, AIX, OSF/1, Solaris,
Cygwin, Haiku. */
long int nprocs = sysconf (_SC_NPROCESSORS_CONF);
@@ -333,7 +332,7 @@ num_processors (enum nproc_query query)
NPROC_CURRENT and NPROC_ALL. */
#if HAVE_SYSCTL && defined HW_NCPU
- { /* This works on MacOS X, FreeBSD, NetBSD, OpenBSD. */
+ { /* This works on Mac OS X, FreeBSD, NetBSD, OpenBSD. */
int nprocs;
size_t len = sizeof (nprocs);
static int mib[2] = { CTL_HW, HW_NCPU };
diff --git a/lib/nproc.h b/lib/nproc.h
index ac2ddd5..c5f6322 100644
--- a/lib/nproc.h
+++ b/lib/nproc.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Glen Lenker and Bruno Haible. */
diff --git a/lib/pathmax.h b/lib/pathmax.h
index 4d643a7..2361321 100644
--- a/lib/pathmax.h
+++ b/lib/pathmax.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _PATHMAX_H
# define _PATHMAX_H
diff --git a/lib/pipe2.c b/lib/pipe2.c
index 12a5a8a..2c018d5 100644
--- a/lib/pipe2.c
+++ b/lib/pipe2.c
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/printf-args.c b/lib/printf-args.c
index bddbf6d..c768883 100644
--- a/lib/printf-args.c
+++ b/lib/printf-args.c
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
/* This file can be parametrized with the following macros:
ENABLE_UNISTDIO Set to 1 to enable the unistdio extensions.
diff --git a/lib/printf-args.h b/lib/printf-args.h
index 0fdfaa5..0bc75ca 100644
--- a/lib/printf-args.h
+++ b/lib/printf-args.h
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _PRINTF_ARGS_H
#define _PRINTF_ARGS_H
diff --git a/lib/printf-parse.c b/lib/printf-parse.c
index 6aded7c..fcc302f 100644
--- a/lib/printf-parse.c
+++ b/lib/printf-parse.c
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
/* This file can be parametrized with the following macros:
CHAR_T The element type of the format string.
@@ -402,7 +401,7 @@ PRINTF_PARSE (const CHAR_T *format, DIRECTIVES *d,
arguments *a)
cp++;
}
#if defined __APPLE__ && defined __MACH__
- /* On MacOS X 10.3, PRIdMAX is defined as "qd".
+ /* On Mac OS X 10.3, PRIdMAX is defined as "qd".
We cannot change it to "lld" because PRIdMAX must also
be understood by the system's printf routines. */
else if (*cp == 'q')
diff --git a/lib/printf-parse.h b/lib/printf-parse.h
index c6a083c..94883c6 100644
--- a/lib/printf-parse.h
+++ b/lib/printf-parse.h
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _PRINTF_PARSE_H
#define _PRINTF_PARSE_H
diff --git a/lib/ref-add.sin b/lib/ref-add.sin
index 2aa7826..8c1a7d0 100644
--- a/lib/ref-add.sin
+++ b/lib/ref-add.sin
@@ -13,8 +13,7 @@
# 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.
+# with this program; if not, see <http://www.gnu.org/licenses/>.
#
# Written by Bruno Haible <address@hidden>.
#
diff --git a/lib/ref-del.sin b/lib/ref-del.sin
index a2ad6ad..fd87588 100644
--- a/lib/ref-del.sin
+++ b/lib/ref-del.sin
@@ -13,8 +13,7 @@
# 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.
+# with this program; if not, see <http://www.gnu.org/licenses/>.
#
# Written by Bruno Haible <address@hidden>.
#
diff --git a/lib/regcomp.c b/lib/regcomp.c
index ac13307..76947c2 100644
--- a/lib/regcomp.c
+++ b/lib/regcomp.c
@@ -14,8 +14,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern,
size_t length, reg_syntax_t syntax);
@@ -273,7 +272,7 @@ int
re_compile_fastmap (bufp)
struct re_pattern_buffer *bufp;
{
- re_dfa_t *dfa = (re_dfa_t *) bufp->buffer;
+ re_dfa_t *dfa = bufp->buffer;
char *fastmap = bufp->fastmap;
memset (fastmap, '\0', sizeof (char) * SBC_MAX);
@@ -307,7 +306,7 @@ static void
re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state,
char *fastmap)
{
- re_dfa_t *dfa = (re_dfa_t *) bufp->buffer;
+ re_dfa_t *dfa = bufp->buffer;
Idx node_cnt;
bool icase = (dfa->mb_cur_max == 1 && (bufp->syntax & RE_ICASE));
for (node_cnt = 0; node_cnt < init_state->nodes.nelem; ++node_cnt)
@@ -586,19 +585,23 @@ weak_alias (__regerror, regerror)
static const bitset_t utf8_sb_map =
{
/* Set the first 128 bits. */
-# if 4 * BITSET_WORD_BITS < ASCII_CHARS
-# error "bitset_word_t is narrower than 32 bits"
-# elif 3 * BITSET_WORD_BITS < ASCII_CHARS
+# ifdef __GNUC__
+ [0 ... 0x80 / BITSET_WORD_BITS - 1] = BITSET_WORD_MAX
+# else
+# if 4 * BITSET_WORD_BITS < ASCII_CHARS
+# error "bitset_word_t is narrower than 32 bits"
+# elif 3 * BITSET_WORD_BITS < ASCII_CHARS
BITSET_WORD_MAX, BITSET_WORD_MAX, BITSET_WORD_MAX,
-# elif 2 * BITSET_WORD_BITS < ASCII_CHARS
+# elif 2 * BITSET_WORD_BITS < ASCII_CHARS
BITSET_WORD_MAX, BITSET_WORD_MAX,
-# elif 1 * BITSET_WORD_BITS < ASCII_CHARS
+# elif 1 * BITSET_WORD_BITS < ASCII_CHARS
BITSET_WORD_MAX,
-# endif
+# endif
(BITSET_WORD_MAX
>> (SBC_MAX % BITSET_WORD_BITS == 0
? 0
: BITSET_WORD_BITS - SBC_MAX % BITSET_WORD_BITS))
+# endif
};
#endif
@@ -657,7 +660,7 @@ void
regfree (preg)
regex_t *preg;
{
- re_dfa_t *dfa = (re_dfa_t *) preg->buffer;
+ re_dfa_t *dfa = preg->buffer;
if (BE (dfa != NULL, 1))
free_dfa_content (dfa);
preg->buffer = NULL;
@@ -764,7 +767,7 @@ re_compile_internal (regex_t *preg, const char * pattern,
size_t length,
preg->regs_allocated = REGS_UNALLOCATED;
/* Initialize the dfa. */
- dfa = (re_dfa_t *) preg->buffer;
+ dfa = preg->buffer;
if (BE (preg->allocated < sizeof (re_dfa_t), 0))
{
/* If zero allocated, but buffer is non-null, try to realloc
@@ -775,7 +778,7 @@ re_compile_internal (regex_t *preg, const char * pattern,
size_t length,
if (dfa == NULL)
return REG_ESPACE;
preg->allocated = sizeof (re_dfa_t);
- preg->buffer = (unsigned char *) dfa;
+ preg->buffer = dfa;
}
preg->used = sizeof (re_dfa_t);
@@ -850,7 +853,7 @@ init_dfa (re_dfa_t *dfa, size_t pat_len)
{
__re_size_t table_size;
#ifndef _LIBC
- char *codeset_name;
+ const char *codeset_name;
#endif
#ifdef RE_ENABLE_I18N
size_t max_i18n_object_size = MAX (sizeof (wchar_t), sizeof (wctype_t));
@@ -873,7 +876,7 @@ init_dfa (re_dfa_t *dfa, size_t pat_len)
calculation below, and for similar doubling calculations
elsewhere. And it's <= rather than <, because some of the
doubling calculations add 1 afterwards. */
- if (BE (SIZE_MAX / max_object_size / 2 <= pat_len, 0))
+ if (BE (MIN (IDX_MAX, SIZE_MAX / max_object_size) / 2 <= pat_len, 0))
return REG_ESPACE;
dfa->nodes_alloc = pat_len + 1;
@@ -896,8 +899,10 @@ init_dfa (re_dfa_t *dfa, size_t pat_len)
!= 0);
#else
codeset_name = nl_langinfo (CODESET);
- if (strcasecmp (codeset_name, "UTF-8") == 0
- || strcasecmp (codeset_name, "UTF8") == 0)
+ if ((codeset_name[0] == 'U' || codeset_name[0] == 'u')
+ && (codeset_name[1] == 'T' || codeset_name[1] == 't')
+ && (codeset_name[2] == 'F' || codeset_name[2] == 'f')
+ && strcmp (codeset_name + 3 + (codeset_name[3] == '-'), "8") == 0)
dfa->is_utf8 = 1;
/* We check exhaustively in the loop below if this charset is a
@@ -947,9 +952,43 @@ static void
internal_function
init_word_char (re_dfa_t *dfa)
{
- int i, j, ch;
dfa->word_ops_used = 1;
- for (i = 0, ch = 0; i < BITSET_WORDS; ++i)
+ int i = 0;
+ int j;
+ int ch = 0;
+ if (BE (dfa->map_notascii == 0, 1))
+ {
+ bitset_word_t bits0 = 0x00000000;
+ bitset_word_t bits1 = 0x03ff0000;
+ bitset_word_t bits2 = 0x87fffffe;
+ bitset_word_t bits3 = 0x07fffffe;
+ if (BITSET_WORD_BITS == 64)
+ {
+ dfa->word_char[0] = bits1 << 31 << 1 | bits0;
+ dfa->word_char[1] = bits3 << 31 << 1 | bits2;
+ i = 2;
+ }
+ else if (BITSET_WORD_BITS == 32)
+ {
+ dfa->word_char[0] = bits0;
+ dfa->word_char[1] = bits1;
+ dfa->word_char[2] = bits2;
+ dfa->word_char[3] = bits3;
+ i = 4;
+ }
+ else
+ goto general_case;
+ ch = 128;
+
+ if (BE (dfa->is_utf8, 1))
+ {
+ memset (&dfa->word_char[i], '\0', (SBC_MAX - ch) / 8);
+ return;
+ }
+ }
+
+ general_case:
+ for (; i < BITSET_WORDS; ++i)
for (j = 0; j < BITSET_WORD_BITS; ++j, ++ch)
if (isalnum (ch) || ch == '_')
dfa->word_char[i] |= (bitset_word_t) 1 << j;
@@ -960,7 +999,7 @@ init_word_char (re_dfa_t *dfa)
static void
free_workarea_compile (regex_t *preg)
{
- re_dfa_t *dfa = (re_dfa_t *) preg->buffer;
+ re_dfa_t *dfa = preg->buffer;
bin_tree_storage_t *storage, *next;
for (storage = dfa->str_tree_storage; storage; storage = next)
{
@@ -1144,7 +1183,7 @@ optimize_utf8 (re_dfa_t *dfa)
static reg_errcode_t
analyze (regex_t *preg)
{
- re_dfa_t *dfa = (re_dfa_t *) preg->buffer;
+ re_dfa_t *dfa = preg->buffer;
reg_errcode_t ret;
/* Allocate arrays. */
@@ -1325,7 +1364,7 @@ lower_subexps (void *extra, bin_tree_t *node)
static bin_tree_t *
lower_subexp (reg_errcode_t *err, regex_t *preg, bin_tree_t *node)
{
- re_dfa_t *dfa = (re_dfa_t *) preg->buffer;
+ re_dfa_t *dfa = preg->buffer;
bin_tree_t *body = node->left;
bin_tree_t *op, *cls, *tree1, *tree;
@@ -2092,7 +2131,7 @@ peek_token_bracket (re_token_t *token, re_string_t
*input, reg_syntax_t syntax)
/* Entry point of the parser.
Parse the regular expression REGEXP and return the structure tree.
- If an error is occured, ERR is set by error code, and return NULL.
+ If an error occurs, ERR is set by error code, and return NULL.
This function build the following tree, from regular expression <reg_exp>:
CAT
/ \
@@ -2106,7 +2145,7 @@ static bin_tree_t *
parse (re_string_t *regexp, regex_t *preg, reg_syntax_t syntax,
reg_errcode_t *err)
{
- re_dfa_t *dfa = (re_dfa_t *) preg->buffer;
+ re_dfa_t *dfa = preg->buffer;
bin_tree_t *tree, *eor, *root;
re_token_t current_token;
dfa->syntax = syntax;
@@ -2140,7 +2179,7 @@ static bin_tree_t *
parse_reg_exp (re_string_t *regexp, regex_t *preg, re_token_t *token,
reg_syntax_t syntax, Idx nest, reg_errcode_t *err)
{
- re_dfa_t *dfa = (re_dfa_t *) preg->buffer;
+ re_dfa_t *dfa = preg->buffer;
bin_tree_t *tree, *branch = NULL;
tree = parse_branch (regexp, preg, token, syntax, nest, err);
if (BE (*err != REG_NOERROR && tree == NULL, 0))
@@ -2182,7 +2221,7 @@ parse_branch (re_string_t *regexp, regex_t *preg,
re_token_t *token,
reg_syntax_t syntax, Idx nest, reg_errcode_t *err)
{
bin_tree_t *tree, *expr;
- re_dfa_t *dfa = (re_dfa_t *) preg->buffer;
+ re_dfa_t *dfa = preg->buffer;
tree = parse_expression (regexp, preg, token, syntax, nest, err);
if (BE (*err != REG_NOERROR && tree == NULL, 0))
return NULL;
@@ -2193,16 +2232,21 @@ parse_branch (re_string_t *regexp, regex_t *preg,
re_token_t *token,
expr = parse_expression (regexp, preg, token, syntax, nest, err);
if (BE (*err != REG_NOERROR && expr == NULL, 0))
{
+ if (tree != NULL)
+ postorder (tree, free_tree, NULL);
return NULL;
}
if (tree != NULL && expr != NULL)
{
- tree = create_tree (dfa, tree, expr, CONCAT);
- if (tree == NULL)
+ bin_tree_t *newtree = create_tree (dfa, tree, expr, CONCAT);
+ if (newtree == NULL)
{
+ postorder (expr, free_tree, NULL);
+ postorder (tree, free_tree, NULL);
*err = REG_ESPACE;
return NULL;
}
+ tree = newtree;
}
else if (tree == NULL)
tree = expr;
@@ -2221,7 +2265,7 @@ static bin_tree_t *
parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token,
reg_syntax_t syntax, Idx nest, reg_errcode_t *err)
{
- re_dfa_t *dfa = (re_dfa_t *) preg->buffer;
+ re_dfa_t *dfa = preg->buffer;
bin_tree_t *tree;
switch (token->type)
{
@@ -2437,7 +2481,7 @@ static bin_tree_t *
parse_sub_exp (re_string_t *regexp, regex_t *preg, re_token_t *token,
reg_syntax_t syntax, Idx nest, reg_errcode_t *err)
{
- re_dfa_t *dfa = (re_dfa_t *) preg->buffer;
+ re_dfa_t *dfa = preg->buffer;
bin_tree_t *tree;
size_t cur_nsub;
cur_nsub = preg->re_nsub++;
@@ -2451,7 +2495,11 @@ parse_sub_exp (re_string_t *regexp, regex_t *preg,
re_token_t *token,
{
tree = parse_reg_exp (regexp, preg, token, syntax, nest, err);
if (BE (*err == REG_NOERROR && token->type != OP_CLOSE_SUBEXP, 0))
- *err = REG_EPAREN;
+ {
+ if (tree != NULL)
+ postorder (tree, free_tree, NULL);
+ *err = REG_EPAREN;
+ }
if (BE (*err != REG_NOERROR, 0))
return NULL;
}
@@ -2529,6 +2577,12 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp,
re_dfa_t *dfa,
*err = REG_BADBR;
return NULL;
}
+
+ if (BE (RE_DUP_MAX < (end == REG_MISSING ? start : end), 0))
+ {
+ *err = REG_ESIZE;
+ return NULL;
+ }
}
else
{
@@ -2569,7 +2623,10 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp,
re_dfa_t *dfa,
old_tree = NULL;
if (elem->token.type == SUBEXP)
- postorder (elem, mark_opt_subexp, (void *) (long) elem->token.opr.idx);
+ {
+ uintptr_t subidx = elem->token.opr.idx;
+ postorder (elem, mark_opt_subexp, (void *) subidx);
+ }
tree = create_tree (dfa, elem, NULL,
(end == REG_MISSING ? OP_DUP_ASTERISK : OP_ALT));
@@ -2615,7 +2672,7 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp,
re_dfa_t *dfa,
Build the range expression which starts from START_ELEM, and ends
at END_ELEM. The result are written to MBCSET and SBCSET.
RANGE_ALLOC is the allocated size of mbcset->range_starts, and
- mbcset->range_ends, is a pointer argument sinse we may
+ mbcset->range_ends, is a pointer argument since we may
update it. */
static reg_errcode_t
@@ -2749,11 +2806,12 @@ build_range_exp (const reg_syntax_t syntax,
static reg_errcode_t
internal_function
-build_collating_symbol (bitset_t sbcset,
# ifdef RE_ENABLE_I18N
- re_charset_t *mbcset, Idx *coll_sym_alloc,
-# endif
- const unsigned char *name)
+build_collating_symbol (bitset_t sbcset, re_charset_t *mbcset,
+ Idx *coll_sym_alloc, const unsigned char *name)
+# else /* not RE_ENABLE_I18N */
+build_collating_symbol (bitset_t sbcset, const unsigned char *name)
+# endif /* not RE_ENABLE_I18N */
{
size_t name_len = strlen ((const char *) name);
if (BE (name_len != 1, 0))
@@ -2781,8 +2839,8 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa,
re_token_t *token,
const int32_t *symb_table;
const unsigned char *extra;
- /* Local function for parse_bracket_exp used in _LIBC environement.
- Seek the collating symbol entry correspondings to NAME.
+ /* Local function for parse_bracket_exp used in _LIBC environment.
+ Seek the collating symbol entry corresponding to NAME.
Return the index of the symbol in the SYMB_TABLE. */
auto inline int32_t
@@ -2885,11 +2943,11 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa,
re_token_t *token,
return UINT_MAX;
}
- /* Local function for parse_bracket_exp used in _LIBC environement.
+ /* Local function for parse_bracket_exp used in _LIBC environment.
Build the range expression which starts from START_ELEM, and ends
at END_ELEM. The result are written to MBCSET and SBCSET.
RANGE_ALLOC is the allocated size of mbcset->range_starts, and
- mbcset->range_ends, is a pointer argument sinse we may
+ mbcset->range_ends, is a pointer argument since we may
update it. */
auto inline reg_errcode_t
@@ -2969,11 +3027,11 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa,
re_token_t *token,
return REG_NOERROR;
}
- /* Local function for parse_bracket_exp used in _LIBC environement.
+ /* Local function for parse_bracket_exp used in _LIBC environment.
Build the collating element which is represented by NAME.
The result are written to MBCSET and SBCSET.
COLL_SYM_ALLOC is the allocated size of mbcset->coll_sym, is a
- pointer argument sinse we may update it. */
+ pointer argument since we may update it. */
auto inline reg_errcode_t
__attribute ((always_inline))
@@ -3075,6 +3133,10 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa,
re_token_t *token,
if (BE (sbcset == NULL, 0))
#endif /* RE_ENABLE_I18N */
{
+ re_free (sbcset);
+#ifdef RE_ENABLE_I18N
+ re_free (mbcset);
+#endif
*err = REG_ESPACE;
return NULL;
}
@@ -3413,7 +3475,7 @@ parse_bracket_symbol (bracket_elem_t *elem, re_string_t
*regexp,
Build the equivalence class which is represented by NAME.
The result are written to MBCSET and SBCSET.
EQUIV_CLASS_ALLOC is the allocated size of mbcset->equiv_classes,
- is a pointer argument sinse we may update it. */
+ is a pointer argument since we may update it. */
static reg_errcode_t
#ifdef RE_ENABLE_I18N
@@ -3444,19 +3506,18 @@ build_equiv_class (bitset_t sbcset, const unsigned char
*name)
_NL_COLLATE_EXTRAMB);
indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE,
_NL_COLLATE_INDIRECTMB);
- idx1 = findidx (&cp);
- if (BE (idx1 == 0 || cp < name + strlen ((const char *) name), 0))
+ idx1 = findidx (&cp, -1);
+ if (BE (idx1 == 0 || *cp != '\0', 0))
/* This isn't a valid character. */
return REG_ECOLLATE;
- /* Build single byte matcing table for this equivalence class. */
- char_buf[1] = (unsigned char) '\0';
+ /* Build single byte matching table for this equivalence class. */
len = weights[idx1 & 0xffffff];
for (ch = 0; ch < SBC_MAX; ++ch)
{
char_buf[0] = ch;
cp = char_buf;
- idx2 = findidx (&cp);
+ idx2 = findidx (&cp, 1);
/*
idx2 = table[ch];
*/
@@ -3509,7 +3570,7 @@ build_equiv_class (bitset_t sbcset, const unsigned char
*name)
Build the character class which is represented by NAME.
The result are written to MBCSET and SBCSET.
CHAR_CLASS_ALLOC is the allocated size of mbcset->char_classes,
- is a pointer argument sinse we may update it. */
+ is a pointer argument since we may update it. */
static reg_errcode_t
#ifdef RE_ENABLE_I18N
@@ -3705,6 +3766,7 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE
trans,
/* This is intended for the expressions like "a{1,3}".
Fetch a number from 'input', and return the number.
Return REG_MISSING if the number field is empty like "{,1}".
+ Return RE_DUP_MAX + 1 if the number field is too large.
Return REG_ERROR if an error occurred. */
static Idx
@@ -3723,8 +3785,9 @@ fetch_number (re_string_t *input, re_token_t *token,
reg_syntax_t syntax)
num = ((token->type != CHARACTER || c < '0' || '9' < c
|| num == REG_ERROR)
? REG_ERROR
- : ((num == REG_MISSING) ? c - '0' : num * 10 + c - '0'));
- num = (num > RE_DUP_MAX) ? REG_ERROR : num;
+ : num == REG_MISSING
+ ? c - '0'
+ : MIN (RE_DUP_MAX + 1, num * 10 + c - '0'));
}
return num;
}
@@ -3798,7 +3861,7 @@ create_token_tree (re_dfa_t *dfa, bin_tree_t *left,
bin_tree_t *right,
static reg_errcode_t
mark_opt_subexp (void *extra, bin_tree_t *node)
{
- Idx idx = (Idx) (long) extra;
+ Idx idx = (uintptr_t) extra;
if (node->token.type == SUBEXP && node->token.opr.idx == idx)
node->token.opt_subexp = 1;
diff --git a/lib/regex.c b/lib/regex.c
index 6e0f752..c578852 100644
--- a/lib/regex.c
+++ b/lib/regex.c
@@ -14,12 +14,20 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
-#include <config.h>
+#ifndef _LIBC
+# include <config.h>
-/* Make sure noone compiles this code with a C++ compiler. */
+# if (__GNUC__ == 4 && 6 <= __GNUC_MINOR__) || 4 < __GNUC__
+# pragma GCC diagnostic ignored "-Wsuggest-attribute=pure"
+# endif
+# if (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) || 4 < __GNUC__
+# pragma GCC diagnostic ignored "-Wtype-limits"
+# endif
+#endif
+
+/* Make sure no one compiles this code with a C++ compiler. */
#if defined __cplusplus && defined _LIBC
# error "This is C code, use a C compiler"
#endif
@@ -53,7 +61,6 @@
GNU regex allows. Include it before <regex.h>, which correctly
#undefs RE_DUP_MAX and sets it to the right value. */
#include <limits.h>
-#include <strings.h>
#include <regex.h>
#include "regex_internal.h"
diff --git a/lib/regex.h b/lib/regex.h
index b612adb..07c1b3d 100644
--- a/lib/regex.h
+++ b/lib/regex.h
@@ -1,6 +1,6 @@
/* Definitions for data structures and routines for the regular
expression library.
- Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2006, 2009-2012
+ Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2012
Free Software Foundation, Inc.
This file is part of the GNU C Library.
@@ -15,8 +15,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _REGEX_H
#define _REGEX_H 1
@@ -28,13 +27,10 @@
extern "C" {
#endif
-/* Define __USE_GNU_REGEX to declare GNU extensions that violate the
+/* Define __USE_GNU to declare GNU extensions that violate the
POSIX name space rules. */
-#undef __USE_GNU_REGEX
-#if (defined _GNU_SOURCE \
- || (!defined _POSIX_C_SOURCE && !defined _POSIX_SOURCE \
- && !defined _XOPEN_SOURCE))
-# define __USE_GNU_REGEX 1
+#ifdef _GNU_SOURCE
+# define __USE_GNU 1
#endif
#ifdef _REGEX_LARGE_OFFSETS
@@ -45,16 +41,6 @@ extern "C" {
supported within glibc itself, and glibc users should not define
_REGEX_LARGE_OFFSETS. */
-/* The type of the offset of a byte within a string.
- For historical reasons POSIX 1003.1-2004 requires that regoff_t be
- at least as wide as off_t. However, many common POSIX platforms set
- regoff_t to the more-sensible ssize_t and the Open Group has
- signalled its intention to change the requirement to be that
- regoff_t be at least as wide as ptrdiff_t and ssize_t; see XBD ERN
- 60 (2005-08-25). We don't know of any hosts where ssize_t or
- ptrdiff_t is wider than ssize_t, so ssize_t is safe. */
-typedef ssize_t regoff_t;
-
/* The type of nonnegative object indexes. Traditionally, GNU regex
uses 'int' for these. Code that uses __re_idx_t should work
regardless of whether the type is signed. */
@@ -69,10 +55,8 @@ typedef size_t __re_long_size_t;
#else
-/* Use types that are binary-compatible with the traditional GNU regex
- implementation, which mishandles strings longer than INT_MAX. */
-
-typedef int regoff_t;
+/* The traditional GNU regex implementation mishandles strings longer
+ than INT_MAX. */
typedef int __re_idx_t;
typedef unsigned int __re_size_t;
typedef unsigned long int __re_long_size_t;
@@ -93,8 +77,7 @@ typedef unsigned long int active_reg_t;
add or remove a bit, only one other definition need change. */
typedef unsigned long int reg_syntax_t;
-#ifdef __USE_GNU_REGEX
-
+#ifdef __USE_GNU
/* If this bit is not set, then \ inside a bracket expression is literal.
If set, then such a \ quotes the following character. */
# define RE_BACKSLASH_ESCAPE_IN_LISTS ((unsigned long int) 1)
@@ -225,8 +208,7 @@ typedef unsigned long int reg_syntax_t;
/* If this bit is set, then no_sub will be set to 1 during
re_compile_pattern. */
# define RE_NO_SUB (RE_CONTEXT_INVALID_DUP << 1)
-
-#endif /* defined __USE_GNU_REGEX */
+#endif
/* This global variable defines the particular regexp syntax to use (for
some interfaces). When a regexp is compiled, the syntax used is
@@ -234,7 +216,7 @@ typedef unsigned long int reg_syntax_t;
already-compiled regexps. */
extern reg_syntax_t re_syntax_options;
-#ifdef __USE_GNU_REGEX
+#ifdef __USE_GNU
/* Define combinations of the above bits for the standard possibilities.
(The [[[ comments delimit what gets put into the Texinfo file, so
don't delete them!) */
@@ -246,16 +228,19 @@ extern reg_syntax_t re_syntax_options;
| RE_NO_BK_PARENS | RE_NO_BK_REFS \
| RE_NO_BK_VBAR | RE_NO_EMPTY_RANGES \
| RE_DOT_NEWLINE | RE_CONTEXT_INDEP_ANCHORS \
+ | RE_CHAR_CLASSES \
| RE_UNMATCHED_RIGHT_PAREN_ORD | RE_NO_GNU_OPS)
# define RE_SYNTAX_GNU_AWK \
- ((RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DEBUG)
\
- & ~(RE_DOT_NOT_NULL | RE_INTERVALS | RE_CONTEXT_INDEP_OPS \
- | RE_CONTEXT_INVALID_OPS ))
+ ((RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS \
+ | RE_INVALID_INTERVAL_ORD) \
+ & ~(RE_DOT_NOT_NULL | RE_CONTEXT_INDEP_OPS \
+ | RE_CONTEXT_INVALID_OPS ))
# define RE_SYNTAX_POSIX_AWK \
(RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS \
- | RE_INTERVALS | RE_NO_GNU_OPS)
+ | RE_INTERVALS | RE_NO_GNU_OPS \
+ | RE_INVALID_INTERVAL_ORD)
# define RE_SYNTAX_GREP
\
(RE_BK_PLUS_QM | RE_CHAR_CLASSES
\
@@ -306,13 +291,12 @@ extern reg_syntax_t re_syntax_options;
| RE_NO_BK_VBAR | RE_UNMATCHED_RIGHT_PAREN_ORD)
/* [[[end syntaxes]]] */
-#endif /* defined __USE_GNU_REGEX */
-
-#ifdef __USE_GNU_REGEX
-
/* Maximum number of duplicates an interval can allow. POSIX-conforming
systems might define this in <limits.h>, but we want our
value, so remove any previous define. */
+# ifdef _REGEX_INCLUDE_LIMITS_H
+# include <limits.h>
+# endif
# ifdef RE_DUP_MAX
# undef RE_DUP_MAX
# endif
@@ -320,13 +304,12 @@ extern reg_syntax_t re_syntax_options;
/* RE_DUP_MAX is 2**15 - 1 because an earlier implementation stored
the counter as a 2-byte signed integer. This is no longer true, so
RE_DUP_MAX could be increased to (INT_MAX / 10 - 1), or to
- ((SIZE_MAX - 2) / 10 - 1) if _REGEX_LARGE_OFFSETS is defined.
+ ((SIZE_MAX - 9) / 10) if _REGEX_LARGE_OFFSETS is defined.
However, there would be a huge performance problem if someone
actually used a pattern like a\{214748363\}, so RE_DUP_MAX retains
its historical value. */
# define RE_DUP_MAX (0x7fff)
-
-#endif /* defined __USE_GNU_REGEX */
+#endif
/* POSIX 'cflags' bits (i.e., information for 'regcomp'). */
@@ -392,11 +375,11 @@ typedef enum
/* Error codes we've added. */
_REG_EEND, /* Premature end. */
- _REG_ESIZE, /* Compiled pattern bigger than 2^16 bytes. */
+ _REG_ESIZE, /* Too large (e.g., repeat count too large). */
_REG_ERPAREN /* Unmatched ) or \); not returned from regcomp. */
} reg_errcode_t;
-#ifdef _XOPEN_SOURCE
+#if defined _XOPEN_SOURCE || defined __USE_XOPEN2K
# define REG_ENOSYS _REG_ENOSYS
#endif
#define REG_NOERROR _REG_NOERROR
@@ -417,62 +400,50 @@ typedef enum
#define REG_ESIZE _REG_ESIZE
#define REG_ERPAREN _REG_ERPAREN
-/* struct re_pattern_buffer normally uses member names like 'buffer'
- that POSIX does not allow. In POSIX mode these members have names
- with leading 're_' (e.g., 're_buffer'). */
-#ifdef __USE_GNU_REGEX
-# define _REG_RE_NAME(id) id
-# define _REG_RM_NAME(id) id
-#else
-# define _REG_RE_NAME(id) re_##id
-# define _REG_RM_NAME(id) rm_##id
+/* This data structure represents a compiled pattern. Before calling
+ the pattern compiler, the fields 'buffer', 'allocated', 'fastmap',
+ and 'translate' can be set. After the pattern has been compiled,
+ the fields 're_nsub', 'not_bol' and 'not_eol' are available. All
+ other fields are private to the regex routines. */
+
+#ifndef RE_TRANSLATE_TYPE
+# define __RE_TRANSLATE_TYPE unsigned char *
+# ifdef __USE_GNU
+# define RE_TRANSLATE_TYPE __RE_TRANSLATE_TYPE
+# endif
#endif
-/* The user can specify the type of the re_translate member by
- defining the macro RE_TRANSLATE_TYPE, which defaults to unsigned
- char *. This pollutes the POSIX name space, so in POSIX mode just
- use unsigned char *. */
-#ifdef __USE_GNU_REGEX
-# ifndef RE_TRANSLATE_TYPE
-# define RE_TRANSLATE_TYPE unsigned char *
-# endif
-# define REG_TRANSLATE_TYPE RE_TRANSLATE_TYPE
+#ifdef __USE_GNU
+# define __REPB_PREFIX(name) name
#else
-# define REG_TRANSLATE_TYPE unsigned char *
+# define __REPB_PREFIX(name) __##name
#endif
-/* This data structure represents a compiled pattern. Before calling
- the pattern compiler, the fields 'buffer', 'allocated', 'fastmap',
- 'translate', and 'no_sub' can be set. After the pattern has been
- compiled, the 're_nsub' field is available. All other fields are
- private to the regex routines. */
-
struct re_pattern_buffer
{
- /* Space that holds the compiled pattern. It is declared as
- 'unsigned char *' because its elements are sometimes used as
- array indexes. */
- unsigned char *_REG_RE_NAME (buffer);
+ /* Space that holds the compiled pattern. The type
+ 'struct re_dfa_t' is private and is not declared here. */
+ struct re_dfa_t *__REPB_PREFIX(buffer);
/* Number of bytes to which 'buffer' points. */
- __re_long_size_t _REG_RE_NAME (allocated);
+ __re_long_size_t __REPB_PREFIX(allocated);
/* Number of bytes actually used in 'buffer'. */
- __re_long_size_t _REG_RE_NAME (used);
+ __re_long_size_t __REPB_PREFIX(used);
/* Syntax setting with which the pattern was compiled. */
- reg_syntax_t _REG_RE_NAME (syntax);
+ reg_syntax_t __REPB_PREFIX(syntax);
/* Pointer to a fastmap, if any, otherwise zero. re_search uses the
fastmap, if there is one, to skip over impossible starting points
for matches. */
- char *_REG_RE_NAME (fastmap);
+ char *__REPB_PREFIX(fastmap);
/* Either a translate table to apply to all characters before
comparing them, or zero for no translation. The translation is
applied to a pattern when it is compiled and to a string when it
is matched. */
- REG_TRANSLATE_TYPE _REG_RE_NAME (translate);
+ __RE_TRANSLATE_TYPE __REPB_PREFIX(translate);
/* Number of subexpressions found by the compiler. */
size_t re_nsub;
@@ -481,57 +452,70 @@ struct re_pattern_buffer
Well, in truth it's used only in 're_search_2', to see whether or
not we should use the fastmap, so we don't set this absolutely
perfectly; see 're_compile_fastmap' (the "duplicate" case). */
- unsigned int _REG_RE_NAME (can_be_null) : 1;
+ unsigned __REPB_PREFIX(can_be_null) : 1;
/* If REGS_UNALLOCATED, allocate space in the 'regs' structure
for 'max (RE_NREGS, re_nsub + 1)' groups.
If REGS_REALLOCATE, reallocate space if necessary.
If REGS_FIXED, use what's there. */
-#ifdef __USE_GNU_REGEX
+#ifdef __USE_GNU
# define REGS_UNALLOCATED 0
# define REGS_REALLOCATE 1
# define REGS_FIXED 2
#endif
- unsigned int _REG_RE_NAME (regs_allocated) : 2;
+ unsigned __REPB_PREFIX(regs_allocated) : 2;
/* Set to zero when 're_compile_pattern' compiles a pattern; set to
one by 're_compile_fastmap' if it updates the fastmap. */
- unsigned int _REG_RE_NAME (fastmap_accurate) : 1;
+ unsigned __REPB_PREFIX(fastmap_accurate) : 1;
/* If set, 're_match_2' does not return information about
subexpressions. */
- unsigned int _REG_RE_NAME (no_sub) : 1;
+ unsigned __REPB_PREFIX(no_sub) : 1;
/* If set, a beginning-of-line anchor doesn't match at the beginning
of the string. */
- unsigned int _REG_RE_NAME (not_bol) : 1;
+ unsigned __REPB_PREFIX(not_bol) : 1;
/* Similarly for an end-of-line anchor. */
- unsigned int _REG_RE_NAME (not_eol) : 1;
+ unsigned __REPB_PREFIX(not_eol) : 1;
/* If true, an anchor at a newline matches. */
- unsigned int _REG_RE_NAME (newline_anchor) : 1;
-
-/* [[[end pattern_buffer]]] */
+ unsigned __REPB_PREFIX(newline_anchor) : 1;
};
typedef struct re_pattern_buffer regex_t;
+/* Type for byte offsets within the string. POSIX mandates this. */
+#ifdef _REGEX_LARGE_OFFSETS
+/* POSIX 1003.1-2008 requires that regoff_t be at least as wide as
+ ptrdiff_t and ssize_t. We don't know of any hosts where ptrdiff_t
+ is wider than ssize_t, so ssize_t is safe. */
+typedef ssize_t regoff_t;
+#else
+/* The traditional GNU regex implementation mishandles strings longer
+ than INT_MAX. */
+typedef int regoff_t;
+#endif
+
+
+#ifdef __USE_GNU
/* This is the structure we store register match data in. See
regex.texinfo for a full description of what registers match. */
struct re_registers
{
- __re_size_t _REG_RM_NAME (num_regs);
- regoff_t *_REG_RM_NAME (start);
- regoff_t *_REG_RM_NAME (end);
+ __re_size_t num_regs;
+ regoff_t *start;
+ regoff_t *end;
};
/* If 'regs_allocated' is REGS_UNALLOCATED in the pattern buffer,
're_match_2' returns information about at least this many registers
the first time a 'regs' structure is passed. */
-#if !defined RE_NREGS && defined __USE_GNU_REGEX
-# define RE_NREGS 30
+# ifndef RE_NREGS
+# define RE_NREGS 30
+# endif
#endif
@@ -546,13 +530,19 @@ typedef struct
/* Declarations for routines. */
+#ifdef __USE_GNU
/* Sets the current default syntax to SYNTAX, and return the old syntax.
You can also simply assign to the 're_syntax_options' variable. */
extern reg_syntax_t re_set_syntax (reg_syntax_t __syntax);
/* Compile the regular expression PATTERN, with length LENGTH
and syntax given by the global 're_syntax_options', into the buffer
- BUFFER. Return NULL if successful, and an error string if not. */
+ BUFFER. Return NULL if successful, and an error string if not.
+
+ To free the allocated storage, you must call 'regfree' on BUFFER.
+ Note that the translate table must either have been initialised by
+ 'regcomp', with a malloc'ed value, or set to NULL before calling
+ 'regfree'. */
extern const char *re_compile_pattern (const char *__pattern, size_t __length,
struct re_pattern_buffer *__buffer);
@@ -609,14 +599,15 @@ extern regoff_t re_match_2 (struct re_pattern_buffer
*__buffer,
register data.
Unless this function is called, the first search or match using
- BUFFER will allocate its own register data, without freeing the old
- data. */
+ BUFFER will allocate its own register data, without
+ freeing the old data. */
extern void re_set_registers (struct re_pattern_buffer *__buffer,
struct re_registers *__regs,
__re_size_t __num_regs,
regoff_t *__starts, regoff_t *__ends);
+#endif /* Use GNU */
-#if defined _REGEX_RE_COMP || defined _LIBC
+#if defined _REGEX_RE_COMP || (defined _LIBC && defined __USE_BSD)
# ifndef _CRAY
/* 4.2 bsd compatibility. */
extern char *re_comp (const char *);
diff --git a/lib/regex_internal.c b/lib/regex_internal.c
index c029c23..71ee41e 100644
--- a/lib/regex_internal.c
+++ b/lib/regex_internal.c
@@ -14,8 +14,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
static void re_string_construct_common (const char *str, Idx len,
re_string_t *pstr,
@@ -134,9 +133,9 @@ re_string_realloc_buffers (re_string_t *pstr, Idx
new_buf_len)
{
wint_t *new_wcs;
- /* Avoid overflow. */
- size_t max_object_size = MAX (sizeof (wint_t), sizeof (Idx));
- if (BE (SIZE_MAX / max_object_size < new_buf_len, 0))
+ /* Avoid overflow in realloc. */
+ const size_t max_object_size = MAX (sizeof (wint_t), sizeof (Idx));
+ if (BE (MIN (IDX_MAX, SIZE_MAX / max_object_size) < new_buf_len, 0))
return REG_ESPACE;
new_wcs = re_realloc (pstr->wcs, wint_t, new_buf_len);
@@ -236,13 +235,8 @@ build_wcs_buffer (re_string_t *pstr)
else
p = (const char *) pstr->raw_mbs + pstr->raw_mbs_idx + byte_idx;
mbclen = __mbrtowc (&wc, p, remain_len, &pstr->cur_state);
- if (BE (mbclen == (size_t) -2, 0))
- {
- /* The buffer doesn't have enough space, finish to build. */
- pstr->cur_state = prev_st;
- break;
- }
- else if (BE (mbclen == (size_t) -1 || mbclen == 0, 0))
+ if (BE (mbclen == (size_t) -1 || mbclen == 0
+ || (mbclen == (size_t) -2 && pstr->bufs_len >= pstr->len), 0))
{
/* We treat these cases as a singlebyte character. */
mbclen = 1;
@@ -251,6 +245,12 @@ build_wcs_buffer (re_string_t *pstr)
wc = pstr->trans[wc];
pstr->cur_state = prev_st;
}
+ else if (BE (mbclen == (size_t) -2, 0))
+ {
+ /* The buffer doesn't have enough space, finish to build. */
+ pstr->cur_state = prev_st;
+ break;
+ }
/* Write wide character and padding. */
pstr->wcs[byte_idx++] = wc;
@@ -333,9 +333,11 @@ build_wcs_upper_buffer (re_string_t *pstr)
for (remain_len = byte_idx + mbclen - 1; byte_idx < remain_len ;)
pstr->wcs[byte_idx++] = WEOF;
}
- else if (mbclen == (size_t) -1 || mbclen == 0)
+ else if (mbclen == (size_t) -1 || mbclen == 0
+ || (mbclen == (size_t) -2 && pstr->bufs_len >= pstr->len))
{
- /* It is an invalid character or '\0'. Just use the byte. */
+ /* It is an invalid character, an incomplete character
+ at the end of the string, or '\0'. Just use the byte. */
int ch = pstr->raw_mbs[pstr->raw_mbs_idx + byte_idx];
pstr->mbs[byte_idx] = ch;
/* And also cast it to wide char. */
@@ -448,7 +450,8 @@ build_wcs_upper_buffer (re_string_t *pstr)
for (remain_len = byte_idx + mbclen - 1; byte_idx < remain_len ;)
pstr->wcs[byte_idx++] = WEOF;
}
- else if (mbclen == (size_t) -1 || mbclen == 0)
+ else if (mbclen == (size_t) -1 || mbclen == 0
+ || (mbclen == (size_t) -2 && pstr->bufs_len >= pstr->len))
{
/* It is an invalid character or '\0'. Just use the byte. */
int ch = pstr->raw_mbs[pstr->raw_mbs_idx + src_idx];
@@ -495,8 +498,7 @@ re_string_skip_chars (re_string_t *pstr, Idx new_raw_idx,
wint_t *last_wc)
rawbuf_idx < new_raw_idx;)
{
wchar_t wc2;
- Idx remain_len;
- remain_len = pstr->len - rawbuf_idx;
+ Idx remain_len = pstr->raw_len - rawbuf_idx;
prev_st = pstr->cur_state;
mbclen = __mbrtowc (&wc2, (const char *) pstr->raw_mbs + rawbuf_idx,
remain_len, &pstr->cur_state);
@@ -732,21 +734,21 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int
eflags)
mbstate_t cur_state;
wchar_t wc2;
Idx mlen = raw + pstr->len - p;
+ unsigned char buf[6];
size_t mbclen;
-#if 0 /* dead code: buf is set but never used */
- unsigned char buf[6];
+ const unsigned char *pp = p;
if (BE (pstr->trans != NULL, 0))
{
int i = mlen < 6 ? mlen : 6;
while (--i >= 0)
buf[i] = pstr->trans[p[i]];
+ pp = buf;
}
-#endif
/* XXX Don't use mbrtowc, we know which conversion
to use (UTF-8 -> UCS4). */
memset (&cur_state, 0, sizeof (cur_state));
- mbclen = __mbrtowc (&wc2, (const char *) p, mlen,
+ mbclen = __mbrtowc (&wc2, (const char *) pp, mlen,
&cur_state);
if (raw + offset - p <= mbclen
&& mbclen < (size_t) -2)
@@ -868,7 +870,7 @@ re_string_peek_byte_case (const re_string_t *pstr, Idx idx)
}
static unsigned char
-internal_function __attribute ((pure))
+internal_function
re_string_fetch_byte_case (re_string_t *pstr)
{
if (BE (!pstr->mbs_allocated, 1))
@@ -1412,13 +1414,12 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token)
Idx *new_nexts, *new_indices;
re_node_set *new_edests, *new_eclosures;
re_token_t *new_nodes;
- size_t max_object_size =
- MAX (sizeof (re_token_t),
- MAX (sizeof (re_node_set),
- sizeof (Idx)));
- /* Avoid overflows. */
- if (BE (SIZE_MAX / 2 / max_object_size < dfa->nodes_alloc, 0))
+ /* Avoid overflows in realloc. */
+ const size_t max_object_size = MAX (sizeof (re_token_t),
+ MAX (sizeof (re_node_set),
+ sizeof (Idx)));
+ if (BE (MIN (IDX_MAX, SIZE_MAX / max_object_size) < new_nodes_alloc, 0))
return REG_MISSING;
new_nodes = re_realloc (dfa->nodes, re_token_t, new_nodes_alloc);
@@ -1579,7 +1580,7 @@ register_state (const re_dfa_t *dfa, re_dfastate_t
*newstate,
{
Idx elem = newstate->nodes.elems[i];
if (!IS_EPSILON_NODE (dfa->nodes[elem].type))
- if (BE (! re_node_set_insert_last (&newstate->non_eps_nodes, elem), 0))
+ if (! re_node_set_insert_last (&newstate->non_eps_nodes, elem))
return REG_ESPACE;
}
@@ -1614,7 +1615,7 @@ free_state (re_dfastate_t *state)
re_free (state);
}
-/* Create the new state which is independ of contexts.
+/* Create the new state which is independent of contexts.
Return the new state if succeeded, otherwise return NULL. */
static re_dfastate_t *
diff --git a/lib/regex_internal.h b/lib/regex_internal.h
index 7261192..fd331b1 100644
--- a/lib/regex_internal.h
+++ b/lib/regex_internal.h
@@ -14,15 +14,13 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _REGEX_INTERNAL_H
#define _REGEX_INTERNAL_H 1
#include <assert.h>
#include <ctype.h>
-#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
@@ -32,13 +30,14 @@
# include "localcharset.h"
#endif
#include <locale.h>
-
#include <wchar.h>
#include <wctype.h>
+#include <stdbool.h>
#include <stdint.h>
#if defined _LIBC
# include <bits/libc-lock.h>
#else
+# define __libc_lock_define(CLASS,NAME)
# define __libc_lock_init(NAME) do { } while (0)
# define __libc_lock_lock(NAME) do { } while (0)
# define __libc_lock_unlock(NAME) do { } while (0)
@@ -76,11 +75,6 @@
# define gettext_noop(String) String
#endif
-/* For loser systems without the definition. */
-#ifndef SIZE_MAX
-# define SIZE_MAX ((size_t) -1)
-#endif
-
#if (defined MB_CUR_MAX && HAVE_WCTYPE_H && HAVE_ISWCTYPE && HAVE_WCSCOLL) ||
_LIBC
# define RE_ENABLE_I18N
#endif
@@ -111,8 +105,8 @@
# define __wctype wctype
# define __iswctype iswctype
# define __btowc btowc
-# define __wcrtomb wcrtomb
# define __mbrtowc mbrtowc
+# define __wcrtomb wcrtomb
# define __regfree regfree
# define attribute_hidden
#endif /* not _LIBC */
@@ -124,6 +118,11 @@
#endif
typedef __re_idx_t Idx;
+#ifdef _REGEX_LARGE_OFFSETS
+# define IDX_MAX (SIZE_MAX - 2)
+#else
+# define IDX_MAX INT_MAX
+#endif
/* Special return value for failure to match. */
#define REG_MISSING ((Idx) -1)
@@ -418,19 +417,21 @@ typedef struct re_dfa_t re_dfa_t;
# define internal_function
#endif
+#ifndef NOT_IN_libc
static reg_errcode_t re_string_realloc_buffers (re_string_t *pstr,
Idx new_buf_len)
internal_function;
-#ifdef RE_ENABLE_I18N
+# ifdef RE_ENABLE_I18N
static void build_wcs_buffer (re_string_t *pstr) internal_function;
static reg_errcode_t build_wcs_upper_buffer (re_string_t *pstr)
- internal_function;
-#endif /* RE_ENABLE_I18N */
+ internal_function;
+# endif /* RE_ENABLE_I18N */
static void build_upper_buffer (re_string_t *pstr) internal_function;
static void re_string_translate_buffer (re_string_t *pstr) internal_function;
static unsigned int re_string_context_at (const re_string_t *input, Idx idx,
int eflags)
internal_function __attribute ((pure));
+#endif
#define re_string_peek_byte(pstr, offset) \
((pstr)->mbs[(pstr)->cur_idx + offset])
#define re_string_fetch_byte(pstr) \
@@ -468,6 +469,9 @@ static unsigned int re_string_context_at (const re_string_t
*input, Idx idx,
#ifndef MAX
# define MAX(a,b) ((a) < (b) ? (b) : (a))
#endif
+#ifndef MIN
+# define MIN(a,b) ((a) < (b) ? (a) : (b))
+#endif
#define re_malloc(t,n) ((t *) malloc ((n) * sizeof (t)))
#define re_realloc(p,t,n) ((t *) realloc (p, (n) * sizeof (t)))
@@ -692,9 +696,7 @@ struct re_dfa_t
#ifdef DEBUG
char* re_str;
#endif
-#ifdef _LIBC
__libc_lock_define (, lock)
-#endif
};
#define re_node_set_init_empty(set) memset (set, '\0', sizeof (re_node_set))
@@ -818,15 +820,15 @@ re_string_wchar_at (const re_string_t *pstr, Idx idx)
return (wint_t) pstr->wcs[idx];
}
+# ifndef NOT_IN_libc
static int
internal_function __attribute ((pure))
re_string_elem_size_at (const re_string_t *pstr, Idx idx)
{
-# ifdef _LIBC
+# ifdef _LIBC
const unsigned char *p, *extra;
const int32_t *table, *indirect;
- int32_t tmp;
-# include <locale/weight.h>
+# include <locale/weight.h>
uint_fast32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES);
if (nrules != 0)
@@ -837,13 +839,14 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx)
indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE,
_NL_COLLATE_INDIRECTMB);
p = pstr->mbs + idx;
- tmp = findidx (&p);
+ findidx (&p, pstr->len - idx);
return p - pstr->mbs - idx;
}
else
-# endif /* _LIBC */
+# endif /* _LIBC */
return 1;
}
+# endif
#endif /* RE_ENABLE_I18N */
#ifndef __GNUC_PREREQ
diff --git a/lib/regexec.c b/lib/regexec.c
index 7130f2a..b2c174f 100644
--- a/lib/regexec.c
+++ b/lib/regexec.c
@@ -14,8 +14,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
static reg_errcode_t match_ctx_init (re_match_context_t *cache, int eflags,
Idx n) internal_function;
@@ -51,9 +50,8 @@ static regoff_t re_search_stub (struct re_pattern_buffer
*bufp,
regoff_t range, Idx stop,
struct re_registers *regs,
bool ret_len) internal_function;
-static unsigned int re_copy_regs (struct re_registers *regs, regmatch_t
*pmatch,
- Idx nregs, int regs_allocated)
- internal_function;
+static unsigned re_copy_regs (struct re_registers *regs, regmatch_t *pmatch,
+ Idx nregs, int regs_allocated) internal_function;
static reg_errcode_t prune_impossible_nodes (re_match_context_t *mctx)
internal_function;
static Idx check_matching (re_match_context_t *mctx, bool fl_longest_match,
@@ -230,7 +228,7 @@ regexec (preg, string, nmatch, pmatch, eflags)
reg_errcode_t err;
Idx start, length;
#ifdef _LIBC
- re_dfa_t *dfa = (re_dfa_t *) preg->buffer;
+ re_dfa_t *dfa = preg->buffer;
#endif
if (eflags & ~(REG_NOTBOL | REG_NOTEOL | REG_STARTEND))
@@ -365,7 +363,6 @@ weak_alias (__re_search_2, re_search_2)
#endif
static regoff_t
-internal_function
re_search_2_stub (struct re_pattern_buffer *bufp,
const char *string1, Idx length1,
const char *string2, Idx length2,
@@ -413,7 +410,6 @@ re_search_2_stub (struct re_pattern_buffer *bufp,
otherwise the position of the match is returned. */
static regoff_t
-internal_function
re_search_stub (struct re_pattern_buffer *bufp,
const char *string, Idx length,
Idx start, regoff_t range, Idx stop, struct re_registers *regs,
@@ -425,7 +421,7 @@ re_search_stub (struct re_pattern_buffer *bufp,
regoff_t rval;
int eflags = 0;
#ifdef _LIBC
- re_dfa_t *dfa = (re_dfa_t *) bufp->buffer;
+ re_dfa_t *dfa = bufp->buffer;
#endif
Idx last_start = start + range;
@@ -477,9 +473,9 @@ re_search_stub (struct re_pattern_buffer *bufp,
rval = 0;
- /* I hope we needn't fill ther regs with -1's when no match was found. */
+ /* I hope we needn't fill their regs with -1's when no match was found. */
if (result != REG_NOERROR)
- rval = -1;
+ rval = result == REG_NOMATCH ? -1 : -2;
else if (regs != NULL)
{
/* If caller wants register contents data back, copy them. */
@@ -505,8 +501,7 @@ re_search_stub (struct re_pattern_buffer *bufp,
return rval;
}
-static unsigned int
-internal_function
+static unsigned
re_copy_regs (struct re_registers *regs, regmatch_t *pmatch, Idx nregs,
int regs_allocated)
{
@@ -636,7 +631,7 @@ re_exec (s)
(0 <= LAST_START && LAST_START <= LENGTH) */
static reg_errcode_t
-internal_function __attribute_warn_unused_result__
+__attribute_warn_unused_result__
re_search_internal (const regex_t *preg,
const char *string, Idx length,
Idx start, Idx last_start, Idx stop,
@@ -644,7 +639,7 @@ re_search_internal (const regex_t *preg,
int eflags)
{
reg_errcode_t err;
- const re_dfa_t *dfa = (const re_dfa_t *) preg->buffer;
+ const re_dfa_t *dfa = preg->buffer;
Idx left_lim, right_lim;
int incr;
bool fl_longest_match;
@@ -719,7 +714,8 @@ re_search_internal (const regex_t *preg,
if (nmatch > 1 || dfa->has_mb_node)
{
/* Avoid overflow. */
- if (BE (SIZE_MAX / sizeof (re_dfastate_t *) <= mctx.input.bufs_len, 0))
+ if (BE ((MIN (IDX_MAX, SIZE_MAX / sizeof (re_dfastate_t *))
+ <= mctx.input.bufs_len), 0))
{
err = REG_ESPACE;
goto free_return;
@@ -921,7 +917,7 @@ re_search_internal (const regex_t *preg,
goto free_return;
}
- /* At last, add the offset to the each registers, since we slided
+ /* At last, add the offset to each register, since we slid
the buffers so that we could assume that the matching starts
from 0. */
for (reg_idx = 0; reg_idx < nmatch; ++reg_idx)
@@ -971,7 +967,7 @@ re_search_internal (const regex_t *preg,
}
static reg_errcode_t
-internal_function __attribute_warn_unused_result__
+__attribute_warn_unused_result__
prune_impossible_nodes (re_match_context_t *mctx)
{
const re_dfa_t *const dfa = mctx->dfa;
@@ -987,7 +983,7 @@ prune_impossible_nodes (re_match_context_t *mctx)
halt_node = mctx->last_node;
/* Avoid overflow. */
- if (BE (SIZE_MAX / sizeof (re_dfastate_t *) <= match_last, 0))
+ if (BE (MIN (IDX_MAX, SIZE_MAX / sizeof (re_dfastate_t *)) <= match_last, 0))
return REG_ESPACE;
sifted_states = re_malloc (re_dfastate_t *, match_last + 1);
@@ -1105,7 +1101,7 @@ acquire_init_state_context (reg_errcode_t *err, const
re_match_context_t *mctx,
FL_LONGEST_MATCH means we want the POSIX longest matching.
If P_MATCH_FIRST is not NULL, and the match fails, it is set to the
next place where we may want to try matching.
- Note that the matcher assume that the maching starts from the current
+ Note that the matcher assumes that the matching starts from the current
index of the buffer. */
static Idx
@@ -1174,7 +1170,8 @@ check_matching (re_match_context_t *mctx, bool
fl_longest_match,
re_dfastate_t *old_state = cur_state;
Idx next_char_idx = re_string_cur_idx (&mctx->input) + 1;
- if (BE (next_char_idx >= mctx->input.bufs_len, 0)
+ if ((BE (next_char_idx >= mctx->input.bufs_len, 0)
+ && mctx->input.bufs_len < mctx->input.len)
|| (BE (next_char_idx >= mctx->input.valid_len, 0)
&& mctx->input.valid_len < mctx->input.len))
{
@@ -1435,7 +1432,7 @@ internal_function __attribute_warn_unused_result__
set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch,
regmatch_t *pmatch, bool fl_backtrack)
{
- const re_dfa_t *dfa = (const re_dfa_t *) preg->buffer;
+ const re_dfa_t *dfa = preg->buffer;
Idx idx, cur_node;
re_node_set eps_via_nodes;
struct re_fail_stack_t *fs;
@@ -1752,7 +1749,8 @@ clean_state_log_if_needed (re_match_context_t *mctx, Idx
next_state_log_idx)
{
Idx top = mctx->state_log_top;
- if (next_state_log_idx >= mctx->input.bufs_len
+ if ((next_state_log_idx >= mctx->input.bufs_len
+ && mctx->input.bufs_len < mctx->input.len)
|| (next_state_log_idx >= mctx->input.valid_len
&& mctx->input.valid_len < mctx->input.len))
{
@@ -2456,7 +2454,7 @@ find_recover_state (reg_errcode_t *err,
re_match_context_t *mctx)
/* From the node set CUR_NODES, pick up the nodes whose types are
OP_OPEN_SUBEXP and which have corresponding back references in the regular
expression. And register them to use them later for evaluating the
- correspoding back references. */
+ corresponding back references. */
static reg_errcode_t
internal_function
@@ -2936,9 +2934,12 @@ check_arrival (re_match_context_t *mctx, state_array_t
*path, Idx top_node,
{
re_dfastate_t **new_array;
Idx old_alloc = path->alloc;
- Idx new_alloc = old_alloc + last_str + mctx->max_mb_elem_len + 1;
- if (BE (new_alloc < old_alloc, 0)
- || BE (SIZE_MAX / sizeof (re_dfastate_t *) < new_alloc, 0))
+ Idx incr_alloc = last_str + mctx->max_mb_elem_len + 1;
+ Idx new_alloc;
+ if (BE (IDX_MAX - old_alloc < incr_alloc, 0))
+ return REG_ESPACE;
+ new_alloc = old_alloc + incr_alloc;
+ if (BE (SIZE_MAX / sizeof (re_dfastate_t *) < new_alloc, 0))
return REG_ESPACE;
new_array = re_realloc (path->array, re_dfastate_t *, new_alloc);
if (BE (new_array == NULL, 0))
@@ -3387,7 +3388,7 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
dests_node = dests_alloc->dests_node;
dests_ch = dests_alloc->dests_ch;
- /* Initialize transiton table. */
+ /* Initialize transition table. */
state->word_trtable = state->trtable = NULL;
/* At first, group all nodes belonging to 'state' into several
@@ -3397,6 +3398,7 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state)
{
if (dests_node_malloced)
free (dests_alloc);
+ /* Return false in case of an error, true otherwise. */
if (ndests == 0)
{
state->trtable = (re_dfastate_t **)
@@ -3896,7 +3898,6 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx
node_idx,
const int32_t *table, *indirect;
const unsigned char *weights, *extra;
const char *collseqwc;
- int32_t idx;
/* This #include defines a local function! */
# include <locale/weight.h>
@@ -3954,7 +3955,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx
node_idx,
_NL_CURRENT (LC_COLLATE, _NL_COLLATE_EXTRAMB);
indirect = (const int32_t *)
_NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB);
- int32_t idx = findidx (&cp);
+ int32_t idx = findidx (&cp, elem_len);
if (idx > 0)
for (i = 0; i < cset->nequiv_classes; ++i)
{
@@ -4066,7 +4067,7 @@ find_collation_sequence_value (const unsigned char *mbs,
size_t mbs_len)
/* Skip the collation sequence value. */
idx += sizeof (uint32_t);
/* Skip the wide char sequence of the collating element. */
- idx = idx + sizeof (uint32_t) * (extra[idx] + 1);
+ idx = idx + sizeof (uint32_t) * (*(int32_t *) (extra + idx) + 1);
/* If we found the entry, return the sequence value. */
if (found)
return *(uint32_t *) (extra + idx);
@@ -4140,11 +4141,12 @@ extend_buffers (re_match_context_t *mctx)
re_string_t *pstr = &mctx->input;
/* Avoid overflow. */
- if (BE (SIZE_MAX / 2 / sizeof (re_dfastate_t *) <= pstr->bufs_len, 0))
+ if (BE (MIN (IDX_MAX, SIZE_MAX / sizeof (re_dfastate_t *)) / 2
+ <= pstr->bufs_len, 0))
return REG_ESPACE;
- /* Double the lengthes of the buffers. */
- ret = re_string_realloc_buffers (pstr, pstr->bufs_len * 2);
+ /* Double the lengths of the buffers. */
+ ret = re_string_realloc_buffers (pstr, MIN (pstr->len, pstr->bufs_len * 2));
if (BE (ret != REG_NOERROR, 0))
return ret;
@@ -4207,7 +4209,7 @@ match_ctx_init (re_match_context_t *mctx, int eflags, Idx
n)
size_t max_object_size =
MAX (sizeof (struct re_backref_cache_entry),
sizeof (re_sub_match_top_t *));
- if (BE (SIZE_MAX / max_object_size < n, 0))
+ if (BE (MIN (IDX_MAX, SIZE_MAX / max_object_size) < n, 0))
return REG_ESPACE;
mctx->bkref_ents = re_malloc (struct re_backref_cache_entry, n);
diff --git a/lib/round.c b/lib/round.c
new file mode 100644
index 0000000..53dfe84
--- /dev/null
+++ b/lib/round.c
@@ -0,0 +1,174 @@
+/* Round toward nearest, breaking ties away from zero.
+ Copyright (C) 2007, 2010-2012 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, see <http://www.gnu.org/licenses/>. */
+
+/* Written by Ben Pfaff <address@hidden>, 2007.
+ Based heavily on code by Bruno Haible. */
+
+#if ! defined USE_LONG_DOUBLE
+# include <config.h>
+#endif
+
+/* Specification. */
+#include <math.h>
+
+#include <float.h>
+
+#undef MIN
+
+#ifdef USE_LONG_DOUBLE
+# define ROUND roundl
+# define FLOOR floorl
+# define CEIL ceill
+# define DOUBLE long double
+# define MANT_DIG LDBL_MANT_DIG
+# define MIN LDBL_MIN
+# define L_(literal) literal##L
+# define HAVE_FLOOR_AND_CEIL HAVE_FLOORL_AND_CEILL
+#elif ! defined USE_FLOAT
+# define ROUND round
+# define FLOOR floor
+# define CEIL ceil
+# define DOUBLE double
+# define MANT_DIG DBL_MANT_DIG
+# define MIN DBL_MIN
+# define L_(literal) literal
+# define HAVE_FLOOR_AND_CEIL 1
+#else /* defined USE_FLOAT */
+# define ROUND roundf
+# define FLOOR floorf
+# define CEIL ceilf
+# define DOUBLE float
+# define MANT_DIG FLT_MANT_DIG
+# define MIN FLT_MIN
+# define L_(literal) literal##f
+# define HAVE_FLOOR_AND_CEIL HAVE_FLOORF_AND_CEILF
+#endif
+
+/* -0.0. See minus-zero.h. */
+#if defined __hpux || defined __sgi || defined __ICC
+# define MINUS_ZERO (-MIN * MIN)
+#else
+# define MINUS_ZERO L_(-0.0)
+#endif
+
+/* MSVC with option -fp:strict refuses to compile constant initializers that
+ contain floating-point operations. Pacify this compiler. */
+#ifdef _MSC_VER
+# pragma fenv_access (off)
+#endif
+
+/* If we're being included from test-round2[f].c, it already defined names for
+ our round implementations. Otherwise, pick the preferred implementation for
+ this machine. */
+#if !defined FLOOR_BASED_ROUND && !defined FLOOR_FREE_ROUND
+# if HAVE_FLOOR_AND_CEIL
+# define FLOOR_BASED_ROUND ROUND
+# else
+# define FLOOR_FREE_ROUND ROUND
+# endif
+#endif
+
+#ifdef FLOOR_BASED_ROUND
+/* An implementation of the C99 round function based on floor and ceil. We use
+ this when floor and ceil are available, on the assumption that they are
+ faster than the open-coded versions below. */
+DOUBLE
+FLOOR_BASED_ROUND (DOUBLE x)
+{
+ if (x >= L_(0.0))
+ {
+ DOUBLE y = FLOOR (x);
+ if (x - y >= L_(0.5))
+ y += L_(1.0);
+ return y;
+ }
+ else
+ {
+ DOUBLE y = CEIL (x);
+ if (y - x >= L_(0.5))
+ y -= L_(1.0);
+ return y;
+ }
+}
+#endif /* FLOOR_BASED_ROUND */
+
+#ifdef FLOOR_FREE_ROUND
+/* An implementation of the C99 round function without floor or ceil.
+ We use this when floor or ceil is missing. */
+DOUBLE
+FLOOR_FREE_ROUND (DOUBLE x)
+{
+ /* 2^(MANT_DIG-1). */
+ static const DOUBLE TWO_MANT_DIG =
+ /* Assume MANT_DIG <= 5 * 31.
+ Use the identity
+ n = floor(n/5) + floor((n+1)/5) + ... + floor((n+4)/5). */
+ (DOUBLE) (1U << ((MANT_DIG - 1) / 5))
+ * (DOUBLE) (1U << ((MANT_DIG - 1 + 1) / 5))
+ * (DOUBLE) (1U << ((MANT_DIG - 1 + 2) / 5))
+ * (DOUBLE) (1U << ((MANT_DIG - 1 + 3) / 5))
+ * (DOUBLE) (1U << ((MANT_DIG - 1 + 4) / 5));
+
+ /* The use of 'volatile' guarantees that excess precision bits are dropped at
+ each addition step and before the following comparison at the caller's
+ site. It is necessary on x86 systems where double-floats are not IEEE
+ compliant by default, to avoid that the results become platform and
+ compiler option dependent. 'volatile' is a portable alternative to gcc's
+ -ffloat-store option. */
+ volatile DOUBLE y = x;
+ volatile DOUBLE z = y;
+
+ if (z > L_(0.0))
+ {
+ /* Avoid rounding error for x = 0.5 - 2^(-MANT_DIG-1). */
+ if (z < L_(0.5))
+ z = L_(0.0);
+ /* Avoid rounding errors for values near 2^k, where k >= MANT_DIG-1. */
+ else if (z < TWO_MANT_DIG)
+ {
+ /* Add 0.5 to the absolute value. */
+ y = z += L_(0.5);
+ /* Round to the next integer (nearest or up or down, doesn't
+ matter). */
+ z += TWO_MANT_DIG;
+ z -= TWO_MANT_DIG;
+ /* Enforce rounding down. */
+ if (z > y)
+ z -= L_(1.0);
+ }
+ }
+ else if (z < L_(0.0))
+ {
+ /* Avoid rounding error for x = -(0.5 - 2^(-MANT_DIG-1)). */
+ if (z > - L_(0.5))
+ z = MINUS_ZERO;
+ /* Avoid rounding errors for values near -2^k, where k >= MANT_DIG-1. */
+ else if (z > -TWO_MANT_DIG)
+ {
+ /* Add 0.5 to the absolute value. */
+ y = z -= L_(0.5);
+ /* Round to the next integer (nearest or up or down, doesn't
+ matter). */
+ z -= TWO_MANT_DIG;
+ z += TWO_MANT_DIG;
+ /* Enforce rounding up. */
+ if (z < y)
+ z += L_(1.0);
+ }
+ }
+ return z;
+}
+#endif /* FLOOR_FREE_ROUND */
diff --git a/lib/safe-read.h b/lib/safe-read.h
index fccc200..dc73922 100644
--- a/lib/safe-read.h
+++ b/lib/safe-read.h
@@ -17,7 +17,7 @@
/* Some system calls may be interrupted and fail with errno = EINTR in the
following situations:
- The process is stopped and restarted (signal SIGSTOP and SIGCONT, user
- types Ctrl-Z) on some platforms: MacOS X.
+ types Ctrl-Z) on some platforms: Mac OS X.
- The process receives a signal for which a signal handler was installed
with sigaction() with an sa_flags field that does not contain
SA_RESTART.
diff --git a/lib/safe-write.h b/lib/safe-write.h
index 84bc36d..3a7f509 100644
--- a/lib/safe-write.h
+++ b/lib/safe-write.h
@@ -17,7 +17,7 @@
/* Some system calls may be interrupted and fail with errno = EINTR in the
following situations:
- The process is stopped and restarted (signal SIGSTOP and SIGCONT, user
- types Ctrl-Z) on some platforms: MacOS X.
+ types Ctrl-Z) on some platforms: Mac OS X.
- The process receives a signal for which a signal handler was installed
with sigaction() with an sa_flags field that does not contain
SA_RESTART.
diff --git a/lib/signal.in.h b/lib/signal.in.h
index 2e195a0..627ae17 100644
--- a/lib/signal.in.h
+++ b/lib/signal.in.h
@@ -55,7 +55,7 @@
#ifndef address@hidden@_SIGNAL_H
#define address@hidden@_SIGNAL_H
-/* MacOS X 10.3, FreeBSD 6.4, OpenBSD 3.8, OSF/1 4.0, Solaris 2.6 declare
+/* Mac OS X 10.3, FreeBSD 6.4, OpenBSD 3.8, OSF/1 4.0, Solaris 2.6 declare
pthread_sigmask in <pthread.h>, not in <signal.h>.
But avoid namespace pollution on glibc systems.*/
#if (@GNULIB_PTHREAD_SIGMASK@ || defined GNULIB_POSIXCHECK) \
@@ -197,7 +197,7 @@ typedef int verify_NSIG_constraint[NSIG <= 32 ? 1 : -1];
/* Test whether a given signal is contained in a signal set. */
# if @HAVE_POSIX_SIGNALBLOCKING@
-/* This function is defined as a macro on MacOS X. */
+/* This function is defined as a macro on Mac OS X. */
# if defined __cplusplus && defined GNULIB_NAMESPACE
# undef sigismember
# endif
@@ -210,7 +210,7 @@ _GL_CXXALIASWARN (sigismember);
/* Initialize a signal set to the empty set. */
# if @HAVE_POSIX_SIGNALBLOCKING@
-/* This function is defined as a macro on MacOS X. */
+/* This function is defined as a macro on Mac OS X. */
# if defined __cplusplus && defined GNULIB_NAMESPACE
# undef sigemptyset
# endif
@@ -222,7 +222,7 @@ _GL_CXXALIASWARN (sigemptyset);
/* Add a signal to a signal set. */
# if @HAVE_POSIX_SIGNALBLOCKING@
-/* This function is defined as a macro on MacOS X. */
+/* This function is defined as a macro on Mac OS X. */
# if defined __cplusplus && defined GNULIB_NAMESPACE
# undef sigaddset
# endif
@@ -235,7 +235,7 @@ _GL_CXXALIASWARN (sigaddset);
/* Remove a signal from a signal set. */
# if @HAVE_POSIX_SIGNALBLOCKING@
-/* This function is defined as a macro on MacOS X. */
+/* This function is defined as a macro on Mac OS X. */
# if defined __cplusplus && defined GNULIB_NAMESPACE
# undef sigdelset
# endif
@@ -248,7 +248,7 @@ _GL_CXXALIASWARN (sigdelset);
/* Fill a signal set with all possible signals. */
# if @HAVE_POSIX_SIGNALBLOCKING@
-/* This function is defined as a macro on MacOS X. */
+/* This function is defined as a macro on Mac OS X. */
# if defined __cplusplus && defined GNULIB_NAMESPACE
# undef sigfillset
# endif
diff --git a/lib/size_max.h b/lib/size_max.h
index d470807..60d50f1 100644
--- a/lib/size_max.h
+++ b/lib/size_max.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef GNULIB_SIZE_MAX_H
#define GNULIB_SIZE_MAX_H
diff --git a/lib/snprintf.c b/lib/snprintf.c
index 731cc2f..eb27f5d 100644
--- a/lib/snprintf.c
+++ b/lib/snprintf.c
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#include <config.h>
diff --git a/lib/stat.c b/lib/stat.c
index a18d577..f46e31d 100644
--- a/lib/stat.c
+++ b/lib/stat.c
@@ -27,6 +27,21 @@
#include <sys/stat.h>
#undef __need_system_sys_stat_h
+#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
+# if _GL_WINDOWS_64_BIT_ST_SIZE
+# undef stat /* avoid warning on mingw64 with _FILE_OFFSET_BITS=64 */
+# define stat _stati64
+# define REPLACE_FUNC_STAT_DIR 1
+# undef REPLACE_FUNC_STAT_FILE
+# elif REPLACE_FUNC_STAT_FILE
+/* mingw64 has a broken stat() function, based on _stat(), in libmingwex.a.
+ Bypass it. */
+# define stat _stat
+# define REPLACE_FUNC_STAT_DIR 1
+# undef REPLACE_FUNC_STAT_FILE
+# endif
+#endif
+
static inline int
orig_stat (const char *filename, struct stat *buf)
{
diff --git a/lib/stdalign.in.h b/lib/stdalign.in.h
index 41dd143..e043871 100644
--- a/lib/stdalign.in.h
+++ b/lib/stdalign.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Paul Eggert and Bruno Haible. */
diff --git a/lib/stdbool.in.h b/lib/stdbool.in.h
index cbf3ea1..6ea7f70 100644
--- a/lib/stdbool.in.h
+++ b/lib/stdbool.in.h
@@ -12,8 +12,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _GL_STDBOOL_H
#define _GL_STDBOOL_H
diff --git a/lib/stddef.in.h b/lib/stddef.in.h
index 4d57637..e17ef24 100644
--- a/lib/stddef.in.h
+++ b/lib/stddef.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Eric Blake. */
diff --git a/lib/stdint.in.h b/lib/stdint.in.h
index 6910401..3a73abf 100644
--- a/lib/stdint.in.h
+++ b/lib/stdint.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/*
* ISO C 99 <stdint.h> for platforms that lack it.
@@ -34,6 +33,16 @@
<inttypes.h>. */
#define _GL_JUST_INCLUDE_SYSTEM_INTTYPES_H
+/* On Android (Bionic libc), <sys/types.h> includes this file before
+ having defined 'time_t'. Therefore in this case avoid including
+ other system header files; just include the system's <stdint.h>.
+ Ideally we should test __BIONIC__ here, but it is only defined after
+ <sys/cdefs.h> has been included; hence test __ANDROID__ instead. */
+#if defined __ANDROID__ \
+ && defined _SYS_TYPES_H_ && !defined _SSIZE_T_DEFINED_
+# @INCLUDE_NEXT@ @NEXT_STDINT_H@
+#else
+
/* 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
@@ -74,14 +83,15 @@
/* <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
+ Mac OS 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. */
+/* Get SCHAR_MIN, SCHAR_MAX, UCHAR_MAX, INT_MIN, INT_MAX,
+ LONG_MIN, LONG_MAX, ULONG_MAX. */
#include <limits.h>
#if @HAVE_INTTYPES_H@
@@ -237,8 +247,9 @@ typedef unsigned long long int gl_uint64_t;
/* 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. */
+ are taken from the same list of types. The following code normally
+ uses types consistent with glibc, as that lessens the chance of
+ incompatibility with older GNU hosts. */
#undef int_fast8_t
#undef uint_fast8_t
@@ -248,12 +259,21 @@ typedef unsigned long long int gl_uint64_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 signed char gl_int_fast8_t;
+typedef unsigned char gl_uint_fast8_t;
+
+#ifdef __sun
+/* Define types compatible with SunOS 5.10, so that code compiled under
+ earlier SunOS versions works with code compiled under SunOS 5.10. */
+typedef int gl_int_fast32_t;
+typedef unsigned int gl_uint_fast32_t;
+#else
typedef long int gl_int_fast32_t;
typedef unsigned long int gl_uint_fast32_t;
+#endif
+typedef gl_int_fast32_t gl_int_fast16_t;
+typedef gl_uint_fast32_t gl_uint_fast16_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
@@ -409,23 +429,29 @@ typedef int _verify_intmax_size[sizeof (intmax_t) ==
sizeof (uintmax_t)
#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
+#define INT_FAST8_MIN SCHAR_MIN
+#define INT_FAST8_MAX SCHAR_MAX
+#define UINT_FAST8_MAX UCHAR_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
+#define INT_FAST16_MIN INT_FAST32_MIN
+#define INT_FAST16_MAX INT_FAST32_MAX
+#define UINT_FAST16_MAX UINT_FAST32_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
+#ifdef __sun
+# define INT_FAST32_MIN INT_MIN
+# define INT_FAST32_MAX INT_MAX
+# define UINT_FAST32_MAX UINT_MAX
+#else
+# define INT_FAST32_MIN LONG_MIN
+# define INT_FAST32_MAX LONG_MAX
+# define UINT_FAST32_MAX ULONG_MAX
+#endif
#undef INT_FAST64_MIN
#undef INT_FAST64_MAX
@@ -606,4 +632,5 @@ typedef int _verify_intmax_size[sizeof (intmax_t) == sizeof
(uintmax_t)
#endif
#endif /* address@hidden@_STDINT_H */
+#endif /* !(defined __ANDROID__ && ...) */
#endif /* !defined address@hidden@_STDINT_H && !defined
_GL_JUST_INCLUDE_SYSTEM_STDINT_H */
diff --git a/lib/stdio.in.h b/lib/stdio.in.h
index 7e4d593..f7e06ad 100644
--- a/lib/stdio.in.h
+++ b/lib/stdio.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#if __GNUC__ >= 3
@PRAGMA_SYSTEM_HEADER@
@@ -53,7 +52,8 @@
#include <stddef.h>
/* Get off_t and ssize_t. Needed on many systems, including glibc 2.8
- and eglibc 2.11.2. */
+ and eglibc 2.11.2.
+ May also define off_t to a 64-bit type on native Windows. */
#include <sys/types.h>
/* The __attribute__ feature is available in gcc versions 2.5 and later.
@@ -699,22 +699,11 @@ _GL_WARN_ON_USE (getline, "getline is unportable - "
# endif
#endif
-#if @GNULIB_GETS@
-# if @REPLACE_STDIO_READ_FUNCS@ && @GNULIB_STDIO_H_NONBLOCKING@
-# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
-# undef gets
-# define gets rpl_gets
-# endif
-_GL_FUNCDECL_RPL (gets, char *, (char *s) _GL_ARG_NONNULL ((1)));
-_GL_CXXALIAS_RPL (gets, char *, (char *s));
-# else
-_GL_CXXALIAS_SYS (gets, char *, (char *s));
-# undef gets
-# endif
-_GL_CXXALIASWARN (gets);
/* It is very rare that the developer ever has full control of stdin,
- so any use of gets warrants an unconditional warning. Assume it is
- always declared, since it is required by C89. */
+ so any use of gets warrants an unconditional warning; besides, C11
+ removed it. */
+#undef gets
+#if HAVE_RAW_DECL_GETS
_GL_WARN_ON_USE (gets, "gets is a security hole - use fgets instead");
#endif
@@ -779,7 +768,7 @@ _GL_CXXALIASWARN (pclose);
#elif defined GNULIB_POSIXCHECK
# undef pclose
# if HAVE_RAW_DECL_PCLOSE
-_GL_WARN_ON_USE (pclose, "popen is unportable - "
+_GL_WARN_ON_USE (pclose, "pclose is unportable - "
"use gnulib module pclose for more portability");
# endif
#endif
@@ -1054,9 +1043,9 @@ _GL_WARN_ON_USE (snprintf, "snprintf is unportable - "
# endif
#endif
-/* Some people would argue that sprintf should be handled like gets
- (for example, OpenBSD issues a link warning for both functions),
- since both can cause security holes due to buffer overruns.
+/* Some people would argue that all sprintf uses should be warned about
+ (for example, OpenBSD issues a link warning for it),
+ since it can cause security holes due to buffer overruns.
However, we believe that sprintf can be used safely, and is more
efficient than snprintf in those safe cases; and as proof of our
belief, we use sprintf in several gnulib modules. So this header
diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h
index c90626a..72c9dd1 100644
--- a/lib/stdlib.in.h
+++ b/lib/stdlib.in.h
@@ -87,13 +87,21 @@ struct random_data
#endif
#if (@GNULIB_MKSTEMP@ || @GNULIB_MKSTEMPS@ || @GNULIB_GETSUBOPT@ || defined
GNULIB_POSIXCHECK) && ! defined __GLIBC__ && !((defined _WIN32 || defined
__WIN32__) && ! defined __CYGWIN__)
-/* On MacOS X 10.3, only <unistd.h> declares mkstemp. */
-/* On MacOS X 10.5, only <unistd.h> declares mkstemps. */
+/* On Mac OS X 10.3, only <unistd.h> declares mkstemp. */
+/* On Mac OS X 10.5, only <unistd.h> declares mkstemps. */
/* On Cygwin 1.7.1, only <unistd.h> declares getsubopt. */
/* But avoid namespace pollution on glibc systems and native Windows. */
# include <unistd.h>
#endif
+/* The __attribute__ feature is available in gcc versions 2.5 and later.
+ The attribute __pure__ was added in gcc 2.96. */
+#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96)
+# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__))
+#else
+# define _GL_ATTRIBUTE_PURE /* empty */
+#endif
+
/* The definition of _Noreturn is copied here. */
/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
@@ -138,7 +146,9 @@ _GL_WARN_ON_USE (_Exit, "_Exit is unportable - "
/* Parse a signed decimal integer.
Returns the value of the integer. Errors are not detected. */
# if address@hidden@
-_GL_FUNCDECL_SYS (atoll, long long, (const char *string) _GL_ARG_NONNULL
((1)));
+_GL_FUNCDECL_SYS (atoll, long long, (const char *string)
+ _GL_ATTRIBUTE_PURE
+ _GL_ARG_NONNULL ((1)));
# endif
_GL_CXXALIAS_SYS (atoll, long long, (const char *string));
_GL_CXXALIASWARN (atoll);
diff --git a/lib/strcasecmp.c b/lib/strcasecmp.c
deleted file mode 100644
index 1ed5175..0000000
--- a/lib/strcasecmp.c
+++ /dev/null
@@ -1,63 +0,0 @@
-/* Case-insensitive string comparison function.
- Copyright (C) 1998-1999, 2005-2007, 2009-2012 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 <string.h>
-
-#include <ctype.h>
-#include <limits.h>
-
-#define TOLOWER(Ch) (isupper (Ch) ? tolower (Ch) : (Ch))
-
-/* 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.
- Note: This function does not work with multibyte strings! */
-
-int
-strcasecmp (const char *s1, const char *s2)
-{
- const unsigned char *p1 = (const unsigned char *) s1;
- const unsigned char *p2 = (const unsigned char *) s2;
- unsigned char c1, c2;
-
- if (p1 == p2)
- return 0;
-
- do
- {
- c1 = TOLOWER (*p1);
- c2 = 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/streq.h b/lib/streq.h
index b649411..7fd07c8 100644
--- a/lib/streq.h
+++ b/lib/streq.h
@@ -21,8 +21,8 @@
#include <string.h>
-/* STREQ allows to optimize string comparison with a small literal string.
- STREQ (s, "EUC-KR", 'E', 'U', 'C', '-', 'K', 'R', 0, 0, 0)
+/* STREQ_OPT allows to optimize string comparison with a small literal string.
+ STREQ_OPT (s, "EUC-KR", 'E', 'U', 'C', '-', 'K', 'R', 0, 0, 0)
is semantically equivalent to
strcmp (s, "EUC-KR") == 0
just faster. */
@@ -163,12 +163,12 @@ streq0 (const char *s1, const char *s2, char s20, char
s21, char s22, char s23,
return 0;
}
-#define STREQ(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \
+#define STREQ_OPT(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \
streq0 (s1, s2, s20, s21, s22, s23, s24, s25, s26, s27, s28)
#else
-#define STREQ(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \
+#define STREQ_OPT(s1,s2,s20,s21,s22,s23,s24,s25,s26,s27,s28) \
(strcmp (s1, s2) == 0)
#endif
diff --git a/lib/strftime.c b/lib/strftime.c
index 7743f52..f5fc3c9 100644
--- a/lib/strftime.c
+++ b/lib/strftime.c
@@ -40,7 +40,7 @@
extern char *tzname[];
#endif
-/* Do multibyte processing if multibytes are supported, unless
+/* Do multibyte processing if multibyte encodings 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 multibyte encodings used by the
diff --git a/lib/string.in.h b/lib/string.in.h
index ab9cd19..0c23526 100644
--- a/lib/string.in.h
+++ b/lib/string.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef address@hidden@_STRING_H
@@ -725,10 +724,14 @@ _GL_WARN_ON_USE (strtok_r, "strtok_r is unportable - "
# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
# define mbslen rpl_mbslen
# endif
-_GL_FUNCDECL_RPL (mbslen, size_t, (const char *string) _GL_ARG_NONNULL ((1)));
+_GL_FUNCDECL_RPL (mbslen, size_t, (const char *string)
+ _GL_ATTRIBUTE_PURE
+ _GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_RPL (mbslen, size_t, (const char *string));
# else
-_GL_FUNCDECL_SYS (mbslen, size_t, (const char *string) _GL_ARG_NONNULL ((1)));
+_GL_FUNCDECL_SYS (mbslen, size_t, (const char *string)
+ _GL_ATTRIBUTE_PURE
+ _GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_SYS (mbslen, size_t, (const char *string));
# endif
_GL_CXXALIASWARN (mbslen);
@@ -738,6 +741,7 @@ _GL_CXXALIASWARN (mbslen);
/* Return the number of multibyte characters in the character string starting
at STRING and ending at STRING + LEN. */
_GL_EXTERN_C size_t mbsnlen (const char *string, size_t len)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1));
#endif
@@ -751,10 +755,12 @@ _GL_EXTERN_C size_t mbsnlen (const char *string, size_t
len)
# define mbschr rpl_mbschr /* avoid collision with HP-UX function */
# endif
_GL_FUNCDECL_RPL (mbschr, char *, (const char *string, int c)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_RPL (mbschr, char *, (const char *string, int c));
# else
_GL_FUNCDECL_SYS (mbschr, char *, (const char *string, int c)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_SYS (mbschr, char *, (const char *string, int c));
# endif
@@ -771,10 +777,12 @@ _GL_CXXALIASWARN (mbschr);
# define mbsrchr rpl_mbsrchr /* avoid collision with system function */
# endif
_GL_FUNCDECL_RPL (mbsrchr, char *, (const char *string, int c)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_RPL (mbsrchr, char *, (const char *string, int c));
# else
_GL_FUNCDECL_SYS (mbsrchr, char *, (const char *string, int c)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1)));
_GL_CXXALIAS_SYS (mbsrchr, char *, (const char *string, int c));
# endif
@@ -787,6 +795,7 @@ _GL_CXXALIASWARN (mbsrchr);
Unlike strstr(), this function works correctly in multibyte locales with
encodings different from UTF-8. */
_GL_EXTERN_C char * mbsstr (const char *haystack, const char *needle)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -798,6 +807,7 @@ _GL_EXTERN_C char * mbsstr (const char *haystack, const
char *needle)
different lengths!
Unlike strcasecmp(), this function works correctly in multibyte locales. */
_GL_EXTERN_C int mbscasecmp (const char *s1, const char *s2)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -812,6 +822,7 @@ _GL_EXTERN_C int mbscasecmp (const char *s1, const char *s2)
Unlike strncasecmp(), this function works correctly in multibyte locales.
But beware that N is not a byte count but a character count! */
_GL_EXTERN_C int mbsncasecmp (const char *s1, const char *s2, size_t n)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -825,6 +836,7 @@ _GL_EXTERN_C int mbsncasecmp (const char *s1, const char
*s2, size_t n)
Unlike strncasecmp(), this function works correctly in multibyte
locales. */
_GL_EXTERN_C char * mbspcasecmp (const char *string, const char *prefix)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -835,6 +847,7 @@ _GL_EXTERN_C char * mbspcasecmp (const char *string, const
char *prefix)
strlen (haystack) < strlen (needle) !
Unlike strcasestr(), this function works correctly in multibyte locales. */
_GL_EXTERN_C char * mbscasestr (const char *haystack, const char *needle)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -845,6 +858,7 @@ _GL_EXTERN_C char * mbscasestr (const char *haystack, const
char *needle)
if none exists.
Unlike strcspn(), this function works correctly in multibyte locales. */
_GL_EXTERN_C size_t mbscspn (const char *string, const char *accept)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -858,10 +872,12 @@ _GL_EXTERN_C size_t mbscspn (const char *string, const
char *accept)
# define mbspbrk rpl_mbspbrk /* avoid collision with HP-UX function */
# endif
_GL_FUNCDECL_RPL (mbspbrk, char *, (const char *string, const char *accept)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2)));
_GL_CXXALIAS_RPL (mbspbrk, char *, (const char *string, const char *accept));
# else
_GL_FUNCDECL_SYS (mbspbrk, char *, (const char *string, const char *accept)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2)));
_GL_CXXALIAS_SYS (mbspbrk, char *, (const char *string, const char *accept));
# endif
@@ -875,6 +891,7 @@ _GL_CXXALIASWARN (mbspbrk);
if none exists.
Unlike strspn(), this function works correctly in multibyte locales. */
_GL_EXTERN_C size_t mbsspn (const char *string, const char *reject)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2));
#endif
@@ -994,6 +1011,7 @@ _GL_WARN_ON_USE (strsignal, "strsignal is unportable - "
#if @GNULIB_STRVERSCMP@
# if address@hidden@
_GL_FUNCDECL_SYS (strverscmp, int, (const char *, const char *)
+ _GL_ATTRIBUTE_PURE
_GL_ARG_NONNULL ((1, 2)));
# endif
_GL_CXXALIAS_SYS (strverscmp, int, (const char *, const char *));
diff --git a/lib/strings.in.h b/lib/strings.in.h
deleted file mode 100644
index fc60919..0000000
--- a/lib/strings.in.h
+++ /dev/null
@@ -1,123 +0,0 @@
-/* A substitute <strings.h>.
-
- Copyright (C) 2007-2012 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 address@hidden@_STRINGS_H
-
-#if __GNUC__ >= 3
address@hidden@
-#endif
address@hidden@
-
-/* Minix 3.1.8 has a bug: <sys/types.h> must be included before <strings.h>.
- But avoid namespace pollution on glibc systems. */
-#if defined __minix && !defined __GLIBC__
-# include <sys/types.h>
-#endif
-
-/* The include_next requires a split double-inclusion guard. */
-#if @HAVE_STRINGS_H@
-# @INCLUDE_NEXT@ @NEXT_STRINGS_H@
-#endif
-
-#ifndef address@hidden@_STRINGS_H
-#define address@hidden@_STRINGS_H
-
-#if ! @HAVE_DECL_STRNCASECMP@
-/* Get size_t. */
-# include <stddef.h>
-#endif
-
-
-/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
-
-/* The definition of _GL_ARG_NONNULL is copied here. */
-
-/* The definition of _GL_WARN_ON_USE is copied here. */
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-
- /* Find the index of the least-significant set bit. */
-#if @GNULIB_FFS@
-# if address@hidden@
-_GL_FUNCDECL_SYS (ffs, int, (int i));
-# endif
-_GL_CXXALIAS_SYS (ffs, int, (int i));
-_GL_CXXALIASWARN (ffs);
-#elif defined GNULIB_POSIXCHECK
-# undef ffs
-# if HAVE_RAW_DECL_FFS
-_GL_WARN_ON_USE (ffs, "ffs is not portable - use the ffs module");
-# endif
-#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.
- Note: This function does not work in multibyte locales. */
-#if ! @HAVE_STRCASECMP@
-extern int strcasecmp (char const *s1, char const *s2)
- _GL_ARG_NONNULL ((1, 2));
-#endif
-#if defined GNULIB_POSIXCHECK
-/* strcasecmp() does not work with multibyte strings:
- POSIX says that it operates on "strings", and "string" in POSIX is defined
- as a sequence of bytes, not of characters. */
-# undef strcasecmp
-# if HAVE_RAW_DECL_STRCASECMP
-_GL_WARN_ON_USE (strcasecmp, "strcasecmp cannot work correctly on character "
- "strings in multibyte locales - "
- "use mbscasecmp if you care about "
- "internationalization, or use c_strcasecmp , "
- "gnulib module c-strcase) if you want a locale "
- "independent function");
-# endif
-#endif
-
-/* Compare no more than N bytes 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.
- Note: This function cannot work correctly in multibyte locales. */
-#if ! @HAVE_DECL_STRNCASECMP@
-extern int strncasecmp (char const *s1, char const *s2, size_t n)
- _GL_ARG_NONNULL ((1, 2));
-#endif
-#if defined GNULIB_POSIXCHECK
-/* strncasecmp() does not work with multibyte strings:
- POSIX says that it operates on "strings", and "string" in POSIX is defined
- as a sequence of bytes, not of characters. */
-# undef strncasecmp
-# if HAVE_RAW_DECL_STRNCASECMP
-_GL_WARN_ON_USE (strncasecmp, "strncasecmp cannot work correctly on character "
- "strings in multibyte locales - "
- "use mbsncasecmp or mbspcasecmp if you care about "
- "internationalization, or use c_strncasecmp , "
- "gnulib module c-strcase) if you want a locale "
- "independent function");
-# endif
-#endif
-
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif /* address@hidden@_STRING_H */
-#endif /* address@hidden@_STRING_H */
diff --git a/lib/strncasecmp.c b/lib/strncasecmp.c
deleted file mode 100644
index d330ff6..0000000
--- a/lib/strncasecmp.c
+++ /dev/null
@@ -1,63 +0,0 @@
-/* strncasecmp.c -- case insensitive string comparator
- Copyright (C) 1998-1999, 2005-2007, 2009-2012 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 <string.h>
-
-#include <ctype.h>
-#include <limits.h>
-
-#define TOLOWER(Ch) (isupper (Ch) ? tolower (Ch) : (Ch))
-
-/* Compare no more than N bytes 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.
- Note: This function cannot work correctly in multibyte locales. */
-
-int
-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 = TOLOWER (*p1);
- c2 = 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/sys_file.in.h b/lib/sys_file.in.h
index bbc551a..476f2f6 100644
--- a/lib/sys_file.in.h
+++ b/lib/sys_file.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Richard W.M. Jones. */
diff --git a/lib/sys_socket.in.h b/lib/sys_socket.in.h
index e238a76..a0bcffb 100644
--- a/lib/sys_socket.in.h
+++ b/lib/sys_socket.in.h
@@ -14,8 +14,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* This file is supposed to be used on platforms that lack <sys/socket.h>,
on platforms where <sys/socket.h> cannot be included standalone, and on
@@ -143,7 +142,7 @@ struct sockaddr_storage
that you can influence which definitions you get by setting the
WINVER symbol before including these two files. For example,
getaddrinfo is only available if _WIN32_WINNT >= 0x0501 (that
- symbol is set indiriectly through WINVER). You can set this by
+ symbol is set indirectly through WINVER). You can set this by
adding AC_DEFINE(WINVER, 0x0501) to configure.ac. Note that your
code may not run on older Windows releases then. My Windows 2000
box was not able to run the code, for example. The situation is
diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h
index 7d24a3f..97fb3c4 100644
--- a/lib/sys_stat.in.h
+++ b/lib/sys_stat.in.h
@@ -12,8 +12,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Eric Blake, Paul Eggert, and Jim Meyering. */
@@ -36,7 +35,8 @@
#ifndef address@hidden@_SYS_STAT_H
-/* Get nlink_t. */
+/* Get nlink_t.
+ May also define off_t to a 64-bit type on native Windows. */
#include <sys/types.h>
/* Get struct timespec. */
@@ -67,6 +67,11 @@
# include <io.h>
#endif
+/* Large File Support on native Windows. */
+#if @WINDOWS_64_BIT_ST_SIZE@
+# define stat _stati64
+#endif
+
#ifndef S_IFIFO
# ifdef _S_IFIFO
# define S_IFIFO _S_IFIFO
@@ -336,6 +341,9 @@ _GL_CXXALIAS_RPL (fstat, int, (int fd, struct stat *buf));
_GL_CXXALIAS_SYS (fstat, int, (int fd, struct stat *buf));
# endif
_GL_CXXALIASWARN (fstat);
+#elif @WINDOWS_64_BIT_ST_SIZE@
+/* Above, we define stat to _stati64. */
+# define fstat _fstati64
#elif defined GNULIB_POSIXCHECK
# undef fstat
# if HAVE_RAW_DECL_FSTAT
@@ -616,14 +624,55 @@ _GL_WARN_ON_USE (mknodat, "mknodat is not portable - "
/* We can't use the object-like #define stat rpl_stat, because of
struct stat. This means that rpl_stat will not be used if the user
does (stat)(a,b). Oh well. */
-# undef stat
-# ifdef _LARGE_FILES
+# if defined _AIX && defined stat && defined _LARGE_FILES
/* With _LARGE_FILES defined, AIX (only) defines stat to stat64,
so we have to replace stat64() instead of stat(). */
-# define stat stat64
# undef stat64
# define stat64(name, st) rpl_stat (name, st)
-# else /* !_LARGE_FILES */
+# elif @WINDOWS_64_BIT_ST_SIZE@
+ /* Above, we define stat to _stati64. */
+# if defined __MINGW32__ && defined _stati64
+# ifndef _USE_32BIT_TIME_T
+ /* The system headers define _stati64 to _stat64. */
+# undef _stat64
+# define _stat64(name, st) rpl_stat (name, st)
+# endif
+# elif defined _MSC_VER && defined _stati64
+# ifdef _USE_32BIT_TIME_T
+ /* The system headers define _stati64 to _stat32i64. */
+# undef _stat32i64
+# define _stat32i64(name, st) rpl_stat (name, st)
+# else
+ /* The system headers define _stati64 to _stat64. */
+# undef _stat64
+# define _stat64(name, st) rpl_stat (name, st)
+# endif
+# else
+# undef _stati64
+# define _stati64(name, st) rpl_stat (name, st)
+# endif
+# elif defined __MINGW32__ && defined stat
+# ifdef _USE_32BIT_TIME_T
+ /* The system headers define stat to _stat32i64. */
+# undef _stat32i64
+# define _stat32i64(name, st) rpl_stat (name, st)
+# else
+ /* The system headers define stat to _stat64. */
+# undef _stat64
+# define _stat64(name, st) rpl_stat (name, st)
+# endif
+# elif defined _MSC_VER && defined stat
+# ifdef _USE_32BIT_TIME_T
+ /* The system headers define stat to _stat32. */
+# undef _stat32
+# define _stat32(name, st) rpl_stat (name, st)
+# else
+ /* The system headers define stat to _stat64i32. */
+# undef _stat64i32
+# define _stat64i32(name, st) rpl_stat (name, st)
+# endif
+# else /* !(_AIX ||__MINGW32__ || _MSC_VER) */
+# undef stat
# define stat(name, st) rpl_stat (name, st)
# endif /* !_LARGE_FILES */
_GL_EXTERN_C int stat (const char *name, struct stat *buf)
diff --git a/lib/sys_time.in.h b/lib/sys_time.in.h
index d1f9541..3dbbf91 100644
--- a/lib/sys_time.in.h
+++ b/lib/sys_time.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Paul Eggert. */
@@ -40,9 +39,11 @@
# include <time.h>
# endif
-/* On native Windows with MSVC:
- Get the 'struct timeval' type. */
-# if defined _MSC_VER && @HAVE_WINSOCK2_H@ && !defined _GL_INCLUDING_WINSOCK2_H
+/* On native Windows with MSVC, get the 'struct timeval' type.
+ Also, on native Windows with a 64-bit time_t, where we are overriding the
+ 'struct timeval' type, get all declarations of system functions whose
+ signature contains 'struct timeval'. */
+# if (defined _MSC_VER || @REPLACE_STRUCT_TIMEVAL@) && @HAVE_WINSOCK2_H@ &&
!defined _GL_INCLUDING_WINSOCK2_H
# define _GL_INCLUDING_WINSOCK2_H
# include <winsock2.h>
# undef _GL_INCLUDING_WINSOCK2_H
@@ -58,7 +59,11 @@
extern "C" {
# endif
-# if ! @HAVE_STRUCT_TIMEVAL@
+# if address@hidden@ || @REPLACE_STRUCT_TIMEVAL@
+
+# if @REPLACE_STRUCT_TIMEVAL@
+# define timeval rpl_timeval
+# endif
# if !GNULIB_defined_struct_timeval
struct timeval
diff --git a/lib/sys_types.in.h b/lib/sys_types.in.h
index 615993a..6eedaeb 100644
--- a/lib/sys_types.in.h
+++ b/lib/sys_types.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#if __GNUC__ >= 3
@PRAGMA_SYSTEM_HEADER@
@@ -29,6 +28,18 @@
#ifndef address@hidden@_SYS_TYPES_H
#define address@hidden@_SYS_TYPES_H
+/* Override off_t if Large File Support is requested on native Windows. */
+#if @WINDOWS_64_BIT_OFF_T@
+/* Same as int64_t in <stdint.h>. */
+# if defined _MSC_VER
+# define off_t __int64
+# else
+# define off_t long long int
+# endif
+/* Indicator, for gnulib internal purposes. */
+# define _GL_WINDOWS_64_BIT_OFF_T 1
+#endif
+
/* MSVC 9 defines size_t in <stddef.h>, not in <sys/types.h>. */
/* But avoid namespace pollution on glibc systems. */
#if ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__) \
diff --git a/lib/sys_uio.in.h b/lib/sys_uio.in.h
index 0abc597..73c34be 100644
--- a/lib/sys_uio.in.h
+++ b/lib/sys_uio.in.h
@@ -12,8 +12,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
# if __GNUC__ >= 3
@PRAGMA_SYSTEM_HEADER@
diff --git a/lib/time.in.h b/lib/time.in.h
index 448466c..11c6ca1 100644
--- a/lib/time.in.h
+++ b/lib/time.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#if __GNUC__ >= 3
@PRAGMA_SYSTEM_HEADER@
diff --git a/lib/time_r.c b/lib/time_r.c
index b25f6a6..267c18d 100644
--- a/lib/time_r.c
+++ b/lib/time_r.c
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Paul Eggert. */
diff --git a/lib/trunc.c b/lib/trunc.c
index 76627fb..3b86ef0 100644
--- a/lib/trunc.c
+++ b/lib/trunc.c
@@ -54,6 +54,12 @@
# define MINUS_ZERO L_(-0.0)
#endif
+/* MSVC with option -fp:strict refuses to compile constant initializers that
+ contain floating-point operations. Pacify this compiler. */
+#ifdef _MSC_VER
+# pragma fenv_access (off)
+#endif
+
/* 2^(MANT_DIG-1). */
static const DOUBLE TWO_MANT_DIG =
/* Assume MANT_DIG <= 5 * 31.
diff --git a/lib/unistd.in.h b/lib/unistd.in.h
index e6e65cb..e96a39c 100644
--- a/lib/unistd.in.h
+++ b/lib/unistd.in.h
@@ -12,8 +12,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#if __GNUC__ >= 3
@PRAGMA_SYSTEM_HEADER@
@@ -108,8 +107,9 @@
# include <netdb.h>
#endif
-/* MSVC defines off_t in <sys/types.h>. */
-#if address@hidden@
+/* MSVC defines off_t in <sys/types.h>.
+ May also define off_t to a 64-bit type on native Windows. */
+#if address@hidden@ || @WINDOWS_64_BIT_OFF_T@
/* Get off_t. */
# include <sys/types.h>
#endif
@@ -563,10 +563,19 @@ _GL_WARN_ON_USE (fsync, "fsync is unportable - "
Return 0 if successful, otherwise -1 and errno set.
See the POSIX:2008 specification
<http://pubs.opengroup.org/onlinepubs/9699919799/functions/ftruncate.html>.
*/
-# if address@hidden@
+# if @REPLACE_FTRUNCATE@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef ftruncate
+# define ftruncate rpl_ftruncate
+# endif
+_GL_FUNCDECL_RPL (ftruncate, int, (int fd, off_t length));
+_GL_CXXALIAS_RPL (ftruncate, int, (int fd, off_t length));
+# else
+# if address@hidden@
_GL_FUNCDECL_SYS (ftruncate, int, (int fd, off_t length));
-# endif
+# endif
_GL_CXXALIAS_SYS (ftruncate, int, (int fd, off_t length));
+# endif
_GL_CXXALIASWARN (ftruncate);
#elif defined GNULIB_POSIXCHECK
# undef ftruncate
@@ -1309,7 +1318,7 @@ _GL_WARN_ON_USE (rmdir, "rmdir is unportable - "
_GL_FUNCDECL_SYS (sethostname, int, (const char *name, size_t len)
_GL_ARG_NONNULL ((1)));
# endif
-/* Need to cast, because on Solaris 11 2011-10, MacOS X 10.5, IRIX 6.5
+/* Need to cast, because on Solaris 11 2011-10, Mac OS X 10.5, IRIX 6.5
and FreeBSD 6.4 the second parameter is int. On Solaris 11
2011-10, the first parameter is not const. */
_GL_CXXALIAS_SYS_CAST (sethostname, int, (const char *name, size_t len));
diff --git a/lib/unistr.in.h b/lib/unistr.in.h
index 83aeeee..2706789 100644
--- a/lib/unistr.in.h
+++ b/lib/unistr.in.h
@@ -66,17 +66,20 @@ extern "C" {
/* 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);
+ u8_check (const uint8_t *s, size_t n)
+ _UC_ATTRIBUTE_PURE;
/* 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);
+ u16_check (const uint16_t *s, size_t n)
+ _UC_ATTRIBUTE_PURE;
/* 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);
+ u32_check (const uint32_t *s, size_t n)
+ _UC_ATTRIBUTE_PURE;
/* Elementary string conversions. */
@@ -119,11 +122,14 @@ extern uint16_t *
failure. */
/* Similar to mblen(), except that s must not be NULL. */
extern int
- u8_mblen (const uint8_t *s, size_t n);
+ u8_mblen (const uint8_t *s, size_t n)
+ _UC_ATTRIBUTE_PURE;
extern int
- u16_mblen (const uint16_t *s, size_t n);
+ u16_mblen (const uint16_t *s, size_t n)
+ _UC_ATTRIBUTE_PURE;
extern int
- u32_mblen (const uint32_t *s, size_t n);
+ u32_mblen (const uint32_t *s, size_t n)
+ _UC_ATTRIBUTE_PURE;
/* 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,
@@ -400,38 +406,50 @@ extern uint32_t *
/* 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);
+ u8_cmp (const uint8_t *s1, const uint8_t *s2, size_t n)
+ _UC_ATTRIBUTE_PURE;
extern int
- u16_cmp (const uint16_t *s1, const uint16_t *s2, size_t n);
+ u16_cmp (const uint16_t *s1, const uint16_t *s2, size_t n)
+ _UC_ATTRIBUTE_PURE;
extern int
- u32_cmp (const uint32_t *s1, const uint32_t *s2, size_t n);
+ u32_cmp (const uint32_t *s1, const uint32_t *s2, size_t n)
+ _UC_ATTRIBUTE_PURE;
/* 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);
+ u8_cmp2 (const uint8_t *s1, size_t n1, const uint8_t *s2, size_t n2)
+ _UC_ATTRIBUTE_PURE;
extern int
- u16_cmp2 (const uint16_t *s1, size_t n1, const uint16_t *s2, size_t n2);
+ u16_cmp2 (const uint16_t *s1, size_t n1, const uint16_t *s2, size_t n2)
+ _UC_ATTRIBUTE_PURE;
extern int
- u32_cmp2 (const uint32_t *s1, size_t n1, const uint32_t *s2, size_t n2);
+ u32_cmp2 (const uint32_t *s1, size_t n1, const uint32_t *s2, size_t n2)
+ _UC_ATTRIBUTE_PURE;
/* 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);
+ u8_chr (const uint8_t *s, size_t n, ucs4_t uc)
+ _UC_ATTRIBUTE_PURE;
extern uint16_t *
- u16_chr (const uint16_t *s, size_t n, ucs4_t uc);
+ u16_chr (const uint16_t *s, size_t n, ucs4_t uc)
+ _UC_ATTRIBUTE_PURE;
extern uint32_t *
- u32_chr (const uint32_t *s, size_t n, ucs4_t uc);
+ u32_chr (const uint32_t *s, size_t n, ucs4_t uc)
+ _UC_ATTRIBUTE_PURE;
/* 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);
+ u8_mbsnlen (const uint8_t *s, size_t n)
+ _UC_ATTRIBUTE_PURE;
extern size_t
- u16_mbsnlen (const uint16_t *s, size_t n);
+ u16_mbsnlen (const uint16_t *s, size_t n)
+ _UC_ATTRIBUTE_PURE;
extern size_t
- u32_mbsnlen (const uint32_t *s, size_t n);
+ u32_mbsnlen (const uint32_t *s, size_t n)
+ _UC_ATTRIBUTE_PURE;
/* Elementary string functions with memory allocation. */
@@ -448,11 +466,14 @@ extern uint32_t *
/* 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);
+ u8_strmblen (const uint8_t *s)
+ _UC_ATTRIBUTE_PURE;
extern int
- u16_strmblen (const uint16_t *s);
+ u16_strmblen (const uint16_t *s)
+ _UC_ATTRIBUTE_PURE;
extern int
- u32_strmblen (const uint32_t *s);
+ u32_strmblen (const uint32_t *s)
+ _UC_ATTRIBUTE_PURE;
/* 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
@@ -487,20 +508,26 @@ extern const uint32_t *
/* Return the number of units in S. */
/* Similar to strlen(), wcslen(). */
extern size_t
- u8_strlen (const uint8_t *s);
+ u8_strlen (const uint8_t *s)
+ _UC_ATTRIBUTE_PURE;
extern size_t
- u16_strlen (const uint16_t *s);
+ u16_strlen (const uint16_t *s)
+ _UC_ATTRIBUTE_PURE;
extern size_t
- u32_strlen (const uint32_t *s);
+ u32_strlen (const uint32_t *s)
+ _UC_ATTRIBUTE_PURE;
/* 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);
+ u8_strnlen (const uint8_t *s, size_t maxlen)
+ _UC_ATTRIBUTE_PURE;
extern size_t
- u16_strnlen (const uint16_t *s, size_t maxlen);
+ u16_strnlen (const uint16_t *s, size_t maxlen)
+ _UC_ATTRIBUTE_PURE;
extern size_t
- u32_strnlen (const uint32_t *s, size_t maxlen);
+ u32_strnlen (const uint32_t *s, size_t maxlen)
+ _UC_ATTRIBUTE_PURE;
/* Copy SRC to DEST. */
/* Similar to strcpy(), wcscpy(). */
@@ -562,16 +589,20 @@ extern uint32_t *
#ifdef __sun
/* Avoid a collision with the u8_strcmp() function in Solaris 11 libc. */
extern int
- u8_strcmp_gnu (const uint8_t *s1, const uint8_t *s2);
+ u8_strcmp_gnu (const uint8_t *s1, const uint8_t *s2)
+ _UC_ATTRIBUTE_PURE;
# define u8_strcmp u8_strcmp_gnu
#else
extern int
- u8_strcmp (const uint8_t *s1, const uint8_t *s2);
+ u8_strcmp (const uint8_t *s1, const uint8_t *s2)
+ _UC_ATTRIBUTE_PURE;
#endif
extern int
- u16_strcmp (const uint16_t *s1, const uint16_t *s2);
+ u16_strcmp (const uint16_t *s1, const uint16_t *s2)
+ _UC_ATTRIBUTE_PURE;
extern int
- u32_strcmp (const uint32_t *s1, const uint32_t *s2);
+ u32_strcmp (const uint32_t *s1, const uint32_t *s2)
+ _UC_ATTRIBUTE_PURE;
/* 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.
@@ -587,11 +618,14 @@ extern int
/* 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);
+ u8_strncmp (const uint8_t *s1, const uint8_t *s2, size_t n)
+ _UC_ATTRIBUTE_PURE;
extern int
- u16_strncmp (const uint16_t *s1, const uint16_t *s2, size_t n);
+ u16_strncmp (const uint16_t *s1, const uint16_t *s2, size_t n)
+ _UC_ATTRIBUTE_PURE;
extern int
- u32_strncmp (const uint32_t *s1, const uint32_t *s2, size_t n);
+ u32_strncmp (const uint32_t *s1, const uint32_t *s2, size_t n)
+ _UC_ATTRIBUTE_PURE;
/* Duplicate S, returning an identical malloc'd string. */
/* Similar to strdup(), wcsdup(). */
@@ -605,74 +639,98 @@ extern uint32_t *
/* Find the first occurrence of UC in STR. */
/* Similar to strchr(), wcschr(). */
extern uint8_t *
- u8_strchr (const uint8_t *str, ucs4_t uc);
+ u8_strchr (const uint8_t *str, ucs4_t uc)
+ _UC_ATTRIBUTE_PURE;
extern uint16_t *
- u16_strchr (const uint16_t *str, ucs4_t uc);
+ u16_strchr (const uint16_t *str, ucs4_t uc)
+ _UC_ATTRIBUTE_PURE;
extern uint32_t *
- u32_strchr (const uint32_t *str, ucs4_t uc);
+ u32_strchr (const uint32_t *str, ucs4_t uc)
+ _UC_ATTRIBUTE_PURE;
/* Find the last occurrence of UC in STR. */
/* Similar to strrchr(), wcsrchr(). */
extern uint8_t *
- u8_strrchr (const uint8_t *str, ucs4_t uc);
+ u8_strrchr (const uint8_t *str, ucs4_t uc)
+ _UC_ATTRIBUTE_PURE;
extern uint16_t *
- u16_strrchr (const uint16_t *str, ucs4_t uc);
+ u16_strrchr (const uint16_t *str, ucs4_t uc)
+ _UC_ATTRIBUTE_PURE;
extern uint32_t *
- u32_strrchr (const uint32_t *str, ucs4_t uc);
+ u32_strrchr (const uint32_t *str, ucs4_t uc)
+ _UC_ATTRIBUTE_PURE;
/* 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);
+ u8_strcspn (const uint8_t *str, const uint8_t *reject)
+ _UC_ATTRIBUTE_PURE;
extern size_t
- u16_strcspn (const uint16_t *str, const uint16_t *reject);
+ u16_strcspn (const uint16_t *str, const uint16_t *reject)
+ _UC_ATTRIBUTE_PURE;
extern size_t
- u32_strcspn (const uint32_t *str, const uint32_t *reject);
+ u32_strcspn (const uint32_t *str, const uint32_t *reject)
+ _UC_ATTRIBUTE_PURE;
/* 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);
+ u8_strspn (const uint8_t *str, const uint8_t *accept)
+ _UC_ATTRIBUTE_PURE;
extern size_t
- u16_strspn (const uint16_t *str, const uint16_t *accept);
+ u16_strspn (const uint16_t *str, const uint16_t *accept)
+ _UC_ATTRIBUTE_PURE;
extern size_t
- u32_strspn (const uint32_t *str, const uint32_t *accept);
+ u32_strspn (const uint32_t *str, const uint32_t *accept)
+ _UC_ATTRIBUTE_PURE;
/* 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);
+ u8_strpbrk (const uint8_t *str, const uint8_t *accept)
+ _UC_ATTRIBUTE_PURE;
extern uint16_t *
- u16_strpbrk (const uint16_t *str, const uint16_t *accept);
+ u16_strpbrk (const uint16_t *str, const uint16_t *accept)
+ _UC_ATTRIBUTE_PURE;
extern uint32_t *
- u32_strpbrk (const uint32_t *str, const uint32_t *accept);
+ u32_strpbrk (const uint32_t *str, const uint32_t *accept)
+ _UC_ATTRIBUTE_PURE;
/* 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);
+ u8_strstr (const uint8_t *haystack, const uint8_t *needle)
+ _UC_ATTRIBUTE_PURE;
extern uint16_t *
- u16_strstr (const uint16_t *haystack, const uint16_t *needle);
+ u16_strstr (const uint16_t *haystack, const uint16_t *needle)
+ _UC_ATTRIBUTE_PURE;
extern uint32_t *
- u32_strstr (const uint32_t *haystack, const uint32_t *needle);
+ u32_strstr (const uint32_t *haystack, const uint32_t *needle)
+ _UC_ATTRIBUTE_PURE;
/* Test whether STR starts with PREFIX. */
extern bool
- u8_startswith (const uint8_t *str, const uint8_t *prefix);
+ u8_startswith (const uint8_t *str, const uint8_t *prefix)
+ _UC_ATTRIBUTE_PURE;
extern bool
- u16_startswith (const uint16_t *str, const uint16_t *prefix);
+ u16_startswith (const uint16_t *str, const uint16_t *prefix)
+ _UC_ATTRIBUTE_PURE;
extern bool
- u32_startswith (const uint32_t *str, const uint32_t *prefix);
+ u32_startswith (const uint32_t *str, const uint32_t *prefix)
+ _UC_ATTRIBUTE_PURE;
/* Test whether STR ends with SUFFIX. */
extern bool
- u8_endswith (const uint8_t *str, const uint8_t *suffix);
+ u8_endswith (const uint8_t *str, const uint8_t *suffix)
+ _UC_ATTRIBUTE_PURE;
extern bool
- u16_endswith (const uint16_t *str, const uint16_t *suffix);
+ u16_endswith (const uint16_t *str, const uint16_t *suffix)
+ _UC_ATTRIBUTE_PURE;
extern bool
- u32_endswith (const uint32_t *str, const uint32_t *suffix);
+ u32_endswith (const uint32_t *str, const uint32_t *suffix)
+ _UC_ATTRIBUTE_PURE;
/* Divide STR into tokens separated by characters in DELIM.
This interface is actually more similar to wcstok than to strtok. */
diff --git a/lib/unitypes.in.h b/lib/unitypes.in.h
index c1204e1..c588589 100644
--- a/lib/unitypes.in.h
+++ b/lib/unitypes.in.h
@@ -1,4 +1,4 @@
-/* Elementary types for the GNU UniString library.
+/* Elementary types and macros for the GNU UniString library.
Copyright (C) 2002, 2005-2006, 2009-2012 Free Software Foundation, Inc.
This program is free software: you can redistribute it and/or modify it
@@ -23,4 +23,24 @@
/* Type representing a Unicode character. */
typedef uint32_t ucs4_t;
+/* Attribute of a function whose result depends only on the arguments
+ (not pointers!) and which has no side effects. */
+#ifndef _UC_ATTRIBUTE_CONST
+# if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 95)
+# define _UC_ATTRIBUTE_CONST __attribute__ ((__const__))
+# else
+# define _UC_ATTRIBUTE_CONST
+# endif
+#endif
+
+/* Attribute of a function whose result depends only on the arguments
+ (possibly pointers) and global memory, and which has no side effects. */
+#ifndef _UC_ATTRIBUTE_PURE
+# if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96)
+# define _UC_ATTRIBUTE_PURE __attribute__ ((__pure__))
+# else
+# define _UC_ATTRIBUTE_PURE
+# endif
+#endif
+
#endif /* _UNITYPES_H */
diff --git a/lib/vasnprintf.c b/lib/vasnprintf.c
index 3a94d2f..1da25f5 100644
--- a/lib/vasnprintf.c
+++ b/lib/vasnprintf.c
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
/* This file can be parametrized with the following macros:
VASNPRINTF The name of the function being defined.
@@ -276,7 +275,7 @@ decimal_point_char (void)
{
const char *point;
/* Determine it in a multithread-safe way. We know nl_langinfo is
- multithread-safe on glibc systems and MacOS X systems, but is not required
+ multithread-safe on glibc systems and Mac OS X systems, but is not
required
to be multithread-safe by POSIX. sprintf(), however, is multithread-safe.
localeconv() is rarely multithread-safe. */
# if HAVE_NL_LANGINFO && (__GLIBC__ || defined __UCLIBC__ || (defined
__APPLE__ && defined __MACH__))
@@ -2814,7 +2813,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
if (has_width)
{
# if ENABLE_UNISTDIO
- /* Outside POSIX, it's preferrable to compare the width
+ /* Outside POSIX, it's preferable to compare the width
against the number of _characters_ of the converted
value. */
w = DCHAR_MBSNLEN (result + length, characters);
@@ -5417,7 +5416,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp,
{
size_t w;
# if ENABLE_UNISTDIO
- /* Outside POSIX, it's preferrable to compare the width
+ /* Outside POSIX, it's preferable to compare the width
against the number of _characters_ of the converted
value. */
w = DCHAR_MBSNLEN (result + length, count);
diff --git a/lib/vasnprintf.h b/lib/vasnprintf.h
index dac6f50..277f270 100644
--- a/lib/vasnprintf.h
+++ b/lib/vasnprintf.h
@@ -12,8 +12,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _VASNPRINTF_H
#define _VASNPRINTF_H
diff --git a/lib/vsnprintf.c b/lib/vsnprintf.c
index c59ce0c..1d8db4e 100644
--- a/lib/vsnprintf.c
+++ b/lib/vsnprintf.c
@@ -13,8 +13,7 @@
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. */
+ with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifdef HAVE_CONFIG_H
# include <config.h>
diff --git a/lib/w32sock.h b/lib/w32sock.h
index 5c1af6b..b397115 100644
--- a/lib/w32sock.h
+++ b/lib/w32sock.h
@@ -1,4 +1,4 @@
-/* w32sock.h --- internal auxilliary functions for Windows socket functions
+/* w32sock.h --- internal auxiliary functions for Windows socket functions
Copyright (C) 2008-2012 Free Software Foundation, Inc.
@@ -29,7 +29,7 @@
#include "msvc-nothrow.h"
#define FD_TO_SOCKET(fd) ((SOCKET) _get_osfhandle ((fd)))
-#define SOCKET_TO_FD(fh) (_open_osfhandle ((long) (fh), O_RDWR | O_BINARY))
+#define SOCKET_TO_FD(fh) (_open_osfhandle ((intptr_t) (fh), O_RDWR |
O_BINARY))
static inline void
set_winsock_errno (void)
diff --git a/lib/wchar.in.h b/lib/wchar.in.h
index 1928729..5c93616 100644
--- a/lib/wchar.in.h
+++ b/lib/wchar.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Eric Blake. */
@@ -84,6 +83,14 @@
#ifndef address@hidden@_WCHAR_H
#define address@hidden@_WCHAR_H
+/* The __attribute__ feature is available in gcc versions 2.5 and later.
+ The attribute __pure__ was added in gcc 2.96. */
+#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96)
+# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__))
+#else
+# define _GL_ATTRIBUTE_PURE /* empty */
+#endif
+
/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */
/* The definition of _GL_ARG_NONNULL is copied here. */
@@ -136,11 +143,11 @@ typedef int rpl_mbstate_t;
# undef btowc
# define btowc rpl_btowc
# endif
-_GL_FUNCDECL_RPL (btowc, wint_t, (int c));
+_GL_FUNCDECL_RPL (btowc, wint_t, (int c) _GL_ATTRIBUTE_PURE);
_GL_CXXALIAS_RPL (btowc, wint_t, (int c));
# else
# if address@hidden@
-_GL_FUNCDECL_SYS (btowc, wint_t, (int c));
+_GL_FUNCDECL_SYS (btowc, wint_t, (int c) _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (btowc, wint_t, (int c));
# endif
@@ -161,12 +168,12 @@ _GL_WARN_ON_USE (btowc, "btowc is unportable - "
# undef wctob
# define wctob rpl_wctob
# endif
-_GL_FUNCDECL_RPL (wctob, int, (wint_t wc));
+_GL_FUNCDECL_RPL (wctob, int, (wint_t wc) _GL_ATTRIBUTE_PURE);
_GL_CXXALIAS_RPL (wctob, int, (wint_t wc));
# else
# if !defined wctob && address@hidden@
/* wctob is provided by gnulib, or wctob exists but is not declared. */
-_GL_FUNCDECL_SYS (wctob, int, (wint_t wc));
+_GL_FUNCDECL_SYS (wctob, int, (wint_t wc) _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wctob, int, (wint_t wc));
# endif
@@ -427,12 +434,12 @@ _GL_WARN_ON_USE (wcsnrtombs, "wcsnrtombs is unportable - "
# undef wcwidth
# define wcwidth rpl_wcwidth
# endif
-_GL_FUNCDECL_RPL (wcwidth, int, (wchar_t));
+_GL_FUNCDECL_RPL (wcwidth, int, (wchar_t) _GL_ATTRIBUTE_PURE);
_GL_CXXALIAS_RPL (wcwidth, int, (wchar_t));
# else
# if address@hidden@
/* wcwidth exists but is not declared. */
-_GL_FUNCDECL_SYS (wcwidth, int, (wchar_t));
+_GL_FUNCDECL_SYS (wcwidth, int, (wchar_t) _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wcwidth, int, (wchar_t));
# endif
@@ -449,7 +456,8 @@ _GL_WARN_ON_USE (wcwidth, "wcwidth is unportable - "
/* Search N wide characters of S for C. */
#if @GNULIB_WMEMCHR@
# if address@hidden@
-_GL_FUNCDECL_SYS (wmemchr, wchar_t *, (const wchar_t *s, wchar_t c, size_t n));
+_GL_FUNCDECL_SYS (wmemchr, wchar_t *, (const wchar_t *s, wchar_t c, size_t n)
+ _GL_ATTRIBUTE_PURE);
# endif
/* On some systems, this function is defined as an overloaded function:
extern "C++" {
@@ -480,7 +488,8 @@ _GL_WARN_ON_USE (wmemchr, "wmemchr is unportable - "
#if @GNULIB_WMEMCMP@
# if address@hidden@
_GL_FUNCDECL_SYS (wmemcmp, int,
- (const wchar_t *s1, const wchar_t *s2, size_t n));
+ (const wchar_t *s1, const wchar_t *s2, size_t n)
+ _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wmemcmp, int,
(const wchar_t *s1, const wchar_t *s2, size_t n));
@@ -550,7 +559,7 @@ _GL_WARN_ON_USE (wmemset, "wmemset is unportable - "
/* Return the number of wide characters in S. */
#if @GNULIB_WCSLEN@
# if address@hidden@
-_GL_FUNCDECL_SYS (wcslen, size_t, (const wchar_t *s));
+_GL_FUNCDECL_SYS (wcslen, size_t, (const wchar_t *s) _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wcslen, size_t, (const wchar_t *s));
_GL_CXXALIASWARN (wcslen);
@@ -566,7 +575,8 @@ _GL_WARN_ON_USE (wcslen, "wcslen is unportable - "
/* Return the number of wide characters in S, but at most MAXLEN. */
#if @GNULIB_WCSNLEN@
# if address@hidden@
-_GL_FUNCDECL_SYS (wcsnlen, size_t, (const wchar_t *s, size_t maxlen));
+_GL_FUNCDECL_SYS (wcsnlen, size_t, (const wchar_t *s, size_t maxlen)
+ _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wcsnlen, size_t, (const wchar_t *s, size_t maxlen));
_GL_CXXALIASWARN (wcsnlen);
@@ -685,7 +695,8 @@ _GL_WARN_ON_USE (wcsncat, "wcsncat is unportable - "
/* Compare S1 and S2. */
#if @GNULIB_WCSCMP@
# if address@hidden@
-_GL_FUNCDECL_SYS (wcscmp, int, (const wchar_t *s1, const wchar_t *s2));
+_GL_FUNCDECL_SYS (wcscmp, int, (const wchar_t *s1, const wchar_t *s2)
+ _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wcscmp, int, (const wchar_t *s1, const wchar_t *s2));
_GL_CXXALIASWARN (wcscmp);
@@ -702,7 +713,8 @@ _GL_WARN_ON_USE (wcscmp, "wcscmp is unportable - "
#if @GNULIB_WCSNCMP@
# if address@hidden@
_GL_FUNCDECL_SYS (wcsncmp, int,
- (const wchar_t *s1, const wchar_t *s2, size_t n));
+ (const wchar_t *s1, const wchar_t *s2, size_t n)
+ _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wcsncmp, int,
(const wchar_t *s1, const wchar_t *s2, size_t n));
@@ -719,7 +731,8 @@ _GL_WARN_ON_USE (wcsncmp, "wcsncmp is unportable - "
/* Compare S1 and S2, ignoring case. */
#if @GNULIB_WCSCASECMP@
# if address@hidden@
-_GL_FUNCDECL_SYS (wcscasecmp, int, (const wchar_t *s1, const wchar_t *s2));
+_GL_FUNCDECL_SYS (wcscasecmp, int, (const wchar_t *s1, const wchar_t *s2)
+ _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wcscasecmp, int, (const wchar_t *s1, const wchar_t *s2));
_GL_CXXALIASWARN (wcscasecmp);
@@ -736,7 +749,8 @@ _GL_WARN_ON_USE (wcscasecmp, "wcscasecmp is unportable - "
#if @GNULIB_WCSNCASECMP@
# if address@hidden@
_GL_FUNCDECL_SYS (wcsncasecmp, int,
- (const wchar_t *s1, const wchar_t *s2, size_t n));
+ (const wchar_t *s1, const wchar_t *s2, size_t n)
+ _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wcsncasecmp, int,
(const wchar_t *s1, const wchar_t *s2, size_t n));
@@ -804,7 +818,8 @@ _GL_WARN_ON_USE (wcsdup, "wcsdup is unportable - "
/* Find the first occurrence of WC in WCS. */
#if @GNULIB_WCSCHR@
# if address@hidden@
-_GL_FUNCDECL_SYS (wcschr, wchar_t *, (const wchar_t *wcs, wchar_t wc));
+_GL_FUNCDECL_SYS (wcschr, wchar_t *, (const wchar_t *wcs, wchar_t wc)
+ _GL_ATTRIBUTE_PURE);
# endif
/* On some systems, this function is defined as an overloaded function:
extern "C++" {
@@ -833,7 +848,8 @@ _GL_WARN_ON_USE (wcschr, "wcschr is unportable - "
/* Find the last occurrence of WC in WCS. */
#if @GNULIB_WCSRCHR@
# if address@hidden@
-_GL_FUNCDECL_SYS (wcsrchr, wchar_t *, (const wchar_t *wcs, wchar_t wc));
+_GL_FUNCDECL_SYS (wcsrchr, wchar_t *, (const wchar_t *wcs, wchar_t wc)
+ _GL_ATTRIBUTE_PURE);
# endif
/* On some systems, this function is defined as an overloaded function:
extern "C++" {
@@ -863,7 +879,8 @@ _GL_WARN_ON_USE (wcsrchr, "wcsrchr is unportable - "
of wide characters not in REJECT. */
#if @GNULIB_WCSCSPN@
# if address@hidden@
-_GL_FUNCDECL_SYS (wcscspn, size_t, (const wchar_t *wcs, const wchar_t
*reject));
+_GL_FUNCDECL_SYS (wcscspn, size_t, (const wchar_t *wcs, const wchar_t *reject)
+ _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wcscspn, size_t, (const wchar_t *wcs, const wchar_t
*reject));
_GL_CXXALIASWARN (wcscspn);
@@ -880,7 +897,8 @@ _GL_WARN_ON_USE (wcscspn, "wcscspn is unportable - "
of wide characters in ACCEPT. */
#if @GNULIB_WCSSPN@
# if address@hidden@
-_GL_FUNCDECL_SYS (wcsspn, size_t, (const wchar_t *wcs, const wchar_t *accept));
+_GL_FUNCDECL_SYS (wcsspn, size_t, (const wchar_t *wcs, const wchar_t *accept)
+ _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wcsspn, size_t, (const wchar_t *wcs, const wchar_t *accept));
_GL_CXXALIASWARN (wcsspn);
@@ -897,7 +915,8 @@ _GL_WARN_ON_USE (wcsspn, "wcsspn is unportable - "
#if @GNULIB_WCSPBRK@
# if address@hidden@
_GL_FUNCDECL_SYS (wcspbrk, wchar_t *,
- (const wchar_t *wcs, const wchar_t *accept));
+ (const wchar_t *wcs, const wchar_t *accept)
+ _GL_ATTRIBUTE_PURE);
# endif
/* On some systems, this function is defined as an overloaded function:
extern "C++" {
@@ -929,7 +948,8 @@ _GL_WARN_ON_USE (wcspbrk, "wcspbrk is unportable - "
#if @GNULIB_WCSSTR@
# if address@hidden@
_GL_FUNCDECL_SYS (wcsstr, wchar_t *,
- (const wchar_t *haystack, const wchar_t *needle));
+ (const wchar_t *haystack, const wchar_t *needle)
+ _GL_ATTRIBUTE_PURE);
# endif
/* On some systems, this function is defined as an overloaded function:
extern "C++" {
@@ -983,11 +1003,13 @@ _GL_WARN_ON_USE (wcstok, "wcstok is unportable - "
# undef wcswidth
# define wcswidth rpl_wcswidth
# endif
-_GL_FUNCDECL_RPL (wcswidth, int, (const wchar_t *s, size_t n));
+_GL_FUNCDECL_RPL (wcswidth, int, (const wchar_t *s, size_t n)
+ _GL_ATTRIBUTE_PURE);
_GL_CXXALIAS_RPL (wcswidth, int, (const wchar_t *s, size_t n));
# else
# if address@hidden@
-_GL_FUNCDECL_SYS (wcswidth, int, (const wchar_t *s, size_t n));
+_GL_FUNCDECL_SYS (wcswidth, int, (const wchar_t *s, size_t n)
+ _GL_ATTRIBUTE_PURE);
# endif
_GL_CXXALIAS_SYS (wcswidth, int, (const wchar_t *s, size_t n));
# endif
diff --git a/lib/wctype.in.h b/lib/wctype.in.h
index f25ad30..e819d44 100644
--- a/lib/wctype.in.h
+++ b/lib/wctype.in.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
/* Written by Bruno Haible and Paul Eggert. */
diff --git a/lib/xsize.h b/lib/xsize.h
index 42799d9..38d1afd 100644
--- a/lib/xsize.h
+++ b/lib/xsize.h
@@ -13,8 +13,7 @@
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. */
+ along with this program; if not, see <http://www.gnu.org/licenses/>. */
#ifndef _XSIZE_H
#define _XSIZE_H
diff --git a/libguile.h b/libguile.h
index 2c10d05..fefca43 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,
2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008,
2009, 2010, 2011, 2012 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
@@ -49,6 +49,7 @@ extern "C" {
#include "libguile/extensions.h"
#include "libguile/feature.h"
#include "libguile/filesys.h"
+#include "libguile/finalizers.h"
#include "libguile/fluids.h"
#include "libguile/foreign.h"
#include "libguile/fports.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index c181b99..e216435 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -142,6 +142,7 @@ address@hidden@_la_SOURCES =
\
extensions.c \
feature.c \
filesys.c \
+ finalizers.c \
fluids.c \
foreign.c \
fports.c \
@@ -447,7 +448,6 @@ install-exec-hook:
## Perhaps we can deal with them normally once the merge seems to be
## working.
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
- ieee-754.h \
srfi-14.i.c \
quicksort.i.c \
win32-uname.h win32-socket.h \
@@ -477,12 +477,14 @@ address@hidden@_la_LDFLAGS = \
$(ISNANF_LIBM) \
$(ISNANL_LIBM) \
$(LDEXP_LIBM) \
- $(LIB_CLOCK_GETTIME) \
$(LIBSOCKET) \
+ $(LIB_CLOCK_GETTIME) \
$(LOG1P_LIBM) \
+ $(LOG_LIBM) \
$(LTLIBICONV) \
$(LTLIBINTL) \
$(LTLIBUNISTRING) \
+ $(ROUND_LIBM) \
$(SERVENT_LIB) \
$(TRUNC_LIBM) \
-version-info $(version_info) \
@@ -530,6 +532,7 @@ modinclude_HEADERS = \
expand.h \
extensions.h \
feature.h \
+ finalizers.h \
filesys.h \
fluids.h \
foreign.h \
diff --git a/libguile/__scm.h b/libguile/__scm.h
index c4f2a1a..1c20bd7 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -126,7 +126,8 @@
/* The SCM_ALIGNED macro, when defined, can be used to instruct the compiler
* to honor the given alignment constraint. */
-#if defined __GNUC__
+/* Sun Studio supports alignment since Sun Studio 12 */
+#if defined __GNUC__ || (defined( __SUNPRO_C ) && (__SUNPRO_C - 0 >= 0x590))
# define SCM_ALIGNED(x) __attribute__ ((aligned (x)))
#elif defined __INTEL_COMPILER
# define SCM_ALIGNED(x) __declspec (align (x))
@@ -192,6 +193,64 @@
+/* We would like gnu89 extern inline semantics, not C99 extern inline
+ semantics, so that we can be sure to avoid reifying definitions of
+ inline functions in all compilation units, which is a possibility at
+ low optimization levels, or if a user takes the address of an inline
+ function.
+
+ Hence the `__gnu_inline__' attribute, in accordance with:
+ http://gcc.gnu.org/gcc-4.3/porting_to.html .
+
+ With GCC 4.2, `__GNUC_STDC_INLINE__' is never defined (because C99 inline
+ semantics are not supported), but a warning is issued in C99 mode if
+ `__gnu_inline__' is not used.
+
+ Apple's GCC build >5400 (since Xcode 3.0) doesn't support GNU inline in
+ C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static
+ inline" in that case. */
+
+# if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ >
5400)) && __STDC_VERSION__ >= 199901L))
+# if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
+# define SCM_C_EXTERN_INLINE \
+ extern __inline__ __attribute__ ((__gnu_inline__))
+# else
+# define SCM_C_EXTERN_INLINE extern __inline__
+# endif
+# endif
+
+/* SCM_INLINE is a macro prepended to all public inline function
+ declarations. Implementations of those functions should also be in
+ the header file, prefixed by SCM_INLINE_IMPLEMENTATION, and protected
+ by SCM_CAN_INLINE and a CPP define for the C file in question, like
+ SCM_INLINE_C_INCLUDING_INLINE_H. See inline.h for an example
+ usage. */
+
+#if defined SCM_IMPLEMENT_INLINES
+/* Reifying functions to a file, whether or not inlining is available. */
+# define SCM_CAN_INLINE 0
+# define SCM_INLINE SCM_API
+# define SCM_INLINE_IMPLEMENTATION
+#elif defined SCM_C_INLINE
+/* Declarations when inlining is available. */
+# define SCM_CAN_INLINE 1
+# ifdef SCM_C_EXTERN_INLINE
+# define SCM_INLINE SCM_C_EXTERN_INLINE
+# else
+/* Fall back to static inline if GNU "extern inline" is unavailable. */
+# define SCM_INLINE static SCM_C_INLINE
+# endif
+# define SCM_INLINE_IMPLEMENTATION SCM_INLINE
+#else
+/* Declarations when inlining is not available. */
+# define SCM_CAN_INLINE 0
+# define SCM_INLINE SCM_API
+/* Don't define SCM_INLINE_IMPLEMENTATION; it should never be seen in
+ this case. */
+#endif
+
+
+
/* {Debugging Options}
*
* These compile time options determine whether to include code that is only
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 48fb2cc..5b4f3b7 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -190,6 +190,11 @@
#define scm_to_off64_t scm_to_int64
#define scm_from_off64_t scm_from_int64
+#if (defined __GNUC__)
+# define SCM_NOINLINE __attribute__ ((__noinline__))
+#else
+# define SCM_NOINLINE /* noinline */
+#endif
/* The endianness marker in objcode. */
#ifdef WORDS_BIGENDIAN
diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h
index 61c11eb..2e1fce2 100644
--- a/libguile/bdw-gc.h
+++ b/libguile/bdw-gc.h
@@ -1,7 +1,7 @@
#ifndef SCM_BDW_GC_H
#define SCM_BDW_GC_H
-/* Copyright (C) 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -46,12 +46,6 @@
# include <gc/gc_local_alloc.h>
#endif
-#if (defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7)
-/* This type was provided by `libgc' 6.x. */
-typedef void *GC_PTR;
-#endif
-
-
/* Return true if PTR points to the heap. */
#define SCM_I_IS_POINTER_TO_THE_HEAP(ptr) \
(GC_base (ptr) != NULL)
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index dc326f5..cf41f2f 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -31,7 +31,6 @@
#include "libguile/bytevectors.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
-#include "libguile/ieee-754.h"
#include "libguile/arrays.h"
#include "libguile/array-handle.h"
#include "libguile/uniform.h"
@@ -1567,6 +1566,18 @@ SCM_DEFINE (scm_bytevector_s64_native_set_x,
"bytevector-s64-native-set!",
Section 2.1 of R6RS-lib (in response to
http://www.r6rs.org/formal-comments/comment-187.txt). */
+union scm_ieee754_float
+{
+ float f;
+ scm_t_uint32 i;
+};
+
+union scm_ieee754_double
+{
+ double d;
+ scm_t_uint64 i;
+};
+
/* Convert to/from a floating-point number with different endianness. This
method is probably not the most efficient but it should be portable. */
@@ -1575,20 +1586,10 @@ static inline void
float_to_foreign_endianness (union scm_ieee754_float *target,
float source)
{
- union scm_ieee754_float src;
-
- src.f = source;
+ union scm_ieee754_float input;
-#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
+ input.f = source;
+ target->i = bswap_32 (input.i);
}
static inline float
@@ -1596,16 +1597,7 @@ 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
+ result.i = bswap_32 (source->i);
return (result.f);
}
@@ -1614,22 +1606,10 @@ static inline void
double_to_foreign_endianness (union scm_ieee754_double *target,
double source)
{
- union scm_ieee754_double src;
+ union scm_ieee754_double input;
- 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
+ input.d = source;
+ target->i = bswap_64 (input.i);
}
static inline double
@@ -1637,18 +1617,7 @@ 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
+ result.i = bswap_64 (source->i);
return (result.d);
}
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 530d2d4..f0211a5 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -2,7 +2,7 @@
deprecate something, move it here when that is feasible.
*/
-/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software
Foundation, Inc.
+/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012 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
@@ -2639,11 +2639,214 @@ scm_i_deprecated_asrtgo (scm_t_bits condition)
+
+/* scm_sym2var
+ *
+ * looks up the variable bound to SYM according to PROC. PROC should be
+ * a `eval closure' of some module.
+ *
+ * When no binding exists, and DEFINEP is true, create a new binding
+ * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
+ * false and no binding exists.
+ *
+ * When PROC is `#f', it is ignored and the binding is searched for in
+ * the scm_pre_modules_obarray (a `eq' hash table).
+ */
+
+SCM
+scm_sym2var (SCM sym, SCM proc, SCM definep)
+#define FUNC_NAME "scm_sym2var"
+{
+ SCM var;
+
+ if (scm_is_true (definep))
+ scm_c_issue_deprecation_warning
+ ("scm_sym2var is deprecated. Use scm_define or scm_module_define\n"
+ "to define variables. In some rare cases you may need\n"
+ "scm_module_ensure_local_variable.");
+ else
+ scm_c_issue_deprecation_warning
+ ("scm_sym2var is deprecated. Use scm_module_variable to look up\n"
+ "variables.");
+
+ if (SCM_NIMP (proc))
+ {
+ if (SCM_EVAL_CLOSURE_P (proc))
+ {
+ /* Bypass evaluator in the standard case. */
+ var = scm_eval_closure_lookup (proc, sym, definep);
+ }
+ else
+ var = scm_call_2 (proc, sym, definep);
+ }
+ else
+ {
+ if (scm_is_false (definep))
+ var = scm_module_variable (scm_the_root_module (), sym);
+ else
+ var = scm_module_ensure_local_variable (scm_the_root_module (), sym);
+ }
+
+ if (scm_is_true (var) && !SCM_VARIABLEP (var))
+ SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
+
+ return var;
+}
+#undef FUNC_NAME
+
+SCM
+scm_lookup_closure_module (SCM proc)
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ if (scm_is_false (proc))
+ return scm_the_root_module ();
+ else if (SCM_EVAL_CLOSURE_P (proc))
+ return SCM_PACK (SCM_SMOB_DATA (proc));
+ else
+ /* FIXME: The `module' property is no longer set on eval closures, as it
+ introduced a circular reference that precludes garbage collection of
+ modules with the current weak hash table semantics (see
+ http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and
+
http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
+ for details). Since it doesn't appear to be used (only in this
+ function, which has 1 caller), we no longer extend
+ `set-module-eval-closure!' to set the `module' property. */
+ abort ();
+}
+
+SCM
+scm_module_lookup_closure (SCM module)
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ if (scm_is_false (module))
+ return SCM_BOOL_F;
+ else
+ return SCM_MODULE_EVAL_CLOSURE (module);
+}
+
+SCM
+scm_current_module_lookup_closure ()
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ if (scm_module_system_booted_p)
+ return scm_module_lookup_closure (scm_current_module ());
+ else
+ return SCM_BOOL_F;
+}
+
+scm_t_bits scm_tc16_eval_closure;
+
+#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0)
+#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
+ (SCM_SMOB_FLAGS (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
+
+/* NOTE: This function may be called by a smob application
+ or from another C function directly. */
+SCM
+scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
+{
+ SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
+
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ if (scm_is_true (definep))
+ {
+ if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
+ return SCM_BOOL_F;
+ return scm_module_ensure_local_variable (module, sym);
+ }
+ else
+ return scm_module_variable (module, sym);
+}
+
+SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
+ (SCM module),
+ "Return an eval closure for the module @var{module}.")
+#define FUNC_NAME s_scm_standard_eval_closure
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_standard_interface_eval_closure,
+ "standard-interface-eval-closure", 1, 0, 0,
+ (SCM module),
+ "Return a interface eval closure for the module @var{module}. "
+ "Such a closure does not allow new bindings to be added.")
+#define FUNC_NAME s_scm_standard_interface_eval_closure
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ SCM_RETURN_NEWSMOB (scm_tc16_eval_closure |
(SCM_F_EVAL_CLOSURE_INTERFACE<<16),
+ SCM_UNPACK (module));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_eval_closure_module,
+ "eval-closure-module", 1, 0, 0,
+ (SCM eval_closure),
+ "Return the module associated with this eval closure.")
+/* the idea is that eval closures are really not the way to do things, they're
+ superfluous given our module system. this function lets mmacros migrate away
+ from eval closures. */
+#define FUNC_NAME s_scm_eval_closure_module
+{
+ scm_c_issue_deprecation_warning
+ ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
+ "the manual, for replacements.");
+
+ SCM_MAKE_VALIDATE_MSG (SCM_ARG1, eval_closure, EVAL_CLOSURE_P,
+ "eval-closure");
+ return SCM_SMOB_OBJECT (eval_closure);
+}
+#undef FUNC_NAME
+
+
+
+
+SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
+ (SCM handle),
+ "Return the vtable tag of the structure @var{handle}.")
+#define FUNC_NAME s_scm_struct_vtable_tag
+{
+ SCM_VALIDATE_VTABLE (1, handle);
+ scm_c_issue_deprecation_warning
+ ("struct-vtable-tag is deprecated. What were you doing with it anyway?");
+
+ return scm_from_unsigned_integer
+ (((scm_t_bits)SCM_STRUCT_DATA (handle)) >> 3);
+}
+#undef FUNC_NAME
+
+
+
+
void
scm_i_init_deprecated ()
{
properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
scm_struct_table = scm_make_hash_table (SCM_UNDEFINED);
+ scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
+ scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
+
#include "libguile/deprecated.x"
}
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 2b85bef..ae0891f 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -810,6 +810,35 @@ SCM_DEPRECATED scm_t_bits scm_i_deprecated_asrtgo
(scm_t_bits condition);
+/* Deprecated 23-05-2012, as as it's undocumented, poorly named, and
+ adequately replaced by scm_module_variable /
+ scm_ensure_module_variable / scm_define / scm_module_define. */
+SCM_DEPRECATED SCM scm_sym2var (SCM sym, SCM thunk, SCM definep);
+
+
+
+/* Eval closure deprecation, 23-05-2012. */
+#define SCM_TOP_LEVEL_LOOKUP_CLOSURE (scm_current_module_lookup_closure())
+
+SCM_DEPRECATED SCM scm_lookup_closure_module (SCM proc);
+SCM_DEPRECATED SCM scm_module_lookup_closure (SCM module);
+SCM_DEPRECATED SCM scm_current_module_lookup_closure (void);
+
+SCM_DEPRECATED scm_t_bits scm_tc16_eval_closure;
+
+#define SCM_EVAL_CLOSURE_P(x) SCM_TYP16_PREDICATE (scm_tc16_eval_closure, x)
+
+SCM_DEPRECATED SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep);
+SCM_DEPRECATED SCM scm_standard_eval_closure (SCM module);
+SCM_DEPRECATED SCM scm_standard_interface_eval_closure (SCM module);
+SCM_DEPRECATED SCM scm_eval_closure_module (SCM eval_closure);
+
+
+
+SCM_DEPRECATED SCM scm_struct_vtable_tag (SCM handle);
+
+
+
void scm_i_init_deprecated (void);
#endif
diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index 0822707..aa50eaf 100644
--- a/libguile/deprecation.c
+++ b/libguile/deprecation.c
@@ -34,12 +34,6 @@
#include "libguile/private-options.h"
-
-/* Windows defines. */
-#ifdef __MINGW32__
-#define vsnprintf _vsnprintf
-#endif
-
struct issued_warning {
diff --git a/libguile/eval.h b/libguile/eval.h
index 014f0de..9e5f654 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -3,7 +3,7 @@
#ifndef SCM_EVAL_H
#define SCM_EVAL_H
-/* Copyright (C)
1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011
+/* Copyright (C)
1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -57,10 +57,6 @@ typedef SCM (*scm_t_trampoline_2) (SCM proc, SCM arg1, SCM
arg2);
#define SCM_EXTEND_ENV scm_acons
-/*fixme* This should probably be removed throught the code. */
-
-#define SCM_TOP_LEVEL_LOOKUP_CLOSURE (scm_current_module_lookup_closure())
-
SCM_API SCM scm_call_0 (SCM proc);
diff --git a/libguile/expand.c b/libguile/expand.c
index bdecd80..cae5520 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -1,4 +1,4 @@
-/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+/* Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -49,9 +49,12 @@ static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
-#define VOID(src) \
+/* The trailing underscores on these first to are to avoid spurious
+ conflicts with macros defined on MinGW. */
+
+#define VOID_(src) \
SCM_MAKE_EXPANDED_VOID(src)
-#define CONST(src, exp) \
+#define CONST_(src, exp) \
SCM_MAKE_EXPANDED_CONST(src, exp)
#define PRIMITIVE_REF_TYPE(src, name) \
SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
@@ -375,7 +378,7 @@ expand (SCM exp, SCM env)
return TOPLEVEL_REF (SCM_BOOL_F, exp);
}
else
- return CONST (SCM_BOOL_F, exp);
+ return CONST_ (SCM_BOOL_F, exp);
}
static SCM
@@ -431,7 +434,7 @@ expand_and (SCM expr, SCM env)
const SCM cdr_expr = CDR (expr);
if (scm_is_null (cdr_expr))
- return CONST (SCM_BOOL_F, SCM_BOOL_T);
+ return CONST_ (SCM_BOOL_F, SCM_BOOL_T);
ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
@@ -441,7 +444,7 @@ expand_and (SCM expr, SCM env)
return CONDITIONAL (scm_source_properties (expr),
expand (CAR (cdr_expr), env),
expand_and (cdr_expr, env),
- CONST (SCM_BOOL_F, SCM_BOOL_F));
+ CONST_ (SCM_BOOL_F, SCM_BOOL_F));
}
static SCM
@@ -469,7 +472,7 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int
alp, SCM env)
}
if (scm_is_null (rest))
- rest = VOID (SCM_BOOL_F);
+ rest = VOID_ (SCM_BOOL_F);
else
rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
@@ -586,7 +589,7 @@ expand_eval_when (SCM expr, SCM env)
|| scm_is_true (scm_memq (sym_load, CADR (expr))))
return expand_sequence (CDDR (expr), env);
else
- return VOID (scm_source_properties (expr));
+ return VOID_ (scm_source_properties (expr));
}
static SCM
@@ -600,7 +603,7 @@ expand_if (SCM expr, SCM env SCM_UNUSED)
expand (CADDR (expr), env),
((length == 3)
? expand (CADDDR (expr), env)
- : VOID (SCM_BOOL_F)));
+ : VOID_ (SCM_BOOL_F)));
}
/* A helper function for expand_lambda to support checking for duplicate
@@ -789,7 +792,7 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (x, CAR (vars), env);
if (scm_is_symbol (x))
- inits = scm_cons (CONST (SCM_BOOL_F, SCM_BOOL_F), inits);
+ inits = scm_cons (CONST_ (SCM_BOOL_F, SCM_BOOL_F), inits);
else
{
ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
@@ -1109,7 +1112,7 @@ expand_or (SCM expr, SCM env SCM_UNUSED)
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
if (scm_is_null (CDR (expr)))
- return CONST (SCM_BOOL_F, SCM_BOOL_F);
+ return CONST_ (SCM_BOOL_F, SCM_BOOL_F);
else
{
SCM tmp = scm_gensym (SCM_UNDEFINED);
@@ -1133,7 +1136,7 @@ expand_quote (SCM expr, SCM env SCM_UNUSED)
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
quotee = CAR (cdr_expr);
- return CONST (scm_source_properties (expr), quotee);
+ return CONST_ (scm_source_properties (expr), quotee);
}
static SCM
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 0211010..9c39307 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -103,9 +103,7 @@
/* Some more definitions for the native Windows port. */
#ifdef __MINGW32__
-# define mkdir(path, mode) mkdir (path)
# define fsync(fd) _commit (fd)
-# define fchmod(fd, mode) (-1)
#endif /* __MINGW32__ */
@@ -1336,12 +1334,13 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
#define FUNC_NAME s_scm_chmod
{
int rv;
- int fdes;
object = SCM_COERCE_OUTPORT (object);
+#if HAVE_FCHMOD
if (scm_is_integer (object) || SCM_OPFPORTP (object))
{
+ int fdes;
if (scm_is_integer (object))
fdes = scm_to_int (object);
else
@@ -1349,6 +1348,7 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
}
else
+#endif
{
STRING_SYSCALL (object, c_object,
rv = chmod (c_object, scm_to_int (mode)));
@@ -1587,32 +1587,40 @@ scm_i_relativize_path (SCM path, SCM in_path)
scanon = scm_take_locale_string (canon);
for (; scm_is_pair (in_path); in_path = scm_cdr (in_path))
- if (scm_is_true (scm_string_prefix_p (scm_car (in_path),
- scanon,
- SCM_UNDEFINED, SCM_UNDEFINED,
- SCM_UNDEFINED, SCM_UNDEFINED)))
- {
- size_t len = scm_c_string_length (scm_car (in_path));
-
- /* The path either has a trailing delimiter or doesn't. scanon will be
- delimited by single delimiters. In the case in which the path does
- not have a trailing delimiter, add one to the length to strip off
the
- delimiter within scanon. */
- if (!len
+ {
+ SCM dir = scm_car (in_path);
+ size_t len = scm_c_string_length (dir);
+
+ /* When DIR is empty, it means "current working directory". We
+ could set DIR to (getcwd) in that case, but then the
+ canonicalization would depend on the current directory, which
+ is not what we want in the context of `compile-file', for
+ instance. */
+ if (len > 0
+ && scm_is_true (scm_string_prefix_p (dir, scanon,
+ SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED, SCM_UNDEFINED)))
+ {
+ /* DIR either has a trailing delimiter or doesn't. SCANON
+ will be delimited by single delimiters. When DIR does not
+ have a trailing delimiter, add one to the length to strip
+ off the delimiter within SCANON. */
+ if (
#ifdef __MINGW32__
- || (scm_i_string_ref (scm_car (in_path), len - 1) != '/'
- && scm_i_string_ref (scm_car (in_path), len - 1) != '\\')
+ (scm_i_string_ref (dir, len - 1) != '/'
+ && scm_i_string_ref (dir, len - 1) != '\\')
#else
- || scm_i_string_ref (scm_car (in_path), len - 1) != '/'
+ scm_i_string_ref (dir, len - 1) != '/'
#endif
- )
- len++;
+ )
+ len++;
- if (scm_c_string_length (scanon) > len)
- return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
- else
- return SCM_BOOL_F;
- }
+ if (scm_c_string_length (scanon) > len)
+ return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
+ else
+ return SCM_BOOL_F;
+ }
+ }
return SCM_BOOL_F;
}
diff --git a/libguile/finalizers.c b/libguile/finalizers.c
new file mode 100644
index 0000000..a179479
--- /dev/null
+++ b/libguile/finalizers.c
@@ -0,0 +1,182 @@
+/* Copyright (C) 2012 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/bdw-gc.h"
+#include "libguile/_scm.h"
+#include "libguile/finalizers.h"
+#include "libguile/gc.h"
+#include "libguile/threads.h"
+
+
+
+static size_t finalization_count;
+
+
+
+
+void
+scm_i_set_finalizer (void *obj, scm_t_finalizer_proc proc, void *data)
+{
+ GC_finalization_proc prev;
+ void *prev_data;
+ GC_REGISTER_FINALIZER_NO_ORDER (obj, proc, data, &prev, &prev_data);
+}
+
+struct scm_t_chained_finalizer
+{
+ int resuscitating_p;
+ scm_t_finalizer_proc proc;
+ void *data;
+ scm_t_finalizer_proc prev;
+ void *prev_data;
+};
+
+static void
+chained_finalizer (void *obj, void *data)
+{
+ struct scm_t_chained_finalizer *chained_data = data;
+ if (chained_data->resuscitating_p)
+ {
+ if (chained_data->prev)
+ scm_i_set_finalizer (obj, chained_data->prev, chained_data->prev_data);
+ chained_data->proc (obj, chained_data->data);
+ }
+ else
+ {
+ chained_data->proc (obj, chained_data->data);
+ if (chained_data->prev)
+ chained_data->prev (obj, chained_data->prev_data);
+ }
+}
+
+void
+scm_i_add_resuscitator (void *obj, scm_t_finalizer_proc proc, void *data)
+{
+ struct scm_t_chained_finalizer *chained_data;
+ chained_data = scm_gc_malloc (sizeof (*chained_data), "chained finalizer");
+ chained_data->resuscitating_p = 1;
+ chained_data->proc = proc;
+ chained_data->data = data;
+ GC_REGISTER_FINALIZER_NO_ORDER (obj, chained_finalizer, chained_data,
+ &chained_data->prev,
+ &chained_data->prev_data);
+}
+
+static void
+shuffle_resuscitators_to_front (struct scm_t_chained_finalizer *cd)
+{
+ while (cd->prev == chained_finalizer)
+ {
+ struct scm_t_chained_finalizer *prev = cd->prev_data;
+ scm_t_finalizer_proc proc = cd->proc;
+ void *data = cd->data;
+
+ if (!prev->resuscitating_p)
+ break;
+
+ cd->resuscitating_p = 1;
+ cd->proc = prev->proc;
+ cd->data = prev->data;
+
+ prev->resuscitating_p = 0;
+ prev->proc = proc;
+ prev->data = data;
+
+ cd = prev;
+ }
+}
+
+void
+scm_i_add_finalizer (void *obj, scm_t_finalizer_proc proc, void *data)
+{
+ struct scm_t_chained_finalizer *chained_data;
+ chained_data = scm_gc_malloc (sizeof (*chained_data), "chained finalizer");
+ chained_data->resuscitating_p = 0;
+ chained_data->proc = proc;
+ chained_data->data = data;
+ GC_REGISTER_FINALIZER_NO_ORDER (obj, chained_finalizer, chained_data,
+ &chained_data->prev,
+ &chained_data->prev_data);
+ shuffle_resuscitators_to_front (chained_data);
+}
+
+
+
+
+static SCM finalizer_async_cell;
+
+static SCM
+run_finalizers_async_thunk (void)
+{
+ finalization_count += GC_invoke_finalizers ();
+ return SCM_UNSPECIFIED;
+}
+
+
+/* The function queue_finalizer_async is run by the GC when there are
+ * objects to finalize. It will enqueue an asynchronous call to
+ * GC_invoke_finalizers() at the next SCM_TICK in this thread.
+ */
+static void
+queue_finalizer_async (void)
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ static scm_i_pthread_mutex_t lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+ scm_i_pthread_mutex_lock (&lock);
+ /* If t is NULL, that could be because we're allocating in
+ threads.c:guilify_self_1. In that case, rely on the
+ GC_invoke_finalizers call there after the thread spins up. */
+ if (t && scm_is_false (SCM_CDR (finalizer_async_cell)))
+ {
+ SCM_SETCDR (finalizer_async_cell, t->active_asyncs);
+ t->active_asyncs = finalizer_async_cell;
+ t->pending_asyncs = 1;
+ }
+ scm_i_pthread_mutex_unlock (&lock);
+}
+
+
+
+
+#ifndef HAVE_GC_SET_FINALIZER_NOTIFIER
+static void
+GC_set_finalizer_notifier (void (*notifier) (void))
+{
+ GC_finalizer_notifier = notifier;
+}
+#endif
+
+void
+scm_init_finalizers (void)
+{
+ /* When the async is to run, the cdr of the pair gets set to the
+ asyncs queue of the current thread. */
+ finalizer_async_cell =
+ scm_cons (scm_c_make_gsubr ("%run-finalizers", 0, 0, 0,
+ run_finalizers_async_thunk),
+ SCM_BOOL_F);
+ GC_set_finalizer_notifier (queue_finalizer_async);
+}
diff --git a/libguile/debug-malloc.h b/libguile/finalizers.h
similarity index 55%
copy from libguile/debug-malloc.h
copy to libguile/finalizers.h
index 7830adb..bad96e1 100644
--- a/libguile/debug-malloc.h
+++ b/libguile/finalizers.h
@@ -1,9 +1,7 @@
-/* classes: h_files */
+#ifndef SCM_FINALIZERS_H
+#define SCM_FINALIZERS_H
-#ifndef SCM_DEBUG_MALLOC_H
-#define SCM_DEBUG_MALLOC_H
-
-/* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -27,19 +25,15 @@
-SCM_API void scm_malloc_register (void *obj, const char *what);
-SCM_API void scm_malloc_unregister (void *obj);
-SCM_API void scm_malloc_reregister (void *obj, void *new, const char *what);
-
-SCM_API SCM scm_malloc_stats (void);
+typedef void (*scm_t_finalizer_proc) (void *obj, void *data);
-SCM_INTERNAL void scm_debug_malloc_prehistory (void);
-SCM_INTERNAL void scm_init_debug_malloc (void);
+SCM_INTERNAL void scm_i_set_finalizer (void *obj, scm_t_finalizer_proc,
+ void *data);
+SCM_INTERNAL void scm_i_add_finalizer (void *obj, scm_t_finalizer_proc,
+ void *data);
+SCM_INTERNAL void scm_i_add_resuscitator (void *obj, scm_t_finalizer_proc,
+ void *data);
-#endif /* SCM_DEBUG_MALLOC_H */
+SCM_INTERNAL void scm_init_finalizers (void);
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+#endif /* SCM_FINALIZERS_H */
diff --git a/libguile/foreign.c b/libguile/foreign.c
index b3d1cc6..320e20d 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -99,7 +99,7 @@ register_weak_reference (SCM from, SCM to)
}
static void
-pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
+pointer_finalizer_trampoline (void *ptr, void *data)
{
scm_t_pointer_finalizer finalizer = data;
finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
@@ -160,16 +160,8 @@ scm_from_pointer (void *ptr, scm_t_pointer_finalizer
finalizer)
ret = scm_cell (scm_tc7_pointer, (scm_t_bits) ptr);
if (finalizer)
- {
- /* Register a finalizer for the newly created instance. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
- pointer_finalizer_trampoline,
- finalizer,
- &prev_finalizer,
- &prev_finalizer_data);
- }
+ scm_i_set_finalizer (SCM2PTR (ret), pointer_finalizer_trampoline,
+ finalizer);
}
return ret;
@@ -319,20 +311,11 @@ SCM_DEFINE (scm_set_pointer_finalizer_x,
"set-pointer-finalizer!", 2, 0, 0,
"Scheme. If you need a Scheme finalizer, use guardians.")
#define FUNC_NAME s_scm_set_pointer_finalizer_x
{
- void *c_finalizer;
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
-
SCM_VALIDATE_POINTER (1, pointer);
SCM_VALIDATE_POINTER (2, finalizer);
- c_finalizer = SCM_POINTER_VALUE (finalizer);
-
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
- pointer_finalizer_trampoline,
- c_finalizer,
- &prev_finalizer,
- &prev_finalizer_data);
+ scm_i_add_finalizer (SCM2PTR (pointer), pointer_finalizer_trampoline,
+ SCM_POINTER_VALUE (finalizer));
return SCM_UNSPECIFIED;
}
@@ -392,7 +375,7 @@ SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 1,
0,
ret = scm_from_pointer
(scm_to_stringn (string, NULL, enc,
- scm_i_get_conversion_strategy (SCM_BOOL_F)),
+ scm_i_default_port_conversion_handler ()),
free);
scm_dynwind_end ();
@@ -437,7 +420,7 @@ SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 2,
0,
scm_dynwind_free (enc);
ret = scm_from_stringn (SCM_POINTER_VALUE (pointer), len, enc,
- scm_i_get_conversion_strategy (SCM_BOOL_F));
+ scm_i_default_port_conversion_handler ());
scm_dynwind_end ();
diff --git a/libguile/fports.c b/libguile/fports.c
index 3ac3ced..10cf671 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 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
@@ -174,7 +174,8 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
{
int cmode;
long csize;
- SCM drained;
+ size_t ndrained;
+ char *drained;
scm_t_port *pt;
port = SCM_COERCE_OUTPORT (port);
@@ -211,9 +212,21 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
pt = SCM_PTAB_ENTRY (port);
if (SCM_INPUT_PORT_P (port))
- drained = scm_drain_input (port);
+ {
+ /* Drain pending input from PORT. Don't use `scm_drain_input' since
+ it returns a string, whereas we want binary input here. */
+ ndrained = pt->read_end - pt->read_pos;
+ if (pt->read_buf == pt->putback_buf)
+ ndrained += pt->saved_read_end - pt->saved_read_pos;
+
+ if (ndrained > 0)
+ {
+ drained = scm_gc_malloc_pointerless (ndrained, "file port");
+ scm_take_from_input_buffers (port, drained, ndrained);
+ }
+ }
else
- drained = scm_nullstr;
+ ndrained = 0;
if (SCM_OUTPUT_PORT_P (port))
scm_flush (port);
@@ -232,8 +245,10 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
scm_fport_buffer_add (port, csize, csize);
- if (scm_is_true (drained) && scm_c_string_length (drained))
- scm_unread_string (drained, port);
+ if (ndrained > 0)
+ /* Put DRAINED back to PORT. */
+ while (ndrained-- > 0)
+ scm_unget_byte (drained[ndrained], port);
return SCM_UNSPECIFIED;
}
diff --git a/libguile/frames.c b/libguile/frames.c
index c7505b2..a7143c4 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -104,11 +104,18 @@ SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_source
{
+ SCM proc;
+
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_program_source (scm_frame_procedure (frame),
- scm_frame_instruction_pointer (frame),
- SCM_UNDEFINED);
+ proc = scm_frame_procedure (frame);
+
+ if (SCM_PROGRAM_P (proc))
+ return scm_program_source (scm_frame_procedure (frame),
+ scm_frame_instruction_pointer (frame),
+ SCM_UNDEFINED);
+
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -237,11 +244,16 @@ SCM_DEFINE (scm_frame_instruction_pointer,
"frame-instruction-pointer", 1, 0, 0,
"")
#define FUNC_NAME s_scm_frame_instruction_pointer
{
+ SCM program;
const struct scm_objcode *c_objcode;
SCM_VALIDATE_VM_FRAME (1, frame);
+ program = scm_frame_procedure (frame);
- c_objcode = SCM_PROGRAM_DATA (scm_frame_procedure (frame));
+ if (!SCM_PROGRAM_P (program))
+ return SCM_INUM0;
+
+ c_objcode = SCM_PROGRAM_DATA (program);
return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame)
- SCM_C_OBJCODE_BASE (c_objcode)));
}
@@ -291,6 +303,7 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
#define FUNC_NAME s_scm_frame_previous
{
SCM *this_fp, *new_fp, *new_sp;
+ SCM proc;
SCM_VALIDATE_VM_FRAME (1, frame);
@@ -298,13 +311,16 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
this_fp = SCM_VM_FRAME_FP (frame);
new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
if (new_fp)
- { new_fp = RELOC (frame, new_fp);
+ {
+ new_fp = RELOC (frame, new_fp);
new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
frame = scm_c_make_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
new_fp, new_sp,
SCM_FRAME_RETURN_ADDRESS (this_fp),
SCM_VM_FRAME_OFFSET (frame));
- if (SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
+ proc = scm_frame_procedure (frame);
+
+ if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
goto again;
else
return frame;
diff --git a/libguile/gc.c b/libguile/gc.c
index fd37046..06b5044 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010, 2011, 2012 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
@@ -391,6 +391,9 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
#define FUNC_NAME s_scm_gc
{
scm_i_gc ("call");
+ /* If you're calling scm_gc(), you probably want synchronous
+ finalization. */
+ GC_invoke_finalizers ();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -615,6 +618,14 @@ scm_getenv_int (const char *var, int def)
return res;
}
+#ifndef HAVE_GC_SET_FINALIZE_ON_DEMAND
+static void
+GC_set_finalize_on_demand (int foo)
+{
+ GC_finalize_on_demand = foo;
+}
+#endif
+
void
scm_storage_prehistory ()
{
@@ -623,6 +634,7 @@ scm_storage_prehistory ()
minimum_free_space_divisor = free_space_divisor;
target_free_space_divisor = free_space_divisor;
GC_set_free_space_divisor (free_space_divisor);
+ GC_set_finalize_on_demand (1);
GC_INIT ();
diff --git a/libguile/gc.h b/libguile/gc.h
index 310569d..9f00e01 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -207,6 +207,114 @@ SCM_API char *scm_gc_strdup (const char *str, const char
*what)
SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what)
SCM_MALLOC;
+
+#ifdef BUILDING_LIBGUILE
+#include "libguile/bdw-gc.h"
+#define SCM_GC_MALLOC(size) GC_MALLOC (size)
+#define SCM_GC_MALLOC_POINTERLESS(size) GC_MALLOC_ATOMIC (size)
+#else
+#define SCM_GC_MALLOC(size) scm_gc_malloc (size, NULL)
+#define SCM_GC_MALLOC_POINTERLESS(size) scm_gc_malloc_pointerless (size, NULL)
+#endif
+
+
+SCM_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_INLINE SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr);
+SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint16 n_words);
+
+#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_cell (scm_t_bits car, scm_t_bits cdr)
+{
+ SCM cell = PTR2SCM (SCM_GC_MALLOC (sizeof (scm_t_cell)));
+
+ /* Initialize the type slot last so that the cell is ignored by the GC
+ until it is completely initialized. This is only relevant when the GC
+ can actually run during this code, which it can't since the GC only runs
+ when all other threads are stopped. */
+ SCM_GC_SET_CELL_WORD (cell, 1, cdr);
+ SCM_GC_SET_CELL_WORD (cell, 0, car);
+
+ return cell;
+}
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr)
+{
+ SCM z;
+
+ z = PTR2SCM (SCM_GC_MALLOC (2 * sizeof (scm_t_cell)));
+ /* Initialize the type slot last so that the cell is ignored by the
+ GC until it is completely initialized. This is only relevant
+ when the GC can actually run during this code, which it can't
+ since the GC only runs when all other threads are stopped.
+ */
+ SCM_GC_SET_CELL_WORD (z, 1, cbr);
+ SCM_GC_SET_CELL_WORD (z, 2, ccr);
+ SCM_GC_SET_CELL_WORD (z, 3, cdr);
+ SCM_GC_SET_CELL_WORD (z, 0, car);
+
+ /* When this function is inlined, it's possible that the last
+ SCM_GC_SET_CELL_WORD above will be adjacent to a following
+ initialization of z. E.g., it occurred in scm_make_real. GCC
+ from around version 3 (e.g., certainly 3.2) began taking
+ advantage of strict C aliasing rules which say that it's OK to
+ interchange the initialization above and the one below when the
+ pointer types appear to differ sufficiently. We don't want that,
+ of course. GCC allows this behaviour to be disabled with the
+ -fno-strict-aliasing option, but would also need to be supplied
+ by Guile users. Instead, the following statements prevent the
+ reordering.
+ */
+#ifdef __GNUC__
+ __asm__ volatile ("" : : : "memory");
+#else
+ /* portable version, just in case any other compiler does the same
+ thing. */
+ scm_remember_upto_here_1 (z);
+#endif
+
+ return z;
+}
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_words (scm_t_bits car, scm_t_uint16 n_words)
+{
+ SCM z;
+
+ z = PTR2SCM (SCM_GC_MALLOC (sizeof (scm_t_bits) * n_words));
+ SCM_GC_SET_CELL_WORD (z, 0, car);
+
+ /* FIXME: is the following concern even relevant with BDW-GC? */
+
+ /* When this function is inlined, it's possible that the last
+ SCM_GC_SET_CELL_WORD above will be adjacent to a following
+ initialization of z. E.g., it occurred in scm_make_real. GCC
+ from around version 3 (e.g., certainly 3.2) began taking
+ advantage of strict C aliasing rules which say that it's OK to
+ interchange the initialization above and the one below when the
+ pointer types appear to differ sufficiently. We don't want that,
+ of course. GCC allows this behaviour to be disabled with the
+ -fno-strict-aliasing option, but would also need to be supplied
+ by Guile users. Instead, the following statements prevent the
+ reordering.
+ */
+#ifdef __GNUC__
+ __asm__ volatile ("" : : : "memory");
+#else
+ /* portable version, just in case any other compiler does the same
+ thing. */
+ scm_remember_upto_here_1 (z);
+#endif
+
+ return z;
+}
+
+#endif /* SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES */
+
SCM_API void scm_remember_upto_here_1 (SCM obj);
SCM_API void scm_remember_upto_here_2 (SCM obj1, SCM obj2);
SCM_API void scm_remember_upto_here (SCM obj1, ...);
diff --git a/libguile/gdbint.c b/libguile/gdbint.c
index 77fdbd1..7a0ebc9 100644
--- a/libguile/gdbint.c
+++ b/libguile/gdbint.c
@@ -1,5 +1,5 @@
/* GDB interface for Guile
- * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009,2011
+ * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009,2011,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -234,8 +234,7 @@ gdb_binding (SCM name, SCM value)
}
SCM_BEGIN_FOREIGN_BLOCK;
{
- SCM var = scm_sym2var (name, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_T);
- SCM_VARIABLE_SET (var, value);
+ scm_define (name, value);
}
SCM_END_FOREIGN_BLOCK;
return 0;
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index 176f25c..77ab94f 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -149,18 +149,17 @@ main (int argc, char *argv[])
pf ("/* limits.h not available */\n");
#endif
-# ifdef TIME_WITH_SYS_TIME
+#if HAVE_SYS_TIME_H
pf ("#include <sys/time.h>\n");
+#else
+ pf ("/* sys/time.h not available */\n");
+#endif
+
+#if HAVE_TIME_H
pf ("#include <time.h>\n");
-# else
-# ifdef HAVE_SYS_TIME_H
- pf ("#include <sys/time.h>\n");
-# else
-# ifdef HAVE_TIME_H
- pf ("#include <time.h>\n");
-# endif
-# endif
-# endif
+#else
+ pf ("/* time.h not available */\n");
+#endif
pf("\n");
#ifdef STDC_HEADERS
diff --git a/libguile/goops.c b/libguile/goops.c
index 2f9cf30..f4b2b34 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -2765,13 +2765,21 @@ SCM_KEYWORD (k_getter, "getter");
SCM
scm_ensure_accessor (SCM name)
{
- SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F);
+ SCM var, gf;
+
+ var = scm_module_variable (scm_current_module (), name);
+ if (SCM_VARIABLEP (var) && !SCM_UNBNDP (SCM_VARIABLE_REF (var)))
+ gf = SCM_VARIABLE_REF (var);
+ else
+ gf = SCM_BOOL_F;
+
if (!SCM_IS_A_P (gf, scm_class_accessor))
{
gf = scm_make (scm_list_3 (scm_class_generic, k_name, name));
gf = scm_make (scm_list_5 (scm_class_accessor,
k_name, name, k_setter, gf));
}
+
return gf;
}
diff --git a/libguile/guardians.c b/libguile/guardians.c
index 81313df..022f54e 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011 Free Software
Foundation, Inc.
- *
+/* Copyright (C) 1998,1999,2000,2001, 2006, 2008, 2009, 2011,
+ * 2012 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -104,7 +105,7 @@ guardian_print (SCM guardian, SCM port, scm_print_state
*pstate SCM_UNUSED)
/* Handle finalization of OBJ which is guarded by the guardians listed in
GUARDIAN_LIST. */
static void
-finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
+finalize_guarded (void *ptr, void *finalizer_data)
{
SCM cell_pool;
SCM obj, guardian_list, proxied_finalizer;
@@ -164,7 +165,7 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
/* Re-register the finalizer that was in place before we installed this
one. */
GC_finalization_proc finalizer, prev_finalizer;
- GC_PTR finalizer_data, prev_finalizer_data;
+ void *finalizer_data, *prev_finalizer_data;
finalizer = (GC_finalization_proc) SCM2PTR (SCM_CAR (proxied_finalizer));
finalizer_data = SCM2PTR (SCM_CDR (proxied_finalizer));
@@ -204,7 +205,7 @@ scm_i_guard (SCM guardian, SCM obj)
the very beginning of an object's lifetime (e.g., see `SCM_NEWSMOB')
or by this function. */
GC_finalization_proc prev_finalizer;
- GC_PTR prev_data;
+ void *prev_data;
SCM guardians_for_obj, finalizer_data;
g->live++;
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index fe718b9..0abc7dc 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -814,10 +814,10 @@ scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
SCM_SETCDR (pair, val);
if (SCM_NIMP (prev) && !SCM_NIMP (val))
- GC_unregister_disappearing_link ((GC_PTR) SCM_CDRLOC (pair));
+ GC_unregister_disappearing_link ((void **) SCM_CDRLOC (pair));
else
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) SCM_CDRLOC (pair),
- (GC_PTR) SCM2PTR (val));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) SCM_CDRLOC (pair),
+ SCM2PTR (val));
}
else
SCM_SETCDR (pair, val);
diff --git a/libguile/ieee-754.h b/libguile/ieee-754.h
deleted file mode 100644
index e345efa..0000000
--- a/libguile/ieee-754.h
+++ /dev/null
@@ -1,90 +0,0 @@
-/* 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/init.c b/libguile/init.c
index f171950..17791e2 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -59,6 +59,7 @@
#include "libguile/expand.h"
#include "libguile/feature.h"
#include "libguile/filesys.h"
+#include "libguile/finalizers.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
#include "libguile/frames.h"
@@ -423,6 +424,7 @@ scm_i_init_guile (void *base)
scm_init_dynwind (); /* requires smob_prehistory */
scm_init_eq ();
scm_init_error ();
+ scm_init_finalizers ();
scm_init_fluids ();
scm_init_control (); /* requires fluids */
scm_init_feature ();
@@ -444,7 +446,8 @@ scm_i_init_guile (void *base)
scm_init_ioext ();
scm_init_keywords (); /* Requires smob_prehistory */
scm_init_list ();
- scm_init_macros (); /* Requires smob_prehistory */
+ scm_init_random (); /* Requires smob_prehistory */
+ scm_init_macros (); /* Requires smob_prehistory and random */
scm_init_mallocs (); /* Requires smob_prehistory */
scm_init_modules (); /* Requires smob_prehistory */
scm_init_numbers ();
@@ -500,7 +503,6 @@ scm_i_init_guile (void *base)
scm_init_eval_in_scheme ();
scm_init_evalext ();
scm_init_debug (); /* Requires macro smobs */
- scm_init_random (); /* Requires smob_prehistory */
scm_init_simpos ();
#if HAVE_MODULES
scm_init_dynamic_linking (); /* Requires smob_prehistory */
diff --git a/libguile/inline.c b/libguile/inline.c
index 79728ff..be7670a 100644
--- a/libguile/inline.c
+++ b/libguile/inline.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2008, 2011 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
@@ -20,5 +20,8 @@
# include <config.h>
#endif
-#define SCM_INLINE_C_INCLUDING_INLINE_H 1
+#define SCM_IMPLEMENT_INLINES 1
+#define SCM_INLINE_C_IMPLEMENTING_INLINES 1
#include "libguile/inline.h"
+#include "libguile/gc.h"
+#include "libguile/smob.h"
diff --git a/libguile/inline.h b/libguile/inline.h
index a78cac5..6b1cf5e 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -23,9 +23,9 @@
*/
/* This file is for inline functions. On platforms that don't support
- inlining functions, they are turned into ordinary functions. See
- "inline.c".
-*/
+ inlining functions, they are turned into ordinary functions. On
+ platforms that do support inline functions, the definitions are still
+ compiled into the library, once, in inline.c. */
#include <stdio.h>
#include <string.h>
@@ -41,174 +41,27 @@
#include "libguile/error.h"
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_INLINE SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
+SCM_INLINE void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM
val);
-/* GCC has `__inline__' in all modes, including strict ansi. GCC 4.3 and
- above with `-std=c99' or `-std=gnu99' implements ISO C99 inline semantics,
- unless `-fgnu89-inline' is used. Here we want GNU "extern inline"
- semantics, hence the `__gnu_inline__' attribute, in accordance with:
- http://gcc.gnu.org/gcc-4.3/porting_to.html .
+SCM_INLINE int scm_is_pair (SCM x);
+SCM_INLINE int scm_is_string (SCM x);
- With GCC 4.2, `__GNUC_STDC_INLINE__' is never defined (because C99 inline
- semantics are not supported), but a warning is issued in C99 mode if
- `__gnu_inline__' is not used.
+SCM_INLINE int scm_get_byte_or_eof (SCM port);
+SCM_INLINE int scm_peek_byte_or_eof (SCM port);
+SCM_INLINE void scm_putc (char c, SCM port);
+SCM_INLINE void scm_puts (const char *str_data, SCM port);
- Apple's GCC build >5400 (since Xcode 3.0) doesn't support GNU inline in
- C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static
- inline" in that case. */
-# if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ >
5400)) && __STDC_VERSION__ >= 199901L))
-# define SCM_C_USE_EXTERN_INLINE 1
-# if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
-# define SCM_C_EXTERN_INLINE \
- extern __inline__ __attribute__ ((__gnu_inline__))
-# else
-# define SCM_C_EXTERN_INLINE extern __inline__
-# endif
-# elif (defined SCM_C_INLINE)
-# define SCM_C_EXTERN_INLINE static SCM_C_INLINE
-# endif
-
-#endif /* SCM_INLINE_C_INCLUDING_INLINE_H */
-
-
-#if (!defined SCM_C_INLINE) || (defined SCM_INLINE_C_INCLUDING_INLINE_H) \
- || (defined SCM_C_USE_EXTERN_INLINE)
-
-/* The `extern' declarations. They should only appear when used from
- "inline.c", when `inline' is not supported at all or when "extern inline"
- is used. */
-
-#include "libguile/bdw-gc.h"
-
-
-SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
-SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+SCM_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_INLINE SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
scm_t_bits ccr, scm_t_bits cdr);
-SCM_API SCM scm_words (scm_t_bits car, scm_t_uint16 n_words);
-
-SCM_API SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
-SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM
val);
-
-SCM_API int scm_is_pair (SCM x);
-SCM_API int scm_is_string (SCM x);
-
-SCM_API int scm_get_byte_or_eof (SCM port);
-SCM_API int scm_peek_byte_or_eof (SCM port);
-SCM_API void scm_putc (char c, SCM port);
-SCM_API void scm_puts (const char *str_data, SCM port);
-
-#endif
-
-
-#if defined SCM_C_EXTERN_INLINE || defined SCM_INLINE_C_INCLUDING_INLINE_H
-/* either inlining, or being included from inline.c. We use (and
- repeat) this long #if test here and below so that we don't have to
- introduce any extraneous symbols into the public namespace. We
- only need SCM_C_INLINE to be seen publically . */
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-
-SCM
-scm_cell (scm_t_bits car, scm_t_bits cdr)
-{
- SCM cell = PTR2SCM (GC_MALLOC (sizeof (scm_t_cell)));
-
- /* Initialize the type slot last so that the cell is ignored by the GC
- until it is completely initialized. This is only relevant when the GC
- can actually run during this code, which it can't since the GC only runs
- when all other threads are stopped. */
- SCM_GC_SET_CELL_WORD (cell, 1, cdr);
- SCM_GC_SET_CELL_WORD (cell, 0, car);
-
- return cell;
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-SCM
-scm_double_cell (scm_t_bits car, scm_t_bits cbr,
- scm_t_bits ccr, scm_t_bits cdr)
-{
- SCM z;
-
- z = PTR2SCM (GC_MALLOC (2 * sizeof (scm_t_cell)));
- /* Initialize the type slot last so that the cell is ignored by the
- GC until it is completely initialized. This is only relevant
- when the GC can actually run during this code, which it can't
- since the GC only runs when all other threads are stopped.
- */
- SCM_GC_SET_CELL_WORD (z, 1, cbr);
- SCM_GC_SET_CELL_WORD (z, 2, ccr);
- SCM_GC_SET_CELL_WORD (z, 3, cdr);
- SCM_GC_SET_CELL_WORD (z, 0, car);
-
- /* When this function is inlined, it's possible that the last
- SCM_GC_SET_CELL_WORD above will be adjacent to a following
- initialization of z. E.g., it occurred in scm_make_real. GCC
- from around version 3 (e.g., certainly 3.2) began taking
- advantage of strict C aliasing rules which say that it's OK to
- interchange the initialization above and the one below when the
- pointer types appear to differ sufficiently. We don't want that,
- of course. GCC allows this behaviour to be disabled with the
- -fno-strict-aliasing option, but would also need to be supplied
- by Guile users. Instead, the following statements prevent the
- reordering.
- */
-#ifdef __GNUC__
- __asm__ volatile ("" : : : "memory");
-#else
- /* portable version, just in case any other compiler does the same
- thing. */
- scm_remember_upto_here_1 (z);
-#endif
-
- return z;
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-SCM
-scm_words (scm_t_bits car, scm_t_uint16 n_words)
-{
- SCM z;
-
- z = PTR2SCM (GC_MALLOC (sizeof (scm_t_bits) * n_words));
- SCM_GC_SET_CELL_WORD (z, 0, car);
-
- /* FIXME: is the following concern even relevant with BDW-GC? */
-
- /* When this function is inlined, it's possible that the last
- SCM_GC_SET_CELL_WORD above will be adjacent to a following
- initialization of z. E.g., it occurred in scm_make_real. GCC
- from around version 3 (e.g., certainly 3.2) began taking
- advantage of strict C aliasing rules which say that it's OK to
- interchange the initialization above and the one below when the
- pointer types appear to differ sufficiently. We don't want that,
- of course. GCC allows this behaviour to be disabled with the
- -fno-strict-aliasing option, but would also need to be supplied
- by Guile users. Instead, the following statements prevent the
- reordering.
- */
-#ifdef __GNUC__
- __asm__ volatile ("" : : : "memory");
-#else
- /* portable version, just in case any other compiler does the same
- thing. */
- scm_remember_upto_here_1 (z);
-#endif
+SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint16 n_words);
- return z;
-}
+#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
+/* Either inlining, or being included from inline.c. */
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-SCM
+SCM_INLINE_IMPLEMENTATION SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
{
if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
@@ -218,10 +71,7 @@ scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
return h->impl->vref (h, h->base + p);
}
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-void
+SCM_INLINE_IMPLEMENTATION void
scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
{
if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
@@ -231,10 +81,7 @@ scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM
v)
h->impl->vset (h, h->base + p, v);
}
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
+SCM_INLINE_IMPLEMENTATION int
scm_is_pair (SCM x)
{
/* The following "workaround_for_gcc_295" avoids bad code generated by
@@ -261,10 +108,7 @@ scm_is_pair (SCM x)
return SCM_I_CONSP (x);
}
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
+SCM_INLINE_IMPLEMENTATION int
scm_is_string (SCM x)
{
return SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string);
@@ -272,10 +116,7 @@ scm_is_string (SCM x)
/* Port I/O. */
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
+SCM_INLINE_IMPLEMENTATION int
scm_get_byte_or_eof (SCM port)
{
int c;
@@ -300,10 +141,7 @@ scm_get_byte_or_eof (SCM port)
}
/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
+SCM_INLINE_IMPLEMENTATION int
scm_peek_byte_or_eof (SCM port)
{
int c;
@@ -327,20 +165,14 @@ scm_peek_byte_or_eof (SCM port)
return c;
}
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-void
+SCM_INLINE_IMPLEMENTATION void
scm_putc (char c, SCM port)
{
SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
scm_lfwrite (&c, 1, port);
}
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-void
+SCM_INLINE_IMPLEMENTATION void
scm_puts (const char *s, SCM port)
{
SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
diff --git a/libguile/macros.c b/libguile/macros.c
index a0b1401..fe33e7e 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009,
2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009,
2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -92,8 +92,8 @@ SCM_DEFINE (scm_make_syntax_transformer,
"make-syntax-transformer", 3, 0, 0,
SCM existing_var;
SCM_VALIDATE_SYMBOL (1, name);
- existing_var = scm_sym2var (name, scm_current_module_lookup_closure (),
- SCM_BOOL_F);
+
+ existing_var = scm_module_variable (scm_current_module (), name);
if (scm_is_true (existing_var)
&& scm_is_true (scm_variable_bound_p (existing_var))
&& SCM_MACROP (SCM_VARIABLE_REF (existing_var)))
diff --git a/libguile/modules.c b/libguile/modules.c
index 6c3f262..7b42a3d 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011
Free Software Foundation, Inc.
+/* Copyright (C)
1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011,2012 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
@@ -80,9 +80,10 @@ SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
"Return the current module.")
#define FUNC_NAME s_scm_current_module
{
- SCM curr = scm_fluid_ref (the_module);
-
- return scm_is_true (curr) ? curr : scm_the_root_module ();
+ if (scm_module_system_booted_p)
+ return scm_fluid_ref (the_module);
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -235,38 +236,6 @@ scm_c_export (const char *name, ...)
}
-/* Environments */
-
-SCM_SYMBOL (sym_module, "module");
-
-SCM
-scm_lookup_closure_module (SCM proc)
-{
- if (scm_is_false (proc))
- return scm_the_root_module ();
- else if (SCM_EVAL_CLOSURE_P (proc))
- return SCM_PACK (SCM_SMOB_DATA (proc));
- else
- {
- SCM mod;
-
- /* FIXME: The `module' property is no longer set on eval closures, as it
- introduced a circular reference that precludes garbage collection of
- modules with the current weak hash table semantics (see
- http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and
-
http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
- for details). Since it doesn't appear to be used (only in this
- function, which has 1 caller), we no longer extend
- `set-module-eval-closure!' to set the `module' property. */
- abort ();
-
- mod = scm_procedure_property (proc, sym_module);
- if (scm_is_false (mod))
- mod = scm_the_root_module ();
- return mod;
- }
-}
-
/*
* C level implementation of the standard eval closure
*
@@ -519,84 +488,37 @@ SCM_DEFINE (scm_module_variable, "module-variable", 2, 0,
0,
}
#undef FUNC_NAME
-scm_t_bits scm_tc16_eval_closure;
-
-#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0)
-#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
- (SCM_SMOB_FLAGS (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
-
-/* NOTE: This function may be called by a smob application
- or from another C function directly. */
SCM
-scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
+scm_module_ensure_local_variable (SCM module, SCM sym)
+#define FUNC_NAME "module-ensure-local-variable"
{
- SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
- if (scm_is_true (definep))
+ if (SCM_LIKELY (scm_module_system_booted_p))
{
- if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
- return SCM_BOOL_F;
+ SCM_VALIDATE_MODULE (1, module);
+ SCM_VALIDATE_SYMBOL (2, sym);
+
return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
- module, sym);
+ module, sym);
}
- else
- return scm_module_variable (module, sym);
-}
-SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
- (SCM module),
- "Return an eval closure for the module @var{module}.")
-#define FUNC_NAME s_scm_standard_eval_closure
-{
- SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
-}
-#undef FUNC_NAME
+ {
+ SCM handle, var;
+ handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
+ sym, SCM_BOOL_F);
+ var = SCM_CDR (handle);
-SCM_DEFINE (scm_standard_interface_eval_closure,
- "standard-interface-eval-closure", 1, 0, 0,
- (SCM module),
- "Return a interface eval closure for the module @var{module}. "
- "Such a closure does not allow new bindings to be added.")
-#define FUNC_NAME s_scm_standard_interface_eval_closure
-{
- SCM_RETURN_NEWSMOB (scm_tc16_eval_closure |
(SCM_F_EVAL_CLOSURE_INTERFACE<<16),
- SCM_UNPACK (module));
-}
-#undef FUNC_NAME
+ if (scm_is_false (var))
+ {
+ var = scm_make_variable (SCM_UNDEFINED);
+ SCM_SETCDR (handle, var);
+ }
-SCM_DEFINE (scm_eval_closure_module,
- "eval-closure-module", 1, 0, 0,
- (SCM eval_closure),
- "Return the module associated with this eval closure.")
-/* the idea is that eval closures are really not the way to do things, they're
- superfluous given our module system. this function lets mmacros migrate away
- from eval closures. */
-#define FUNC_NAME s_scm_eval_closure_module
-{
- SCM_MAKE_VALIDATE_MSG (SCM_ARG1, eval_closure, EVAL_CLOSURE_P,
- "eval-closure");
- return SCM_SMOB_OBJECT (eval_closure);
+ return var;
+ }
}
#undef FUNC_NAME
-SCM
-scm_module_lookup_closure (SCM module)
-{
- if (scm_is_false (module))
- return SCM_BOOL_F;
- else
- return SCM_MODULE_EVAL_CLOSURE (module);
-}
-
-SCM
-scm_current_module_lookup_closure ()
-{
- if (scm_module_system_booted_p)
- return scm_module_lookup_closure (scm_current_module ());
- else
- return SCM_BOOL_F;
-}
-
SCM_SYMBOL (sym_macroexpand, "macroexpand");
SCM_DEFINE (scm_module_transformer, "module-transformer", 1, 0, 0,
@@ -676,61 +598,6 @@ scm_module_public_interface (SCM module)
return scm_call_1 (SCM_VARIABLE_REF (module_public_interface_var), module);
}
-/* scm_sym2var
- *
- * looks up the variable bound to SYM according to PROC. PROC should be
- * a `eval closure' of some module.
- *
- * When no binding exists, and DEFINEP is true, create a new binding
- * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
- * false and no binding exists.
- *
- * When PROC is `#f', it is ignored and the binding is searched for in
- * the scm_pre_modules_obarray (a `eq' hash table).
- */
-
-SCM
-scm_sym2var (SCM sym, SCM proc, SCM definep)
-#define FUNC_NAME "scm_sym2var"
-{
- SCM var;
-
- if (SCM_NIMP (proc))
- {
- if (SCM_EVAL_CLOSURE_P (proc))
- {
- /* Bypass evaluator in the standard case. */
- var = scm_eval_closure_lookup (proc, sym, definep);
- }
- else
- var = scm_call_2 (proc, sym, definep);
- }
- else
- {
- SCM handle;
-
- if (scm_is_false (definep))
- var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
- else
- {
- handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
- sym, SCM_BOOL_F);
- var = SCM_CDR (handle);
- if (scm_is_false (var))
- {
- var = scm_make_variable (SCM_UNDEFINED);
- SCM_SETCDR (handle, var);
- }
- }
- }
-
- if (scm_is_true (var) && !SCM_VARIABLEP (var))
- SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
-
- return var;
-}
-#undef FUNC_NAME
-
SCM
scm_c_module_lookup (SCM module, const char *name)
{
@@ -742,9 +609,7 @@ scm_module_lookup (SCM module, SCM sym)
#define FUNC_NAME "module-lookup"
{
SCM var;
- SCM_VALIDATE_MODULE (1, module);
-
- var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
+ var = scm_module_variable (module, sym);
if (scm_is_false (var))
unbound_variable (FUNC_NAME, sym);
return var;
@@ -760,11 +625,7 @@ scm_c_lookup (const char *name)
SCM
scm_lookup (SCM sym)
{
- SCM var =
- scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
- if (scm_is_false (var))
- unbound_variable (NULL, sym);
- return var;
+ return scm_module_lookup (scm_current_module (), sym);
}
SCM
@@ -896,10 +757,10 @@ scm_module_define (SCM module, SCM sym, SCM value)
#define FUNC_NAME "module-define"
{
SCM var;
- SCM_VALIDATE_MODULE (1, module);
- var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
+ var = scm_module_ensure_local_variable (module, sym);
SCM_VARIABLE_SET (var, value);
+
return var;
}
#undef FUNC_NAME
@@ -917,11 +778,9 @@ SCM_DEFINE (scm_define, "define!", 2, 0, 0,
"not a macro.")
#define FUNC_NAME s_scm_define
{
- SCM var;
SCM_VALIDATE_SYMBOL (SCM_ARG1, sym);
- var = scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
- SCM_VARIABLE_SET (var, value);
- return var;
+
+ return scm_module_define (scm_current_module (), sym, value);
}
#undef FUNC_NAME
@@ -1017,9 +876,6 @@ scm_init_modules ()
#include "libguile/modules.x"
module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
SCM_UNDEFINED);
- scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
- scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
-
the_module = scm_make_fluid ();
}
diff --git a/libguile/modules.h b/libguile/modules.h
index 07dc2c3..28df6c6 100644
--- a/libguile/modules.h
+++ b/libguile/modules.h
@@ -3,7 +3,7 @@
#ifndef SCM_MODULES_H
#define SCM_MODULES_H
-/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007, 2008, 2011 Free
Software Foundation, Inc.
+/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007, 2008, 2011, 2012
Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -64,16 +64,10 @@ SCM_API scm_t_bits scm_module_tag;
#define SCM_MODULE_IMPORT_OBARRAY(module) \
SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_import_obarray])
-SCM_API scm_t_bits scm_tc16_eval_closure;
-
-#define SCM_EVAL_CLOSURE_P(x) SCM_TYP16_PREDICATE (scm_tc16_eval_closure, x)
-
SCM_API SCM scm_current_module (void);
SCM_API SCM scm_the_root_module (void);
-SCM_API SCM scm_module_variable (SCM module, SCM sym);
-SCM_API SCM scm_module_local_variable (SCM module, SCM sym);
SCM_API SCM scm_interaction_environment (void);
SCM_API SCM scm_set_current_module (SCM module);
@@ -81,6 +75,10 @@ SCM_API SCM scm_c_call_with_current_module (SCM module,
SCM (*func)(void *), void *data);
SCM_API void scm_dynwind_current_module (SCM module);
+SCM_API SCM scm_module_variable (SCM module, SCM sym);
+SCM_API SCM scm_module_local_variable (SCM module, SCM sym);
+SCM_API SCM scm_module_ensure_local_variable (SCM module, SCM sym);
+
SCM_API SCM scm_c_lookup (const char *name);
SCM_API SCM scm_c_define (const char *name, SCM val);
SCM_API SCM scm_lookup (SCM symbol);
@@ -115,20 +113,11 @@ SCM_API SCM scm_c_define_module (const char *name,
SCM_API void scm_c_use_module (const char *name);
SCM_API void scm_c_export (const char *name, ...);
-SCM_API SCM scm_sym2var (SCM sym, SCM thunk, SCM definep);
-
SCM_API SCM scm_module_public_interface (SCM module);
SCM_API SCM scm_module_import_interface (SCM module, SCM sym);
-SCM_API SCM scm_module_lookup_closure (SCM module);
SCM_API SCM scm_module_transformer (SCM module);
-SCM_API SCM scm_current_module_lookup_closure (void);
SCM_API SCM scm_current_module_transformer (void);
-SCM_API SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep);
-SCM_API SCM scm_standard_eval_closure (SCM module);
-SCM_API SCM scm_standard_interface_eval_closure (SCM module);
-SCM_API SCM scm_eval_closure_module (SCM eval_closure); /* deprecated already
*/
SCM_API SCM scm_get_pre_modules_obarray (void);
-SCM_API SCM scm_lookup_closure_module (SCM proc);
SCM_INTERNAL void scm_modules_prehistory (void);
SCM_INTERNAL void scm_init_modules (void);
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 25e9533..3458847 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, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006,
2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
@@ -179,7 +179,7 @@ static mpz_t z_negative_one;
/* Clear the `mpz_t' embedded in bignum PTR. */
static void
-finalize_bignum (GC_PTR ptr, GC_PTR data)
+finalize_bignum (void *ptr, void *data)
{
SCM bignum;
@@ -217,17 +217,13 @@ static inline SCM
make_bignum (void)
{
scm_t_bits *p;
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
/* Allocate one word for the type tag and enough room for an `mpz_t'. */
p = scm_gc_malloc_pointerless (sizeof (scm_t_bits) + sizeof (mpz_t),
"bignum");
p[0] = scm_tc16_big;
- GC_REGISTER_FINALIZER_NO_ORDER (p, finalize_bignum, NULL,
- &prev_finalizer,
- &prev_finalizer_data);
+ scm_i_set_finalizer (p, finalize_bignum, NULL);
return SCM_PACK (p);
}
diff --git a/libguile/ports.c b/libguile/ports.c
index 12efce8..2f8c792 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -289,19 +289,21 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
}
#undef FUNC_NAME
-/* move up to read_len chars from port's putback and/or read buffers
- into memory starting at dest. returns the number of chars moved. */
-size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len)
+/* Move up to READ_LEN bytes from PORT's putback and/or read buffers
+ into memory starting at DEST. Return the number of bytes moved.
+ PORT's line/column numbers are left unchanged. */
+size_t
+scm_take_from_input_buffers (SCM port, char *dest, size_t read_len)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- size_t chars_read = 0;
+ size_t bytes_read = 0;
size_t from_buf = min (pt->read_end - pt->read_pos, read_len);
if (from_buf > 0)
{
memcpy (dest, pt->read_pos, from_buf);
pt->read_pos += from_buf;
- chars_read += from_buf;
+ bytes_read += from_buf;
read_len -= from_buf;
dest += from_buf;
}
@@ -314,10 +316,11 @@ size_t scm_take_from_input_buffers (SCM port, char *dest,
size_t read_len)
{
memcpy (dest, pt->saved_read_pos, from_buf);
pt->saved_read_pos += from_buf;
- chars_read += from_buf;
+ bytes_read += from_buf;
}
}
- return chars_read;
+
+ return bytes_read;
}
/* Clear a port's read buffers, returning the contents. */
@@ -540,25 +543,20 @@ scm_i_pthread_mutex_t scm_i_port_table_mutex =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* Port finalization. */
-static void finalize_port (GC_PTR, GC_PTR);
+static void finalize_port (void *, void *);
/* Register a finalizer for PORT. */
static SCM_C_INLINE_KEYWORD void
register_finalizer_for_port (SCM port)
{
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalization_data;
-
/* Register a finalizer for PORT so that its iconv CDs get freed and
optionally its type's `free' function gets called. */
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0,
- &prev_finalizer,
- &prev_finalization_data);
+ scm_i_set_finalizer (SCM2PTR (port), finalize_port, NULL);
}
/* Finalize the object (a port) pointed to by PTR. */
static void
-finalize_port (GC_PTR ptr, GC_PTR data)
+finalize_port (void *ptr, void *data)
{
long port_type;
SCM port = PTR2SCM (ptr);
@@ -630,7 +628,7 @@ scm_new_port_table_entry (scm_t_bits tag)
entry->input_cd = (iconv_t) -1;
entry->output_cd = (iconv_t) -1;
- entry->ilseq_handler = scm_i_get_conversion_strategy (SCM_BOOL_F);
+ entry->ilseq_handler = scm_i_default_port_conversion_handler ();
SCM_SET_CELL_TYPE (z, tag);
SCM_SETPTAB_ENTRY (z, entry);
@@ -2311,62 +2309,81 @@ SCM_DEFINE (scm_set_port_encoding_x,
"set-port-encoding!", 2, 0, 0,
#undef FUNC_NAME
-/* This determines how conversions handle unconvertible characters. */
-SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy");
+/* A fluid specifying the default conversion handler for newly created
+ ports. Its value should be one of the symbols below. */
+SCM_VARIABLE (default_conversion_strategy_var,
+ "%default-port-conversion-strategy");
+
+/* Whether the above fluid is initialized. */
static int scm_conversion_strategy_init = 0;
+/* The possible conversion strategies. */
+SCM_SYMBOL (sym_error, "error");
+SCM_SYMBOL (sym_substitute, "substitute");
+SCM_SYMBOL (sym_escape, "escape");
+
+/* Return the default failed encoding conversion policy for new created
+ ports. */
scm_t_string_failed_conversion_handler
-scm_i_get_conversion_strategy (SCM port)
+scm_i_default_port_conversion_handler (void)
{
- SCM encoding;
-
- if (scm_is_false (port))
- {
- if (!scm_conversion_strategy_init
- || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
- return SCM_FAILED_CONVERSION_QUESTION_MARK;
- else
- {
- encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy));
- if (scm_is_false (encoding))
- return SCM_FAILED_CONVERSION_QUESTION_MARK;
- else
- return (scm_t_string_failed_conversion_handler) scm_to_int
(encoding);
- }
- }
+ scm_t_string_failed_conversion_handler handler;
+
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var)))
+ handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
else
{
- scm_t_port *pt;
- pt = SCM_PTAB_ENTRY (port);
- return pt->ilseq_handler;
+ SCM fluid, value;
+
+ fluid = SCM_VARIABLE_REF (default_conversion_strategy_var);
+ value = scm_fluid_ref (fluid);
+
+ if (scm_is_eq (sym_substitute, value))
+ handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else if (scm_is_eq (sym_escape, value))
+ handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;
+ else
+ /* Default to 'error also when the fluid's value is not one of
+ the valid symbols. */
+ handler = SCM_FAILED_CONVERSION_ERROR;
}
-
+
+ return handler;
}
+/* Use HANDLER as the default conversion strategy for future ports. */
void
-scm_i_set_conversion_strategy_x (SCM port,
- scm_t_string_failed_conversion_handler handler)
+scm_i_set_default_port_conversion_handler
(scm_t_string_failed_conversion_handler
+ handler)
{
SCM strategy;
- scm_t_port *pt;
-
- strategy = scm_from_int ((int) handler);
-
- if (scm_is_false (port))
- {
- /* Set the default encoding for future ports. */
- if (!scm_conversion_strategy_init
- || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
- scm_misc_error (NULL, "tried to set conversion strategy fluid before it
is initialized",
- SCM_EOL);
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy);
- }
- else
+
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var)))
+ scm_misc_error (NULL, "tried to set conversion strategy fluid before it is
initialized",
+ SCM_EOL);
+
+ switch (handler)
{
- /* Set the character encoding for this port. */
- pt = SCM_PTAB_ENTRY (port);
- pt->ilseq_handler = handler;
+ case SCM_FAILED_CONVERSION_ERROR:
+ strategy = sym_error;
+ break;
+
+ case SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE:
+ strategy = sym_escape;
+ break;
+
+ case SCM_FAILED_CONVERSION_QUESTION_MARK:
+ strategy = sym_substitute;
+ break;
+
+ default:
+ abort ();
}
+
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var),
+ strategy);
}
SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy",
@@ -2386,14 +2403,18 @@ SCM_DEFINE (scm_port_conversion_strategy,
"port-conversion-strategy",
{
scm_t_string_failed_conversion_handler h;
- SCM_VALIDATE_OPPORT (1, port);
-
- if (!scm_is_false (port))
+ if (scm_is_false (port))
+ h = scm_i_default_port_conversion_handler ();
+ else
{
+ scm_t_port *pt;
+
SCM_VALIDATE_OPPORT (1, port);
+ pt = SCM_PTAB_ENTRY (port);
+
+ h = pt->ilseq_handler;
}
- h = scm_i_get_conversion_strategy (port);
if (h == SCM_FAILED_CONVERSION_ERROR)
return scm_from_latin1_symbol ("error");
else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK)
@@ -2428,40 +2449,25 @@ SCM_DEFINE (scm_set_port_conversion_strategy_x,
"set-port-conversion-strategy!",
"this thread.\n")
#define FUNC_NAME s_scm_set_port_conversion_strategy_x
{
- SCM err;
- SCM qm;
- SCM esc;
+ scm_t_string_failed_conversion_handler handler;
- if (!scm_is_false (port))
- {
- SCM_VALIDATE_OPPORT (1, port);
- }
-
- err = scm_from_latin1_symbol ("error");
- if (scm_is_true (scm_eqv_p (sym, err)))
- {
- scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR);
- return SCM_UNSPECIFIED;
- }
-
- qm = scm_from_latin1_symbol ("substitute");
- if (scm_is_true (scm_eqv_p (sym, qm)))
- {
- scm_i_set_conversion_strategy_x (port,
- SCM_FAILED_CONVERSION_QUESTION_MARK);
- return SCM_UNSPECIFIED;
- }
+ if (scm_is_eq (sym, sym_error))
+ handler = SCM_FAILED_CONVERSION_ERROR;
+ else if (scm_is_eq (sym, sym_substitute))
+ handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else if (scm_is_eq (sym, sym_escape))
+ handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;
+ else
+ SCM_MISC_ERROR ("unknown conversion strategy ~s", scm_list_1 (sym));
- esc = scm_from_latin1_symbol ("escape");
- if (scm_is_true (scm_eqv_p (sym, esc)))
+ if (scm_is_false (port))
+ scm_i_set_default_port_conversion_handler (handler);
+ else
{
- scm_i_set_conversion_strategy_x (port,
- SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
- return SCM_UNSPECIFIED;
+ SCM_VALIDATE_OPPORT (1, port);
+ SCM_PTAB_ENTRY (port)->ilseq_handler = handler;
}
- SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym));
-
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -2579,11 +2585,10 @@ scm_init_ports ()
scm_make_fluid_with_default (SCM_BOOL_F));
scm_port_encoding_init = 1;
- SCM_VARIABLE_SET (scm_conversion_strategy,
- scm_make_fluid_with_default
- (scm_from_int ((int)
SCM_FAILED_CONVERSION_QUESTION_MARK)));
+ SCM_VARIABLE_SET (default_conversion_strategy_var,
+ scm_make_fluid_with_default (sym_substitute));
scm_conversion_strategy_init = 1;
-
+
/* These bindings are used when boot-9 turns `current-input-port' et
al into parameters. They are then removed from the guile module. */
scm_c_define ("%current-input-port-fluid", cur_inport_fluid);
diff --git a/libguile/ports.h b/libguile/ports.h
index fcf1424..d4d59b7 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -4,7 +4,7 @@
#define SCM_PORTS_H
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
- * 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ * 2006, 2008, 2009, 2010, 2011, 2012 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
@@ -242,7 +242,8 @@ SCM_API void scm_set_port_truncate (scm_t_bits tc,
scm_t_off length));
SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting)
(SCM));
SCM_API SCM scm_char_ready_p (SCM port);
-size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len);
+SCM_API size_t scm_take_from_input_buffers (SCM port, char *dest,
+ size_t read_len);
SCM_API SCM scm_drain_input (SCM port);
SCM_API SCM scm_current_input_port (void);
SCM_API SCM scm_current_output_port (void);
@@ -288,7 +289,7 @@ SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t
start, size_t end,
SCM_API void scm_flush (SCM port);
SCM_API void scm_end_input (SCM port);
SCM_API int scm_fill_input (SCM port);
-SCM_INTERNAL void scm_unget_byte (int c, SCM port);
+SCM_API void scm_unget_byte (int c, SCM port);
SCM_API void scm_ungetc (scm_t_wchar c, SCM port);
SCM_API void scm_ungets (const char *s, int n, SCM port);
SCM_API SCM scm_peek_char (SCM port);
@@ -307,9 +308,12 @@ SCM_INTERNAL void scm_i_set_default_port_encoding (const
char *);
SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str);
SCM_API SCM scm_port_encoding (SCM port);
SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding);
-SCM_INTERNAL scm_t_string_failed_conversion_handler
scm_i_get_conversion_strategy (SCM port);
-SCM_INTERNAL void scm_i_set_conversion_strategy_x (SCM port,
-
scm_t_string_failed_conversion_handler h);
+SCM_INTERNAL scm_t_string_failed_conversion_handler
+scm_i_default_port_conversion_handler (void);
+/* Use HANDLER as the default conversion strategy for future ports. */
+SCM_INTERNAL void
+scm_i_set_default_port_conversion_handler
(scm_t_string_failed_conversion_handler);
+
SCM_API SCM scm_port_conversion_strategy (SCM port);
SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior);
SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *);
diff --git a/libguile/posix.c b/libguile/posix.c
index 154d26a..4f8b8ac 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1254,6 +1254,201 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
return scm_from_int (pid);
}
#undef FUNC_NAME
+
+/* Since Guile uses threads, we have to be very careful to avoid calling
+ functions that are not async-signal-safe in the child. That's why
+ this function is implemented in C. */
+static SCM
+scm_open_process (SCM mode, SCM prog, SCM args)
+#define FUNC_NAME "open-process"
+{
+ long mode_bits;
+ int reading, writing;
+ int c2p[2]; /* Child to parent. */
+ int p2c[2]; /* Parent to child. */
+ int in = -1, out = -1, err = -1;
+ int pid;
+ char *exec_file;
+ char **exec_argv;
+ int max_fd = 1024;
+
+ exec_file = scm_to_locale_string (prog);
+ exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
+
+ mode_bits = scm_i_mode_bits (mode);
+ reading = mode_bits & SCM_RDNG;
+ writing = mode_bits & SCM_WRTNG;
+
+ if (reading)
+ {
+ if (pipe (c2p))
+ {
+ int errno_save = errno;
+ free (exec_file);
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+ out = c2p[1];
+ }
+
+ if (writing)
+ {
+ if (pipe (p2c))
+ {
+ int errno_save = errno;
+ free (exec_file);
+ if (reading)
+ {
+ close (c2p[0]);
+ close (c2p[1]);
+ }
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+ in = p2c[0];
+ }
+
+ {
+ SCM port;
+
+ if (SCM_OPOUTFPORTP ((port = scm_current_error_port ())))
+ err = SCM_FPORT_FDES (port);
+ if (out == -1 && SCM_OPOUTFPORTP ((port = scm_current_output_port ())))
+ out = SCM_FPORT_FDES (port);
+ if (in == -1 && SCM_OPINFPORTP ((port = scm_current_input_port ())))
+ in = SCM_FPORT_FDES (port);
+ }
+
+#if defined (HAVE_GETRLIMIT) && defined (RLIMIT_NOFILE)
+ {
+ struct rlimit lim = { 0, 0 };
+ if (getrlimit (RLIMIT_NOFILE, &lim) == 0)
+ max_fd = lim.rlim_cur;
+ }
+#endif
+
+ pid = fork ();
+
+ if (pid == -1)
+ {
+ int errno_save = errno;
+ free (exec_file);
+ if (reading)
+ {
+ close (c2p[0]);
+ close (c2p[1]);
+ }
+ if (writing)
+ {
+ close (p2c[0]);
+ close (p2c[1]);
+ }
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+
+ if (pid)
+ /* Parent. */
+ {
+ SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F, port;
+
+ /* There is no sense in catching errors on close(). */
+ if (reading)
+ {
+ close (c2p[1]);
+ read_port = scm_fdes_to_port (c2p[0], "r", sym_read_pipe);
+ scm_setvbuf (read_port, scm_from_int (_IONBF), SCM_UNDEFINED);
+ }
+ if (writing)
+ {
+ close (p2c[0]);
+ write_port = scm_fdes_to_port (p2c[1], "w", sym_write_pipe);
+ scm_setvbuf (write_port, scm_from_int (_IONBF), SCM_UNDEFINED);
+ }
+
+ if (reading && writing)
+ {
+ static SCM make_rw_port = SCM_BOOL_F;
+
+ if (scm_is_false (make_rw_port))
+ make_rw_port = scm_c_private_variable ("ice-9 popen",
+ "make-rw-port");
+
+ port = scm_call_2 (scm_variable_ref (make_rw_port),
+ read_port, write_port);
+ }
+ else if (reading)
+ port = read_port;
+ else if (writing)
+ port = write_port;
+ else
+ port = scm_sys_make_void_port (mode);
+
+ return scm_cons (port, scm_from_int (pid));
+ }
+
+ /* The child. */
+ if (reading)
+ close (c2p[0]);
+ if (writing)
+ close (p2c[1]);
+
+ /* Close all file descriptors in ports inherited from the parent
+ except for in, out, and err. Heavy-handed, but robust. */
+ while (max_fd--)
+ if (max_fd != in && max_fd != out && max_fd != err)
+ close (max_fd);
+
+ /* Ignore errors on these open() calls. */
+ if (in == -1)
+ in = open ("/dev/null", O_RDONLY);
+ if (out == -1)
+ out = open ("/dev/null", O_WRONLY);
+ if (err == -1)
+ err = open ("/dev/null", O_WRONLY);
+
+ if (in > 0)
+ {
+ if (out == 0)
+ do out = dup (out); while (errno == EINTR);
+ if (err == 0)
+ do err = dup (err); while (errno == EINTR);
+ do dup2 (in, 0); while (errno == EINTR);
+ close (in);
+ }
+ if (out > 1)
+ {
+ if (err == 1)
+ do err = dup (err); while (errno == EINTR);
+ do dup2 (out, 1); while (errno == EINTR);
+ close (out);
+ }
+ if (err > 2)
+ {
+ do dup2 (err, 2); while (errno == EINTR);
+ close (err);
+ }
+
+ execvp (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv);
+
+ /* The exec failed! There is nothing sensible to do. */
+ if (err > 0)
+ {
+ char *msg = strerror (errno);
+ fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
+ exec_file, msg);
+ }
+
+ _exit (EXIT_FAILURE);
+ /* Not reached. */
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
#endif /* HAVE_FORK */
#ifdef __MINGW32__
@@ -2083,6 +2278,14 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
#endif /* HAVE_GETHOSTNAME */
+#ifdef HAVE_FORK
+static void
+scm_init_popen (void)
+{
+ scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
+}
+#endif
+
void
scm_init_posix ()
{
@@ -2171,6 +2374,11 @@ scm_init_posix ()
#include "libguile/cpp-SIG.c"
#include "libguile/posix.x"
+
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_popen",
+ (scm_t_extension_init_func) scm_init_popen,
+ NULL);
}
/*
diff --git a/libguile/print.c b/libguile/print.c
index c2dcd28..cb3c0b9 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -61,6 +61,9 @@
/* Character printers. */
+#define PORT_CONVERSION_HANDLER(port) \
+ SCM_PTAB_ENTRY (port)->ilseq_handler
+
static size_t display_string (const void *, int, size_t, SCM,
scm_t_string_failed_conversion_handler);
@@ -393,7 +396,7 @@ print_extended_symbol (SCM sym, SCM port)
scm_t_string_failed_conversion_handler strategy;
len = scm_i_symbol_length (sym);
- strategy = scm_i_get_conversion_strategy (port);
+ strategy = PORT_CONVERSION_HANDLER (port);
scm_lfwrite ("#{", 2, port);
@@ -500,7 +503,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
else
{
if (!display_character (SCM_CHAR (exp), port,
- scm_i_get_conversion_strategy (port)))
+ PORT_CONVERSION_HANDLER (port)))
scm_encoding_error (__func__, errno,
"cannot convert to output locale",
port, exp);
@@ -586,7 +589,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
printed = display_string (scm_i_string_data (exp),
scm_i_is_narrow_string (exp),
len, port,
- scm_i_get_conversion_strategy (port));
+ PORT_CONVERSION_HANDLER (port));
if (SCM_UNLIKELY (printed < len))
scm_encoding_error (__func__, errno,
"cannot convert to output locale",
@@ -1116,7 +1119,7 @@ write_character (scm_t_wchar ch, SCM port, int
string_escapes_p)
int printed = 0;
scm_t_string_failed_conversion_handler strategy;
- strategy = scm_i_get_conversion_strategy (port);
+ strategy = PORT_CONVERSION_HANDLER (port);
if (string_escapes_p)
{
@@ -1469,7 +1472,7 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
port = SCM_COERCE_OUTPORT (port);
if (!display_character (SCM_CHAR (chr), port,
- scm_i_get_conversion_strategy (port)))
+ PORT_CONVERSION_HANDLER (port)))
scm_encoding_error (__func__, errno,
"cannot convert to output locale",
port, chr);
@@ -1541,14 +1544,12 @@ SCM_DEFINE (scm_get_print_state, "get-print-state", 1,
0, 0,
void
scm_init_print ()
{
- SCM vtable, layout, type;
+ SCM type;
scm_gc_register_root (&print_state_pool);
scm_gc_register_root (&scm_print_state_vtable);
- vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
- layout =
- scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT));
- type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout));
+ type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
+ SCM_BOOL_F);
scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
scm_print_state_vtable = type;
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 9a75254..36228d3 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -80,8 +80,16 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest)
case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
return 0;
- proc = scm_i_smob_apply_trampoline (proc);
- break;
+ if (!scm_i_program_arity
+ (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline_objcode,
+ req, opt, rest))
+ return 0;
+
+ /* The trampoline gets the smob too, which users don't
+ see. */
+ *req -= 1;
+
+ return 1;
case scm_tcs_struct:
if (!SCM_STRUCT_APPLICABLE_P (proc))
return 0;
diff --git a/libguile/read.c b/libguile/read.c
index bbaf3f6..87d73bf 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -161,8 +161,8 @@ scm_i_read_hash_procedures_set_x (SCM value)
/* Size of the C buffer used to read symbols and numbers. */
#define READER_BUFFER_SIZE 128
-/* Size of the C buffer used to read strings. */
-#define READER_STRING_BUFFER_SIZE 512
+/* Number of 32-bit codepoints in the buffer used to read strings. */
+#define READER_STRING_BUFFER_SIZE 128
/* The maximum size of Scheme character names. */
#define READER_CHAR_NAME_MAX_SIZE 50
@@ -208,8 +208,8 @@ static SCM scm_get_hash_procedure (int);
fewer than BUF_SIZE bytes, non-zero otherwise. READ will be set the number
of
bytes actually read. */
static int
-read_token (SCM port, char *buf, const size_t buf_size, size_t *read)
- {
+read_token (SCM port, char *buf, size_t buf_size, size_t *read)
+{
*read = 0;
while (*read < buf_size)
@@ -235,20 +235,15 @@ read_token (SCM port, char *buf, const size_t buf_size,
size_t *read)
return 1;
}
-/* Read from PORT until a delimiter (e.g., a whitespace) is read. Put the
- result in the pre-allocated buffer BUFFER, if the whole token has fewer than
- BUFFER_SIZE bytes, or into OVERFLOW_BUFFER, allocated here to be freed by
the
- caller. Return zero if the token fits in BUFFER, non-zero otherwise. READ
- will be set the number of bytes actually read. */
-static int
-read_complete_token (SCM port, char *buffer, const size_t buffer_size,
- char **overflow_buffer, size_t *read)
+/* Like `read_token', but return either BUFFER, or a GC-allocated buffer
+ if the token doesn't fit in BUFFER_SIZE bytes. */
+static char *
+read_complete_token (SCM port, char *buffer, size_t buffer_size,
+ size_t *read)
{
int overflow = 0;
- size_t bytes_read, overflow_size;
-
- *overflow_buffer = NULL;
- overflow_size = 0;
+ size_t bytes_read, overflow_size = 0;
+ char *overflow_buffer = NULL;
do
{
@@ -259,14 +254,19 @@ read_complete_token (SCM port, char *buffer, const size_t
buffer_size,
{
if (overflow_size == 0)
{
- *overflow_buffer = scm_malloc (bytes_read);
- memcpy (*overflow_buffer, buffer, bytes_read);
+ overflow_buffer = scm_gc_malloc_pointerless (bytes_read, "read");
+ memcpy (overflow_buffer, buffer, bytes_read);
overflow_size = bytes_read;
}
else
{
- *overflow_buffer = scm_realloc (*overflow_buffer, overflow_size
+ bytes_read);
- memcpy (*overflow_buffer + overflow_size, buffer, bytes_read);
+ char *new_buf =
+ scm_gc_malloc_pointerless (overflow_size + bytes_read, "read");
+
+ memcpy (new_buf, overflow_buffer, overflow_size);
+ memcpy (new_buf + overflow_size, buffer, bytes_read);
+
+ overflow_buffer = new_buf;
overflow_size += bytes_read;
}
}
@@ -278,7 +278,7 @@ read_complete_token (SCM port, char *buffer, const size_t
buffer_size,
else
*read = bytes_read;
- return (overflow_size != 0);
+ return (overflow_size > 0 ? overflow_buffer : buffer);
}
/* Skip whitespace from PORT and return the first non-whitespace character
@@ -493,15 +493,14 @@ scm_read_string (int chr, SCM port)
/* For strings smaller than C_STR, this function creates only one Scheme
object (the string returned). */
- SCM str = SCM_BOOL_F;
- unsigned c_str_len = 0;
- scm_t_wchar c;
+ SCM str = SCM_EOL;
+ size_t c_str_len = 0;
+ scm_t_wchar c, c_str[READER_STRING_BUFFER_SIZE];
/* Need to capture line and column numbers here. */
long line = SCM_LINUM (port);
int column = SCM_COL (port) - 1;
- str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0);
while ('"' != (c = scm_getc (port)))
{
if (c == EOF)
@@ -511,12 +510,11 @@ scm_read_string (int chr, SCM port)
"end of file in string constant", SCM_EOL);
}
- if (c_str_len + 1 >= scm_i_string_length (str))
- {
- SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0);
-
- str = scm_string_append (scm_list_2 (str, addy));
- }
+ if (c_str_len + 1 >= READER_STRING_BUFFER_SIZE)
+ {
+ str = scm_cons (scm_from_utf32_stringn (c_str, c_str_len), str);
+ c_str_len = 0;
+ }
if (c == '\\')
{
@@ -580,12 +578,22 @@ scm_read_string (int chr, SCM port)
scm_list_1 (SCM_MAKE_CHAR (c)));
}
}
- str = scm_i_string_start_writing (str);
- scm_i_string_set_x (str, c_str_len++, c);
- scm_i_string_stop_writing ();
+
+ c_str[c_str_len++] = c;
}
- return maybe_annotate_source (scm_i_substring_copy (str, 0, c_str_len),
- port, line, column);
+
+ if (scm_is_null (str))
+ /* Fast path: we got a string that fits in C_STR. */
+ str = scm_from_utf32_stringn (c_str, c_str_len);
+ else
+ {
+ if (c_str_len > 0)
+ str = scm_cons (scm_from_utf32_stringn (c_str, c_str_len), str);
+
+ str = scm_string_concatenate_reverse (str, SCM_UNDEFINED, SCM_UNDEFINED);
+ }
+
+ return maybe_annotate_source (str, port, line, column);
}
#undef FUNC_NAME
@@ -594,10 +602,8 @@ static SCM
scm_read_number (scm_t_wchar chr, SCM port)
{
SCM result, str = SCM_EOL;
- char buffer[READER_BUFFER_SIZE];
- char *overflow_buffer = NULL;
+ char local_buffer[READER_BUFFER_SIZE], *buffer;
size_t bytes_read;
- int overflow;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
/* Need to capture line and column numbers here. */
@@ -605,14 +611,10 @@ scm_read_number (scm_t_wchar chr, SCM port)
int column = SCM_COL (port) - 1;
scm_ungetc (chr, port);
- overflow = read_complete_token (port, buffer, sizeof (buffer),
- &overflow_buffer, &bytes_read);
+ buffer = read_complete_token (port, local_buffer, sizeof local_buffer,
+ &bytes_read);
- if (!overflow)
- str = scm_from_stringn (buffer, bytes_read, pt->encoding,
pt->ilseq_handler);
- else
- str = scm_from_stringn (overflow_buffer, bytes_read, pt->encoding,
- pt->ilseq_handler);
+ str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler);
result = scm_string_to_number (str, SCM_UNDEFINED);
if (scm_is_false (result))
@@ -625,8 +627,6 @@ scm_read_number (scm_t_wchar chr, SCM port)
else if (SCM_NIMP (result))
result = maybe_annotate_source (result, port, line, column);
- if (overflow)
- free (overflow_buffer);
SCM_COL (port) += scm_i_string_length (str);
return result;
}
@@ -638,29 +638,20 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
int ends_with_colon = 0;
size_t bytes_read;
int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix);
- int overflow;
- char buffer[READER_BUFFER_SIZE], *overflow_buffer;
+ char local_buffer[READER_BUFFER_SIZE], *buffer;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM str;
scm_ungetc (chr, port);
- overflow = read_complete_token (port, buffer, READER_BUFFER_SIZE,
- &overflow_buffer, &bytes_read);
+ buffer = read_complete_token (port, local_buffer, sizeof local_buffer,
+ &bytes_read);
if (bytes_read > 0)
- {
- if (!overflow)
- ends_with_colon = buffer[bytes_read - 1] == ':';
- else
- ends_with_colon = overflow_buffer[bytes_read - 1] == ':';
- }
+ ends_with_colon = buffer[bytes_read - 1] == ':';
if (postfix && ends_with_colon && (bytes_read > 1))
{
- if (!overflow)
- str = scm_from_stringn (buffer, bytes_read - 1, pt->encoding,
pt->ilseq_handler);
- else
- str = scm_from_stringn (overflow_buffer, bytes_read - 1, pt->encoding,
- pt->ilseq_handler);
+ str = scm_from_stringn (buffer, bytes_read - 1,
+ pt->encoding, pt->ilseq_handler);
if (SCM_CASE_INSENSITIVE_P)
str = scm_string_downcase_x (str);
@@ -668,19 +659,14 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
}
else
{
- if (!overflow)
- str = scm_from_stringn (buffer, bytes_read, pt->encoding,
pt->ilseq_handler);
- else
- str = scm_from_stringn (overflow_buffer, bytes_read, pt->encoding,
- pt->ilseq_handler);
+ str = scm_from_stringn (buffer, bytes_read,
+ pt->encoding, pt->ilseq_handler);
if (SCM_CASE_INSENSITIVE_P)
str = scm_string_downcase_x (str);
result = scm_string_to_symbol (str);
}
- if (overflow)
- free (overflow_buffer);
SCM_COL (port) += scm_i_string_length (str);
return result;
}
@@ -691,8 +677,7 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port)
{
SCM result;
size_t read;
- char buffer[READER_BUFFER_SIZE], *overflow_buffer;
- int overflow;
+ char local_buffer[READER_BUFFER_SIZE], *buffer;
unsigned int radix;
SCM str;
scm_t_port *pt;
@@ -725,21 +710,14 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port)
radix = 10;
}
- overflow = read_complete_token (port, buffer, sizeof (buffer),
- &overflow_buffer, &read);
+ buffer = read_complete_token (port, local_buffer, sizeof local_buffer,
+ &read);
pt = SCM_PTAB_ENTRY (port);
- if (!overflow)
- str = scm_from_stringn (buffer, read, pt->encoding, pt->ilseq_handler);
- else
- str = scm_from_stringn (overflow_buffer, read, pt->encoding,
- pt->ilseq_handler);
+ str = scm_from_stringn (buffer, read, pt->encoding, pt->ilseq_handler);
result = scm_string_to_number (str, scm_from_uint (radix));
- if (overflow)
- free (overflow_buffer);
-
SCM_COL (port) += scm_i_string_length (str);
if (scm_is_true (result))
diff --git a/libguile/smob.c b/libguile/smob.c
index 8b038f5..c2e8f24 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010,
2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010,
2011, 2012 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
@@ -120,233 +120,81 @@ scm_smob_print (SCM exp, SCM port, scm_print_state
*pstate SCM_UNUSED)
/* {Apply}
*/
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40
-#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
-#else
-#define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0
-#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
-#endif
-
-/* This code is the same as in gsubr.c, except we use smob_call instead of
- struct_call. */
-
-/* A: req; B: opt; C: rest */
-#define A(nreq) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr
pointer */ \
- /* 5 */ scm_op_smob_call, nreq, /* and call (will return value as well) */ \
- /* 7 */ scm_op_nop, \
- /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (3, 7, nreq, 0, 0)
-
-#define B(nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \
- /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob
pointer */ \
- /* 8 */ scm_op_smob_call, nopt, /* and call (will return value as well) */ \
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, 0, nopt, 0)
-
-#define C() \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */ \
- /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob
pointer */ \
- /* 5 */ scm_op_smob_call, 1, /* and call (will return value as well) */ \
- /* 7 */ scm_op_nop, \
- /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (3, 7, 0, 0, 1)
-
-#define AB(nreq, nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \
- /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \
- /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob
pointer */ \
- /* 11 */ scm_op_smob_call, nreq+nopt, /* and call (will return value as
well) */ \
- /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (9, 13, nreq, nopt, 0)
-
-#define AC(nreq) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob
pointer */ \
- /* 8 */ scm_op_smob_call, nreq+1, /* and call (will return value as well) */
\
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, nreq, 0, 1)
-
-#define BC(nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \
- /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob
pointer */ \
- /* 8 */ scm_op_smob_call, nopt+1, /* and call (will return value as well) */
\
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, 0, nopt, 1)
-
-#define ABC(nreq, nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \
- /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */ \
- /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the smob
pointer */ \
- /* 11 */ scm_op_smob_call, nreq+nopt+1, /* and call (will return value as
well) */ \
- /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (9, 13, nreq, nopt, 1)
+static SCM scm_smob_trampolines[16];
-#define META(start, end, nreq, nopt, rest) \
- META_HEADER, \
- /* 0 */ scm_op_make_eol, /* bindings */ \
- /* 1 */ scm_op_make_eol, /* sources */ \
- /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N
to ip N */ \
- /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
- /* 8 */ scm_op_make_int8, nopt, /* N optionals */ \
- /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */
\
- /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */ \
- /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */ \
- /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
- /* 25 */ scm_op_object_ref, 1, /* the name from the object table */ \
- /* 27 */ scm_op_cons, /* make a pair for the properties */ \
- /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list
*/ \
- /* 31 */ scm_op_return /* and return */ \
- /* 32 */
-
-static const struct
+/* (nargs * nargs) + nopt + rest * (nargs + 1) */
+#define SCM_SMOB_TRAMPOLINE(nreq,nopt,rest) \
+ scm_smob_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
+ + nopt + rest * (nreq + nopt + rest + 1)]
+
+static SCM
+apply_0 (SCM smob)
{
- scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way
*/
- const scm_t_uint8 bytes[16 * (sizeof (struct scm_objcode) + 16
- + sizeof (struct scm_objcode) + 32)];
-} raw_bytecode = {
- 0,
- {
- /* Use the elisp macros from gsubr.c */
- /* C-u 3 M-x generate-bytecodes RET */
- /* 0 arguments */
- A(0),
- /* 1 arguments */
- A(1), B(1), C(),
- /* 2 arguments */
- A(2), AB(1,1), B(2), AC(1), BC(1),
- /* 3 arguments */
- A(3), AB(2,1), AB(1,2), B(3), AC(2), ABC(1,1), BC(2)
- }
-};
-
-#undef A
-#undef B
-#undef C
-#undef AB
-#undef AC
-#undef BC
-#undef ABC
-#undef OBJCODE_HEADER
-#undef META_HEADER
-#undef META
-
-#define STATIC_OBJCODE_TAG \
- SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
-
-static const struct
+ SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+ return subr (smob);
+}
+
+static SCM
+apply_1 (SCM smob, SCM a)
{
- scm_t_uint64 dummy; /* alignment */
- scm_t_cell cells[16 * 2]; /* 4*4 double cells */
-} objcode_cells = {
- 0,
- /* C-u 3 M-x generate-objcode-cells RET */
- {
- /* 0 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 1 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 2 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 512) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 3 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) },
- { SCM_BOOL_F, SCM_PACK (0) }
- }
-};
-
-static const SCM scm_smob_objcode_trampolines[16] = {
- /* C-u 3 M-x generate-objcodes RET */
- /* 0 arguments */
- SCM_PACK (objcode_cells.cells+0),
-
- /* 1 arguments */
- SCM_PACK (objcode_cells.cells+2),
- SCM_PACK (objcode_cells.cells+4),
- SCM_PACK (objcode_cells.cells+6),
-
- /* 2 arguments */
- SCM_PACK (objcode_cells.cells+8),
- SCM_PACK (objcode_cells.cells+10),
- SCM_PACK (objcode_cells.cells+12),
- SCM_PACK (objcode_cells.cells+14),
- SCM_PACK (objcode_cells.cells+16),
-
- /* 3 arguments */
- SCM_PACK (objcode_cells.cells+18),
- SCM_PACK (objcode_cells.cells+20),
- SCM_PACK (objcode_cells.cells+22),
- SCM_PACK (objcode_cells.cells+24),
- SCM_PACK (objcode_cells.cells+26),
- SCM_PACK (objcode_cells.cells+28),
- SCM_PACK (objcode_cells.cells+30)
-};
+ SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+ return subr (smob, a);
+}
-/* (nargs * nargs) + nopt + rest * (nargs + 1) */
-#define SCM_SMOB_OBJCODE_TRAMPOLINE(nreq,nopt,rest) \
- scm_smob_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
- + nopt + rest * (nreq + nopt + rest + 1)]
+static SCM
+apply_2 (SCM smob, SCM a, SCM b)
+{
+ SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+ return subr (smob, a, b);
+}
+
+static SCM
+apply_3 (SCM smob, SCM a, SCM b, SCM c)
+{
+ SCM (*subr)() = SCM_SMOB_DESCRIPTOR (smob).apply;
+ return subr (smob, a, b, c);
+}
static SCM
-scm_smob_objcode_trampoline (unsigned int nreq, unsigned int nopt,
- unsigned int rest)
+scm_smob_trampoline (unsigned int nreq, unsigned int nopt,
+ unsigned int rest)
{
+ SCM trampoline;
+
if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 3))
scm_out_of_range ("make-smob", scm_from_uint (nreq + nopt + rest));
- return SCM_SMOB_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
+ trampoline = SCM_SMOB_TRAMPOLINE (nreq, nopt, rest);
+
+ if (SCM_LIKELY (SCM_UNPACK (trampoline)))
+ return trampoline;
+
+ switch (nreq + nopt + rest)
+ {
+ /* The + 1 is for the smob itself. */
+ case 0:
+ trampoline = scm_c_make_gsubr ("apply-smob/0", nreq + 1, nopt, rest,
+ apply_0);
+ break;
+ case 1:
+ trampoline = scm_c_make_gsubr ("apply-smob/1", nreq + 1, nopt, rest,
+ apply_1);
+ break;
+ case 2:
+ trampoline = scm_c_make_gsubr ("apply-smob/2", nreq + 1, nopt, rest,
+ apply_2);
+ break;
+ case 3:
+ trampoline = scm_c_make_gsubr ("apply-smob/3", nreq + 1, nopt, rest,
+ apply_3);
+ break;
+ default:
+ abort ();
+ }
+
+ SCM_SMOB_TRAMPOLINE (nreq, nopt, rest) = trampoline;
+
+ return trampoline;
}
@@ -406,51 +254,16 @@ void
scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
unsigned int req, unsigned int opt, unsigned int rst)
{
- scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
- scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode
- = scm_smob_objcode_trampoline (req, opt, rst);
+ SCM trampoline = scm_smob_trampoline (req, opt, rst);
+
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
+ /* In 2.2 this field is renamed to "apply_trampoline". */
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode = trampoline;
if (SCM_UNPACK (scm_smob_class[0]) != 0)
scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
}
-static SCM tramp_weak_map = SCM_BOOL_F;
-static scm_i_pthread_mutex_t tramp_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
-SCM
-scm_i_smob_apply_trampoline (SCM smob)
-{
- SCM tramp;
-
- scm_i_pthread_mutex_lock (&tramp_lock);
- tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
- scm_i_pthread_mutex_unlock (&tramp_lock);
-
- if (scm_is_true (tramp))
- return tramp;
- else
- {
- const char *name;
- SCM objtable;
-
- name = SCM_SMOBNAME (SCM_SMOBNUM (smob));
- if (!name)
- name = "smob-apply";
- objtable = scm_c_make_vector (2, SCM_UNDEFINED);
- SCM_SIMPLE_VECTOR_SET (objtable, 0, smob);
- SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name));
- tramp = scm_make_program (SCM_SMOB_DESCRIPTOR
(smob).apply_trampoline_objcode,
- objtable, SCM_BOOL_F);
-
- /* Race conditions (between the ref and this set!) cannot cause
- any harm here. */
- scm_i_pthread_mutex_lock (&tramp_lock);
- scm_hashq_set_x (tramp_weak_map, smob, tramp);
- scm_i_pthread_mutex_unlock (&tramp_lock);
- return tramp;
- }
-}
-
SCM
scm_make_smob (scm_t_bits tc)
{
@@ -472,8 +285,8 @@ scm_make_smob (scm_t_bits tc)
static int smob_gc_kind;
-/* The generic SMOB mark procedure that gets called for SMOBs allocated with
- `scm_i_new_smob_with_mark_proc ()'. */
+/* The generic SMOB mark procedure that gets called for SMOBs allocated
+ with smob_gc_kind. */
static struct GC_ms_entry *
smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
struct GC_ms_entry *mark_stack_limit, GC_word env)
@@ -562,28 +375,10 @@ scm_gc_mark (SCM o)
#undef CURRENT_MARK_LIMIT
}
-/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
- provide a custom mark procedure and it will be honored. */
-SCM
-scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1,
- scm_t_bits data2, scm_t_bits data3)
-{
- /* Return a double cell. */
- SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell),
- smob_gc_kind));
-
- SCM_SET_CELL_WORD_3 (cell, data3);
- SCM_SET_CELL_WORD_2 (cell, data2);
- SCM_SET_CELL_WORD_1 (cell, data1);
- SCM_SET_CELL_WORD_0 (cell, tc);
-
- return cell;
-}
-
/* Finalize SMOB by calling its SMOB type's free function, if any. */
-void
-scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
+static void
+finalize_smob (void *ptr, void *data)
{
SCM smob;
size_t (* free_smob) (SCM);
@@ -599,6 +394,79 @@ scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
free_smob (smob);
}
+/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
+ provide a custom mark procedure and it will be honored. */
+SCM
+scm_i_new_smob (scm_t_bits tc, scm_t_bits data)
+{
+ scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
+ SCM ret;
+
+ /* Use the smob_gc_kind if needed to allow the mark procedure to
+ run. Since the marker only deals with double cells, that case
+ allocates a double cell. We leave words 2 and 3 to there initial
+ values, which is 0. */
+ if (scm_smobs [smobnum].mark)
+ ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
+ else
+ ret = PTR2SCM (GC_MALLOC (sizeof (scm_t_cell)));
+
+ SCM_SET_CELL_WORD_1 (ret, data);
+ SCM_SET_CELL_WORD_0 (ret, tc);
+
+ if (scm_smobs[smobnum].free)
+ scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
+
+ return ret;
+}
+
+/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
+ provide a custom mark procedure and it will be honored. */
+SCM
+scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1,
+ scm_t_bits data2, scm_t_bits data3)
+{
+ scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
+ SCM ret;
+
+ /* Use the smob_gc_kind if needed to allow the mark procedure to
+ run. */
+ if (scm_smobs [smobnum].mark)
+ ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
+ else
+ ret = PTR2SCM (GC_MALLOC (2 * sizeof (scm_t_cell)));
+
+ SCM_SET_CELL_WORD_3 (ret, data3);
+ SCM_SET_CELL_WORD_2 (ret, data2);
+ SCM_SET_CELL_WORD_1 (ret, data1);
+ SCM_SET_CELL_WORD_0 (ret, tc);
+
+ if (scm_smobs[smobnum].free)
+ scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
+
+ return ret;
+}
+
+
+
+
+/* These two are internal details of the previous implementation of
+ SCM_NEWSMOB and are no longer used. They are still here to preserve
+ ABI stability in the 2.0 series. */
+void
+scm_i_finalize_smob (void *ptr, void *data)
+{
+ finalize_smob (ptr, data);
+}
+
+SCM
+scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits word1,
+ scm_t_bits word2, scm_t_bits word3)
+{
+ return scm_new_double_smob (tc, word1, word2, word3);
+}
+
+
void
scm_smob_prehistory ()
@@ -624,8 +492,6 @@ scm_smob_prehistory ()
scm_smobs[i].apply = 0;
scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
}
-
- tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
}
/*
diff --git a/libguile/smob.h b/libguile/smob.h
index 6a7ceea..60abe37 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -4,7 +4,7 @@
#define SCM_SMOB_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2009,
- * 2010, 2011 Free Software Foundation, Inc.
+ * 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -27,8 +27,6 @@
#include "libguile/__scm.h"
#include "libguile/print.h"
-#include "libguile/bdw-gc.h"
-
/* This is the internal representation of a smob type */
@@ -42,82 +40,92 @@ typedef struct scm_smob_descriptor
int (*print) (SCM exp, SCM port, scm_print_state *pstate);
SCM (*equalp) (SCM, SCM);
scm_t_subr apply;
+ /* In 2.2 this field is renamed to "apply_trampoline". */
SCM apply_trampoline_objcode;
} scm_smob_descriptor;
+#define SCM_SMOB_TYPE_MASK 0xffff
+#define SCM_SMOB_TYPE_BITS(tc) (tc)
+#define SCM_TC2SMOBNUM(x) (0x0ff & ((x) >> 8))
+#define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CELL_TYPE (x)))
+/* SCM_SMOBNAME can be 0 if name is missing */
+#define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name)
+#define SCM_SMOB_PREDICATE(tag, obj) SCM_TYP16_PREDICATE (tag, obj)
+#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)])
+#define SCM_SMOB_APPLICABLE_P(x) (SCM_SMOB_DESCRIPTOR (x).apply)
+
+/* Maximum number of SMOB types. */
+#define SCM_I_MAX_SMOB_TYPE_COUNT 256
+
+SCM_API long scm_numsmob;
+SCM_API scm_smob_descriptor scm_smobs[];
+
+
-SCM_API SCM scm_i_new_smob_with_mark_proc (scm_t_bits tc,
- scm_t_bits, scm_t_bits, scm_t_bits);
-
-
-
-#define SCM_NEWSMOB(z, tc, data) \
-do \
- { \
- register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc);
\
- z = (scm_smobs[_smobnum].mark \
- ? scm_i_new_smob_with_mark_proc ((tc), (scm_t_bits)(data), \
- 0, 0) \
- : scm_cell (tc, (scm_t_bits)(data))); \
- if (scm_smobs[_smobnum].free) \
- {
\
- GC_finalization_proc _prev_finalizer; \
- GC_PTR _prev_finalizer_data; \
- \
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \
- NULL, \
- &_prev_finalizer, \
- &_prev_finalizer_data); \
- }
\
- } \
-while (0)
-
-#define SCM_RETURN_NEWSMOB(tc, data) \
- do { SCM __SCM_smob_answer; \
- SCM_NEWSMOB (__SCM_smob_answer, (tc), (data)); \
- return __SCM_smob_answer; \
- } while (0)
-
-#define SCM_NEWSMOB2(z, tc, data1, data2) \
- SCM_NEWSMOB3 (z, tc, data1, data2, 0)
-
-#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \
- do { SCM __SCM_smob_answer; \
- SCM_NEWSMOB2 (__SCM_smob_answer, (tc), (data1), (data2)); \
- return __SCM_smob_answer; \
- } while (0)
-
-#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \
-do \
- { \
- register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc);
\
- z = (scm_smobs[_smobnum].mark \
- ? scm_i_new_smob_with_mark_proc (tc, (scm_t_bits)(data1), \
- (scm_t_bits)(data2), \
- (scm_t_bits)(data3)) \
- : scm_double_cell ((tc), (scm_t_bits)(data1), \
- (scm_t_bits)(data2), \
- (scm_t_bits)(data3))); \
- if (scm_smobs[_smobnum].free) \
- {
\
- GC_finalization_proc _prev_finalizer; \
- GC_PTR _prev_finalizer_data; \
- \
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \
- NULL, \
- &_prev_finalizer, \
- &_prev_finalizer_data); \
- }
\
- } \
-while (0)
-
-#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \
- do { SCM __SCM_smob_answer; \
- SCM_NEWSMOB3 (__SCM_smob_answer, (tc), (data1), (data2), (data3)); \
- return __SCM_smob_answer; \
- } while (0)
+SCM_API SCM scm_i_new_smob (scm_t_bits tc, scm_t_bits);
+SCM_API SCM scm_i_new_double_smob (scm_t_bits tc, scm_t_bits,
+ scm_t_bits, scm_t_bits);
+
+
+SCM_INLINE SCM scm_new_smob (scm_t_bits tc, scm_t_bits);
+SCM_INLINE SCM scm_new_double_smob (scm_t_bits tc, scm_t_bits,
+ scm_t_bits, scm_t_bits);
+
+/* These two are internal details of the previous implementation of
+ SCM_NEWSMOB and are no longer used. They are still here to preserve
+ ABI stability in the 2.0 series. */
+SCM_API void scm_i_finalize_smob (void *ptr, void *data);
+SCM_API SCM scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits,
+ scm_t_bits, scm_t_bits);
+
+
+#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
+SCM_INLINE_IMPLEMENTATION SCM
+scm_new_smob (scm_t_bits tc, scm_t_bits data)
+{
+ scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
+
+ if (SCM_UNLIKELY (scm_smobs[smobnum].mark || scm_smobs[smobnum].free))
+ return scm_i_new_smob (tc, data);
+ else
+ return scm_cell (tc, data);
+}
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_new_double_smob (scm_t_bits tc, scm_t_bits data1,
+ scm_t_bits data2, scm_t_bits data3)
+{
+ scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
+
+ if (SCM_UNLIKELY (scm_smobs[smobnum].mark || scm_smobs[smobnum].free))
+ return scm_i_new_double_smob (tc, data1, data2, data3);
+ else
+ return scm_double_cell (tc, data1, data2, data3);
+}
+#endif
+
+#define SCM_NEWSMOB(z, tc, data) \
+ z = scm_new_smob ((tc), (scm_t_bits)(data))
+#define SCM_RETURN_NEWSMOB(tc, data) \
+ return scm_new_smob ((tc), (scm_t_bits)(data))
+
+#define SCM_NEWSMOB2(z, tc, data1, data2) \
+ z = scm_new_double_smob ((tc), (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), 0)
+#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \
+ return scm_new_double_smob ((tc), (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), 0)
+
+#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \
+ z = scm_new_double_smob ((tc), (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), (scm_t_bits)(data3))
+#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \
+ return scm_new_double_smob ((tc), (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), (scm_t_bits)(data3))
+
+
#define SCM_SMOB_DATA_N(x, n) (SCM_CELL_WORD ((x), (n)))
#define SCM_SET_SMOB_DATA_N(x, n, data) (SCM_SET_CELL_WORD ((x), (n),
(data)))
@@ -158,28 +166,11 @@ while (0)
#define SCM_SMOB_OBJECT_LOC(x) (SCM_SMOB_OBJECT_1_LOC (x)))
-#define SCM_SMOB_TYPE_MASK 0xffff
-#define SCM_SMOB_TYPE_BITS(tc) (tc)
-#define SCM_TC2SMOBNUM(x) (0x0ff & ((x) >> 8))
-#define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CELL_TYPE (x)))
-/* SCM_SMOBNAME can be 0 if name is missing */
-#define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name)
-#define SCM_SMOB_PREDICATE(tag, obj) SCM_TYP16_PREDICATE (tag, obj)
-#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)])
-#define SCM_SMOB_APPLICABLE_P(x) (SCM_SMOB_DESCRIPTOR (x).apply)
#define SCM_SMOB_APPLY_0(x) (scm_call_0 (x))
#define SCM_SMOB_APPLY_1(x, a1) (scm_call_1 (x, a1))
#define SCM_SMOB_APPLY_2(x, a1, a2) (scm_call_2 (x, a1, a2))
#define SCM_SMOB_APPLY_3(x, a1, a2, rst) (scm_call_3 (x, a1, a2, a3))
-/* Maximum number of SMOB types. */
-#define SCM_I_MAX_SMOB_TYPE_COUNT 256
-
-SCM_API long scm_numsmob;
-SCM_API scm_smob_descriptor scm_smobs[];
-
-SCM_API void scm_i_finalize_smob (GC_PTR obj, GC_PTR data);
-
SCM_API SCM scm_mark0 (SCM ptr);
@@ -214,8 +205,6 @@ SCM_API void scm_assert_smob_type (scm_t_bits tag, SCM val);
SCM_API SCM scm_make_smob (scm_t_bits tc);
-SCM_INTERNAL SCM scm_i_smob_apply_trampoline (SCM smob);
-
SCM_API void scm_smob_prehistory (void);
#endif /* SCM_SMOB_H */
diff --git a/libguile/sort.c b/libguile/sort.c
index ecadd82..2a36320 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -1,4 +1,6 @@
-/* Copyright (C) 1999,2000,2001,2002, 2004, 2006, 2007, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
+/* Copyright (C) 1999, 2000, 2001, 2002, 2004, 2006, 2007, 2008, 2009,
+ * 2010, 2011, 2012 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -101,9 +103,10 @@ SCM_DEFINE (scm_restricted_vector_sort_x,
"restricted-vector-sort!", 4, 0, 0,
* (not (less? (list-ref list i) (list-ref list (- i 1)))). */
SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
(SCM items, SCM less),
- "Return @code{#t} iff @var{items} is a list or a vector such that\n"
- "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
- "applied to all elements i - 1 and i")
+ "Return @code{#t} iff @var{items} is a list or vector such that, "
+ "for each element @var{x} and the next element @var{y} of "
+ "@var{items}, @code{(@var{less} @var{y} @var{x})} returns "
+ "@code{#f}.")
#define FUNC_NAME s_scm_sorted_p
{
long len, j; /* list/vector length, temp j */
diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index 75feae3..2834553 100644
--- a/libguile/srfi-13.c
+++ b/libguile/srfi-13.c
@@ -1,6 +1,6 @@
/* srfi-13.c --- SRFI-13 procedures for Guile
*
- * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software
Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012 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
@@ -719,7 +719,8 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
MY_VALIDATE_SUBSTRING_SPEC (1, s,
3, start, cstart,
4, end, cend);
- if (SCM_UNBNDP (char_pred))
+ if (SCM_UNBNDP (char_pred)
+ || scm_is_eq (char_pred, scm_char_set_whitespace))
{
while (cstart < cend)
{
@@ -794,7 +795,8 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1,
3, 0,
MY_VALIDATE_SUBSTRING_SPEC (1, s,
3, start, cstart,
4, end, cend);
- if (SCM_UNBNDP (char_pred))
+ if (SCM_UNBNDP (char_pred)
+ || scm_is_eq (char_pred, scm_char_set_whitespace))
{
while (cstart < cend)
{
@@ -869,7 +871,8 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3,
0,
MY_VALIDATE_SUBSTRING_SPEC (1, s,
3, start, cstart,
4, end, cend);
- if (SCM_UNBNDP (char_pred))
+ if (SCM_UNBNDP (char_pred)
+ || scm_is_eq (char_pred, scm_char_set_whitespace))
{
while (cstart < cend)
{
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 9599554..37a9161 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -1,5 +1,5 @@
/* A stack holds a frame chain
- * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011 Free
Software Foundation
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012
Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -278,6 +278,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
/* FIXME: is this even possible? */
if (scm_is_true (frame)
+ && SCM_PROGRAM_P (scm_frame_procedure (frame))
&& SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
frame = scm_frame_previous (frame);
diff --git a/libguile/strings.c b/libguile/strings.c
index 71eee6c..414951e 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -748,7 +748,7 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
name = SH_STRING_STRING (name);
start += STRING_START (name);
}
- buf = SYMBOL_STRINGBUF (name);
+ buf = STRING_STRINGBUF (name);
if (start == 0 && length == STRINGBUF_LENGTH (buf))
{
@@ -1577,7 +1577,7 @@ SCM
scm_from_locale_stringn (const char *str, size_t len)
{
return scm_from_stringn (str, len, locale_charset (),
- scm_i_get_conversion_strategy (SCM_BOOL_F));
+ scm_i_default_port_conversion_handler ());
}
SCM
@@ -1802,9 +1802,9 @@ scm_to_locale_string (SCM str)
char *
scm_to_locale_stringn (SCM str, size_t *lenp)
{
- return scm_to_stringn (str, lenp,
+ return scm_to_stringn (str, lenp,
locale_charset (),
- scm_i_get_conversion_strategy (SCM_BOOL_F));
+ scm_i_default_port_conversion_handler ());
}
char *
@@ -1874,6 +1874,52 @@ latin1_to_u8 (const scm_t_uint8 *str, size_t latin_len,
return u8_result;
}
+/* UTF-8 code table
+
+ (Note that this includes code points that are not allowed by Unicode,
+ but since this function has no way to report an error, and its
+ purpose is to determine the size of destination buffers for
+ libunicode conversion functions, we err on the safe side and handle
+ everything that libunicode might conceivably handle, now or in the
+ future.)
+
+ Char. number range | UTF-8 octet sequence
+ (hexadecimal) | (binary)
+ --------------------+------------------------------------------------------
+ 0000 0000-0000 007F | 0xxxxxxx
+ 0000 0080-0000 07FF | 110xxxxx 10xxxxxx
+ 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx
+ 0001 0000-001F FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
+ 0020 0000-03FF FFFF | 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
+ 0400 0000-7FFF FFFF | 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
+*/
+
+static size_t
+u32_u8_length_in_bytes (const scm_t_uint32 *str, size_t len)
+{
+ size_t ret, i;
+
+ for (i = 0, ret = 0; i < len; i++)
+ {
+ scm_t_uint32 c = str[i];
+
+ if (c <= 0x7f)
+ ret += 1;
+ else if (c <= 0x7ff)
+ ret += 2;
+ else if (c <= 0xffff)
+ ret += 3;
+ else if (c <= 0x1fffff)
+ ret += 4;
+ else if (c <= 0x3ffffff)
+ ret += 5;
+ else
+ ret += 6;
+ }
+
+ return ret;
+}
+
char *
scm_to_utf8_stringn (SCM str, size_t *lenp)
{
@@ -1882,9 +1928,46 @@ scm_to_utf8_stringn (SCM str, size_t *lenp)
scm_i_string_length (str),
NULL, lenp);
else
- return (char *) u32_to_u8 ((scm_t_uint32*)scm_i_string_wide_chars (str),
- scm_i_string_length (str),
- NULL, lenp);
+ {
+ scm_t_uint32 *chars = (scm_t_uint32 *) scm_i_string_wide_chars (str);
+ scm_t_uint8 *buf, *ret;
+ size_t num_chars = scm_i_string_length (str);
+ size_t num_bytes_predicted, num_bytes_actual;
+
+ num_bytes_predicted = u32_u8_length_in_bytes (chars, num_chars);
+
+ if (lenp)
+ {
+ *lenp = num_bytes_predicted;
+ buf = scm_malloc (num_bytes_predicted);
+ }
+ else
+ {
+ buf = scm_malloc (num_bytes_predicted + 1);
+ buf[num_bytes_predicted] = 0;
+ }
+
+ num_bytes_actual = num_bytes_predicted;
+ ret = u32_to_u8 (chars, num_chars, buf, &num_bytes_actual);
+
+ if (SCM_LIKELY (ret == buf && num_bytes_actual == num_bytes_predicted))
+ return (char *) ret;
+
+ /* An error: a bad codepoint. */
+ {
+ int saved_errno = errno;
+
+ free (buf);
+ if (!saved_errno)
+ abort ();
+
+ scm_decoding_error ("scm_to_utf8_stringn", errno,
+ "invalid codepoint in string", str);
+
+ /* Not reached. */
+ return NULL;
+ }
+ }
}
scm_t_wchar *
diff --git a/libguile/strports.c b/libguile/strports.c
index b7fec47..14cc93f 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009,
2010, 2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006,
+ * 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -287,7 +288,18 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char
*caller)
scm_i_dynwind_pthread_mutex_lock (&scm_i_port_table_mutex);
z = scm_new_port_table_entry (scm_tc16_strport);
- pt = SCM_PTAB_ENTRY(z);
+ SCM_SET_CELL_TYPE (z, scm_tc16_strport);
+ pt = SCM_PTAB_ENTRY (z);
+
+ /* Make PT initially empty, and release the port-table mutex
+ immediately. This is so that if one of the function calls below
+ raises an exception, a pre-unwind catch handler can still create
+ new ports; for instance, `display-backtrace' needs to be able to
+ allocate a new string port. See <http://bugs.gnu.org/11197>. */
+ scm_port_non_buffer (pt);
+ SCM_SETSTREAM (z, SCM_UNPACK (scm_null_bytevector));
+
+ scm_dynwind_end ();
if (scm_is_false (str))
{
@@ -295,10 +307,6 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char
*caller)
str_len = INITIAL_BUFFER_SIZE;
buf = scm_c_make_bytevector (str_len);
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
-
- /* Reset `read_buf_size'. It will contain the actual number of
- bytes written to PT. */
- pt->read_buf_size = 0;
c_pos = 0;
}
else
@@ -317,12 +325,21 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char
*caller)
free (copy);
c_pos = scm_to_unsigned_integer (pos, 0, str_len);
- pt->read_buf_size = str_len;
}
+ /* Now, finish up the port. */
+ scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+
SCM_SETSTREAM (z, SCM_UNPACK (buf));
SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes);
+ if (scm_is_false (str))
+ /* Reset `read_buf_size'. It will contain the actual number of
+ bytes written to PT. */
+ pt->read_buf_size = 0;
+ else
+ pt->read_buf_size = str_len;
+
pt->write_buf = pt->read_buf = (unsigned char *) c_buf;
pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
pt->write_buf_size = str_len;
@@ -330,13 +347,12 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char
*caller)
pt->rw_random = 1;
- scm_dynwind_end ();
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
/* Ensure WRITE_POS is writable. */
if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
st_flush (z);
- scm_i_set_conversion_strategy_x (z, SCM_FAILED_CONVERSION_ERROR);
return z;
}
diff --git a/libguile/struct.c b/libguile/struct.c
index 2aa5c11..a5c4e3a 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008,
2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008,
2009, 2010, 2011, 2012 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
@@ -410,7 +410,7 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
/* Finalization: invoke the finalizer of the struct pointed to by PTR. */
static void
-struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
+struct_finalizer_trampoline (void *ptr, void *unused_data)
{
SCM obj = PTR2SCM (ptr);
scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);
@@ -443,16 +443,8 @@ scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
/* vtable_data can be null when making a vtable vtable */
if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
- {
- /* Register a finalizer for the newly created instance. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
- struct_finalizer_trampoline,
- NULL,
- &prev_finalizer,
- &prev_finalizer_data);
- }
+ /* Register a finalizer for the newly created instance. */
+ scm_i_set_finalizer (SCM2PTR (ret), struct_finalizer_trampoline, NULL);
return ret;
}
@@ -925,17 +917,6 @@ SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
- (SCM handle),
- "Return the vtable tag of the structure @var{handle}.")
-#define FUNC_NAME s_scm_struct_vtable_tag
-{
- SCM_VALIDATE_VTABLE (1, handle);
- return scm_from_unsigned_integer
- (((scm_t_bits)SCM_STRUCT_DATA (handle)) >> 3);
-}
-#undef FUNC_NAME
-
/* {Associating names and classes with vtables}
*
* The name of a vtable should probably be stored as a slot. This is
@@ -1041,11 +1022,13 @@ scm_init_struct ()
GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
+ scm_c_define ("standard-vtable-fields", required_vtable_fields);
required_applicable_fields = scm_from_locale_string
(SCM_APPLICABLE_BASE_LAYOUT);
required_applicable_with_setter_fields = scm_from_locale_string
(SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
scm_standard_vtable_vtable =
scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
+ scm_c_define ("<standard-vtable>", scm_standard_vtable_vtable);
scm_applicable_struct_vtable_vtable =
scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
diff --git a/libguile/struct.h b/libguile/struct.h
index c3c7d8f..743e7ae 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRUCT_H
#define SCM_STRUCT_H
-/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011,
2012 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
@@ -184,7 +184,6 @@ SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM
tail_array_size, SCM i
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
-SCM_API SCM scm_struct_vtable_tag (SCM handle);
SCM_API SCM scm_struct_vtable_name (SCM vtable);
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
diff --git a/libguile/threads.c b/libguile/threads.c
index 7944f48..e8305b4 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -620,6 +620,9 @@ guilify_self_2 (SCM parent)
t->join_queue = make_queue ();
t->block_asyncs = 0;
+
+ /* See note in finalizers.c:queue_finalizer_async(). */
+ GC_invoke_finalizers ();
}
diff --git a/libguile/values.c b/libguile/values.c
index 9c9e5ff..98a9df1 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011 Free Software Foundation,
Inc.
+/* Copyright (C) 2000, 2001, 2006, 2008, 2009, 2011, 2012 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
@@ -67,6 +67,15 @@ print_values (SCM obj, SCM pwps)
return SCM_UNSPECIFIED;
}
+size_t
+scm_c_nvalues (SCM obj)
+{
+ if (SCM_LIKELY (SCM_VALUESP (obj)))
+ return scm_ilength (scm_struct_ref (obj, SCM_INUM0));
+ else
+ return 1;
+}
+
SCM
scm_c_value_ref (SCM obj, size_t idx)
{
@@ -108,14 +117,26 @@ SCM_DEFINE (scm_values, "values", 0, 0, 1,
if (n == 1)
result = SCM_CAR (args);
else
- {
- result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args));
- }
+ result = scm_c_make_struct (scm_values_vtable, 0, 1, SCM_UNPACK (args));
return result;
}
#undef FUNC_NAME
+SCM
+scm_c_values (SCM *base, size_t nvalues)
+{
+ SCM ret, *walk;
+
+ if (nvalues == 1)
+ return *base;
+
+ for (ret = SCM_EOL, walk = base + nvalues - 1; walk >= base; walk--)
+ ret = scm_cons (*walk, ret);
+
+ return scm_values (ret);
+}
+
void
scm_init_values (void)
{
diff --git a/libguile/values.h b/libguile/values.h
index 5f79855..3dbd0b7 100644
--- a/libguile/values.h
+++ b/libguile/values.h
@@ -3,7 +3,7 @@
#ifndef SCM_VALUES_H
#define SCM_VALUES_H
-/* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2000,2001, 2006, 2008, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -33,7 +33,9 @@ SCM_API SCM scm_values_vtable;
SCM_INTERNAL void scm_i_extract_values_2 (SCM obj, SCM *p1, SCM *p2);
SCM_API SCM scm_values (SCM args);
-SCM_API SCM scm_c_value_ref (SCM values, size_t idx);
+SCM_API SCM scm_c_values (SCM *base, size_t n);
+SCM_API size_t scm_c_nvalues (SCM obj);
+SCM_API SCM scm_c_value_ref (SCM obj, size_t idx);
SCM_INTERNAL void scm_init_values (void);
#endif /* SCM_VALUES_H */
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 2805278..b386deb 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010,
+ * 2011, 2012 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -277,9 +278,8 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
if (SCM_I_WVECTP (v))
{
/* Make it a weak pointer. */
- GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]);
- SCM_I_REGISTER_DISAPPEARING_LINK (link,
- (GC_PTR) SCM2PTR (obj));
+ SCM *link = & SCM_I_VECTOR_WELTS (v)[k];
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) link, SCM2PTR (obj));
}
}
else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
@@ -296,9 +296,8 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj)
if (SCM_I_WVECTP (vv))
{
/* Make it a weak pointer. */
- GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]);
- SCM_I_REGISTER_DISAPPEARING_LINK (link,
- (GC_PTR) SCM2PTR (obj));
+ SCM *link = & SCM_I_VECTOR_WELTS (vv)[k];
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) link, SCM2PTR (obj));
}
}
else
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index c90458d..12e62d5 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -57,9 +57,7 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
/* Internal variables */
int nvalues = 0;
- const char *func_name = NULL; /* used for error reporting */
- SCM finish_args; /* used both for returns: both in error
- and normal situations */
+
#ifdef HAVE_LABELS_AS_VALUES
static const void **jump_table_pointer = NULL;
#endif
@@ -88,32 +86,55 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
jump_table = jump_table_pointer;
#endif
- /* Initialization */
- {
- SCM prog = program;
+ /* Initial frame */
+ CACHE_REGISTER ();
+ PUSH (SCM_PACK (fp)); /* dynamic link */
+ PUSH (SCM_PACK (0)); /* mvra */
+ PUSH (SCM_PACK (ip)); /* ra */
+ PUSH (boot_continuation);
+ fp = sp + 1;
+ ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
+
+ /* MV-call frame, function & arguments */
+ PUSH (SCM_PACK (fp)); /* dynamic link */
+ PUSH (SCM_PACK (ip + 1)); /* mvra */
+ PUSH (SCM_PACK (ip)); /* ra */
+ PUSH (program);
+ fp = sp + 1;
+ VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
+ while (nargs--)
+ PUSH (*argv++);
+
+ PUSH_CONTINUATION_HOOK ();
+
+ apply:
+ program = fp[-1];
+ if (!SCM_PROGRAM_P (program))
+ {
+ if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
+ fp[-1] = SCM_STRUCT_PROCEDURE (program);
+ else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ && SCM_SMOB_APPLICABLE_P (program))
+ {
+ /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
+ int i;
+ PUSH (SCM_BOOL_F);
+ for (i = sp - fp; i >= 0; i--)
+ fp[i] = fp[i - 1];
+ fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline_objcode;
+ }
+ else
+ {
+ SYNC_ALL();
+ vm_error_wrong_type_apply (program);
+ }
+ goto apply;
+ }
- /* Boot program */
- program = vm_make_boot_program (nargs);
+ CACHE_PROGRAM ();
+ ip = SCM_C_OBJCODE_BASE (bp);
- /* Initial frame */
- CACHE_REGISTER ();
- PUSH (SCM_PACK (fp)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (ip)); /* ra */
- CACHE_PROGRAM ();
- PUSH (program);
- fp = sp + 1;
- ip = SCM_C_OBJCODE_BASE (bp);
- /* MV-call frame, function & arguments */
- PUSH (SCM_PACK (0)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (0)); /* ra */
- PUSH (prog);
- if (SCM_UNLIKELY (sp + nargs >= stack_limit))
- goto vm_error_too_many_args;
- while (nargs--)
- PUSH (*argv++);
- }
+ APPLY_HOOK ();
/* Let's go! */
NEXT;
@@ -134,176 +155,15 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
}
#endif
-
- vm_done:
- SYNC_ALL ();
- return finish_args;
-
- /* Errors */
- {
- SCM err_msg;
-
- /* FIXME: need to sync regs before allocating anything, in each case. */
-
- vm_error_bad_instruction:
- err_msg = scm_from_latin1_string ("VM: Bad instruction: ~s");
- finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
- goto vm_error;
-
- vm_error_unbound:
- /* FINISH_ARGS should be the name of the unbound variable. */
- SYNC_ALL ();
- err_msg = scm_from_latin1_string ("Unbound variable: ~s");
- scm_error_scm (scm_misc_error_key, program, err_msg,
- scm_list_1 (finish_args), SCM_BOOL_F);
- goto vm_error;
-
- vm_error_unbound_fluid:
- SYNC_ALL ();
- err_msg = scm_from_latin1_string ("Unbound fluid: ~s");
- scm_error_scm (scm_misc_error_key, program, err_msg,
- scm_list_1 (finish_args), SCM_BOOL_F);
- goto vm_error;
-
- vm_error_not_a_variable:
- SYNC_ALL ();
- scm_error (scm_arg_type_key, func_name, "Not a variable: ~S",
- scm_list_1 (finish_args), scm_list_1 (finish_args));
- goto vm_error;
-
- vm_error_apply_to_non_list:
- SYNC_ALL ();
- scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
- scm_list_1 (finish_args), scm_list_1 (finish_args));
- goto vm_error;
-
- vm_error_kwargs_length_not_even:
- SYNC_ALL ();
- err_msg = scm_from_latin1_string ("Odd length of keyword argument list");
- scm_error_scm (sym_keyword_argument_error, program, err_msg,
- SCM_EOL, SCM_BOOL_F);
-
- vm_error_kwargs_invalid_keyword:
- /* FIXME say which one it was */
- SYNC_ALL ();
- err_msg = scm_from_latin1_string ("Invalid keyword");
- scm_error_scm (sym_keyword_argument_error, program, err_msg,
- SCM_EOL, SCM_BOOL_F);
-
- vm_error_kwargs_unrecognized_keyword:
- /* FIXME say which one it was */
- SYNC_ALL ();
- err_msg = scm_from_latin1_string ("Unrecognized keyword");
- scm_error_scm (sym_keyword_argument_error, program, err_msg,
- SCM_EOL, SCM_BOOL_F);
-
- vm_error_too_many_args:
- err_msg = scm_from_latin1_string ("VM: Too many arguments");
- finish_args = scm_list_1 (scm_from_int (nargs));
- goto vm_error;
-
- vm_error_wrong_num_args:
- /* nargs and program are valid */
- SYNC_ALL ();
- scm_wrong_num_args (program);
- /* shouldn't get here */
- goto vm_error;
-
- vm_error_wrong_type_apply:
- SYNC_ALL ();
- scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
- scm_list_1 (program), scm_list_1 (program));
- goto vm_error;
-
- vm_error_stack_overflow:
- err_msg = scm_from_latin1_string ("VM: Stack overflow");
- finish_args = SCM_EOL;
- if (stack_limit < vp->stack_base + vp->stack_size)
- /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
- that `throw' below can run on this VM. */
- vp->stack_limit = vp->stack_base + vp->stack_size;
- goto vm_error;
-
- vm_error_stack_underflow:
- err_msg = scm_from_latin1_string ("VM: Stack underflow");
- finish_args = SCM_EOL;
- goto vm_error;
-
- vm_error_improper_list:
- err_msg = scm_from_latin1_string ("Expected a proper list, but got object
with tail ~s");
- goto vm_error;
-
- vm_error_not_a_pair:
- SYNC_ALL ();
- scm_wrong_type_arg_msg (func_name, 1, finish_args, "pair");
- /* shouldn't get here */
- goto vm_error;
-
- vm_error_not_a_bytevector:
- SYNC_ALL ();
- scm_wrong_type_arg_msg (func_name, 1, finish_args, "bytevector");
- /* shouldn't get here */
- goto vm_error;
-
- vm_error_not_a_struct:
- SYNC_ALL ();
- scm_wrong_type_arg_msg (func_name, 1, finish_args, "struct");
- /* shouldn't get here */
- goto vm_error;
-
- vm_error_not_a_thunk:
- SYNC_ALL ();
- scm_wrong_type_arg_msg ("dynamic-wind", 1, finish_args, "thunk");
- /* shouldn't get here */
- goto vm_error;
-
- vm_error_no_values:
- err_msg = scm_from_latin1_string ("Zero values returned to single-valued
continuation");
- finish_args = SCM_EOL;
- goto vm_error;
-
- vm_error_not_enough_values:
- err_msg = scm_from_latin1_string ("Too few values returned to
continuation");
- finish_args = SCM_EOL;
- goto vm_error;
-
- vm_error_continuation_not_rewindable:
- err_msg = scm_from_latin1_string ("Unrewindable partial continuation");
- finish_args = scm_cons (finish_args, SCM_EOL);
- goto vm_error;
-
- vm_error_bad_wide_string_length:
- err_msg = scm_from_latin1_string ("VM: Bad wide string length: ~S");
- goto vm_error;
-
-#ifdef VM_CHECK_IP
- vm_error_invalid_address:
- err_msg = scm_from_latin1_string ("VM: Invalid program address");
- finish_args = SCM_EOL;
- goto vm_error;
-#endif
-
-#if VM_CHECK_OBJECT
- vm_error_object:
- err_msg = scm_from_latin1_string ("VM: Invalid object table access");
- finish_args = SCM_EOL;
- goto vm_error;
-#endif
-
-#if VM_CHECK_FREE_VARIABLES
- vm_error_free_variable:
- err_msg = scm_from_latin1_string ("VM: Invalid free variable access");
- finish_args = SCM_EOL;
- goto vm_error;
-#endif
-
- vm_error:
- SYNC_ALL ();
+ abort (); /* never reached */
- scm_ithrow (sym_vm_error, scm_list_3 (sym_vm_run, err_msg, finish_args),
- 1);
- }
+ vm_error_bad_instruction:
+ vm_error_bad_instruction (ip[-1]);
+ abort (); /* never reached */
+ handle_overflow:
+ SYNC_ALL ();
+ vm_error_stack_overflow (vp);
abort (); /* never reached */
}
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 000397d..46d4cff 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -103,8 +103,11 @@
* Cache/Sync
*/
+#define VM_ASSERT(condition, handler) \
+ do { if (SCM_UNLIKELY (!(condition))) { SYNC_ALL(); handler; } } while (0)
+
#ifdef VM_ENABLE_ASSERTIONS
-# define ASSERT(condition) if (SCM_UNLIKELY (!(condition))) abort()
+# define ASSERT(condition) VM_ASSERT (condition, abort())
#else
# define ASSERT(condition)
#endif
@@ -191,18 +194,16 @@
/* Accesses to a program's object table. */
#if VM_CHECK_OBJECT
-#define CHECK_OBJECT(_num) \
- do { if (SCM_UNLIKELY ((_num) >= object_count)) goto vm_error_object; }
while (0)
+#define CHECK_OBJECT(_num) \
+ VM_ASSERT ((_num) < object_count, vm_error_object ())
#else
#define CHECK_OBJECT(_num)
#endif
#if VM_CHECK_FREE_VARIABLES
-#define CHECK_FREE_VARIABLE(_num) \
- do { \
- if (SCM_UNLIKELY ((_num) >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))) \
- goto vm_error_free_variable; \
- } while (0)
+#define CHECK_FREE_VARIABLE(_num) \
+ VM_ASSERT ((_num) < SCM_PROGRAM_NUM_FREE_VARIABLES (program), \
+ vm_error_free_variable ())
#else
#define CHECK_FREE_VARIABLE(_num)
#endif
@@ -276,21 +277,20 @@
# define NULLSTACK_FOR_NONLOCAL_EXIT()
#endif
-#define CHECK_OVERFLOW() \
- if (SCM_UNLIKELY (sp >= stack_limit)) \
- goto vm_error_stack_overflow
+/* For this check, we don't use VM_ASSERT, because that leads to a
+ per-site SYNC_ALL, which is too much code growth. The real problem
+ of course is having to check for overflow all the time... */
+#define CHECK_OVERFLOW() \
+ do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0)
#ifdef VM_CHECK_UNDERFLOW
-#define CHECK_UNDERFLOW() \
- if (SCM_UNLIKELY (sp <= SCM_FRAME_UPPER_ADDRESS (fp))) \
- goto vm_error_stack_underflow
#define PRE_CHECK_UNDERFLOW(N) \
- if (SCM_UNLIKELY (sp - N <= SCM_FRAME_UPPER_ADDRESS (fp))) \
- goto vm_error_stack_underflow
+ VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow
())
+#define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0)
#else
-#define CHECK_UNDERFLOW() /* nop */
#define PRE_CHECK_UNDERFLOW(N) /* nop */
+#define CHECK_UNDERFLOW() /* nop */
#endif
@@ -333,10 +333,7 @@ do \
{ \
for (; scm_is_pair (l); l = SCM_CDR (l)) \
PUSH (SCM_CAR (l)); \
- if (SCM_UNLIKELY (!NILP (l))) { \
- finish_args = scm_list_1 (l); \
- goto vm_error_improper_list; \
- } \
+ VM_ASSERT (NILP (l), vm_error_improper_list (l)); \
} while (0)
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 6fa8eb2..c323156 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001,2008,2009,2010,2011,2012 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
@@ -105,11 +105,8 @@ VM_DEFINE_LOADER (107, load_wide_string,
"load-wide-string")
scm_t_wchar *wbuf;
FETCH_LENGTH (len);
- if (SCM_UNLIKELY (len % 4))
- {
- finish_args = scm_list_1 (scm_from_size_t (len));
- goto vm_error_bad_wide_string_length;
- }
+ VM_ASSERT ((len % 4) == 0,
+ vm_error_bad_wide_string_length (len));
SYNC_REGISTER ();
PUSH (scm_i_make_wide_string (len / 4, &wbuf, 1));
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 80328cd..5191b8e 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -124,11 +124,7 @@ VM_DEFINE_FUNCTION (140, cons, "cons", 2)
}
#define VM_VALIDATE_CONS(x, proc) \
- if (SCM_UNLIKELY (!scm_is_pair (x))) \
- { func_name = proc; \
- finish_args = x; \
- goto vm_error_not_a_pair; \
- }
+ VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
VM_DEFINE_FUNCTION (141, car, "car", 1)
{
@@ -503,12 +499,7 @@ VM_DEFINE_INSTRUCTION (165, make_array, "make-array", 3,
-1, 1)
* Structs
*/
#define VM_VALIDATE_STRUCT(obj, proc) \
- if (SCM_UNLIKELY (!SCM_STRUCTP (obj))) \
- { \
- func_name = proc; \
- finish_args = (obj); \
- goto vm_error_not_a_struct; \
- }
+ VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
VM_DEFINE_FUNCTION (166, struct_p, "struct?", 1)
{
@@ -654,16 +645,7 @@ VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
* Bytevectors
*/
#define VM_VALIDATE_BYTEVECTOR(x, proc) \
- do \
- { \
- if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \
- { \
- func_name = proc; \
- finish_args = x; \
- goto vm_error_not_a_bytevector; \
- } \
- } \
- while (0)
+ VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
#define BV_REF_WITH_ENDIANNESS(stem, fn_stem) \
{ \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 474fe78..40d26af 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -31,16 +31,20 @@ VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
{
+ SCM ret;
+
nvalues = SCM_I_INUM (*sp--);
NULLSTACK (1);
+
if (nvalues == 1)
- POP (finish_args);
+ POP (ret);
else
{
- POP_LIST (nvalues);
- POP (finish_args);
SYNC_REGISTER ();
- finish_args = scm_values (finish_args);
+ sp -= nvalues;
+ CHECK_UNDERFLOW ();
+ ret = scm_c_values (sp + 1, nvalues);
+ NULLSTACK (nvalues);
}
{
@@ -58,7 +62,8 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
NULLSTACK (old_sp - sp);
}
- goto vm_done;
+ SYNC_ALL ();
+ return ret;
}
VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0)
@@ -298,20 +303,17 @@ VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref",
0, 1, 1)
unlike in top-variable-ref, it really isn't an internal assertion
that can be optimized out -- the variable could be coming directly
from the user. */
- if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
- {
- func_name = "variable-ref";
- finish_args = x;
- goto vm_error_not_a_variable;
- }
- else if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
+ VM_ASSERT (SCM_VARIABLEP (x),
+ vm_error_not_a_variable ("variable-ref", x));
+
+ if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
{
SCM var_name;
+ SYNC_ALL ();
/* Attempt to provide the variable name in the error message. */
var_name = scm_module_reverse_lookup (scm_current_module (), x);
- finish_args = scm_is_true (var_name) ? var_name : x;
- goto vm_error_unbound;
+ vm_error_unbound (program, scm_is_true (var_name) ? var_name : x);
}
else
{
@@ -326,14 +328,10 @@ VM_DEFINE_INSTRUCTION (26, variable_bound,
"variable-bound?", 0, 1, 1)
{
SCM x = *sp;
- if (SCM_UNLIKELY (!SCM_VARIABLEP (x)))
- {
- func_name = "variable-bound?";
- finish_args = x;
- goto vm_error_not_a_variable;
- }
- else
- *sp = scm_from_bool (VARIABLE_BOUNDP (x));
+ VM_ASSERT (SCM_VARIABLEP (x),
+ vm_error_not_a_variable ("variable-bound?", x));
+
+ *sp = scm_from_bool (VARIABLE_BOUNDP (x));
NEXT;
}
@@ -348,11 +346,7 @@ VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref",
1, 0, 1)
{
SYNC_REGISTER ();
resolved = resolve_variable (what, scm_program_module (program));
- if (!VARIABLE_BOUNDP (resolved))
- {
- finish_args = what;
- goto vm_error_unbound;
- }
+ VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (program, what));
what = resolved;
OBJECT_SET (objnum, what);
}
@@ -374,11 +368,8 @@ VM_DEFINE_INSTRUCTION (28, long_toplevel_ref,
"long-toplevel-ref", 2, 0, 1)
{
SYNC_REGISTER ();
resolved = resolve_variable (what, scm_program_module (program));
- if (!VARIABLE_BOUNDP (resolved))
- {
- finish_args = what;
- goto vm_error_unbound;
- }
+ VM_ASSERT (VARIABLE_BOUNDP (resolved),
+ vm_error_unbound (program, what));
what = resolved;
OBJECT_SET (objnum, what);
}
@@ -410,12 +401,8 @@ VM_DEFINE_INSTRUCTION (30, long_local_set,
"long-local-set", 2, 1, 0)
VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0)
{
- if (SCM_UNLIKELY (!SCM_VARIABLEP (sp[0])))
- {
- func_name = "variable-set!";
- finish_args = sp[0];
- goto vm_error_not_a_variable;
- }
+ VM_ASSERT (SCM_VARIABLEP (sp[0]),
+ vm_error_not_a_variable ("variable-set!", sp[0]));
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
@@ -585,8 +572,8 @@ VM_DEFINE_INSTRUCTION (44, assert_nargs_ee,
"assert-nargs-ee", 2, 0, 0)
scm_t_ptrdiff n;
n = FETCH () << 8;
n += FETCH ();
- if (sp - (fp - 1) != n)
- goto vm_error_wrong_num_args;
+ VM_ASSERT (sp - (fp - 1) == n,
+ vm_error_wrong_num_args (program));
NEXT;
}
@@ -595,8 +582,8 @@ VM_DEFINE_INSTRUCTION (45, assert_nargs_ge,
"assert-nargs-ge", 2, 0, 0)
scm_t_ptrdiff n;
n = FETCH () << 8;
n += FETCH ();
- if (sp - (fp - 1) < n)
- goto vm_error_wrong_num_args;
+ VM_ASSERT (sp - (fp - 1) >= n,
+ vm_error_wrong_num_args (program));
NEXT;
}
@@ -666,9 +653,9 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5,
0, 0)
nkw += FETCH ();
kw_and_rest_flags = FETCH ();
- if (!(kw_and_rest_flags & F_REST)
- && ((sp - (fp - 1) - nkw) % 2))
- goto vm_error_kwargs_length_not_even;
+ VM_ASSERT ((kw_and_rest_flags & F_REST)
+ || ((sp - (fp - 1) - nkw) % 2) == 0,
+ vm_error_kwargs_length_not_even (program))
CHECK_OBJECT (idx);
kw = OBJECT_REF (idx);
@@ -690,13 +677,14 @@ VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5,
0, 0)
break;
}
}
- if (!(kw_and_rest_flags & F_ALLOW_OTHER_KEYS) && !scm_is_pair (walk))
- goto vm_error_kwargs_unrecognized_keyword;
-
+ VM_ASSERT (scm_is_pair (walk)
+ || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS),
+ vm_error_kwargs_unrecognized_keyword (program));
nkw++;
}
- else if (!(kw_and_rest_flags & F_REST))
- goto vm_error_kwargs_invalid_keyword;
+ else
+ VM_ASSERT (kw_and_rest_flags & F_REST,
+ vm_error_kwargs_invalid_keyword (program));
}
NEXT;
@@ -776,30 +764,8 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
nargs = FETCH ();
vm_call:
- program = sp[-nargs];
-
VM_HANDLE_INTERRUPTS;
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
- goto vm_call;
- }
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
- && SCM_SMOB_APPLICABLE_P (program))
- {
- SYNC_REGISTER ();
- sp[-nargs] = scm_i_smob_apply_trampoline (program);
- goto vm_call;
- }
- else
- goto vm_error_wrong_type_apply;
- }
-
- CACHE_PROGRAM ();
-
{
SCM *old_fp = fp;
@@ -813,8 +779,16 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
}
- ip = SCM_C_OBJCODE_BASE (bp);
PUSH_CONTINUATION_HOOK ();
+
+ program = fp[-1];
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+ goto apply;
+
+ CACHE_PROGRAM ();
+ ip = SCM_C_OBJCODE_BASE (bp);
+
APPLY_HOOK ();
NEXT;
}
@@ -824,50 +798,34 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1,
1)
nargs = FETCH ();
vm_tail_call:
- program = sp[-nargs];
-
VM_HANDLE_INTERRUPTS;
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
- goto vm_tail_call;
- }
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
- && SCM_SMOB_APPLICABLE_P (program))
- {
- SYNC_REGISTER ();
- sp[-nargs] = scm_i_smob_apply_trampoline (program);
- goto vm_tail_call;
- }
- else
- goto vm_error_wrong_type_apply;
- }
- else
- {
- int i;
+ {
+ int i;
#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp = sp;
- CHECK_STACK_LEAK ();
+ SCM *old_sp = sp;
+ CHECK_STACK_LEAK ();
#endif
- /* switch programs */
- CACHE_PROGRAM ();
- /* shuffle down the program and the arguments */
- for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
- SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
+ /* shuffle down the program and the arguments */
+ for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
+ SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
- sp = fp + i - 1;
+ sp = fp + i - 1;
- NULLSTACK (old_sp - sp);
+ NULLSTACK (old_sp - sp);
+ }
- ip = SCM_C_OBJCODE_BASE (bp);
+ program = fp[-1];
- APPLY_HOOK ();
- NEXT;
- }
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+ goto apply;
+
+ CACHE_PROGRAM ();
+ ip = SCM_C_OBJCODE_BASE (bp);
+
+ APPLY_HOOK ();
+ NEXT;
}
VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
@@ -1035,10 +993,8 @@ VM_DEFINE_INSTRUCTION (59, partial_cont_call,
"partial-cont-call", 0, -1, 0)
SCM vmcont, intwinds, prevwinds;
POP2 (intwinds, vmcont);
SYNC_REGISTER ();
- if (SCM_UNLIKELY (!SCM_VM_CONT_REWINDABLE_P (vmcont)))
- { finish_args = vmcont;
- goto vm_error_continuation_not_rewindable;
- }
+ VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
+ vm_error_continuation_not_rewindable (vmcont));
prevwinds = scm_i_dynwinds ();
vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
vm_cookie);
@@ -1079,51 +1035,33 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
{
scm_t_int32 offset;
scm_t_uint8 *mvra;
+ SCM *old_fp = fp;
nargs = FETCH ();
FETCH_OFFSET (offset);
mvra = ip + offset;
- vm_mv_call:
- program = sp[-nargs];
-
VM_HANDLE_INTERRUPTS;
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- {
- sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
- goto vm_mv_call;
- }
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
- && SCM_SMOB_APPLICABLE_P (program))
- {
- SYNC_REGISTER ();
- sp[-nargs] = scm_i_smob_apply_trampoline (program);
- goto vm_mv_call;
- }
- else
- goto vm_error_wrong_type_apply;
- }
+ fp = sp - nargs + 1;
+
+ ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
+ ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+ ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+ SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
+
+ PUSH_CONTINUATION_HOOK ();
- CACHE_PROGRAM ();
+ program = fp[-1];
- {
- SCM *old_fp = fp;
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+ goto apply;
- fp = sp - nargs + 1;
-
- ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
- }
-
+ CACHE_PROGRAM ();
ip = SCM_C_OBJCODE_BASE (bp);
- PUSH_CONTINUATION_HOOK ();
+
APPLY_HOOK ();
NEXT;
}
@@ -1138,12 +1076,8 @@ VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
ASSERT (nargs >= 2);
len = scm_ilength (ls);
- if (SCM_UNLIKELY (len < 0))
- {
- finish_args = ls;
- goto vm_error_apply_to_non_list;
- }
-
+ VM_ASSERT (len >= 0,
+ vm_error_apply_to_non_list (ls));
PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
nargs += len - 2;
@@ -1160,12 +1094,8 @@ VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1,
-1, 1)
ASSERT (nargs >= 2);
len = scm_ilength (ls);
- if (SCM_UNLIKELY (len < 0))
- {
- finish_args = ls;
- goto vm_error_apply_to_non_list;
- }
-
+ VM_ASSERT (len >= 0,
+ vm_error_apply_to_non_list (ls));
PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
nargs += len - 2;
@@ -1330,7 +1260,10 @@ VM_DEFINE_INSTRUCTION (68, return_values,
"return/values", 1, -1, -1)
NULLSTACK (vals + nvalues - sp);
}
else
- goto vm_error_no_values;
+ {
+ SYNC_ALL ();
+ vm_error_no_values ();
+ }
/* Restore the last program */
program = SCM_FRAME_PROGRAM (fp);
@@ -1354,10 +1287,7 @@ VM_DEFINE_INSTRUCTION (69, return_values_star,
"return/values*", 1, -1, -1)
l = SCM_CDR (l);
nvalues++;
}
- if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) {
- finish_args = scm_list_1 (l);
- goto vm_error_improper_list;
- }
+ VM_ASSERT (SCM_NULL_OR_NIL_P (l), vm_error_improper_list (l));
goto vm_return_values;
}
@@ -1383,8 +1313,7 @@ VM_DEFINE_INSTRUCTION (71, truncate_values,
"truncate-values", 2, -1, -1)
if (rest)
nbinds--;
- if (nvalues < nbinds)
- goto vm_error_not_enough_values;
+ VM_ASSERT (nvalues >= nbinds, vm_error_not_enough_values ());
if (rest)
POP_LIST (nvalues - nbinds);
@@ -1517,9 +1446,7 @@ VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
SCM sym, val;
POP2 (sym, val);
SYNC_REGISTER ();
- VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
- SCM_BOOL_T),
- val);
+ scm_define (sym, val);
NEXT;
}
@@ -1585,16 +1512,10 @@ VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
/* Push wind and unwind procedures onto the dynamic stack. Note that neither
are actually called; the compiler should emit calls to wind and unwind for
the normal dynamic-wind control flow. */
- if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (wind))))
- {
- finish_args = wind;
- goto vm_error_not_a_thunk;
- }
- if (SCM_UNLIKELY (scm_is_false (scm_thunk_p (unwind))))
- {
- finish_args = unwind;
- goto vm_error_not_a_thunk;
- }
+ VM_ASSERT (scm_to_bool (scm_thunk_p (wind)),
+ vm_error_not_a_thunk ("dynamic-wind", wind));
+ VM_ASSERT (scm_to_bool (scm_thunk_p (unwind)),
+ vm_error_not_a_thunk ("dynamic-wind", unwind));
scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
NEXT;
}
@@ -1603,8 +1524,7 @@ VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
{
unsigned n = FETCH ();
SYNC_REGISTER ();
- if (sp - n - 2 <= SCM_FRAME_UPPER_ADDRESS (fp))
- goto vm_error_stack_underflow;
+ PRE_CHECK_UNDERFLOW (n + 2);
vm_abort (vm, n, vm_cookie);
/* vm_abort should not return */
abort ();
@@ -1662,11 +1582,8 @@ VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1,
1)
SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
if (scm_is_eq (val, SCM_UNDEFINED))
val = SCM_I_FLUID_DEFAULT (*sp);
- if (SCM_UNLIKELY (scm_is_eq (val, SCM_UNDEFINED)))
- {
- finish_args = *sp;
- goto vm_error_unbound_fluid;
- }
+ VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
+ vm_error_unbound_fluid (program, *sp));
*sp = val;
}
@@ -1701,8 +1618,8 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals,
"assert-nargs-ee/locals", 1,
/* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
n = FETCH ();
- if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
- goto vm_error_wrong_num_args;
+ VM_ASSERT (sp - (fp - 1) == (n & 0x7),
+ vm_error_wrong_num_args (program));
old_sp = sp;
sp += (n >> 3);
diff --git a/libguile/vm.c b/libguile/vm.c
index 8fae656..5dec106 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -370,54 +370,236 @@ scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
scm_puts (">", port);
}
-static SCM
-really_make_boot_program (long nargs)
+
+/*
+ * VM Error Handling
+ */
+
+static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
+static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN;
+static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN;
+static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN;
+static void vm_error_not_a_variable (const char *func_name, SCM x)
SCM_NORETURN;
+static void vm_error_not_a_thunk (const char *func_name, SCM x) SCM_NORETURN;
+static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN;
+static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN;
+static void vm_error_kwargs_invalid_keyword (SCM proc) SCM_NORETURN;
+static void vm_error_kwargs_unrecognized_keyword (SCM proc) SCM_NORETURN;
+static void vm_error_too_many_args (int nargs) SCM_NORETURN;
+static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN;
+static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN;
+static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN;
+static void vm_error_stack_underflow (void) SCM_NORETURN;
+static void vm_error_improper_list (SCM x) SCM_NORETURN;
+static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN;
+static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN;
+static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN;
+static void vm_error_no_values (void) SCM_NORETURN;
+static void vm_error_not_enough_values (void) SCM_NORETURN;
+static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN;
+static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN;
+#if VM_CHECK_IP
+static void vm_error_invalid_address (void) SCM_NORETURN;
+#endif
+#if VM_CHECK_OBJECT
+static void vm_error_object (void) SCM_NORETURN;
+#endif
+#if VM_CHECK_FREE_VARIABLES
+static void vm_error_free_variable (void) SCM_NORETURN;
+#endif
+
+static void
+vm_error (const char *msg, SCM arg)
{
- SCM u8vec;
- scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
- scm_op_make_int8_1, scm_op_halt };
- struct scm_objcode *bp;
- SCM ret;
+ scm_throw (sym_vm_error,
+ scm_list_3 (sym_vm_run, scm_from_latin1_string (msg),
+ SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg)));
+ abort(); /* not reached */
+}
- if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
- scm_misc_error ("vm-engine", "too many args when making boot procedure",
- scm_list_1 (scm_from_long (nargs)));
+static void
+vm_error_bad_instruction (scm_t_uint32 inst)
+{
+ vm_error ("VM: Bad instruction: ~s", scm_from_uint32 (inst));
+}
- text[1] = (scm_t_uint8)nargs;
+static void
+vm_error_unbound (SCM proc, SCM sym)
+{
+ scm_error_scm (scm_misc_error_key, proc,
+ scm_from_latin1_string ("Unbound variable: ~s"),
+ scm_list_1 (sym), SCM_BOOL_F);
+}
- bp = scm_gc_malloc_pointerless (sizeof (struct scm_objcode) + sizeof (text),
- "boot-program");
- memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
- bp->len = sizeof(text);
- bp->metalen = 0;
+static void
+vm_error_unbound_fluid (SCM proc, SCM fluid)
+{
+ scm_error_scm (scm_misc_error_key, proc,
+ scm_from_latin1_string ("Unbound fluid: ~s"),
+ scm_list_1 (fluid), SCM_BOOL_F);
+}
- u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
- sizeof (struct scm_objcode) + sizeof
(text));
- ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
- SCM_BOOL_F, SCM_BOOL_F);
- SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
+static void
+vm_error_not_a_variable (const char *func_name, SCM x)
+{
+ scm_error (scm_arg_type_key, func_name, "Not a variable: ~S",
+ scm_list_1 (x), scm_list_1 (x));
+}
- return ret;
+static void
+vm_error_not_a_thunk (const char *func_name, SCM x)
+{
+ scm_error (scm_arg_type_key, func_name, "Not a thunk: ~S",
+ scm_list_1 (x), scm_list_1 (x));
}
-#define NUM_BOOT_PROGS 8
-static SCM
-vm_make_boot_program (long nargs)
+
+static void
+vm_error_apply_to_non_list (SCM x)
{
- static SCM programs[NUM_BOOT_PROGS] = { SCM_BOOL_F, };
+ scm_error (scm_arg_type_key, "apply", "Apply to non-list: ~S",
+ scm_list_1 (x), scm_list_1 (x));
+}
- if (SCM_UNLIKELY (scm_is_false (programs[0])))
- {
- int i;
- for (i = 0; i < NUM_BOOT_PROGS; i++)
- programs[i] = really_make_boot_program (i);
- }
-
- if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
- return programs[nargs];
+static void
+vm_error_kwargs_length_not_even (SCM proc)
+{
+ scm_error_scm (sym_keyword_argument_error, proc,
+ scm_from_latin1_string ("Odd length of keyword argument
list"),
+ SCM_EOL, SCM_BOOL_F);
+}
+
+static void
+vm_error_kwargs_invalid_keyword (SCM proc)
+{
+ scm_error_scm (sym_keyword_argument_error, proc,
+ scm_from_latin1_string ("Invalid keyword"),
+ SCM_EOL, SCM_BOOL_F);
+}
+
+static void
+vm_error_kwargs_unrecognized_keyword (SCM proc)
+{
+ scm_error_scm (sym_keyword_argument_error, proc,
+ scm_from_latin1_string ("Unrecognized keyword"),
+ SCM_EOL, SCM_BOOL_F);
+}
+
+static void
+vm_error_too_many_args (int nargs)
+{
+ vm_error ("VM: Too many arguments", scm_from_int (nargs));
+}
+
+static void
+vm_error_wrong_num_args (SCM proc)
+{
+ scm_wrong_num_args (proc);
+}
+
+static void
+vm_error_wrong_type_apply (SCM proc)
+{
+ scm_error (scm_arg_type_key, NULL, "Wrong type to apply: ~S",
+ scm_list_1 (proc), scm_list_1 (proc));
+}
+
+static void
+vm_error_stack_overflow (struct scm_vm *vp)
+{
+ if (vp->stack_limit < vp->stack_base + vp->stack_size)
+ /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
+ that `throw' below can run on this VM. */
+ vp->stack_limit = vp->stack_base + vp->stack_size;
else
- return really_make_boot_program (nargs);
+ /* There is no space left on the stack. FIXME: Do something more
+ sensible here! */
+ abort ();
+ vm_error ("VM: Stack overflow", SCM_UNDEFINED);
+}
+
+static void
+vm_error_stack_underflow (void)
+{
+ vm_error ("VM: Stack underflow", SCM_UNDEFINED);
}
+static void
+vm_error_improper_list (SCM x)
+{
+ vm_error ("Expected a proper list, but got object with tail ~s", x);
+}
+
+static void
+vm_error_not_a_pair (const char *subr, SCM x)
+{
+ scm_wrong_type_arg_msg (subr, 1, x, "pair");
+}
+
+static void
+vm_error_not_a_bytevector (const char *subr, SCM x)
+{
+ scm_wrong_type_arg_msg (subr, 1, x, "bytevector");
+}
+
+static void
+vm_error_not_a_struct (const char *subr, SCM x)
+{
+ scm_wrong_type_arg_msg (subr, 1, x, "struct");
+}
+
+static void
+vm_error_no_values (void)
+{
+ vm_error ("Zero values returned to single-valued continuation",
+ SCM_UNDEFINED);
+}
+
+static void
+vm_error_not_enough_values (void)
+{
+ vm_error ("Too few values returned to continuation", SCM_UNDEFINED);
+}
+
+static void
+vm_error_continuation_not_rewindable (SCM cont)
+{
+ vm_error ("Unrewindable partial continuation", cont);
+}
+
+static void
+vm_error_bad_wide_string_length (size_t len)
+{
+ vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
+}
+
+#ifdef VM_CHECK_IP
+static void
+vm_error_invalid_address (void)
+{
+ vm_error ("VM: Invalid program address", SCM_UNDEFINED);
+}
+#endif
+
+#if VM_CHECK_OBJECT
+static void
+vm_error_object ()
+{
+ vm_error ("VM: Invalid object table access", SCM_UNDEFINED);
+}
+#endif
+
+#if VM_CHECK_FREE_VARIABLES
+static void
+vm_error_free_variable ()
+{
+ vm_error ("VM: Invalid free variable access", SCM_UNDEFINED);
+}
+#endif
+
+
+
+static SCM boot_continuation;
+
/*
* VM
@@ -428,18 +610,10 @@ resolve_variable (SCM what, SCM program_module)
{
if (SCM_LIKELY (scm_is_symbol (what)))
{
- if (SCM_LIKELY (scm_module_system_booted_p
- && scm_is_true (program_module)))
- /* might longjmp */
+ if (scm_is_true (program_module))
return scm_module_lookup (program_module, what);
else
- {
- SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
- if (scm_is_false (v))
- scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
- else
- return v;
- }
+ return scm_module_lookup (scm_the_root_module (), what);
}
else
{
@@ -878,6 +1052,33 @@ SCM scm_load_compiled_with_vm (SCM file)
return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
}
+
+static SCM
+make_boot_program (void)
+{
+ struct scm_objcode *bp;
+ size_t bp_size;
+ SCM u8vec, ret;
+
+ const scm_t_uint8 text[] = {
+ scm_op_make_int8_1,
+ scm_op_halt
+ };
+
+ bp_size = sizeof (struct scm_objcode) + sizeof (text);
+ bp = scm_gc_malloc_pointerless (bp_size, "boot-program");
+ memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
+ bp->len = sizeof(text);
+ bp->metalen = 0;
+
+ u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size);
+ ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
+ SCM_BOOL_F, SCM_BOOL_F);
+ SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT));
+
+ return ret;
+}
+
void
scm_bootstrap_vm (void)
{
@@ -891,6 +1092,8 @@ scm_bootstrap_vm (void)
sym_regular = scm_from_latin1_symbol ("regular");
sym_debug = scm_from_latin1_symbol ("debug");
+ boot_continuation = make_boot_program ();
+
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vm_stack_gc_kind =
GC_new_kind (GC_new_free_list (),
diff --git a/libguile/vports.c b/libguile/vports.c
index 5178d79..75e7df3 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -56,21 +56,11 @@ sf_flush (SCM port)
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM stream = SCM_PACK (pt->stream);
- if (pt->write_pos > pt->write_buf)
- {
- /* write the byte. */
- scm_call_1 (SCM_SIMPLE_VECTOR_REF (stream, 0),
- SCM_MAKE_CHAR (*pt->write_buf));
- pt->write_pos = pt->write_buf;
-
- /* flush the output. */
- {
- SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);
+ SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);
+
+ if (scm_is_true (f))
+ scm_call_0 (f);
- if (scm_is_true (f))
- scm_call_0 (f);
- }
- }
}
static void
diff --git a/libguile/weaks.c b/libguile/weaks.c
index 92d351e..79ae1fe 100644
--- a/libguile/weaks.c
+++ b/libguile/weaks.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2006, 2008, 2009, 2010,
+ * 2011, 2012 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -63,8 +64,7 @@ scm_weak_car_pair (SCM car, SCM cdr)
if (SCM_NIMP (car))
/* Weak car cells make sense iff the car is non-immediate. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
- (GC_PTR) SCM2PTR (car));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_0, SCM2PTR (car));
return (SCM_PACK (cell));
}
@@ -82,8 +82,7 @@ scm_weak_cdr_pair (SCM car, SCM cdr)
if (SCM_NIMP (cdr))
/* Weak cdr cells make sense iff the cdr is non-immediate. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
- (GC_PTR) SCM2PTR (cdr));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_1, SCM2PTR (cdr));
return (SCM_PACK (cell));
}
@@ -99,11 +98,9 @@ scm_doubly_weak_pair (SCM car, SCM cdr)
cell->word_1 = cdr;
if (SCM_NIMP (car))
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
- (GC_PTR) SCM2PTR (car));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_0, SCM2PTR (car));
if (SCM_NIMP (cdr))
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
- (GC_PTR) SCM2PTR (cdr));
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_1, SCM2PTR (cdr));
return (SCM_PACK (cell));
}
diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4
index 623253f..37df6fc 100644
--- a/m4/canonicalize.m4
+++ b/m4/canonicalize.m4
@@ -1,4 +1,4 @@
-# canonicalize.m4 serial 23
+# canonicalize.m4 serial 24
dnl Copyright (C) 2003-2007, 2009-2012 Free Software Foundation, Inc.
@@ -16,8 +16,11 @@ AC_DEFUN([gl_FUNC_CANONICALIZE_FILENAME_MODE],
AC_REQUIRE([gl_FUNC_REALPATH_WORKS])
if test $ac_cv_func_canonicalize_file_name = no; then
HAVE_CANONICALIZE_FILE_NAME=0
- elif test "$gl_cv_func_realpath_works" != yes; then
- REPLACE_CANONICALIZE_FILE_NAME=1
+ else
+ case "$gl_cv_func_realpath_works" in
+ *yes) ;;
+ *) REPLACE_CANONICALIZE_FILE_NAME=1 ;;
+ esac
fi
])
@@ -30,12 +33,21 @@ AC_DEFUN([gl_CANONICALIZE_LGPL],
HAVE_CANONICALIZE_FILE_NAME=0
if test $ac_cv_func_realpath = no; then
HAVE_REALPATH=0
- elif test "$gl_cv_func_realpath_works" != yes; then
- REPLACE_REALPATH=1
+ else
+ case "$gl_cv_func_realpath_works" in
+ *yes) ;;
+ *) REPLACE_REALPATH=1 ;;
+ esac
fi
- elif test "$gl_cv_func_realpath_works" != yes; then
- REPLACE_CANONICALIZE_FILE_NAME=1
- REPLACE_REALPATH=1
+ else
+ case "$gl_cv_func_realpath_works" in
+ *yes)
+ ;;
+ *)
+ REPLACE_CANONICALIZE_FILE_NAME=1
+ REPLACE_REALPATH=1
+ ;;
+ esac
fi
])
@@ -56,6 +68,7 @@ AC_DEFUN([gl_CANONICALIZE_LGPL_SEPARATE],
AC_DEFUN([gl_FUNC_REALPATH_WORKS],
[
AC_CHECK_FUNCS_ONCE([realpath])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether realpath works], [gl_cv_func_realpath_works], [
touch conftest.a
mkdir conftest.d
@@ -89,13 +102,23 @@ AC_DEFUN([gl_FUNC_REALPATH_WORKS],
}
return result;
]])
- ], [gl_cv_func_realpath_works=yes], [gl_cv_func_realpath_works=no],
- [gl_cv_func_realpath_works="guessing no"])
+ ],
+ [gl_cv_func_realpath_works=yes],
+ [gl_cv_func_realpath_works=no],
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *gnu*) gl_cv_func_realpath_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_realpath_works="guessing no" ;;
+ esac
+ ])
rm -rf conftest.a conftest.d
])
- if test "$gl_cv_func_realpath_works" = yes; then
- AC_DEFINE([FUNC_REALPATH_WORKS], [1], [Define to 1 if realpath()
- can malloc memory, always gives an absolute path, and handles
- trailing slash correctly.])
- fi
+ case "$gl_cv_func_realpath_works" in
+ *yes)
+ AC_DEFINE([FUNC_REALPATH_WORKS], [1], [Define to 1 if realpath()
+ can malloc memory, always gives an absolute path, and handles
+ trailing slash correctly.])
+ ;;
+ esac
])
diff --git a/m4/ceil.m4 b/m4/ceil.m4
index fd9ac4c..890517b 100644
--- a/m4/ceil.m4
+++ b/m4/ceil.m4
@@ -1,4 +1,4 @@
-# ceil.m4 serial 8
+# ceil.m4 serial 9
dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -15,6 +15,7 @@ AC_DEFUN([gl_FUNC_CEIL],
fi
m4_ifdef([gl_FUNC_CEIL_IEEE], [
if test $gl_ceil_required = ieee && test $REPLACE_CEIL = 0; then
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether ceil works according to ISO C 99 with IEC 60559],
[gl_cv_func_ceil_ieee],
[
@@ -44,7 +45,13 @@ int main (int argc, char *argv[])
]])],
[gl_cv_func_ceil_ieee=yes],
[gl_cv_func_ceil_ieee=no],
- [gl_cv_func_ceil_ieee="guessing no"])
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_ceil_ieee="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_ceil_ieee="guessing no" ;;
+ esac
+ ])
LIBS="$save_LIBS"
])
case "$gl_cv_func_ceil_ieee" in
diff --git a/m4/check-math-lib.m4 b/m4/check-math-lib.m4
index 0b77d8f..4f370eb 100644
--- a/m4/check-math-lib.m4
+++ b/m4/check-math-lib.m4
@@ -1,10 +1,10 @@
-# check-math-lib.m4 serial 3
+# check-math-lib.m4 serial 4
dnl Copyright (C) 2007, 2009-2012 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
-dnl gl_CHECK_MATH_LIB (VARIABLE, EXPRESSION)
+dnl gl_CHECK_MATH_LIB (VARIABLE, EXPRESSION [, EXTRA-CODE])
dnl
dnl Sets the shell VARIABLE according to the libraries needed by EXPRESSION
dnl to compile and link: to the empty string if no extra libraries are needed,
@@ -22,6 +22,7 @@ AC_DEFUN([gl_CHECK_MATH_LIB], [
# define __NO_MATH_INLINES 1 /* for glibc */
#endif
#include <math.h>
+ $3
double x;]],
[$2])],
[$1=$libm
diff --git a/m4/clock_time.m4 b/m4/clock_time.m4
new file mode 100644
index 0000000..fb3a17a
--- /dev/null
+++ b/m4/clock_time.m4
@@ -0,0 +1,38 @@
+# clock_time.m4 serial 10
+dnl Copyright (C) 2002-2006, 2009-2012 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.
+
+# Check for clock_gettime and clock_settime, and set LIB_CLOCK_GETTIME.
+# For a program named, say foo, you should add a line like the following
+# in the corresponding Makefile.am file:
+# foo_LDADD = $(LDADD) $(LIB_CLOCK_GETTIME)
+
+AC_DEFUN([gl_CLOCK_TIME],
+[
+ dnl Persuade glibc and Solaris <time.h> to declare these functions.
+ AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+
+ # Solaris 2.5.1 needs -lposix4 to get the clock_gettime function.
+ # Solaris 7 prefers the library name -lrt to the obsolescent name -lposix4.
+
+ # Save and restore LIBS so e.g., -lrt, isn't added to it. Otherwise, *all*
+ # programs in the package would end up linked with that potentially-shared
+ # library, inducing unnecessary run-time overhead.
+ LIB_CLOCK_GETTIME=
+ AC_SUBST([LIB_CLOCK_GETTIME])
+ gl_saved_libs=$LIBS
+ AC_SEARCH_LIBS([clock_gettime], [rt posix4],
+ [if test "$ac_cv_search_clock_gettime" = "none required";
then
+ AC_SEARCH_LIBS([clock_getcpuclockid], [rt posix4],
+ [test "$ac_cv_search_clock_getcpuclockid"
= "none required" \
+ ||
LIB_CLOCK_GETTIME=$ac_cv_search_clock_getcpuclockid],
+ [test "$ac_cv_search_clock_gettime" =
"none required" \
+ ||
LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime])
+ else
+ LIB_CLOCK_GETTIME=$ac_cv_search_clock_gettime
+ fi])
+ AC_CHECK_FUNCS([clock_gettime clock_settime clock_getcpuclockid])
+ LIBS=$gl_saved_libs
+])
diff --git a/m4/errno_h.m4 b/m4/errno_h.m4
index 4f0bb83..1e76ba2 100644
--- a/m4/errno_h.m4
+++ b/m4/errno_h.m4
@@ -1,4 +1,4 @@
-# errno_h.m4 serial 10
+# errno_h.m4 serial 11
dnl Copyright (C) 2004, 2006, 2008-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -10,6 +10,9 @@ AC_DEFUN_ONCE([gl_HEADER_ERRNO_H],
AC_CACHE_CHECK([for complete errno.h], [gl_cv_header_errno_h_complete], [
AC_EGREP_CPP([booboo],[
#include <errno.h>
+#if !defined ETXTBSY
+booboo
+#endif
#if !defined ENOMSG
booboo
#endif
@@ -49,6 +52,12 @@ booboo
#if !defined ECANCELED
booboo
#endif
+#if !defined EOWNERDEAD
+booboo
+#endif
+#if !defined ENOTRECOVERABLE
+booboo
+#endif
],
[gl_cv_header_errno_h_complete=no],
[gl_cv_header_errno_h_complete=yes])
diff --git a/m4/exponentd.m4 b/m4/exponentd.m4
index 48df999..0ae4ccf 100644
--- a/m4/exponentd.m4
+++ b/m4/exponentd.m4
@@ -1,4 +1,4 @@
-# exponentd.m4 serial 2
+# exponentd.m4 serial 3
dnl Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -80,7 +80,8 @@ int main ()
dnl different sets of instructions: The older FPA instructions assume
dnl that they are stored in big-endian word order, while the words
dnl (like integer types) are stored in little-endian byte order.
- dnl The newer VFP instructions assume little-endian order
consistenly.
+ dnl The newer VFP instructions assume little-endian order
+ dnl consistently.
AC_EGREP_CPP([mixed_endianness], [
#if defined arm || defined __arm || defined __arm__
mixed_endianness
diff --git a/m4/extensions.m4 b/m4/extensions.m4
index 0bfaef6..6d17d8a 100644
--- a/m4/extensions.m4
+++ b/m4/extensions.m4
@@ -1,4 +1,4 @@
-# serial 11 -*- Autoconf -*-
+# serial 12 -*- Autoconf -*-
# Enable extensions on systems that normally disable them.
# Copyright (C) 2003, 2006-2012 Free Software Foundation, Inc.
@@ -67,7 +67,7 @@ AC_BEFORE([$0], [AC_RUN_IFELSE])dnl
#ifndef _ALL_SOURCE
# undef _ALL_SOURCE
#endif
-/* Enable general extensions on MacOS X. */
+/* Enable general extensions on Mac OS X. */
#ifndef _DARWIN_C_SOURCE
# undef _DARWIN_C_SOURCE
#endif
diff --git a/m4/floor.m4 b/m4/floor.m4
index 501d636..a6e7ec8 100644
--- a/m4/floor.m4
+++ b/m4/floor.m4
@@ -1,4 +1,4 @@
-# floor.m4 serial 7
+# floor.m4 serial 8
dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -15,6 +15,7 @@ AC_DEFUN([gl_FUNC_FLOOR],
fi
m4_ifdef([gl_FUNC_FLOOR_IEEE], [
if test $gl_floor_required = ieee && test $REPLACE_FLOOR = 0; then
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether floor works according to ISO C 99 with IEC
60559],
[gl_cv_func_floor_ieee],
[
@@ -40,7 +41,13 @@ int main (int argc, char *argv[])
]])],
[gl_cv_func_floor_ieee=yes],
[gl_cv_func_floor_ieee=no],
- [gl_cv_func_floor_ieee="guessing no"])
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_floor_ieee="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_floor_ieee="guessing no" ;;
+ esac
+ ])
LIBS="$save_LIBS"
])
case "$gl_cv_func_floor_ieee" in
diff --git a/m4/fpieee.m4 b/m4/fpieee.m4
index 93b8d90..82fd778 100644
--- a/m4/fpieee.m4
+++ b/m4/fpieee.m4
@@ -1,4 +1,4 @@
-# fpieee.m4 serial 1
+# fpieee.m4 serial 2
dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -36,9 +36,11 @@ AC_DEFUN([gl_FP_IEEE],
#
<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.
+ # For full IEEE compliance (rarely needed), use option
-mieee-with-inexact.
CPPFLAGS="$CPPFLAGS -mieee"
else
- # Compaq (ex-DEC) C has the option -ieee.
+ # Compaq (ex-DEC) C has the option -ieee, equivalent to
-ieee_with_no_inexact.
+ # For full IEEE compliance (rarely needed), use option
-ieee_with_inexact.
CPPFLAGS="$CPPFLAGS -ieee"
fi
;;
diff --git a/m4/frexp.m4 b/m4/frexp.m4
index 4162195..fb8db70 100644
--- a/m4/frexp.m4
+++ b/m4/frexp.m4
@@ -1,4 +1,4 @@
-# frexp.m4 serial 13
+# frexp.m4 serial 14
dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -107,7 +107,7 @@ AC_DEFUN([gl_FUNC_FREXP_WORKS],
/* HP cc on HP-UX 10.20 has a bug with the constant expression -0.0.
ICC 10.0 has a bug when optimizing the expression -zero.
The expression -DBL_MIN * DBL_MIN does not work when cross-compiling
- to PowerPC on MacOS X 10.5. */
+ to PowerPC on Mac OS X 10.5. */
#if defined __hpux || defined __sgi || defined __ICC
static double
compute_minus_zero (void)
diff --git a/m4/fstat.m4 b/m4/fstat.m4
index e3f8f3e..3ab3297 100644
--- a/m4/fstat.m4
+++ b/m4/fstat.m4
@@ -1,4 +1,4 @@
-# fstat.m4 serial 1
+# fstat.m4 serial 3
dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -7,16 +7,27 @@ dnl with or without modifications, as long as this notice is
preserved.
AC_DEFUN([gl_FUNC_FSTAT],
[
AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS])
+
AC_REQUIRE([gl_MSVC_INVAL])
if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then
REPLACE_FSTAT=1
fi
+
+ AC_REQUIRE([gl_HEADER_SYS_STAT_H])
+ if test $WINDOWS_64_BIT_ST_SIZE = 1; then
+ REPLACE_FSTAT=1
+ fi
+
dnl Replace fstat() for supporting the gnulib-defined open() on directories.
m4_ifdef([gl_FUNC_FCHDIR], [
gl_TEST_FCHDIR
- if test $HAVE_FCHDIR = 0 \
- && test "$gl_cv_func_open_directory_works" != yes; then
- REPLACE_FSTAT=1
+ if test $HAVE_FCHDIR = 0; then
+ case "$gl_cv_func_open_directory_works" in
+ *yes) ;;
+ *)
+ REPLACE_FSTAT=1
+ ;;
+ esac
fi
])
])
diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4
index 7b6644a..654224f 100644
--- a/m4/gnulib-cache.m4
+++ b/m4/gnulib-cache.m4
@@ -27,7 +27,7 @@
# Specification in the form of a command-line invocation:
-# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu
--source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap canonicalize-lgpl ceil close connect dirfd duplocale
environ extensions flock floor fpieee frexp full-read full-write func gendocs
getaddrinfo getpeername getsockname getsockopt git-version-gen
gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf
inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility
libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu
malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename send
sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh
string sys_stat trunc verify vsnprintf warnings wchar
+# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu
--source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests
--aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool
--macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen
autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd
duplocale environ extensions flock floor fpieee frexp full-read full-write func
gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen
gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf
inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility
libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu
malloca nl_langinfo nproc open pipe2 putenv recv recvfrom regex rename send
sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh
string sys_stat trunc verify vsnprintf warnings wchar
# Specification in the form of a few gnulib-tool.m4 macro invocations:
gl_LOCAL_DIR([gnulib-local])
@@ -41,6 +41,7 @@ gl_MODULES([
byteswap
canonicalize-lgpl
ceil
+ clock-time
close
connect
dirfd
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4
index ae4d254..15d2b2b 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -1,4 +1,4 @@
-# gnulib-common.m4 serial 32
+# gnulib-common.m4 serial 33
dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -14,7 +14,8 @@ AC_DEFUN([gl_COMMON], [
AC_DEFUN([gl_COMMON_BODY], [
AH_VERBATIM([_Noreturn],
[/* The _Noreturn keyword of C11. */
-#ifndef _Noreturn
+#if ! (defined _Noreturn \
+ || (defined __STDC_VERSION__ && 201112 <= __STDC_VERSION__))
# if (3 <= __GNUC__ || (__GNUC__ == 2 && 8 <= __GNUC_MINOR__) \
|| 0x5110 <= __SUNPRO_C)
# define _Noreturn __attribute__ ((__noreturn__))
@@ -29,7 +30,7 @@ AC_DEFUN([gl_COMMON_BODY], [
[/* Work around a bug in Apple GCC 4.0.1 build 5465: In C99 mode, it supports
the ISO C 99 semantics of 'extern inline' (unlike the GNU C semantics of
earlier versions), but does not display it by setting __GNUC_STDC_INLINE__.
- __APPLE__ && __MACH__ test for MacOS X.
+ __APPLE__ && __MACH__ test for Mac OS X.
__APPLE_CC__ tests for the Apple compiler and its version.
__STDC_VERSION__ tests for the C99 mode. */
#if defined __APPLE__ && defined __MACH__ && __APPLE_CC__ >= 5465 && !defined
__cplusplus && __STDC_VERSION__ >= 199901L && !defined __GNUC_STDC_INLINE__
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index 498c5fa..13bf4e8 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -56,6 +56,7 @@ AC_DEFUN([gl_EARLY],
# Code from module canonicalize-lgpl:
# Code from module ceil:
# Code from module chdir:
+ # Code from module clock-time:
# Code from module close:
# Code from module configmake:
# Code from module connect:
@@ -119,6 +120,8 @@ AC_DEFUN([gl_EARLY],
# Code from module listen:
# Code from module localcharset:
# Code from module locale:
+ # Code from module localeconv:
+ # Code from module log:
# Code from module log1p:
# Code from module lstat:
# Code from module maintainer-makefile:
@@ -150,6 +153,7 @@ AC_DEFUN([gl_EARLY],
# Code from module regex:
# Code from module rename:
# Code from module rmdir:
+ # Code from module round:
# Code from module safe-read:
# Code from module safe-write:
# Code from module same-inode:
@@ -180,12 +184,10 @@ AC_DEFUN([gl_EARLY],
# Code from module stdint:
# Code from module stdio:
# Code from module stdlib:
- # Code from module strcase:
# Code from module streq:
# Code from module strftime:
# Code from module striconveh:
# Code from module string:
- # Code from module strings:
# Code from module sys_file:
# Code from module sys_socket:
# Code from module sys_stat:
@@ -238,6 +240,7 @@ gl_SYS_SOCKET_MODULE_INDICATOR([accept])
gl_FUNC_ALLOCA
gl_HEADER_ARPA_INET
AC_PROG_MKDIR_P
+AC_REQUIRE([AC_C_INLINE])
AC_REQUIRE([gl_HEADER_SYS_SOCKET])
if test "$ac_cv_header_winsock2_h" = yes; then
AC_LIBOBJ([bind])
@@ -263,6 +266,7 @@ if test $REPLACE_CEIL = 1; then
fi
gl_MATH_MODULE_INDICATOR([ceil])
gl_UNISTD_MODULE_INDICATOR([chdir])
+gl_CLOCK_TIME
gl_FUNC_CLOSE
if test $REPLACE_CLOSE = 1; then
AC_LIBOBJ([close])
@@ -425,6 +429,7 @@ if test $HAVE_ISNANL = 0 || test $REPLACE_ISNAN = 1; then
fi
gl_MATH_MODULE_INDICATOR([isnanl])
gl_LANGINFO_H
+AC_REQUIRE([gl_LARGEFILE])
gl_FUNC_LDEXP
gl_LD_VERSION_SCRIPT
gl_VISIBILITY
@@ -438,7 +443,22 @@ gl_LOCALCHARSET
LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(abs_top_builddir)/$gl_source_base\""
AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT])
gl_LOCALE_H
-gl_COMMON_DOUBLE_MATHFUNC([log1p])
+gl_FUNC_LOCALECONV
+if test $REPLACE_LOCALECONV = 1; then
+ AC_LIBOBJ([localeconv])
+ gl_PREREQ_LOCALECONV
+fi
+gl_LOCALE_MODULE_INDICATOR([localeconv])
+AC_REQUIRE([gl_FUNC_LOG])
+if test $REPLACE_LOG = 1; then
+ AC_LIBOBJ([log])
+fi
+gl_MATH_MODULE_INDICATOR([log])
+gl_FUNC_LOG1P
+if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then
+ AC_LIBOBJ([log1p])
+fi
+gl_MATH_MODULE_INDICATOR([log1p])
gl_FUNC_LSTAT
if test $REPLACE_LSTAT = 1; then
AC_LIBOBJ([lstat])
@@ -558,6 +578,11 @@ if test $REPLACE_RMDIR = 1; then
AC_LIBOBJ([rmdir])
fi
gl_UNISTD_MODULE_INDICATOR([rmdir])
+gl_FUNC_ROUND
+if test $HAVE_ROUND = 0 || test $REPLACE_ROUND = 1; then
+ AC_LIBOBJ([round])
+fi
+gl_MATH_MODULE_INDICATOR([round])
gl_PREREQ_SAFE_READ
gl_PREREQ_SAFE_WRITE
AC_REQUIRE([gl_HEADER_SYS_SOCKET])
@@ -623,22 +648,12 @@ gl_STDDEF_H
gl_STDINT_H
gl_STDIO_H
gl_STDLIB_H
-gl_STRCASE
-if test $HAVE_STRCASECMP = 0; then
- AC_LIBOBJ([strcasecmp])
- gl_PREREQ_STRCASECMP
-fi
-if test $HAVE_STRNCASECMP = 0; then
- AC_LIBOBJ([strncasecmp])
- gl_PREREQ_STRNCASECMP
-fi
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_SYS_SOCKET
@@ -678,7 +693,6 @@ gl_LIBUNISTRING_LIBHEADER([0.9], [unitypes.h])
gl_FUNC_VASNPRINTF
gl_FUNC_VSNPRINTF
gl_STDIO_MODULE_INDICATOR([vsnprintf])
-AC_SUBST([WARN_CFLAGS])
gl_WCHAR_H
gl_FUNC_WCRTOMB
if test $HAVE_WCRTOMB = 0 || test $REPLACE_WCRTOMB = 1; then
@@ -918,6 +932,9 @@ AC_DEFUN([gl_FILE_LIST], [
lib/localcharset.c
lib/localcharset.h
lib/locale.in.h
+ lib/localeconv.c
+ lib/log.c
+ lib/log1p.c
lib/lstat.c
lib/malloc.c
lib/malloca.c
@@ -962,6 +979,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/regexec.c
lib/rename.c
lib/rmdir.c
+ lib/round.c
lib/safe-read.c
lib/safe-read.h
lib/safe-write.c
@@ -986,16 +1004,13 @@ AC_DEFUN([gl_FILE_LIST], [
lib/stdint.in.h
lib/stdio.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/stripslash.c
- lib/strncasecmp.c
lib/sys_file.in.h
lib/sys_socket.in.h
lib/sys_stat.in.h
@@ -1036,6 +1051,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/canonicalize.m4
m4/ceil.m4
m4/check-math-lib.m4
+ m4/clock_time.m4
m4/close.m4
m4/codeset.m4
m4/configmake.m4
@@ -1093,6 +1109,9 @@ AC_DEFUN([gl_FILE_LIST], [
m4/locale-ja.m4
m4/locale-zh.m4
m4/locale_h.m4
+ m4/localeconv.m4
+ m4/log.m4
+ m4/log1p.m4
m4/longlong.m4
m4/lstat.m4
m4/malloc.m4
@@ -1114,6 +1133,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/nl_langinfo.m4
m4/nocrash.m4
m4/nproc.m4
+ m4/off_t.m4
m4/open.m4
m4/pathmax.m4
m4/pipe2.m4
@@ -1125,6 +1145,7 @@ AC_DEFUN([gl_FILE_LIST], [
m4/regex.m4
m4/rename.m4
m4/rmdir.m4
+ m4/round.m4
m4/safe-read.m4
m4/safe-write.m4
m4/servent.m4
@@ -1146,10 +1167,8 @@ AC_DEFUN([gl_FILE_LIST], [
m4/stdint_h.m4
m4/stdio_h.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/sys_socket_h.m4
m4/sys_stat_h.m4
diff --git a/m4/largefile.m4 b/m4/largefile.m4
index 1369bbe..a88850a 100644
--- a/m4/largefile.m4
+++ b/m4/largefile.m4
@@ -102,3 +102,48 @@ fi
])# AC_SYS_LARGEFILE
])# m4_version_prereq 2.69
+
+# Enable large files on systems where this is implemented by Gnulib, not by the
+# system headers.
+# Set the variables WINDOWS_64_BIT_OFF_T, WINDOWS_64_BIT_ST_SIZE if Gnulib
+# overrides ensure that off_t or 'struct size.st_size' are 64-bit,
respectively.
+AC_DEFUN([gl_LARGEFILE],
+[
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ case "$host_os" in
+ mingw*)
+ dnl Native Windows.
+ dnl mingw64 defines off_t to a 64-bit type already, if
+ dnl _FILE_OFFSET_BITS=64, which is ensured by AC_SYS_LARGEFILE.
+ AC_CACHE_CHECK([for 64-bit off_t], [gl_cv_type_off_t_64],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <sys/types.h>
+ int verify_off_t_size[sizeof (off_t) >= 8 ? 1 : -1];
+ ]],
+ [[]])],
+ [gl_cv_type_off_t_64=yes], [gl_cv_type_off_t_64=no])
+ ])
+ if test $gl_cv_type_off_t_64 = no; then
+ WINDOWS_64_BIT_OFF_T=1
+ else
+ WINDOWS_64_BIT_OFF_T=0
+ fi
+ dnl But all native Windows platforms (including mingw64) have a 32-bit
+ dnl st_size member in 'struct stat'.
+ WINDOWS_64_BIT_ST_SIZE=1
+ ;;
+ *)
+ dnl Nothing to do on gnulib's side.
+ dnl A 64-bit off_t is
+ dnl - already the default on Mac OS X, FreeBSD, NetBSD, OpenBSD, IRIX,
+ dnl OSF/1, Cygwin,
+ dnl - enabled by _FILE_OFFSET_BITS=64 (ensured by AC_SYS_LARGEFILE) on
+ dnl glibc, HP-UX, Solaris,
+ dnl - enabled by _LARGE_FILES=1 (ensured by AC_SYS_LARGEFILE) on AIX,
+ dnl - impossible to achieve on Minix 3.1.8.
+ WINDOWS_64_BIT_OFF_T=0
+ WINDOWS_64_BIT_ST_SIZE=0
+ ;;
+ esac
+])
diff --git a/m4/locale-fr.m4 b/m4/locale-fr.m4
index 4cb14b5..71b6847 100644
--- a/m4/locale-fr.m4
+++ b/m4/locale-fr.m4
@@ -1,4 +1,4 @@
-# locale-fr.m4 serial 14
+# locale-fr.m4 serial 17
dnl Copyright (C) 2003, 2005-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -28,7 +28,7 @@ int main () {
#if (defined _WIN32 || defined __WIN32__) && !defined __CYGWIN__
/* On native Windows, setlocale(category, "") looks at the system settings,
not at the environment variables. Also, when an encoding suffix such
- as ".65001" or ".54936" is speficied, it succeeds but sets the LC_CTYPE
+ as ".65001" or ".54936" is specified, it succeeds but sets the LC_CTYPE
category of the locale to "C". */
if (setlocale (LC_ALL, getenv ("LC_ALL")) == NULL
|| strcmp (setlocale (LC_CTYPE, NULL), "C") == 0)
@@ -37,7 +37,7 @@ int main () {
if (setlocale (LC_ALL, "") == NULL) return 1;
#endif
/* Check whether nl_langinfo(CODESET) is nonempty and not "ASCII" or "646".
- On MacOS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
+ On Mac OS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
is empty, and the behaviour of Tcl 8.4 in this locale is not useful.
On OpenBSD 4.0, when an unsupported locale is specified, setlocale()
succeeds but then nl_langinfo(CODESET) is "646". In this situation,
@@ -63,10 +63,12 @@ int main () {
one byte long. This excludes the UTF-8 encoding. */
t.tm_year = 1975 - 1900; t.tm_mon = 2 - 1; t.tm_mday = 4;
if (strftime (buf, sizeof (buf), "%b", &t) < 3 || buf[2] != 'v') return 1;
+#if !defined __BIONIC__ /* Bionic libc's 'struct lconv' is just a dummy. */
/* Check whether the decimal separator is a comma.
On NetBSD 3.0 in the fr_FR.ISO8859-1 locale, localeconv()->decimal_point
are nl_langinfo(RADIXCHAR) are both ".". */
if (localeconv () ->decimal_point[0] != ',') return 1;
+#endif
return 0;
}
changequote([,])dnl
@@ -90,7 +92,7 @@ changequote([,])dnl
;;
*)
# 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
+ # otherwise on Mac OS 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.
@@ -154,7 +156,7 @@ int main () {
# if (defined _WIN32 || defined __WIN32__) && !defined __CYGWIN__
/* On native Windows, setlocale(category, "") looks at the system settings,
not at the environment variables. Also, when an encoding suffix such
- as ".65001" or ".54936" is speficied, it succeeds but sets the LC_CTYPE
+ as ".65001" or ".54936" is specified, it succeeds but sets the LC_CTYPE
category of the locale to "C". */
if (setlocale (LC_ALL, getenv ("LC_ALL")) == NULL
|| strcmp (setlocale (LC_CTYPE, NULL), "C") == 0)
@@ -163,7 +165,7 @@ int main () {
if (setlocale (LC_ALL, "") == NULL) return 1;
# endif
/* Check whether nl_langinfo(CODESET) is nonempty and not "ASCII" or "646".
- On MacOS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
+ On Mac OS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
is empty, and the behaviour of Tcl 8.4 in this locale is not useful.
On OpenBSD 4.0, when an unsupported locale is specified, setlocale()
succeeds but then nl_langinfo(CODESET) is "646". In this situation,
@@ -189,10 +191,12 @@ int main () {
|| buf[1] != (char) 0xc3 || buf[2] != (char) 0xa9 || buf[3] != 'v')
return 1;
#endif
+#if !defined __BIONIC__ /* Bionic libc's 'struct lconv' is just a dummy. */
/* Check whether the decimal separator is a comma.
On NetBSD 3.0 in the fr_FR.ISO8859-1 locale, localeconv()->decimal_point
are nl_langinfo(RADIXCHAR) are both ".". */
if (localeconv () ->decimal_point[0] != ',') return 1;
+#endif
return 0;
}
changequote([,])dnl
@@ -216,7 +220,7 @@ changequote([,])dnl
;;
*)
# 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
+ # otherwise on Mac OS 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.
diff --git a/m4/locale-ja.m4 b/m4/locale-ja.m4
index b427f09..5ba0e43 100644
--- a/m4/locale-ja.m4
+++ b/m4/locale-ja.m4
@@ -1,4 +1,4 @@
-# locale-ja.m4 serial 10
+# locale-ja.m4 serial 12
dnl Copyright (C) 2003, 2005-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -30,7 +30,7 @@ int main ()
#if (defined _WIN32 || defined __WIN32__) && !defined __CYGWIN__
/* On native Windows, setlocale(category, "") looks at the system settings,
not at the environment variables. Also, when an encoding suffix such
- as ".65001" or ".54936" is speficied, it succeeds but sets the LC_CTYPE
+ as ".65001" or ".54936" is specified, it succeeds but sets the LC_CTYPE
category of the locale to "C". */
if (setlocale (LC_ALL, getenv ("LC_ALL")) == NULL
|| strcmp (setlocale (LC_CTYPE, NULL), "C") == 0)
@@ -39,7 +39,7 @@ int main ()
if (setlocale (LC_ALL, "") == NULL) return 1;
#endif
/* Check whether nl_langinfo(CODESET) is nonempty and not "ASCII" or "646".
- On MacOS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
+ On Mac OS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
is empty, and the behaviour of Tcl 8.4 in this locale is not useful.
On OpenBSD 4.0, when an unsupported locale is specified, setlocale()
succeeds but then nl_langinfo(CODESET) is "646". In this situation,
@@ -91,7 +91,7 @@ changequote([,])dnl
;;
*)
# 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
+ # otherwise on Mac OS 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.
diff --git a/m4/locale-zh.m4 b/m4/locale-zh.m4
index de1a43b..e5502b2 100644
--- a/m4/locale-zh.m4
+++ b/m4/locale-zh.m4
@@ -1,4 +1,4 @@
-# locale-zh.m4 serial 10
+# locale-zh.m4 serial 12
dnl Copyright (C) 2003, 2005-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -31,7 +31,7 @@ int main ()
#if (defined _WIN32 || defined __WIN32__) && !defined __CYGWIN__
/* On native Windows, setlocale(category, "") looks at the system settings,
not at the environment variables. Also, when an encoding suffix such
- as ".65001" or ".54936" is speficied, it succeeds but sets the LC_CTYPE
+ as ".65001" or ".54936" is specified, it succeeds but sets the LC_CTYPE
category of the locale to "C". */
if (setlocale (LC_ALL, getenv ("LC_ALL")) == NULL
|| strcmp (setlocale (LC_CTYPE, NULL), "C") == 0)
@@ -40,7 +40,7 @@ int main ()
if (setlocale (LC_ALL, "") == NULL) return 1;
#endif
/* Check whether nl_langinfo(CODESET) is nonempty and not "ASCII" or "646".
- On MacOS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
+ On Mac OS X 10.3.5 (Darwin 7.5) in the fr_FR locale, nl_langinfo(CODESET)
is empty, and the behaviour of Tcl 8.4 in this locale is not useful.
On OpenBSD 4.0, when an unsupported locale is specified, setlocale()
succeeds but then nl_langinfo(CODESET) is "646". In this situation,
@@ -101,7 +101,7 @@ changequote([,])dnl
;;
*)
# 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
+ # otherwise on Mac OS 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.
diff --git a/m4/locale_h.m4 b/m4/locale_h.m4
index 4289587..c0f4d52 100644
--- a/m4/locale_h.m4
+++ b/m4/locale_h.m4
@@ -1,4 +1,4 @@
-# locale_h.m4 serial 14
+# locale_h.m4 serial 19
dnl Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -10,18 +10,29 @@ AC_DEFUN([gl_LOCALE_H],
dnl once only, before all statements that occur in other macros.
AC_REQUIRE([gl_LOCALE_H_DEFAULTS])
- dnl Persuade glibc <locale.h> to define locale_t.
+ dnl Persuade glibc <locale.h> to define locale_t and the int_p_*, int_n_*
+ dnl members of 'struct lconv'.
AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
dnl If <stddef.h> is replaced, then <locale.h> must also be replaced.
AC_REQUIRE([gl_STDDEF_H])
+ dnl Solaris 11 2011-11 defines the int_p_*, int_n_* members of 'struct lconv'
+ dnl only if _LCONV_C99 is defined.
+ AC_REQUIRE([AC_CANONICAL_HOST])
+ case "$host_os" in
+ solaris*)
+ AC_DEFINE([_LCONV_C99], [1], [Define to 1 on Solaris.])
+ ;;
+ esac
+
AC_CACHE_CHECK([whether locale.h conforms to POSIX:2001],
[gl_cv_header_locale_h_posix2001],
[AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
[[#include <locale.h>
- int x = LC_MESSAGES;]],
+ int x = LC_MESSAGES;
+ int y = sizeof (((struct lconv *) 0)->decimal_point);]],
[[]])],
[gl_cv_header_locale_h_posix2001=yes],
[gl_cv_header_locale_h_posix2001=no])])
@@ -31,7 +42,7 @@ AC_DEFUN([gl_LOCALE_H],
if test $ac_cv_header_xlocale_h = yes; then
HAVE_XLOCALE_H=1
dnl Check whether use of locale_t requires inclusion of <xlocale.h>,
- dnl e.g. on MacOS X 10.5. If <locale.h> does not define locale_t by
+ dnl e.g. on Mac OS X 10.5. If <locale.h> does not define locale_t by
dnl itself, we assume that <xlocale.h> will do so.
AC_CACHE_CHECK([whether locale.h defines locale_t],
[gl_cv_header_locale_has_locale_t],
@@ -54,6 +65,26 @@ AC_DEFUN([gl_LOCALE_H],
fi
AC_SUBST([HAVE_XLOCALE_H])
+ dnl Check whether 'struct lconv' is complete.
+ dnl Bionic libc's 'struct lconv' is just a dummy.
+ dnl On OpenBSD 4.9, HP-UX 11, IRIX 6.5, OSF/1 5.1, Solaris 9, Cygwin 1.5.x,
+ dnl mingw, MSVC 9, it lacks the int_p_* and int_n_* members.
+ AC_CACHE_CHECK([whether struct lconv is properly defined],
+ [gl_cv_sys_struct_lconv_ok],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <locale.h>
+ struct lconv l;
+ int x = sizeof (l.decimal_point);
+ int y = sizeof (l.int_p_cs_precedes);]],
+ [[]])],
+ [gl_cv_sys_struct_lconv_ok=yes],
+ [gl_cv_sys_struct_lconv_ok=no])
+ ])
+ if test $gl_cv_sys_struct_lconv_ok = no; then
+ REPLACE_STRUCT_LCONV=1
+ fi
+
dnl <locale.h> is always overridden, because of GNULIB_POSIXCHECK.
gl_NEXT_HEADERS([locale.h])
@@ -79,10 +110,13 @@ AC_DEFUN([gl_LOCALE_MODULE_INDICATOR],
AC_DEFUN([gl_LOCALE_H_DEFAULTS],
[
+ GNULIB_LOCALECONV=0; AC_SUBST([GNULIB_LOCALECONV])
GNULIB_SETLOCALE=0; AC_SUBST([GNULIB_SETLOCALE])
GNULIB_DUPLOCALE=0; AC_SUBST([GNULIB_DUPLOCALE])
dnl Assume proper GNU behavior unless another module says otherwise.
- HAVE_DUPLOCALE=1; AC_SUBST([HAVE_DUPLOCALE])
- REPLACE_SETLOCALE=0; AC_SUBST([REPLACE_SETLOCALE])
- REPLACE_DUPLOCALE=0; AC_SUBST([REPLACE_DUPLOCALE])
+ HAVE_DUPLOCALE=1; AC_SUBST([HAVE_DUPLOCALE])
+ REPLACE_LOCALECONV=0; AC_SUBST([REPLACE_LOCALECONV])
+ REPLACE_SETLOCALE=0; AC_SUBST([REPLACE_SETLOCALE])
+ REPLACE_DUPLOCALE=0; AC_SUBST([REPLACE_DUPLOCALE])
+ REPLACE_STRUCT_LCONV=0; AC_SUBST([REPLACE_STRUCT_LCONV])
])
diff --git a/m4/localeconv.m4 b/m4/localeconv.m4
new file mode 100644
index 0000000..5fae06d
--- /dev/null
+++ b/m4/localeconv.m4
@@ -0,0 +1,22 @@
+# localeconv.m4 serial 1
+dnl Copyright (C) 2012 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_LOCALECONV],
+[
+ AC_REQUIRE([gl_LOCALE_H_DEFAULTS])
+ AC_REQUIRE([gl_LOCALE_H])
+
+ if test $REPLACE_STRUCT_LCONV = 1; then
+ REPLACE_LOCALECONV=1
+ fi
+])
+
+# Prerequisites of lib/localeconv.c.
+AC_DEFUN([gl_PREREQ_LOCALECONV],
+[
+ AC_CHECK_MEMBERS([struct lconv.decimal_point], [], [],
+ [[#include <locale.h>]])
+])
diff --git a/m4/log.m4 b/m4/log.m4
new file mode 100644
index 0000000..a04362a
--- /dev/null
+++ b/m4/log.m4
@@ -0,0 +1,107 @@
+# log.m4 serial 4
+dnl Copyright (C) 2011-2012 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_LOG],
+[
+ m4_divert_text([DEFAULTS], [gl_log_required=plain])
+ AC_REQUIRE([gl_MATH_H_DEFAULTS])
+
+ dnl Determine LOG_LIBM.
+ gl_COMMON_DOUBLE_MATHFUNC([log])
+
+ save_LIBS="$LIBS"
+ LIBS="$LIBS $LOG_LIBM"
+ gl_FUNC_LOG_WORKS
+ LIBS="$save_LIBS"
+ case "$gl_cv_func_log_works" in
+ *yes) ;;
+ *) REPLACE_LOG=1 ;;
+ esac
+
+ m4_ifdef([gl_FUNC_LOG_IEEE], [
+ if test $gl_log_required = ieee && test $REPLACE_LOG = 0; then
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_CACHE_CHECK([whether log works according to ISO C 99 with IEC 60559],
+ [gl_cv_func_log_ieee],
+ [
+ save_LIBS="$LIBS"
+ LIBS="$LIBS $LOG_LIBM"
+ AC_RUN_IFELSE(
+ [AC_LANG_SOURCE([[
+#ifndef __NO_MATH_INLINES
+# define __NO_MATH_INLINES 1 /* for glibc */
+#endif
+#include <math.h>
+/* Compare two numbers with ==.
+ This is a separate function because IRIX 6.5 "cc -O" miscompiles an
+ 'x == x' test. */
+static int
+numeric_equal (double x, double y)
+{
+ return x == y;
+}
+static double dummy (double x) { return 0; }
+int main (int argc, char *argv[])
+{
+ double (*my_log) (double) = argc ? log : dummy;
+ /* Test log(negative).
+ This test fails on NetBSD 5.1, Solaris 11 2011-11. */
+ double y = my_log (-1.0);
+ if (numeric_equal (y, y))
+ return 1;
+ return 0;
+}
+ ]])],
+ [gl_cv_func_log_ieee=yes],
+ [gl_cv_func_log_ieee=no],
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_log_ieee="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_log_ieee="guessing no" ;;
+ esac
+ ])
+ LIBS="$save_LIBS"
+ ])
+ case "$gl_cv_func_log_ieee" in
+ *yes) ;;
+ *) REPLACE_LOG=1 ;;
+ esac
+ fi
+ ])
+])
+
+dnl Test whether log() works.
+dnl On OSF/1 5.1, log(-0.0) is NaN.
+AC_DEFUN([gl_FUNC_LOG_WORKS],
+[
+ AC_REQUIRE([AC_PROG_CC])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_CACHE_CHECK([whether log works], [gl_cv_func_log_works],
+ [
+ AC_RUN_IFELSE(
+ [AC_LANG_SOURCE([[
+#include <math.h>
+volatile double x;
+double y;
+int main ()
+{
+ x = -0.0;
+ y = log (x);
+ if (!(y + y == y))
+ return 1;
+ return 0;
+}
+]])],
+ [gl_cv_func_log_works=yes],
+ [gl_cv_func_log_works=no],
+ [case "$host_os" in
+ osf*) gl_cv_func_log_works="guessing no";;
+ *) gl_cv_func_log_works="guessing yes";;
+ esac
+ ])
+ ])
+])
diff --git a/m4/log1p.m4 b/m4/log1p.m4
new file mode 100644
index 0000000..4bca324
--- /dev/null
+++ b/m4/log1p.m4
@@ -0,0 +1,94 @@
+# log1p.m4 serial 3
+dnl Copyright (C) 2012 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_LOG1P],
+[
+ m4_divert_text([DEFAULTS], [gl_log1p_required=plain])
+ AC_REQUIRE([gl_MATH_H_DEFAULTS])
+
+ dnl Persuade glibc <math.h> to declare log1p().
+ AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+
+ dnl Determine LOG1P_LIBM.
+ gl_COMMON_DOUBLE_MATHFUNC([log1p])
+
+ dnl Test whether log1p() exists.
+ save_LIBS="$LIBS"
+ LIBS="$LIBS $LOG1P_LIBM"
+ AC_CHECK_FUNCS([log1p])
+ LIBS="$save_LIBS"
+ if test $ac_cv_func_log1p = yes; then
+ :
+ m4_ifdef([gl_FUNC_LOG1P_IEEE], [
+ if test $gl_log1p_required = ieee && test $REPLACE_LOG1P = 0; then
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_CACHE_CHECK([whether log1p works according to ISO C 99 with IEC
60559],
+ [gl_cv_func_log1p_ieee],
+ [
+ save_LIBS="$LIBS"
+ LIBS="$LIBS $LOG1P_LIBM"
+ AC_RUN_IFELSE(
+ [AC_LANG_SOURCE([[
+#ifndef __NO_MATH_INLINES
+# define __NO_MATH_INLINES 1 /* for glibc */
+#endif
+#include <math.h>
+]gl_DOUBLE_MINUS_ZERO_CODE[
+]gl_DOUBLE_SIGNBIT_CODE[
+static double dummy (double x) { return 0; }
+int main (int argc, char *argv[])
+{
+ double (*my_log1p) (double) = argc ? log1p : dummy;
+ /* This test fails on AIX, HP-UX 11. */
+ double y = my_log1p (minus_zerod);
+ if (!(y == 0.0) || (signbitd (minus_zerod) && !signbitd (y)))
+ return 1;
+ return 0;
+}
+ ]])],
+ [gl_cv_func_log1p_ieee=yes],
+ [gl_cv_func_log1p_ieee=no],
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_log1p_ieee="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_log1p_ieee="guessing no" ;;
+ esac
+ ])
+ LIBS="$save_LIBS"
+ ])
+ case "$gl_cv_func_log1p_ieee" in
+ *yes) ;;
+ *) REPLACE_LOG1P=1 ;;
+ esac
+ fi
+ ])
+ else
+ HAVE_LOG1P=0
+ fi
+ if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then
+ dnl Find libraries needed to link lib/log1p.c.
+ AC_REQUIRE([gl_FUNC_ISNAND])
+ AC_REQUIRE([gl_FUNC_LOG])
+ AC_REQUIRE([gl_FUNC_ROUND])
+ LOG1P_LIBM=
+ dnl Append $ISNAND_LIBM to LOG1P_LIBM, avoiding gratuitous duplicates.
+ case " $LOG1P_LIBM " in
+ *" $ISNAND_LIBM "*) ;;
+ *) LOG1P_LIBM="$LOG1P_LIBM $ISNAND_LIBM" ;;
+ esac
+ dnl Append $LOG_LIBM to LOG1P_LIBM, avoiding gratuitous duplicates.
+ case " $LOG1P_LIBM " in
+ *" $LOG_LIBM "*) ;;
+ *) LOG1P_LIBM="$LOG1P_LIBM $LOG_LIBM" ;;
+ esac
+ dnl Append $ROUND_LIBM to LOG1P_LIBM, avoiding gratuitous duplicates.
+ case " $LOG1P_LIBM " in
+ *" $ROUND_LIBM "*) ;;
+ *) LOG1P_LIBM="$LOG1P_LIBM $ROUND_LIBM" ;;
+ esac
+ fi
+])
diff --git a/m4/lstat.m4 b/m4/lstat.m4
index b83858b..b7335bd 100644
--- a/m4/lstat.m4
+++ b/m4/lstat.m4
@@ -1,4 +1,4 @@
-# serial 24
+# serial 25
# Copyright (C) 1997-2001, 2003-2012 Free Software Foundation, Inc.
#
@@ -16,9 +16,11 @@ AC_DEFUN([gl_FUNC_LSTAT],
AC_CHECK_FUNCS_ONCE([lstat])
if test $ac_cv_func_lstat = yes; then
AC_REQUIRE([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK])
- if test $gl_cv_func_lstat_dereferences_slashed_symlink = no; then
- REPLACE_LSTAT=1
- fi
+ case "$gl_cv_func_lstat_dereferences_slashed_symlink" in
+ *no)
+ REPLACE_LSTAT=1
+ ;;
+ esac
else
HAVE_LSTAT=0
fi
@@ -51,20 +53,25 @@ AC_DEFUN([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK],
]])],
[gl_cv_func_lstat_dereferences_slashed_symlink=yes],
[gl_cv_func_lstat_dereferences_slashed_symlink=no],
- [# When cross-compiling, be pessimistic so we will end up using the
- # replacement version of lstat that checks for trailing slashes and
- # calls lstat a second time when necessary.
- gl_cv_func_lstat_dereferences_slashed_symlink=no
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_lstat_dereferences_slashed_symlink="guessing
yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_lstat_dereferences_slashed_symlink="guessing
no" ;;
+ esac
])
else
# If the 'ln -s' command failed, then we probably don't even
# have an lstat function.
- gl_cv_func_lstat_dereferences_slashed_symlink=no
+ gl_cv_func_lstat_dereferences_slashed_symlink="guessing no"
fi
rm -f conftest.sym conftest.file
])
- test $gl_cv_func_lstat_dereferences_slashed_symlink = yes &&
- AC_DEFINE_UNQUOTED([LSTAT_FOLLOWS_SLASHED_SYMLINK], [1],
- [Define to 1 if 'lstat' dereferences a symlink specified
- with a trailing slash.])
+ case "$gl_cv_func_lstat_dereferences_slashed_symlink" in
+ *yes)
+ AC_DEFINE_UNQUOTED([LSTAT_FOLLOWS_SLASHED_SYMLINK], [1],
+ [Define to 1 if 'lstat' dereferences a symlink specified
+ with a trailing slash.])
+ ;;
+ esac
])
diff --git a/m4/malloc.m4 b/m4/malloc.m4
index d3c39f5..8fa48e9 100644
--- a/m4/malloc.m4
+++ b/m4/malloc.m4
@@ -1,9 +1,47 @@
-# malloc.m4 serial 13
+# malloc.m4 serial 14
dnl Copyright (C) 2007, 2009-2012 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.
+m4_version_prereq([2.70], [] ,[
+
+# This is taken from the following Autoconf patch:
+#
http://git.savannah.gnu.org/gitweb/?p=autoconf.git;a=commitdiff;h=7fbb553727ed7e0e689a17594b58559ecf3ea6e9
+AC_DEFUN([_AC_FUNC_MALLOC_IF],
+[
+ AC_REQUIRE([AC_HEADER_STDC])dnl
+ AC_REQUIRE([AC_CANONICAL_HOST])dnl for cross-compiles
+ AC_CHECK_HEADERS([stdlib.h])
+ AC_CACHE_CHECK([for GNU libc compatible malloc],
+ [ac_cv_func_malloc_0_nonnull],
+ [AC_RUN_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#if defined STDC_HEADERS || defined HAVE_STDLIB_H
+ # include <stdlib.h>
+ #else
+ char *malloc ();
+ #endif
+ ]],
+ [[return ! malloc (0);]])
+ ],
+ [ac_cv_func_malloc_0_nonnull=yes],
+ [ac_cv_func_malloc_0_nonnull=no],
+ [case "$host_os" in
+ # Guess yes on platforms where we know the result.
+ *-gnu* | freebsd* | netbsd* | openbsd* \
+ | hpux* | solaris* | cygwin* | mingw*)
+ ac_cv_func_malloc_0_nonnull=yes ;;
+ # If we don't know, assume the worst.
+ *) ac_cv_func_malloc_0_nonnull=no ;;
+ esac
+ ])
+ ])
+ AS_IF([test $ac_cv_func_malloc_0_nonnull = yes], [$1], [$2])
+])# _AC_FUNC_MALLOC_IF
+
+])
+
# gl_FUNC_MALLOC_GNU
# ------------------
# Test whether 'malloc (0)' is handled like in GNU libc, and replace malloc if
diff --git a/m4/math_h.m4 b/m4/math_h.m4
index 5d7d52b..90d248a 100644
--- a/m4/math_h.m4
+++ b/m4/math_h.m4
@@ -1,4 +1,4 @@
-# math_h.m4 serial 56
+# math_h.m4 serial 113
dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -40,9 +40,16 @@ AC_DEFUN([gl_MATH_H],
dnl corresponding gnulib module is not in use.
gl_WARN_ON_USE_PREPARE([[#include <math.h>]],
[acosf acosl asinf asinl atanf atanl
- ceilf ceill copysign copysignf copysignl cosf cosl coshf
- expf expl fabsf floorf floorl fma fmaf fmal fmodf frexpf frexpl
- ldexpf ldexpl logb logf logl log10f modff powf
+ cbrt cbrtf cbrtl ceilf ceill copysign copysignf copysignl cosf cosl coshf
+ expf expl exp2 exp2f exp2l expm1 expm1f expm1l
+ fabsf fabsl floorf floorl fma fmaf fmal
+ fmod fmodf fmodl frexpf frexpl hypotf hypotl
+ ilogb ilogbf ilogbl
+ ldexpf ldexpl
+ log logf logl log10 log10f log10l log1p log1pf log1pl log2 log2f log2l
+ logb logbf logbl
+ modf modff modfl powf
+ remainder remainderf remainderl
rint rintf rintl round roundf roundl sinf sinl sinhf sqrtf sqrtl
tanf tanl tanhf trunc truncf truncl])
])
@@ -58,67 +65,101 @@ AC_DEFUN([gl_MATH_MODULE_INDICATOR],
AC_DEFUN([gl_MATH_H_DEFAULTS],
[
- GNULIB_ACOSF=0; AC_SUBST([GNULIB_ACOSF])
- GNULIB_ACOSL=0; AC_SUBST([GNULIB_ACOSL])
- GNULIB_ASINF=0; AC_SUBST([GNULIB_ASINF])
- GNULIB_ASINL=0; AC_SUBST([GNULIB_ASINL])
- GNULIB_ATANF=0; AC_SUBST([GNULIB_ATANF])
- GNULIB_ATANL=0; AC_SUBST([GNULIB_ATANL])
- GNULIB_ATAN2F=0; AC_SUBST([GNULIB_ATAN2F])
- GNULIB_CEIL=0; AC_SUBST([GNULIB_CEIL])
- GNULIB_CEILF=0; AC_SUBST([GNULIB_CEILF])
- GNULIB_CEILL=0; AC_SUBST([GNULIB_CEILL])
- GNULIB_COPYSIGN=0; AC_SUBST([GNULIB_COPYSIGN])
- GNULIB_COPYSIGNF=0; AC_SUBST([GNULIB_COPYSIGNF])
- GNULIB_COPYSIGNL=0; AC_SUBST([GNULIB_COPYSIGNL])
- GNULIB_COSF=0; AC_SUBST([GNULIB_COSF])
- GNULIB_COSL=0; AC_SUBST([GNULIB_COSL])
- GNULIB_COSHF=0; AC_SUBST([GNULIB_COSHF])
- GNULIB_EXPF=0; AC_SUBST([GNULIB_EXPF])
- GNULIB_EXPL=0; AC_SUBST([GNULIB_EXPL])
- GNULIB_FABSF=0; AC_SUBST([GNULIB_FABSF])
- GNULIB_FLOOR=0; AC_SUBST([GNULIB_FLOOR])
- GNULIB_FLOORF=0; AC_SUBST([GNULIB_FLOORF])
- GNULIB_FLOORL=0; AC_SUBST([GNULIB_FLOORL])
- GNULIB_FMA=0; AC_SUBST([GNULIB_FMA])
- GNULIB_FMAF=0; AC_SUBST([GNULIB_FMAF])
- GNULIB_FMAL=0; AC_SUBST([GNULIB_FMAL])
- GNULIB_FMODF=0; AC_SUBST([GNULIB_FMODF])
- GNULIB_FREXPF=0; AC_SUBST([GNULIB_FREXPF])
- GNULIB_FREXP=0; AC_SUBST([GNULIB_FREXP])
- GNULIB_FREXPL=0; AC_SUBST([GNULIB_FREXPL])
- GNULIB_ISFINITE=0; AC_SUBST([GNULIB_ISFINITE])
- GNULIB_ISINF=0; AC_SUBST([GNULIB_ISINF])
- GNULIB_ISNAN=0; AC_SUBST([GNULIB_ISNAN])
- GNULIB_ISNANF=0; AC_SUBST([GNULIB_ISNANF])
- GNULIB_ISNAND=0; AC_SUBST([GNULIB_ISNAND])
- GNULIB_ISNANL=0; AC_SUBST([GNULIB_ISNANL])
- GNULIB_LDEXPF=0; AC_SUBST([GNULIB_LDEXPF])
- GNULIB_LDEXPL=0; AC_SUBST([GNULIB_LDEXPL])
- GNULIB_LOGB=0; AC_SUBST([GNULIB_LOGB])
- GNULIB_LOGF=0; AC_SUBST([GNULIB_LOGF])
- GNULIB_LOGL=0; AC_SUBST([GNULIB_LOGL])
- GNULIB_LOG10F=0; AC_SUBST([GNULIB_LOG10F])
- GNULIB_MODFF=0; AC_SUBST([GNULIB_MODFF])
- GNULIB_POWF=0; AC_SUBST([GNULIB_POWF])
- GNULIB_RINT=0; AC_SUBST([GNULIB_RINT])
- GNULIB_RINTF=0; AC_SUBST([GNULIB_RINTF])
- GNULIB_RINTL=0; AC_SUBST([GNULIB_RINTL])
- GNULIB_ROUND=0; AC_SUBST([GNULIB_ROUND])
- GNULIB_ROUNDF=0; AC_SUBST([GNULIB_ROUNDF])
- GNULIB_ROUNDL=0; AC_SUBST([GNULIB_ROUNDL])
- GNULIB_SIGNBIT=0; AC_SUBST([GNULIB_SIGNBIT])
- GNULIB_SINF=0; AC_SUBST([GNULIB_SINF])
- GNULIB_SINL=0; AC_SUBST([GNULIB_SINL])
- GNULIB_SINHF=0; AC_SUBST([GNULIB_SINHF])
- GNULIB_SQRTF=0; AC_SUBST([GNULIB_SQRTF])
- GNULIB_SQRTL=0; AC_SUBST([GNULIB_SQRTL])
- GNULIB_TANF=0; AC_SUBST([GNULIB_TANF])
- GNULIB_TANL=0; AC_SUBST([GNULIB_TANL])
- GNULIB_TANHF=0; AC_SUBST([GNULIB_TANHF])
- GNULIB_TRUNC=0; AC_SUBST([GNULIB_TRUNC])
- GNULIB_TRUNCF=0; AC_SUBST([GNULIB_TRUNCF])
- GNULIB_TRUNCL=0; AC_SUBST([GNULIB_TRUNCL])
+ GNULIB_ACOSF=0; AC_SUBST([GNULIB_ACOSF])
+ GNULIB_ACOSL=0; AC_SUBST([GNULIB_ACOSL])
+ GNULIB_ASINF=0; AC_SUBST([GNULIB_ASINF])
+ GNULIB_ASINL=0; AC_SUBST([GNULIB_ASINL])
+ GNULIB_ATANF=0; AC_SUBST([GNULIB_ATANF])
+ GNULIB_ATANL=0; AC_SUBST([GNULIB_ATANL])
+ GNULIB_ATAN2F=0; AC_SUBST([GNULIB_ATAN2F])
+ GNULIB_CBRT=0; AC_SUBST([GNULIB_CBRT])
+ GNULIB_CBRTF=0; AC_SUBST([GNULIB_CBRTF])
+ GNULIB_CBRTL=0; AC_SUBST([GNULIB_CBRTL])
+ GNULIB_CEIL=0; AC_SUBST([GNULIB_CEIL])
+ GNULIB_CEILF=0; AC_SUBST([GNULIB_CEILF])
+ GNULIB_CEILL=0; AC_SUBST([GNULIB_CEILL])
+ GNULIB_COPYSIGN=0; AC_SUBST([GNULIB_COPYSIGN])
+ GNULIB_COPYSIGNF=0; AC_SUBST([GNULIB_COPYSIGNF])
+ GNULIB_COPYSIGNL=0; AC_SUBST([GNULIB_COPYSIGNL])
+ GNULIB_COSF=0; AC_SUBST([GNULIB_COSF])
+ GNULIB_COSL=0; AC_SUBST([GNULIB_COSL])
+ GNULIB_COSHF=0; AC_SUBST([GNULIB_COSHF])
+ GNULIB_EXPF=0; AC_SUBST([GNULIB_EXPF])
+ GNULIB_EXPL=0; AC_SUBST([GNULIB_EXPL])
+ GNULIB_EXP2=0; AC_SUBST([GNULIB_EXP2])
+ GNULIB_EXP2F=0; AC_SUBST([GNULIB_EXP2F])
+ GNULIB_EXP2L=0; AC_SUBST([GNULIB_EXP2L])
+ GNULIB_EXPM1=0; AC_SUBST([GNULIB_EXPM1])
+ GNULIB_EXPM1F=0; AC_SUBST([GNULIB_EXPM1F])
+ GNULIB_EXPM1L=0; AC_SUBST([GNULIB_EXPM1L])
+ GNULIB_FABSF=0; AC_SUBST([GNULIB_FABSF])
+ GNULIB_FABSL=0; AC_SUBST([GNULIB_FABSL])
+ GNULIB_FLOOR=0; AC_SUBST([GNULIB_FLOOR])
+ GNULIB_FLOORF=0; AC_SUBST([GNULIB_FLOORF])
+ GNULIB_FLOORL=0; AC_SUBST([GNULIB_FLOORL])
+ GNULIB_FMA=0; AC_SUBST([GNULIB_FMA])
+ GNULIB_FMAF=0; AC_SUBST([GNULIB_FMAF])
+ GNULIB_FMAL=0; AC_SUBST([GNULIB_FMAL])
+ GNULIB_FMOD=0; AC_SUBST([GNULIB_FMOD])
+ GNULIB_FMODF=0; AC_SUBST([GNULIB_FMODF])
+ GNULIB_FMODL=0; AC_SUBST([GNULIB_FMODL])
+ GNULIB_FREXPF=0; AC_SUBST([GNULIB_FREXPF])
+ GNULIB_FREXP=0; AC_SUBST([GNULIB_FREXP])
+ GNULIB_FREXPL=0; AC_SUBST([GNULIB_FREXPL])
+ GNULIB_HYPOT=0; AC_SUBST([GNULIB_HYPOT])
+ GNULIB_HYPOTF=0; AC_SUBST([GNULIB_HYPOTF])
+ GNULIB_HYPOTL=0; AC_SUBST([GNULIB_HYPOTL])
+ GNULIB_ILOGB=0; AC_SUBST([GNULIB_ILOGB])
+ GNULIB_ILOGBF=0; AC_SUBST([GNULIB_ILOGBF])
+ GNULIB_ILOGBL=0; AC_SUBST([GNULIB_ILOGBL])
+ GNULIB_ISFINITE=0; AC_SUBST([GNULIB_ISFINITE])
+ GNULIB_ISINF=0; AC_SUBST([GNULIB_ISINF])
+ GNULIB_ISNAN=0; AC_SUBST([GNULIB_ISNAN])
+ GNULIB_ISNANF=0; AC_SUBST([GNULIB_ISNANF])
+ GNULIB_ISNAND=0; AC_SUBST([GNULIB_ISNAND])
+ GNULIB_ISNANL=0; AC_SUBST([GNULIB_ISNANL])
+ GNULIB_LDEXPF=0; AC_SUBST([GNULIB_LDEXPF])
+ GNULIB_LDEXPL=0; AC_SUBST([GNULIB_LDEXPL])
+ GNULIB_LOG=0; AC_SUBST([GNULIB_LOG])
+ GNULIB_LOGF=0; AC_SUBST([GNULIB_LOGF])
+ GNULIB_LOGL=0; AC_SUBST([GNULIB_LOGL])
+ GNULIB_LOG10=0; AC_SUBST([GNULIB_LOG10])
+ GNULIB_LOG10F=0; AC_SUBST([GNULIB_LOG10F])
+ GNULIB_LOG10L=0; AC_SUBST([GNULIB_LOG10L])
+ GNULIB_LOG1P=0; AC_SUBST([GNULIB_LOG1P])
+ GNULIB_LOG1PF=0; AC_SUBST([GNULIB_LOG1PF])
+ GNULIB_LOG1PL=0; AC_SUBST([GNULIB_LOG1PL])
+ GNULIB_LOG2=0; AC_SUBST([GNULIB_LOG2])
+ GNULIB_LOG2F=0; AC_SUBST([GNULIB_LOG2F])
+ GNULIB_LOG2L=0; AC_SUBST([GNULIB_LOG2L])
+ GNULIB_LOGB=0; AC_SUBST([GNULIB_LOGB])
+ GNULIB_LOGBF=0; AC_SUBST([GNULIB_LOGBF])
+ GNULIB_LOGBL=0; AC_SUBST([GNULIB_LOGBL])
+ GNULIB_MODF=0; AC_SUBST([GNULIB_MODF])
+ GNULIB_MODFF=0; AC_SUBST([GNULIB_MODFF])
+ GNULIB_MODFL=0; AC_SUBST([GNULIB_MODFL])
+ GNULIB_POWF=0; AC_SUBST([GNULIB_POWF])
+ GNULIB_REMAINDER=0; AC_SUBST([GNULIB_REMAINDER])
+ GNULIB_REMAINDERF=0; AC_SUBST([GNULIB_REMAINDERF])
+ GNULIB_REMAINDERL=0; AC_SUBST([GNULIB_REMAINDERL])
+ GNULIB_RINT=0; AC_SUBST([GNULIB_RINT])
+ GNULIB_RINTF=0; AC_SUBST([GNULIB_RINTF])
+ GNULIB_RINTL=0; AC_SUBST([GNULIB_RINTL])
+ GNULIB_ROUND=0; AC_SUBST([GNULIB_ROUND])
+ GNULIB_ROUNDF=0; AC_SUBST([GNULIB_ROUNDF])
+ GNULIB_ROUNDL=0; AC_SUBST([GNULIB_ROUNDL])
+ GNULIB_SIGNBIT=0; AC_SUBST([GNULIB_SIGNBIT])
+ GNULIB_SINF=0; AC_SUBST([GNULIB_SINF])
+ GNULIB_SINL=0; AC_SUBST([GNULIB_SINL])
+ GNULIB_SINHF=0; AC_SUBST([GNULIB_SINHF])
+ GNULIB_SQRTF=0; AC_SUBST([GNULIB_SQRTF])
+ GNULIB_SQRTL=0; AC_SUBST([GNULIB_SQRTL])
+ GNULIB_TANF=0; AC_SUBST([GNULIB_TANF])
+ GNULIB_TANL=0; AC_SUBST([GNULIB_TANL])
+ GNULIB_TANHF=0; AC_SUBST([GNULIB_TANHF])
+ GNULIB_TRUNC=0; AC_SUBST([GNULIB_TRUNC])
+ GNULIB_TRUNCF=0; AC_SUBST([GNULIB_TRUNCF])
+ GNULIB_TRUNCL=0; AC_SUBST([GNULIB_TRUNCL])
dnl Assume proper GNU behavior unless another module says otherwise.
HAVE_ACOSF=1; AC_SUBST([HAVE_ACOSF])
HAVE_ACOSL=1; AC_SUBST([HAVE_ACOSL])
@@ -127,20 +168,31 @@ AC_DEFUN([gl_MATH_H_DEFAULTS],
HAVE_ATANF=1; AC_SUBST([HAVE_ATANF])
HAVE_ATANL=1; AC_SUBST([HAVE_ATANL])
HAVE_ATAN2F=1; AC_SUBST([HAVE_ATAN2F])
+ HAVE_CBRT=1; AC_SUBST([HAVE_CBRT])
+ HAVE_CBRTF=1; AC_SUBST([HAVE_CBRTF])
+ HAVE_CBRTL=1; AC_SUBST([HAVE_CBRTL])
HAVE_COPYSIGN=1; AC_SUBST([HAVE_COPYSIGN])
- HAVE_COPYSIGNF=1; AC_SUBST([HAVE_COPYSIGNF])
HAVE_COPYSIGNL=1; AC_SUBST([HAVE_COPYSIGNL])
HAVE_COSF=1; AC_SUBST([HAVE_COSF])
HAVE_COSL=1; AC_SUBST([HAVE_COSL])
HAVE_COSHF=1; AC_SUBST([HAVE_COSHF])
HAVE_EXPF=1; AC_SUBST([HAVE_EXPF])
HAVE_EXPL=1; AC_SUBST([HAVE_EXPL])
+ HAVE_EXPM1=1; AC_SUBST([HAVE_EXPM1])
+ HAVE_EXPM1F=1; AC_SUBST([HAVE_EXPM1F])
HAVE_FABSF=1; AC_SUBST([HAVE_FABSF])
+ HAVE_FABSL=1; AC_SUBST([HAVE_FABSL])
HAVE_FMA=1; AC_SUBST([HAVE_FMA])
HAVE_FMAF=1; AC_SUBST([HAVE_FMAF])
HAVE_FMAL=1; AC_SUBST([HAVE_FMAL])
HAVE_FMODF=1; AC_SUBST([HAVE_FMODF])
+ HAVE_FMODL=1; AC_SUBST([HAVE_FMODL])
HAVE_FREXPF=1; AC_SUBST([HAVE_FREXPF])
+ HAVE_HYPOTF=1; AC_SUBST([HAVE_HYPOTF])
+ HAVE_HYPOTL=1; AC_SUBST([HAVE_HYPOTL])
+ HAVE_ILOGB=1; AC_SUBST([HAVE_ILOGB])
+ HAVE_ILOGBF=1; AC_SUBST([HAVE_ILOGBF])
+ HAVE_ILOGBL=1; AC_SUBST([HAVE_ILOGBL])
HAVE_ISNANF=1; AC_SUBST([HAVE_ISNANF])
HAVE_ISNAND=1; AC_SUBST([HAVE_ISNAND])
HAVE_ISNANL=1; AC_SUBST([HAVE_ISNANL])
@@ -148,10 +200,18 @@ AC_DEFUN([gl_MATH_H_DEFAULTS],
HAVE_LOGF=1; AC_SUBST([HAVE_LOGF])
HAVE_LOGL=1; AC_SUBST([HAVE_LOGL])
HAVE_LOG10F=1; AC_SUBST([HAVE_LOG10F])
+ HAVE_LOG10L=1; AC_SUBST([HAVE_LOG10L])
+ HAVE_LOG1P=1; AC_SUBST([HAVE_LOG1P])
+ HAVE_LOG1PF=1; AC_SUBST([HAVE_LOG1PF])
+ HAVE_LOG1PL=1; AC_SUBST([HAVE_LOG1PL])
+ HAVE_LOGBF=1; AC_SUBST([HAVE_LOGBF])
+ HAVE_LOGBL=1; AC_SUBST([HAVE_LOGBL])
HAVE_MODFF=1; AC_SUBST([HAVE_MODFF])
+ HAVE_MODFL=1; AC_SUBST([HAVE_MODFL])
HAVE_POWF=1; AC_SUBST([HAVE_POWF])
+ HAVE_REMAINDER=1; AC_SUBST([HAVE_REMAINDER])
+ HAVE_REMAINDERF=1; AC_SUBST([HAVE_REMAINDERF])
HAVE_RINT=1; AC_SUBST([HAVE_RINT])
- HAVE_RINTF=1; AC_SUBST([HAVE_RINTF])
HAVE_RINTL=1; AC_SUBST([HAVE_RINTL])
HAVE_SINF=1; AC_SUBST([HAVE_SINF])
HAVE_SINL=1; AC_SUBST([HAVE_SINL])
@@ -164,16 +224,30 @@ AC_DEFUN([gl_MATH_H_DEFAULTS],
HAVE_DECL_ACOSL=1; AC_SUBST([HAVE_DECL_ACOSL])
HAVE_DECL_ASINL=1; AC_SUBST([HAVE_DECL_ASINL])
HAVE_DECL_ATANL=1; AC_SUBST([HAVE_DECL_ATANL])
+ HAVE_DECL_CBRTF=1; AC_SUBST([HAVE_DECL_CBRTF])
+ HAVE_DECL_CBRTL=1; AC_SUBST([HAVE_DECL_CBRTL])
HAVE_DECL_CEILF=1; AC_SUBST([HAVE_DECL_CEILF])
HAVE_DECL_CEILL=1; AC_SUBST([HAVE_DECL_CEILL])
+ HAVE_DECL_COPYSIGNF=1; AC_SUBST([HAVE_DECL_COPYSIGNF])
HAVE_DECL_COSL=1; AC_SUBST([HAVE_DECL_COSL])
HAVE_DECL_EXPL=1; AC_SUBST([HAVE_DECL_EXPL])
+ HAVE_DECL_EXP2=1; AC_SUBST([HAVE_DECL_EXP2])
+ HAVE_DECL_EXP2F=1; AC_SUBST([HAVE_DECL_EXP2F])
+ HAVE_DECL_EXP2L=1; AC_SUBST([HAVE_DECL_EXP2L])
+ HAVE_DECL_EXPM1L=1; AC_SUBST([HAVE_DECL_EXPM1L])
HAVE_DECL_FLOORF=1; AC_SUBST([HAVE_DECL_FLOORF])
HAVE_DECL_FLOORL=1; AC_SUBST([HAVE_DECL_FLOORL])
HAVE_DECL_FREXPL=1; AC_SUBST([HAVE_DECL_FREXPL])
HAVE_DECL_LDEXPL=1; AC_SUBST([HAVE_DECL_LDEXPL])
- HAVE_DECL_LOGB=1; AC_SUBST([HAVE_DECL_LOGB])
HAVE_DECL_LOGL=1; AC_SUBST([HAVE_DECL_LOGL])
+ HAVE_DECL_LOG10L=1; AC_SUBST([HAVE_DECL_LOG10L])
+ HAVE_DECL_LOG2=1; AC_SUBST([HAVE_DECL_LOG2])
+ HAVE_DECL_LOG2F=1; AC_SUBST([HAVE_DECL_LOG2F])
+ HAVE_DECL_LOG2L=1; AC_SUBST([HAVE_DECL_LOG2L])
+ HAVE_DECL_LOGB=1; AC_SUBST([HAVE_DECL_LOGB])
+ HAVE_DECL_REMAINDER=1; AC_SUBST([HAVE_DECL_REMAINDER])
+ HAVE_DECL_REMAINDERL=1; AC_SUBST([HAVE_DECL_REMAINDERL])
+ HAVE_DECL_RINTF=1; AC_SUBST([HAVE_DECL_RINTF])
HAVE_DECL_ROUND=1; AC_SUBST([HAVE_DECL_ROUND])
HAVE_DECL_ROUNDF=1; AC_SUBST([HAVE_DECL_ROUNDF])
HAVE_DECL_ROUNDL=1; AC_SUBST([HAVE_DECL_ROUNDL])
@@ -183,29 +257,66 @@ AC_DEFUN([gl_MATH_H_DEFAULTS],
HAVE_DECL_TRUNC=1; AC_SUBST([HAVE_DECL_TRUNC])
HAVE_DECL_TRUNCF=1; AC_SUBST([HAVE_DECL_TRUNCF])
HAVE_DECL_TRUNCL=1; AC_SUBST([HAVE_DECL_TRUNCL])
+ REPLACE_CBRTF=0; AC_SUBST([REPLACE_CBRTF])
+ REPLACE_CBRTL=0; AC_SUBST([REPLACE_CBRTL])
REPLACE_CEIL=0; AC_SUBST([REPLACE_CEIL])
REPLACE_CEILF=0; AC_SUBST([REPLACE_CEILF])
REPLACE_CEILL=0; AC_SUBST([REPLACE_CEILL])
+ REPLACE_EXPM1=0; AC_SUBST([REPLACE_EXPM1])
+ REPLACE_EXPM1F=0; AC_SUBST([REPLACE_EXPM1F])
+ REPLACE_EXP2=0; AC_SUBST([REPLACE_EXP2])
+ REPLACE_EXP2L=0; AC_SUBST([REPLACE_EXP2L])
+ REPLACE_FABSL=0; AC_SUBST([REPLACE_FABSL])
REPLACE_FLOOR=0; AC_SUBST([REPLACE_FLOOR])
REPLACE_FLOORF=0; AC_SUBST([REPLACE_FLOORF])
REPLACE_FLOORL=0; AC_SUBST([REPLACE_FLOORL])
REPLACE_FMA=0; AC_SUBST([REPLACE_FMA])
REPLACE_FMAF=0; AC_SUBST([REPLACE_FMAF])
REPLACE_FMAL=0; AC_SUBST([REPLACE_FMAL])
+ REPLACE_FMOD=0; AC_SUBST([REPLACE_FMOD])
+ REPLACE_FMODF=0; AC_SUBST([REPLACE_FMODF])
+ REPLACE_FMODL=0; AC_SUBST([REPLACE_FMODL])
REPLACE_FREXPF=0; AC_SUBST([REPLACE_FREXPF])
REPLACE_FREXP=0; AC_SUBST([REPLACE_FREXP])
REPLACE_FREXPL=0; AC_SUBST([REPLACE_FREXPL])
REPLACE_HUGE_VAL=0; AC_SUBST([REPLACE_HUGE_VAL])
+ REPLACE_HYPOT=0; AC_SUBST([REPLACE_HYPOT])
+ REPLACE_HYPOTF=0; AC_SUBST([REPLACE_HYPOTF])
+ REPLACE_HYPOTL=0; AC_SUBST([REPLACE_HYPOTL])
+ REPLACE_ILOGB=0; AC_SUBST([REPLACE_ILOGB])
+ REPLACE_ILOGBF=0; AC_SUBST([REPLACE_ILOGBF])
REPLACE_ISFINITE=0; AC_SUBST([REPLACE_ISFINITE])
REPLACE_ISINF=0; AC_SUBST([REPLACE_ISINF])
REPLACE_ISNAN=0; AC_SUBST([REPLACE_ISNAN])
REPLACE_LDEXPL=0; AC_SUBST([REPLACE_LDEXPL])
+ REPLACE_LOG=0; AC_SUBST([REPLACE_LOG])
+ REPLACE_LOGF=0; AC_SUBST([REPLACE_LOGF])
+ REPLACE_LOGL=0; AC_SUBST([REPLACE_LOGL])
+ REPLACE_LOG10=0; AC_SUBST([REPLACE_LOG10])
+ REPLACE_LOG10F=0; AC_SUBST([REPLACE_LOG10F])
+ REPLACE_LOG10L=0; AC_SUBST([REPLACE_LOG10L])
+ REPLACE_LOG1P=0; AC_SUBST([REPLACE_LOG1P])
+ REPLACE_LOG1PF=0; AC_SUBST([REPLACE_LOG1PF])
+ REPLACE_LOG1PL=0; AC_SUBST([REPLACE_LOG1PL])
+ REPLACE_LOG2=0; AC_SUBST([REPLACE_LOG2])
+ REPLACE_LOG2F=0; AC_SUBST([REPLACE_LOG2F])
+ REPLACE_LOG2L=0; AC_SUBST([REPLACE_LOG2L])
+ REPLACE_LOGB=0; AC_SUBST([REPLACE_LOGB])
+ REPLACE_LOGBF=0; AC_SUBST([REPLACE_LOGBF])
+ REPLACE_LOGBL=0; AC_SUBST([REPLACE_LOGBL])
+ REPLACE_MODF=0; AC_SUBST([REPLACE_MODF])
+ REPLACE_MODFF=0; AC_SUBST([REPLACE_MODFF])
+ REPLACE_MODFL=0; AC_SUBST([REPLACE_MODFL])
REPLACE_NAN=0; AC_SUBST([REPLACE_NAN])
+ REPLACE_REMAINDER=0; AC_SUBST([REPLACE_REMAINDER])
+ REPLACE_REMAINDERF=0; AC_SUBST([REPLACE_REMAINDERF])
+ REPLACE_REMAINDERL=0; AC_SUBST([REPLACE_REMAINDERL])
REPLACE_ROUND=0; AC_SUBST([REPLACE_ROUND])
REPLACE_ROUNDF=0; AC_SUBST([REPLACE_ROUNDF])
REPLACE_ROUNDL=0; AC_SUBST([REPLACE_ROUNDL])
REPLACE_SIGNBIT=0; AC_SUBST([REPLACE_SIGNBIT])
REPLACE_SIGNBIT_USING_GCC=0; AC_SUBST([REPLACE_SIGNBIT_USING_GCC])
+ REPLACE_SQRTL=0; AC_SUBST([REPLACE_SQRTL])
REPLACE_TRUNC=0; AC_SUBST([REPLACE_TRUNC])
REPLACE_TRUNCF=0; AC_SUBST([REPLACE_TRUNCF])
REPLACE_TRUNCL=0; AC_SUBST([REPLACE_TRUNCL])
diff --git a/m4/mathfunc.m4 b/m4/mathfunc.m4
index def871a..7147f7e 100644
--- a/m4/mathfunc.m4
+++ b/m4/mathfunc.m4
@@ -1,4 +1,4 @@
-# mathfunc.m4 serial 10
+# mathfunc.m4 serial 11
dnl Copyright (C) 2010-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -113,7 +113,7 @@ AC_DEFUN([gl_MATHFUNC],
# tests whether the function FUNC is available in libc or libm.
# It sets FUNC_LIBM to empty or "-lm" accordingly.
# FUNC must be one of the following functions, that are present on all systems
-# and provided by libm on all systems except MacOS X, BeOS, Haiku:
+# and provided by libm on all systems except Mac OS X, BeOS, Haiku:
# acos asin atan atan2 cbrt cos cosh erf erfc exp fmod hypot j0 j1 jn lgamma
# log log10 log1p pow remainder sin sinh sqrt tan tanh y0 y1 yn
diff --git a/m4/mmap-anon.m4 b/m4/mmap-anon.m4
index 4613cbe..748b17d 100644
--- a/m4/mmap-anon.m4
+++ b/m4/mmap-anon.m4
@@ -1,4 +1,4 @@
-# mmap-anon.m4 serial 9
+# mmap-anon.m4 serial 10
dnl Copyright (C) 2005, 2007, 2009-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -9,7 +9,7 @@ dnl with or without modifications, as long as this notice is
preserved.
# - On Linux, AIX, OSF/1, Solaris, Cygwin, Interix, Haiku, both MAP_ANONYMOUS
# and MAP_ANON exist and have the same value.
# - On HP-UX, only MAP_ANONYMOUS exists.
-# - On MacOS X, FreeBSD, NetBSD, OpenBSD, only MAP_ANON exists.
+# - On Mac OS X, FreeBSD, NetBSD, OpenBSD, only MAP_ANON exists.
# - On IRIX, neither exists, and a file descriptor opened to /dev/zero must be
# used.
@@ -27,18 +27,18 @@ AC_DEFUN([gl_FUNC_MMAP_ANON],
gl_have_mmap_anonymous=no
if test $gl_have_mmap = yes; then
AC_MSG_CHECKING([for MAP_ANONYMOUS])
- AC_EGREP_CPP([I cant identify this map], [
+ AC_EGREP_CPP([I cannot identify this map], [
#include <sys/mman.h>
#ifdef MAP_ANONYMOUS
- I cant identify this map
+ I cannot identify this map
#endif
],
[gl_have_mmap_anonymous=yes])
if test $gl_have_mmap_anonymous != yes; then
- AC_EGREP_CPP([I cant identify this map], [
+ AC_EGREP_CPP([I cannot identify this map], [
#include <sys/mman.h>
#ifdef MAP_ANON
- I cant identify this map
+ I cannot identify this map
#endif
],
[AC_DEFINE([MAP_ANONYMOUS], [MAP_ANON],
diff --git a/m4/multiarch.m4 b/m4/multiarch.m4
index b424dce..0c288b8 100644
--- a/m4/multiarch.m4
+++ b/m4/multiarch.m4
@@ -1,4 +1,4 @@
-# multiarch.m4 serial 6
+# multiarch.m4 serial 7
dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -6,7 +6,7 @@ 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
+# On Mac OS 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
diff --git a/m4/nocrash.m4 b/m4/nocrash.m4
index 08ef825..c2638df 100644
--- a/m4/nocrash.m4
+++ b/m4/nocrash.m4
@@ -1,4 +1,4 @@
-# nocrash.m4 serial 3
+# nocrash.m4 serial 4
dnl Copyright (C) 2005, 2009-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -18,7 +18,7 @@ dnl int main() { nocrash_init(); ... }
AC_DEFUN([GL_NOCRASH],[[
#include <stdlib.h>
#if defined __MACH__ && defined __APPLE__
-/* Avoid a crash on MacOS X. */
+/* Avoid a crash on Mac OS X. */
#include <mach/mach.h>
#include <mach/mach_error.h>
#include <mach/thread_status.h>
diff --git a/m4/off_t.m4 b/m4/off_t.m4
new file mode 100644
index 0000000..dfca2df
--- /dev/null
+++ b/m4/off_t.m4
@@ -0,0 +1,18 @@
+# off_t.m4 serial 1
+dnl Copyright (C) 2012 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 Check whether to override the 'off_t' type.
+dnl Set WINDOWS_64_BIT_OFF_T.
+
+AC_DEFUN([gl_TYPE_OFF_T],
+[
+ m4_ifdef([gl_LARGEFILE], [
+ AC_REQUIRE([gl_LARGEFILE])
+ ], [
+ WINDOWS_64_BIT_OFF_T=0
+ ])
+ AC_SUBST([WINDOWS_64_BIT_OFF_T])
+])
diff --git a/m4/printf.m4 b/m4/printf.m4
index d75aca0..751e896 100644
--- a/m4/printf.m4
+++ b/m4/printf.m4
@@ -1,4 +1,4 @@
-# printf.m4 serial 48
+# printf.m4 serial 50
dnl Copyright (C) 2003, 2007-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -63,7 +63,7 @@ changequote(,)dnl
# Guess yes on FreeBSD >= 5.
freebsd[1-4]*) gl_cv_func_printf_sizes_c99="guessing no";;
freebsd* | kfreebsd*) gl_cv_func_printf_sizes_c99="guessing yes";;
- # Guess yes on MacOS X >= 10.3.
+ # Guess yes on Mac OS X >= 10.3.
darwin[1-6].*) gl_cv_func_printf_sizes_c99="guessing no";;
darwin*) gl_cv_func_printf_sizes_c99="guessing yes";;
# Guess yes on OpenBSD >= 3.9.
@@ -222,7 +222,7 @@ changequote(,)dnl
# Guess yes on FreeBSD >= 6.
freebsd[1-5]*) gl_cv_func_printf_infinite="guessing no";;
freebsd* | kfreebsd*) gl_cv_func_printf_infinite="guessing yes";;
- # Guess yes on MacOS X >= 10.3.
+ # Guess yes on Mac OS X >= 10.3.
darwin[1-6].*) gl_cv_func_printf_infinite="guessing no";;
darwin*) gl_cv_func_printf_infinite="guessing yes";;
# Guess yes on HP-UX >= 11.
@@ -507,14 +507,14 @@ int main ()
if (sprintf (buf, "%010a %d", 1.0 / zero, 33, 44, 55) < 0
|| buf[0] == '0')
result |= 8;
- /* This catches a MacOS X 10.3.9 (Darwin 7.9) bug. */
+ /* This catches a Mac OS X 10.3.9 (Darwin 7.9) bug. */
if (sprintf (buf, "%.1a", 1.999) < 0
|| (strcmp (buf, "0x1.0p+1") != 0
&& strcmp (buf, "0x2.0p+0") != 0
&& strcmp (buf, "0x4.0p-1") != 0
&& strcmp (buf, "0x8.0p-2") != 0))
result |= 16;
- /* This catches the same MacOS X 10.3.9 (Darwin 7.9) bug and also a
+ /* This catches the same Mac OS X 10.3.9 (Darwin 7.9) bug and also a
glibc 2.4 bug <http://sourceware.org/bugzilla/show_bug.cgi?id=2908>. */
if (sprintf (buf, "%.1La", 1.999L) < 0
|| (strcmp (buf, "0x1.0p+1") != 0
@@ -590,7 +590,7 @@ changequote(,)dnl
# Guess yes on FreeBSD >= 6.
freebsd[1-5]*) gl_cv_func_printf_directive_f="guessing no";;
freebsd* | kfreebsd*) gl_cv_func_printf_directive_f="guessing yes";;
- # Guess yes on MacOS X >= 10.3.
+ # Guess yes on Mac OS X >= 10.3.
darwin[1-6].*) gl_cv_func_printf_directive_f="guessing no";;
darwin*) gl_cv_func_printf_directive_f="guessing yes";;
# Guess yes on Solaris >= 2.10.
@@ -1028,8 +1028,9 @@ int main()
changequote([,])dnl
])])
if AC_TRY_EVAL([ac_link]) && test -s conftest$ac_exeext; then
- (./conftest
+ (./conftest 2>&AS_MESSAGE_LOG_FD
result=$?
+ _AS_ECHO_LOG([\$? = $result])
if test $result != 0 && test $result != 77; then result=1; fi
exit $result
) >/dev/null 2>/dev/null
@@ -1043,7 +1044,7 @@ changequote([,])dnl
fi
rm -fr conftest*
else
- dnl A universal build on Apple MacOS X platforms.
+ dnl A universal build on Apple Mac OS X platforms.
dnl The result would be 'no' in 32-bit mode and 'yes' in 64-bit mode.
dnl But we need a configuration result that is valid in both modes.
gl_cv_func_printf_enomem="guessing no"
@@ -1137,7 +1138,7 @@ changequote(,)dnl
# Guess yes on FreeBSD >= 5.
freebsd[1-4]*) gl_cv_func_snprintf_truncation_c99="guessing
no";;
freebsd* | kfreebsd*) gl_cv_func_snprintf_truncation_c99="guessing
yes";;
- # Guess yes on MacOS X >= 10.3.
+ # Guess yes on Mac OS X >= 10.3.
darwin[1-6].*) gl_cv_func_snprintf_truncation_c99="guessing
no";;
darwin*) gl_cv_func_snprintf_truncation_c99="guessing
yes";;
# Guess yes on OpenBSD >= 3.9.
@@ -1236,7 +1237,7 @@ changequote(,)dnl
# Guess yes on FreeBSD >= 5.
freebsd[1-4]*) gl_cv_func_snprintf_retval_c99="guessing no";;
freebsd* | kfreebsd*) gl_cv_func_snprintf_retval_c99="guessing
yes";;
- # Guess yes on MacOS X >= 10.3.
+ # Guess yes on Mac OS X >= 10.3.
darwin[1-6].*) gl_cv_func_snprintf_retval_c99="guessing no";;
darwin*) gl_cv_func_snprintf_retval_c99="guessing
yes";;
# Guess yes on OpenBSD >= 3.9.
@@ -1317,7 +1318,7 @@ changequote(,)dnl
# Guess yes on FreeBSD >= 5.
freebsd[1-4]*) gl_cv_func_snprintf_directive_n="guessing
no";;
freebsd* | kfreebsd*) gl_cv_func_snprintf_directive_n="guessing
yes";;
- # Guess yes on MacOS X >= 10.3.
+ # Guess yes on Mac OS X >= 10.3.
darwin[1-6].*) gl_cv_func_snprintf_directive_n="guessing
no";;
darwin*) gl_cv_func_snprintf_directive_n="guessing
yes";;
# Guess yes on Solaris >= 2.6.
@@ -1459,7 +1460,7 @@ changequote(,)dnl
# Guess yes on FreeBSD >= 5.
freebsd[1-4]*) gl_cv_func_vsnprintf_zerosize_c99="guessing
no";;
freebsd* | kfreebsd*) gl_cv_func_vsnprintf_zerosize_c99="guessing
yes";;
- # Guess yes on MacOS X >= 10.3.
+ # Guess yes on Mac OS X >= 10.3.
darwin[1-6].*) gl_cv_func_vsnprintf_zerosize_c99="guessing
no";;
darwin*) gl_cv_func_vsnprintf_zerosize_c99="guessing
yes";;
# Guess yes on Cygwin.
@@ -1539,8 +1540,8 @@ dnl 1 2 3 4 5 6 7
8 9 10 11 12 13 14 15
dnl glibc 2.5 . . . . . . . . . . . . . .
. . . . . .
dnl glibc 2.3.6 . . . . # . . . . . . . . .
. . . . . .
dnl FreeBSD 5.4, 6.1 . . . . # . . . . . . # . #
. . . . . .
-dnl MacOS X 10.5.8 . . . # # . . . . . . # . .
. . . . . .
-dnl MacOS X 10.3.9 . . . . # . . . . . . # . #
. . . . . .
+dnl Mac OS X 10.5.8 . . . # # . . . . . . # . .
. . . . . .
+dnl Mac OS X 10.3.9 . . . . # . . . . . . # . #
. . . . . .
dnl OpenBSD 3.9, 4.0 . . # # # # . # . # . # . #
. . . . . .
dnl Cygwin 1.7.0 (2009) . . . # . . . ? . . . . . ?
. . . . . .
dnl Cygwin 1.5.25 (2008) . . . # # . . # . . . . . #
. . . . . .
diff --git a/m4/putenv.m4 b/m4/putenv.m4
index 1cb23a5..b971b12 100644
--- a/m4/putenv.m4
+++ b/m4/putenv.m4
@@ -1,4 +1,4 @@
-# putenv.m4 serial 18
+# putenv.m4 serial 19
dnl Copyright (C) 2002-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -12,6 +12,7 @@ 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_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([for putenv compatible with GNU and SVID],
[gl_cv_func_svid_putenv],
[AC_RUN_IFELSE([AC_LANG_PROGRAM([AC_INCLUDES_DEFAULT],[[
@@ -32,9 +33,18 @@ AC_DEFUN([gl_FUNC_PUTENV],
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)
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_svid_putenv="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_svid_putenv="guessing no" ;;
+ esac
+ ])
])
- if test $gl_cv_func_svid_putenv = no; then
- REPLACE_PUTENV=1
- fi
+ case "$gl_cv_func_svid_putenv" in
+ *yes) ;;
+ *)
+ REPLACE_PUTENV=1
+ ;;
+ esac
])
diff --git a/m4/readlink.m4 b/m4/readlink.m4
index 107083f..ccf5141 100644
--- a/m4/readlink.m4
+++ b/m4/readlink.m4
@@ -1,4 +1,4 @@
-# readlink.m4 serial 11
+# readlink.m4 serial 12
dnl Copyright (C) 2003, 2007, 2009-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -7,6 +7,7 @@ dnl with or without modifications, as long as this notice is
preserved.
AC_DEFUN([gl_FUNC_READLINK],
[
AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CHECK_FUNCS_ONCE([readlink])
if test $ac_cv_func_readlink = no; then
HAVE_READLINK=0
@@ -32,15 +33,26 @@ AC_DEFUN([gl_FUNC_READLINK],
]], [[char buf[20];
return readlink ("conftest.lnk2/", buf, sizeof buf) != -1;]])],
[gl_cv_func_readlink_works=yes], [gl_cv_func_readlink_works=no],
- [gl_cv_func_readlink_works="guessing no"])
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_readlink_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_readlink_works="guessing no" ;;
+ esac
+ ])
rm -f conftest.link conftest.lnk2])
- if test "$gl_cv_func_readlink_works" != yes; then
- AC_DEFINE([READLINK_TRAILING_SLASH_BUG], [1], [Define to 1 if readlink
- fails to recognize a trailing slash.])
- REPLACE_READLINK=1
- elif test "$gl_cv_decl_readlink_works" != yes; then
- REPLACE_READLINK=1
- fi
+ case "$gl_cv_func_readlink_works" in
+ *yes)
+ if test "$gl_cv_decl_readlink_works" != yes; then
+ REPLACE_READLINK=1
+ fi
+ ;;
+ *)
+ AC_DEFINE([READLINK_TRAILING_SLASH_BUG], [1], [Define to 1 if readlink
+ fails to recognize a trailing slash.])
+ REPLACE_READLINK=1
+ ;;
+ esac
fi
])
diff --git a/m4/regex.m4 b/m4/regex.m4
index 08f1352..41be5e8 100644
--- a/m4/regex.m4
+++ b/m4/regex.m4
@@ -1,4 +1,4 @@
-# serial 60
+# serial 61
# Copyright (C) 1996-2001, 2003-2012 Free Software Foundation, Inc.
#
@@ -175,6 +175,9 @@ AC_DEFUN([gl_REGEX],
esac
if test $ac_use_included_regex = yes; then
+ AC_DEFINE([_REGEX_INCLUDE_LIMITS_H], [1],
+ [Define if you want <regex.h> to include <limits.h>, so that it
+ consistently overrides <limits.h>'s RE_DUP_MAX.])
AC_DEFINE([_REGEX_LARGE_OFFSETS], [1],
[Define if you want regoff_t to be at least as wide POSIX requires.])
AC_DEFINE([re_syntax_options], [rpl_re_syntax_options],
diff --git a/m4/rename.m4 b/m4/rename.m4
index 59cc5c7..378b5ec 100644
--- a/m4/rename.m4
+++ b/m4/rename.m4
@@ -1,4 +1,4 @@
-# serial 25
+# serial 26
# Copyright (C) 2001, 2003, 2005-2006, 2009-2012 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
@@ -54,15 +54,24 @@ AC_DEFUN([gl_FUNC_RENAME],
[gl_cv_func_rename_slash_dst_works=yes],
[gl_cv_func_rename_slash_dst_works=no],
dnl When crosscompiling, assume rename is broken.
- [gl_cv_func_rename_slash_dst_works="guessing no"])
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_rename_slash_dst_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_rename_slash_dst_works="guessing no" ;;
+ esac
+ ])
rm -rf conftest.f conftest.f1 conftest.f2 conftest.d1 conftest.d2
conftest.lnk
])
- if test "x$gl_cv_func_rename_slash_dst_works" != xyes; then
- REPLACE_RENAME=1
- AC_DEFINE([RENAME_TRAILING_SLASH_DEST_BUG], [1],
- [Define if rename does not correctly handle slashes on the destination
- argument, such as on Solaris 10 or NetBSD 1.6.])
- fi
+ case "$gl_cv_func_rename_slash_dst_works" in
+ *yes) ;;
+ *)
+ REPLACE_RENAME=1
+ AC_DEFINE([RENAME_TRAILING_SLASH_DEST_BUG], [1],
+ [Define if rename does not correctly handle slashes on the destination
+ argument, such as on Solaris 10 or NetBSD 1.6.])
+ ;;
+ esac
dnl SunOS 4.1.1_U1 mistakenly forbids rename("dir/","name").
dnl Solaris 9 mistakenly allows rename("file/","name").
@@ -97,15 +106,24 @@ AC_DEFUN([gl_FUNC_RENAME],
[gl_cv_func_rename_slash_src_works=yes],
[gl_cv_func_rename_slash_src_works=no],
dnl When crosscompiling, assume rename is broken.
- [gl_cv_func_rename_slash_src_works="guessing no"])
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_rename_slash_src_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_rename_slash_src_works="guessing no" ;;
+ esac
+ ])
rm -rf conftest.f conftest.f1 conftest.d1 conftest.d2 conftest.d3
conftest.lnk
])
- if test "x$gl_cv_func_rename_slash_src_works" != xyes; then
- REPLACE_RENAME=1
- AC_DEFINE([RENAME_TRAILING_SLASH_SOURCE_BUG], [1],
- [Define if rename does not correctly handle slashes on the source
- argument, such as on Solaris 9 or cygwin 1.5.])
- fi
+ case "$gl_cv_func_rename_slash_src_works" in
+ *yes) ;;
+ *)
+ REPLACE_RENAME=1
+ AC_DEFINE([RENAME_TRAILING_SLASH_SOURCE_BUG], [1],
+ [Define if rename does not correctly handle slashes on the source
+ argument, such as on Solaris 9 or cygwin 1.5.])
+ ;;
+ esac
dnl NetBSD 1.6 and cygwin 1.5.x mistakenly reduce hard link count
dnl on rename("h1","h2").
@@ -137,7 +155,13 @@ AC_DEFUN([gl_FUNC_RENAME],
[gl_cv_func_rename_link_works=yes],
[gl_cv_func_rename_link_works=no],
dnl When crosscompiling, assume rename is broken.
- [gl_cv_func_rename_link_works="guessing no"])
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_rename_link_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_rename_link_works="guessing no" ;;
+ esac
+ ])
else
gl_cv_func_rename_link_works="guessing no"
fi
@@ -146,12 +170,15 @@ AC_DEFUN([gl_FUNC_RENAME],
gl_cv_func_rename_link_works=yes
fi
])
- if test "x$gl_cv_func_rename_link_works" != xyes; then
- REPLACE_RENAME=1
- AC_DEFINE([RENAME_HARD_LINK_BUG], [1],
- [Define if rename fails to leave hard links alone, as on NetBSD 1.6
- or Cygwin 1.5.])
- fi
+ case "$gl_cv_func_rename_link_works" in
+ *yes) ;;
+ *)
+ REPLACE_RENAME=1
+ AC_DEFINE([RENAME_HARD_LINK_BUG], [1],
+ [Define if rename fails to leave hard links alone, as on NetBSD 1.6
+ or Cygwin 1.5.])
+ ;;
+ esac
dnl Cygwin 1.5.x mistakenly allows rename("dir","file").
dnl mingw mistakenly forbids rename("dir1","dir2").
@@ -177,13 +204,22 @@ AC_DEFUN([gl_FUNC_RENAME],
[gl_cv_func_rename_dest_works=yes],
[gl_cv_func_rename_dest_works=no],
dnl When crosscompiling, assume rename is broken.
- [gl_cv_func_rename_dest_works="guessing no"])
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_rename_dest_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_rename_dest_works="guessing no" ;;
+ esac
+ ])
rm -rf conftest.f conftest.d1 conftest.d2
])
- if test "x$gl_cv_func_rename_dest_works" != xyes; then
- REPLACE_RENAME=1
- AC_DEFINE([RENAME_DEST_EXISTS_BUG], [1],
- [Define if rename does not work when the destination file exists,
- as on Cygwin 1.5 or Windows.])
- fi
+ case "$gl_cv_func_rename_dest_works" in
+ *yes) ;;
+ *)
+ REPLACE_RENAME=1
+ AC_DEFINE([RENAME_DEST_EXISTS_BUG], [1],
+ [Define if rename does not work when the destination file exists,
+ as on Cygwin 1.5 or Windows.])
+ ;;
+ esac
])
diff --git a/m4/rmdir.m4 b/m4/rmdir.m4
index c5f24cd..34ca876 100644
--- a/m4/rmdir.m4
+++ b/m4/rmdir.m4
@@ -1,4 +1,4 @@
-# rmdir.m4 serial 12
+# rmdir.m4 serial 13
dnl Copyright (C) 2002, 2005, 2009-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -7,6 +7,7 @@ dnl with or without modifications, as long as this notice is
preserved.
AC_DEFUN([gl_FUNC_RMDIR],
[
AC_REQUIRE([gl_UNISTD_H_DEFAULTS])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
dnl Detect cygwin 1.5.x bug.
AC_CHECK_HEADERS_ONCE([unistd.h])
AC_CACHE_CHECK([whether rmdir works], [gl_cv_func_rmdir_works],
@@ -31,9 +32,18 @@ AC_DEFUN([gl_FUNC_RMDIR],
return result;
]])],
[gl_cv_func_rmdir_works=yes], [gl_cv_func_rmdir_works=no],
- [gl_cv_func_rmdir_works="guessing no"])
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_rmdir_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_rmdir_works="guessing no" ;;
+ esac
+ ])
rm -rf conftest.dir conftest.file])
- if test x"$gl_cv_func_rmdir_works" != xyes; then
- REPLACE_RMDIR=1
- fi
+ case "$gl_cv_func_rmdir_works" in
+ *yes) ;;
+ *)
+ REPLACE_RMDIR=1
+ ;;
+ esac
])
diff --git a/m4/round.m4 b/m4/round.m4
new file mode 100644
index 0000000..514c4f7
--- /dev/null
+++ b/m4/round.m4
@@ -0,0 +1,142 @@
+# round.m4 serial 16
+dnl Copyright (C) 2007, 2009-2012 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_ROUND],
+[
+ m4_divert_text([DEFAULTS], [gl_round_required=plain])
+ AC_REQUIRE([gl_MATH_H_DEFAULTS])
+
+ dnl Persuade glibc <math.h> to declare round().
+ AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS])
+
+ gl_CHECK_MATH_LIB([ROUND_LIBM], [x = round (x);],
+ [extern
+ #ifdef __cplusplus
+ "C"
+ #endif
+ double round (double);
+ ])
+ if test "$ROUND_LIBM" != missing; then
+ HAVE_ROUND=1
+ dnl Also check whether it's declared.
+ dnl IRIX 6.5 has round() in libm but doesn't declare it in <math.h>.
+ AC_CHECK_DECLS([round], , [HAVE_DECL_ROUND=0], [[#include <math.h>]])
+
+ dnl Test whether round() produces correct results. On NetBSD 3.0, for
+ dnl x = 1/2 - 2^-54, the system's round() returns a wrong result.
+ AC_REQUIRE([AC_PROG_CC])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_CACHE_CHECK([whether round works], [gl_cv_func_round_works],
+ [
+ save_LIBS="$LIBS"
+ LIBS="$LIBS $ROUND_LIBM"
+ AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#include <float.h>
+#include <math.h>
+extern
+#ifdef __cplusplus
+"C"
+#endif
+double round (double);
+#ifdef _MSC_VER
+# pragma fenv_access (off)
+#endif
+int main()
+{
+ /* 2^DBL_MANT_DIG. */
+ static const double TWO_MANT_DIG =
+ /* Assume DBL_MANT_DIG <= 5 * 31.
+ Use the identity
+ n = floor(n/5) + floor((n+1)/5) + ... + floor((n+4)/5). */
+ (double) (1U << (DBL_MANT_DIG / 5))
+ * (double) (1U << ((DBL_MANT_DIG + 1) / 5))
+ * (double) (1U << ((DBL_MANT_DIG + 2) / 5))
+ * (double) (1U << ((DBL_MANT_DIG + 3) / 5))
+ * (double) (1U << ((DBL_MANT_DIG + 4) / 5));
+ volatile double x = 0.5 - 0.5 / TWO_MANT_DIG;
+ exit (x < 0.5 && round (x) != 0.0);
+}]])], [gl_cv_func_round_works=yes], [gl_cv_func_round_works=no],
+ [case "$host_os" in
+ netbsd* | aix*) gl_cv_func_round_works="guessing no";;
+ *) gl_cv_func_round_works="guessing yes";;
+ esac
+ ])
+ LIBS="$save_LIBS"
+ ])
+ case "$gl_cv_func_round_works" in
+ *no) REPLACE_ROUND=1 ;;
+ esac
+
+ m4_ifdef([gl_FUNC_ROUND_IEEE], [
+ if test $gl_round_required = ieee && test $REPLACE_ROUND = 0; then
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
+ AC_CACHE_CHECK([whether round works according to ISO C 99 with IEC
60559],
+ [gl_cv_func_round_ieee],
+ [
+ save_LIBS="$LIBS"
+ LIBS="$LIBS $ROUND_LIBM"
+ AC_RUN_IFELSE(
+ [AC_LANG_SOURCE([[
+#ifndef __NO_MATH_INLINES
+# define __NO_MATH_INLINES 1 /* for glibc */
+#endif
+#include <math.h>
+extern
+#ifdef __cplusplus
+"C"
+#endif
+double round (double);
+]gl_DOUBLE_MINUS_ZERO_CODE[
+]gl_DOUBLE_SIGNBIT_CODE[
+static double dummy (double f) { return 0; }
+int main (int argc, char *argv[])
+{
+ double (*my_round) (double) = argc ? round : dummy;
+ /* Test whether round (-0.0) is -0.0. */
+ if (signbitd (minus_zerod) && !signbitd (my_round (minus_zerod)))
+ return 1;
+ return 0;
+}
+ ]])],
+ [gl_cv_func_round_ieee=yes],
+ [gl_cv_func_round_ieee=no],
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_round_ieee="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_round_ieee="guessing no" ;;
+ esac
+ ])
+ LIBS="$save_LIBS"
+ ])
+ case "$gl_cv_func_round_ieee" in
+ *yes) ;;
+ *) REPLACE_ROUND=1 ;;
+ esac
+ fi
+ ])
+ else
+ HAVE_ROUND=0
+ HAVE_DECL_ROUND=0
+ fi
+ if test $HAVE_ROUND = 0 || test $REPLACE_ROUND = 1; then
+ dnl Find libraries needed to link lib/round.c.
+ gl_FUNC_FLOOR_LIBS
+ gl_FUNC_CEIL_LIBS
+ ROUND_LIBM=
+ dnl Append $FLOOR_LIBM to ROUND_LIBM, avoiding gratuitous duplicates.
+ case " $ROUND_LIBM " in
+ *" $FLOOR_LIBM "*) ;;
+ *) ROUND_LIBM="$ROUND_LIBM $FLOOR_LIBM" ;;
+ esac
+ dnl Append $CEIL_LIBM to ROUND_LIBM, avoiding gratuitous duplicates.
+ case " $ROUND_LIBM " in
+ *" $CEIL_LIBM "*) ;;
+ *) ROUND_LIBM="$ROUND_LIBM $CEIL_LIBM" ;;
+ esac
+ fi
+ AC_SUBST([ROUND_LIBM])
+])
diff --git a/m4/setenv.m4 b/m4/setenv.m4
index a1f30bc..e1931e7 100644
--- a/m4/setenv.m4
+++ b/m4/setenv.m4
@@ -1,4 +1,4 @@
-# setenv.m4 serial 25
+# setenv.m4 serial 26
dnl Copyright (C) 2001-2004, 2006-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -7,6 +7,7 @@ dnl with or without modifications, as long as this notice is
preserved.
AC_DEFUN([gl_FUNC_SETENV],
[
AC_REQUIRE([gl_FUNC_SETENV_SEPARATE])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
if test $ac_cv_func_setenv = no; then
HAVE_SETENV=0
else
@@ -33,10 +34,19 @@ AC_DEFUN([gl_FUNC_SETENV],
return result;
]])],
[gl_cv_func_setenv_works=yes], [gl_cv_func_setenv_works=no],
- [gl_cv_func_setenv_works="guessing no"])])
- if test "$gl_cv_func_setenv_works" != yes; then
- REPLACE_SETENV=1
- fi
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_setenv_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_setenv_works="guessing no" ;;
+ esac
+ ])])
+ case "$gl_cv_func_setenv_works" in
+ *yes) ;;
+ *)
+ REPLACE_SETENV=1
+ ;;
+ esac
fi
])
@@ -56,6 +66,7 @@ AC_DEFUN([gl_FUNC_SETENV_SEPARATE],
AC_DEFUN([gl_FUNC_UNSETENV],
[
AC_REQUIRE([gl_STDLIB_H_DEFAULTS])
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CHECK_DECLS_ONCE([unsetenv])
if test $ac_cv_have_decl_unsetenv = no; then
HAVE_DECL_UNSETENV=0
@@ -115,10 +126,19 @@ int unsetenv (const char *name);
if (getenv ("a")) return 6;
]])],
[gl_cv_func_unsetenv_works=yes], [gl_cv_func_unsetenv_works=no],
- [gl_cv_func_unsetenv_works="guessing no"])])
- if test "$gl_cv_func_unsetenv_works" != yes; then
- REPLACE_UNSETENV=1
- fi
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_unsetenv_works="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_unsetenv_works="guessing no" ;;
+ esac
+ ])])
+ case "$gl_cv_func_unsetenv_works" in
+ *yes) ;;
+ *)
+ REPLACE_UNSETENV=1
+ ;;
+ esac
fi
])
diff --git a/m4/stat.m4 b/m4/stat.m4
index d67dbcd..a8b79f5 100644
--- a/m4/stat.m4
+++ b/m4/stat.m4
@@ -1,4 +1,4 @@
-# serial 8
+# serial 10
# Copyright (C) 2009-2012 Free Software Foundation, Inc.
#
@@ -23,8 +23,9 @@ AC_DEFUN([gl_FUNC_STAT],
mingw*) gl_cv_func_stat_dir_slash="guessing no";;
*) gl_cv_func_stat_dir_slash="guessing yes";;
esac])])
- dnl AIX 7.1, Solaris 9 mistakenly succeed on stat("file/")
- dnl FreeBSD 7.2 mistakenly succeeds on stat("link-to-file/")
+ dnl AIX 7.1, Solaris 9, mingw64 mistakenly succeed on stat("file/").
+ dnl (For mingw, this is due to a broken stat() override in libmingwex.a.)
+ dnl FreeBSD 7.2 mistakenly succeeds on stat("link-to-file/").
AC_CACHE_CHECK([whether stat handles trailing slashes on files],
[gl_cv_func_stat_file_slash],
[touch conftest.tmp
@@ -46,7 +47,13 @@ AC_DEFUN([gl_FUNC_STAT],
return result;
]])],
[gl_cv_func_stat_file_slash=yes], [gl_cv_func_stat_file_slash=no],
- [gl_cv_func_stat_file_slash="guessing no"])
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_stat_file_slash="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_stat_file_slash="guessing no" ;;
+ esac
+ ])
rm -f conftest.tmp conftest.lnk])
case $gl_cv_func_stat_dir_slash in
*no) REPLACE_STAT=1
diff --git a/m4/stdalign.m4 b/m4/stdalign.m4
index 9752ba5..6659c9c 100644
--- a/m4/stdalign.m4
+++ b/m4/stdalign.m4
@@ -14,13 +14,27 @@ AC_DEFUN([gl_STDALIGN_H],
[AC_COMPILE_IFELSE(
[AC_LANG_PROGRAM(
[[#include <stdalign.h>
- int align_int = alignof (int) + _Alignof (double);
+ #include <stddef.h>
+
+ /* Test that alignof yields a result consistent with offsetof.
+ This catches GCC bug 52023
+ <http://gcc.gnu.org/bugzilla/show_bug.cgi?id=52023>. */
+ #ifdef __cplusplus
+ template <class t> struct alignof_helper { char a; t b; };
+ # define ao(type) offsetof (alignof_helper<type>, b)
+ #else
+ # define ao(type) offsetof (struct { char a; type b; }, b)
+ #endif
+ char test_double[ao (double) % _Alignof (double) == 0 ? 1 : -1];
+ char test_long[ao (long int) % _Alignof (long int) == 0 ? 1 : -1];
+ char test_alignof[alignof (double) == _Alignof (double) ? 1 : -1];
/* Test _Alignas only on platforms where gnulib can help. */
#if \
(__GNUC__ || __IBMC__ || __IBMCPP__ \
|| 0x5110 <= __SUNPRO_C || 1300 <= _MSC_VER)
int alignas (8) alignas_int = 1;
+ char test_alignas[_Alignof (alignas_int) == 8 ? 1 : -1];
#endif
]])],
[gl_cv_header_working_stdalign_h=yes],
diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4
index 1973e8d..5298dd6 100644
--- a/m4/stdio_h.m4
+++ b/m4/stdio_h.m4
@@ -1,4 +1,4 @@
-# stdio_h.m4 serial 40
+# stdio_h.m4 serial 42
dnl Copyright (C) 2007-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -13,12 +13,13 @@ AC_DEFUN([gl_STDIO_H],
dnl No need to create extra modules for these functions. Everyone who uses
dnl <stdio.h> likely needs them.
GNULIB_FSCANF=1
+ gl_MODULE_INDICATOR([fscanf])
GNULIB_SCANF=1
+ gl_MODULE_INDICATOR([scanf])
GNULIB_FGETC=1
GNULIB_GETC=1
GNULIB_GETCHAR=1
GNULIB_FGETS=1
- GNULIB_GETS=1
GNULIB_FREAD=1
dnl This ifdef is necessary to avoid an error "missing file lib/stdio-read.c"
dnl "expected source file, required through AC_LIBSOURCES, not found". It is
@@ -72,10 +73,10 @@ AC_DEFUN([gl_STDIO_H],
dnl Check for declarations of anything we want to poison if the
dnl corresponding gnulib module is not in use, and which is not
- dnl guaranteed by C89.
+ dnl guaranteed by both C89 and C11.
gl_WARN_ON_USE_PREPARE([[#include <stdio.h>
- ]], [dprintf fpurge fseeko ftello getdelim getline pclose popen renameat
- snprintf tmpfile vdprintf vsnprintf])
+ ]], [dprintf fpurge fseeko ftello getdelim getline gets pclose popen
+ renameat snprintf tmpfile vdprintf vsnprintf])
])
AC_DEFUN([gl_STDIO_MODULE_INDICATOR],
@@ -113,7 +114,6 @@ AC_DEFUN([gl_STDIO_H_DEFAULTS],
GNULIB_GETCHAR=0; AC_SUBST([GNULIB_GETCHAR])
GNULIB_GETDELIM=0; AC_SUBST([GNULIB_GETDELIM])
GNULIB_GETLINE=0; AC_SUBST([GNULIB_GETLINE])
- GNULIB_GETS=0; AC_SUBST([GNULIB_GETS])
GNULIB_OBSTACK_PRINTF=0; AC_SUBST([GNULIB_OBSTACK_PRINTF])
GNULIB_OBSTACK_PRINTF_POSIX=0; AC_SUBST([GNULIB_OBSTACK_PRINTF_POSIX])
GNULIB_PCLOSE=0; AC_SUBST([GNULIB_PCLOSE])
diff --git a/m4/strcase.m4 b/m4/strcase.m4
deleted file mode 100644
index 717fa9c..0000000
--- a/m4/strcase.m4
+++ /dev/null
@@ -1,45 +0,0 @@
-# strcase.m4 serial 11
-dnl Copyright (C) 2002, 2005-2012 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_STRCASE],
-[
- gl_FUNC_STRCASECMP
- gl_FUNC_STRNCASECMP
-])
-
-AC_DEFUN([gl_FUNC_STRCASECMP],
-[
- AC_REQUIRE([gl_HEADER_STRINGS_H_DEFAULTS])
- AC_CHECK_FUNCS([strcasecmp])
- if test $ac_cv_func_strcasecmp = no; then
- HAVE_STRCASECMP=0
- fi
-])
-
-AC_DEFUN([gl_FUNC_STRNCASECMP],
-[
- AC_REQUIRE([gl_HEADER_STRINGS_H_DEFAULTS])
- AC_CHECK_FUNCS([strncasecmp])
- if test $ac_cv_func_strncasecmp = yes; then
- HAVE_STRNCASECMP=1
- else
- HAVE_STRNCASECMP=0
- fi
- AC_CHECK_DECLS([strncasecmp])
- if test $ac_cv_have_decl_strncasecmp = no; then
- HAVE_DECL_STRNCASECMP=0
- fi
-])
-
-# Prerequisites of lib/strcasecmp.c.
-AC_DEFUN([gl_PREREQ_STRCASECMP], [
- :
-])
-
-# Prerequisites of lib/strncasecmp.c.
-AC_DEFUN([gl_PREREQ_STRNCASECMP], [
- :
-])
diff --git a/m4/strings_h.m4 b/m4/strings_h.m4
deleted file mode 100644
index a057e1c..0000000
--- a/m4/strings_h.m4
+++ /dev/null
@@ -1,52 +0,0 @@
-# Configure a replacement for <strings.h>.
-# serial 6
-
-# Copyright (C) 2007, 2009-2012 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.
-
-AC_DEFUN([gl_HEADER_STRINGS_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_STRINGS_H_BODY])
-])
-
-AC_DEFUN([gl_HEADER_STRINGS_H_BODY],
-[
- AC_REQUIRE([gl_HEADER_STRINGS_H_DEFAULTS])
-
- gl_CHECK_NEXT_HEADERS([strings.h])
- if test $ac_cv_header_strings_h = yes; then
- HAVE_STRINGS_H=1
- else
- HAVE_STRINGS_H=0
- fi
- AC_SUBST([HAVE_STRINGS_H])
-
- dnl Check for declarations of anything we want to poison if the
- dnl corresponding gnulib module is not in use.
- gl_WARN_ON_USE_PREPARE([[
- /* Minix 3.1.8 has a bug: <sys/types.h> must be included before
- <strings.h>. */
- #include <sys/types.h>
- #include <strings.h>
- ]], [ffs strcasecmp strncasecmp])
-])
-
-AC_DEFUN([gl_STRINGS_MODULE_INDICATOR],
-[
- dnl Use AC_REQUIRE here, so that the default settings are expanded once only.
- AC_REQUIRE([gl_HEADER_STRINGS_H_DEFAULTS])
- gl_MODULE_INDICATOR_SET_VARIABLE([$1])
-])
-
-AC_DEFUN([gl_HEADER_STRINGS_H_DEFAULTS],
-[
- GNULIB_FFS=0; AC_SUBST([GNULIB_FFS])
- dnl Assume proper GNU behavior unless another module says otherwise.
- HAVE_FFS=1; AC_SUBST([HAVE_FFS])
- HAVE_STRCASECMP=1; AC_SUBST([HAVE_STRCASECMP])
- HAVE_DECL_STRNCASECMP=1; AC_SUBST([HAVE_DECL_STRNCASECMP])
-])
diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4
index a0b96bc..f45dee1 100644
--- a/m4/sys_stat_h.m4
+++ b/m4/sys_stat_h.m4
@@ -1,4 +1,4 @@
-# sys_stat_h.m4 serial 26 -*- Autoconf -*-
+# sys_stat_h.m4 serial 27 -*- Autoconf -*-
dnl Copyright (C) 2006-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -22,6 +22,19 @@ AC_DEFUN([gl_HEADER_SYS_STAT_H],
dnl Ensure the type mode_t gets defined.
AC_REQUIRE([AC_TYPE_MODE_T])
+ dnl Whether to override 'struct stat'.
+ m4_ifdef([gl_LARGEFILE], [
+ AC_REQUIRE([gl_LARGEFILE])
+ ], [
+ WINDOWS_64_BIT_ST_SIZE=0
+ ])
+ AC_SUBST([WINDOWS_64_BIT_ST_SIZE])
+ if test $WINDOWS_64_BIT_ST_SIZE = 1; then
+ AC_DEFINE([_GL_WINDOWS_64_BIT_ST_SIZE], [1],
+ [Define to 1 if Gnulib overrides 'struct stat' on Windows so that
+ struct stat.st_size becomes 64-bit.])
+ fi
+
dnl Define types that are supposed to be defined in <sys/types.h> or
dnl <sys/stat.h>.
AC_CHECK_TYPE([nlink_t], [],
diff --git a/m4/sys_time_h.m4 b/m4/sys_time_h.m4
index bed3797..c4a30cd 100644
--- a/m4/sys_time_h.m4
+++ b/m4/sys_time_h.m4
@@ -1,5 +1,5 @@
# Configure a replacement for <sys/time.h>.
-# serial 7
+# serial 8
# Copyright (C) 2007, 2009-2012 Free Software Foundation, Inc.
# This file is free software; the Free Software Foundation
@@ -43,9 +43,40 @@ AC_DEFUN([gl_HEADER_SYS_TIME_H_BODY],
]],
[[static struct timeval x; x.tv_sec = x.tv_usec;]])],
[gl_cv_sys_struct_timeval=yes],
- [gl_cv_sys_struct_timeval=no])])
+ [gl_cv_sys_struct_timeval=no])
+ ])
if test $gl_cv_sys_struct_timeval != yes; then
HAVE_STRUCT_TIMEVAL=0
+ else
+ dnl On native Windows with a 64-bit 'time_t', 'struct timeval' is defined
+ dnl (in <sys/time.h> and <winsock2.h> for mingw64, in <winsock2.h> only
+ dnl for MSVC) with a tv_sec field of type 'long' (32-bit!), which is
+ dnl smaller than the 'time_t' type mandated by POSIX.
+ dnl On OpenBSD 5.1 amd64, tv_sec is 64 bits and time_t 32 bits, but
+ dnl that is good enough.
+ AC_CACHE_CHECK([for wide-enough struct timeval.tv_sec member],
+ [gl_cv_sys_struct_timeval_tv_sec],
+ [AC_COMPILE_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#if HAVE_SYS_TIME_H
+ #include <sys/time.h>
+ #endif
+ #include <time.h>
+ #if HAVE_WINSOCK2_H
+ # include <winsock2.h>
+ #endif
+ ]],
+ [[static struct timeval x;
+ typedef int verify_tv_sec_type[
+ sizeof (time_t) <= sizeof x.tv_sec ? 1 : -1
+ ];
+ ]])],
+ [gl_cv_sys_struct_timeval_tv_sec=yes],
+ [gl_cv_sys_struct_timeval_tv_sec=no])
+ ])
+ if test $gl_cv_sys_struct_timeval_tv_sec != yes; then
+ REPLACE_STRUCT_TIMEVAL=1
+ fi
fi
dnl Check for declarations of anything we want to poison if the
@@ -75,4 +106,5 @@ AC_DEFUN([gl_HEADER_SYS_TIME_H_DEFAULTS],
HAVE_STRUCT_TIMEVAL=1; AC_SUBST([HAVE_STRUCT_TIMEVAL])
HAVE_SYS_TIME_H=1; AC_SUBST([HAVE_SYS_TIME_H])
REPLACE_GETTIMEOFDAY=0; AC_SUBST([REPLACE_GETTIMEOFDAY])
+ REPLACE_STRUCT_TIMEVAL=0; AC_SUBST([REPLACE_STRUCT_TIMEVAL])
])
diff --git a/m4/sys_types_h.m4 b/m4/sys_types_h.m4
index 8d18ddb..f11eef2 100644
--- a/m4/sys_types_h.m4
+++ b/m4/sys_types_h.m4
@@ -1,4 +1,4 @@
-# sys_types_h.m4 serial 2
+# sys_types_h.m4 serial 4
dnl Copyright (C) 2011-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -14,6 +14,9 @@ AC_DEFUN([gl_SYS_TYPES_H],
dnl Ensure the type mode_t gets defined.
AC_REQUIRE([AC_TYPE_MODE_T])
+
+ dnl Whether to override the 'off_t' type.
+ AC_REQUIRE([gl_TYPE_OFF_T])
])
AC_DEFUN([gl_SYS_TYPES_H_DEFAULTS],
diff --git a/m4/time_h.m4 b/m4/time_h.m4
index b88da76..6415bfb 100644
--- a/m4/time_h.m4
+++ b/m4/time_h.m4
@@ -2,7 +2,7 @@
# Copyright (C) 2000-2001, 2003-2007, 2009-2012 Free Software Foundation, Inc.
-# serial 6
+# serial 7
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -25,7 +25,7 @@ AC_DEFUN([gl_HEADER_TIME_H_BODY],
AC_REQUIRE([gl_CHECK_TYPE_STRUCT_TIMESPEC])
])
-dnl Define HAVE_STRUCT_TIMESPEC if 'struct timespec' is declared
+dnl Check whether 'struct timespec' is declared
dnl in time.h, sys/time.h, or pthread.h.
AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC],
diff --git a/m4/time_r.m4 b/m4/time_r.m4
index c3579fb..9ddbd01 100644
--- a/m4/time_r.m4
+++ b/m4/time_r.m4
@@ -17,7 +17,7 @@ AC_DEFUN([gl_TIME_R],
dnl Some systems don't declare localtime_r() and gmtime_r() if _REENTRANT is
dnl not defined.
- AC_CHECK_DECLS_ONCE([localtime_r])
+ AC_CHECK_DECLS([localtime_r], [], [], [[#include <time.h>]])
if test $ac_cv_have_decl_localtime_r = no; then
HAVE_DECL_LOCALTIME_R=0
fi
diff --git a/m4/trunc.m4 b/m4/trunc.m4
index e9d5295..278384d 100644
--- a/m4/trunc.m4
+++ b/m4/trunc.m4
@@ -1,4 +1,4 @@
-# trunc.m4 serial 8
+# trunc.m4 serial 9
dnl Copyright (C) 2007, 2010-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -43,6 +43,7 @@ AC_DEFUN([gl_FUNC_TRUNC],
fi
m4_ifdef([gl_FUNC_TRUNC_IEEE], [
if test $gl_trunc_required = ieee && test $REPLACE_TRUNC = 0; then
+ AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles
AC_CACHE_CHECK([whether trunc works according to ISO C 99 with IEC
60559],
[gl_cv_func_trunc_ieee],
[
@@ -68,7 +69,13 @@ int main (int argc, char *argv[])
]])],
[gl_cv_func_trunc_ieee=yes],
[gl_cv_func_trunc_ieee=no],
- [gl_cv_func_trunc_ieee="guessing no"])
+ [case "$host_os" in
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_trunc_ieee="guessing yes" ;;
+ # If we don't know, assume the worst.
+ *) gl_cv_func_trunc_ieee="guessing no" ;;
+ esac
+ ])
LIBS="$save_LIBS"
])
case "$gl_cv_func_trunc_ieee" in
diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4
index 7595534..7e7651b 100644
--- a/m4/unistd_h.m4
+++ b/m4/unistd_h.m4
@@ -1,4 +1,4 @@
-# unistd_h.m4 serial 63
+# unistd_h.m4 serial 65
dnl Copyright (C) 2006-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -24,6 +24,9 @@ AC_DEFUN([gl_UNISTD_H],
dnl Ensure the type pid_t gets defined.
AC_REQUIRE([AC_TYPE_PID_T])
+ dnl Determine WINDOWS_64_BIT_OFF_T.
+ AC_REQUIRE([gl_TYPE_OFF_T])
+
dnl Check for declarations of anything we want to poison if the
dnl corresponding gnulib module is not in use.
gl_WARN_ON_USE_PREPARE([[
@@ -155,6 +158,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS],
REPLACE_DUP=0; AC_SUBST([REPLACE_DUP])
REPLACE_DUP2=0; AC_SUBST([REPLACE_DUP2])
REPLACE_FCHOWNAT=0; AC_SUBST([REPLACE_FCHOWNAT])
+ REPLACE_FTRUNCATE=0; AC_SUBST([REPLACE_FTRUNCATE])
REPLACE_GETCWD=0; AC_SUBST([REPLACE_GETCWD])
REPLACE_GETDOMAINNAME=0; AC_SUBST([REPLACE_GETDOMAINNAME])
REPLACE_GETLOGIN_R=0; AC_SUBST([REPLACE_GETLOGIN_R])
diff --git a/m4/vasnprintf.m4 b/m4/vasnprintf.m4
index 61fe499..0ce11da 100644
--- a/m4/vasnprintf.m4
+++ b/m4/vasnprintf.m4
@@ -1,4 +1,4 @@
-# vasnprintf.m4 serial 34
+# vasnprintf.m4 serial 35
dnl Copyright (C) 2002-2004, 2006-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -29,7 +29,7 @@ AC_DEFUN([gl_REPLACE_VASNPRINTF],
gl_PREREQ_ASNPRINTF
])
-# Prequisites of lib/printf-args.h, lib/printf-args.c.
+# Prerequisites of lib/printf-args.h, lib/printf-args.c.
AC_DEFUN([gl_PREREQ_PRINTF_ARGS],
[
AC_REQUIRE([AC_TYPE_LONG_LONG_INT])
@@ -37,7 +37,7 @@ AC_DEFUN([gl_PREREQ_PRINTF_ARGS],
AC_REQUIRE([gt_TYPE_WINT_T])
])
-# Prequisites of lib/printf-parse.h, lib/printf-parse.c.
+# Prerequisites of lib/printf-parse.h, lib/printf-parse.c.
AC_DEFUN([gl_PREREQ_PRINTF_PARSE],
[
AC_REQUIRE([gl_FEATURES_H])
diff --git a/m4/visibility.m4 b/m4/visibility.m4
index 7b24d39..a7d4d8c 100644
--- a/m4/visibility.m4
+++ b/m4/visibility.m4
@@ -1,4 +1,4 @@
-# visibility.m4 serial 4 (gettext-0.18.2)
+# visibility.m4 serial 5 (gettext-0.18.2)
dnl Copyright (C) 2005, 2008, 2010-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -12,7 +12,7 @@ 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 Mac OS 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
diff --git a/m4/warn-on-use.m4 b/m4/warn-on-use.m4
index 03b113c..a77802e 100644
--- a/m4/warn-on-use.m4
+++ b/m4/warn-on-use.m4
@@ -1,4 +1,4 @@
-# warn-on-use.m4 serial 4
+# warn-on-use.m4 serial 5
dnl Copyright (C) 2010-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -18,8 +18,8 @@ dnl with or without modifications, as long as this notice is
preserved.
# some systems declare functions in the wrong header, then INCLUDES
# should do likewise.
#
-# If you assume C89, then it is generally safe to assume declarations
-# for functions declared in that standard (such as gets) without
+# It is generally safe to assume declarations for functions declared
+# in the intersection of C89 and C11 (such as printf) without
# needing gl_WARN_ON_USE_PREPARE.
AC_DEFUN([gl_WARN_ON_USE_PREPARE],
[
diff --git a/m4/warnings.m4 b/m4/warnings.m4
index 69d05a6..28b8294 100644
--- a/m4/warnings.m4
+++ b/m4/warnings.m4
@@ -1,4 +1,4 @@
-# warnings.m4 serial 5
+# warnings.m4 serial 7
dnl Copyright (C) 2008-2012 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -14,24 +14,48 @@ m4_ifdef([AS_VAR_APPEND],
[m4_define([gl_AS_VAR_APPEND],
[AS_VAR_SET([$1], [AS_VAR_GET([$1])$2])])])
-# gl_WARN_ADD(PARAMETER, [VARIABLE = WARN_CFLAGS])
-# ------------------------------------------------
-# Adds parameter to WARN_CFLAGS if the compiler supports it. For example,
-# gl_WARN_ADD([-Wparentheses]).
-AC_DEFUN([gl_WARN_ADD],
-dnl FIXME: gl_Warn must be used unquoted until we can assume
-dnl autoconf 2.64 or newer.
-[AS_VAR_PUSHDEF([gl_Warn], [gl_cv_warn_$1])dnl
-AC_CACHE_CHECK([whether compiler handles $1], m4_defn([gl_Warn]), [
- gl_save_CPPFLAGS="$CPPFLAGS"
- CPPFLAGS="${CPPFLAGS} $1"
- AC_PREPROC_IFELSE([AC_LANG_PROGRAM([])],
+
+# gl_COMPILER_OPTION_IF(OPTION, [IF-SUPPORTED], [IF-NOT-SUPPORTED],
+# [PROGRAM = AC_LANG_PROGRAM()])
+# -----------------------------------------------------------------
+# Check if the compiler supports OPTION when compiling PROGRAM.
+#
+# FIXME: gl_Warn must be used unquoted until we can assume Autoconf
+# 2.64 or newer.
+AC_DEFUN([gl_COMPILER_OPTION_IF],
+[AS_VAR_PUSHDEF([gl_Warn], [gl_cv_warn_[]_AC_LANG_ABBREV[]_$1])dnl
+AS_VAR_PUSHDEF([gl_Flags], [_AC_LANG_PREFIX[]FLAGS])dnl
+AC_CACHE_CHECK([whether _AC_LANG compiler handles $1], m4_defn([gl_Warn]), [
+ gl_save_compiler_FLAGS="$gl_Flags"
+ gl_AS_VAR_APPEND(m4_defn([gl_Flags]), [" $1"])
+ AC_COMPILE_IFELSE([m4_default([$4], [AC_LANG_PROGRAM([])])],
[AS_VAR_SET(gl_Warn, [yes])],
[AS_VAR_SET(gl_Warn, [no])])
- CPPFLAGS="$gl_save_CPPFLAGS"
+ gl_Flags="$gl_save_compiler_FLAGS"
])
-AS_VAR_IF(gl_Warn, [yes],
- [gl_AS_VAR_APPEND(m4_if([$2], [], [[WARN_CFLAGS]], [[$2]]), [" $1"])])
+AS_VAR_IF(gl_Warn, [yes], [$2], [$3])
+AS_VAR_POPDEF([gl_Flags])dnl
AS_VAR_POPDEF([gl_Warn])dnl
-m4_ifval([$2], [AS_LITERAL_IF([$2], [AC_SUBST([$2])], [])])dnl
])
+
+
+# gl_WARN_ADD(OPTION, [VARIABLE = WARN_CFLAGS],
+# [PROGRAM = AC_LANG_PROGRAM()])
+# ---------------------------------------------
+# Adds parameter to WARN_CFLAGS if the compiler supports it when
+# compiling PROGRAM. For example, gl_WARN_ADD([-Wparentheses]).
+#
+# If VARIABLE is a variable name, AC_SUBST it.
+AC_DEFUN([gl_WARN_ADD],
+[gl_COMPILER_OPTION_IF([$1],
+ [gl_AS_VAR_APPEND(m4_if([$2], [], [[WARN_CFLAGS]], [[$2]]), [" $1"])],
+ [],
+ [$3])
+m4_ifval([$2],
+ [AS_LITERAL_IF([$2], [AC_SUBST([$2])])],
+ [AC_SUBST([WARN_CFLAGS])])dnl
+])
+
+# Local Variables:
+# mode: autoconf
+# End:
diff --git a/m4/wctype_h.m4 b/m4/wctype_h.m4
index a109383..4b19f64 100644
--- a/m4/wctype_h.m4
+++ b/m4/wctype_h.m4
@@ -1,4 +1,4 @@
-# wctype_h.m4 serial 16
+# wctype_h.m4 serial 17
dnl A placeholder for ISO C99 <wctype.h>, for platforms that lack it.
@@ -57,7 +57,8 @@ AC_DEFUN([gl_WCTYPE_H],
#if __GNU_LIBRARY__ == 1
Linux libc5 i18n is broken.
#endif]], [])],
- [gl_cv_func_iswcntrl_works=yes], [gl_cv_func_iswcntrl_works=no])
+ [gl_cv_func_iswcntrl_works="guessing yes"],
+ [gl_cv_func_iswcntrl_works="guessing no"])
])
])
fi
@@ -67,11 +68,10 @@ AC_DEFUN([gl_WCTYPE_H],
fi
AC_SUBST([HAVE_WCTYPE_H])
- if test "$gl_cv_func_iswcntrl_works" = no; then
- REPLACE_ISWCNTRL=1
- else
- REPLACE_ISWCNTRL=0
- fi
+ case "$gl_cv_func_iswcntrl_works" in
+ *yes) REPLACE_ISWCNTRL=0 ;;
+ *) REPLACE_ISWCNTRL=1 ;;
+ esac
AC_SUBST([REPLACE_ISWCNTRL])
if test $HAVE_ISWCNTRL = 0 || test $REPLACE_ISWCNTRL = 1; then
diff --git a/maint.mk b/maint.mk
index ad6aac7..a1af711 100644
--- a/maint.mk
+++ b/maint.mk
@@ -178,6 +178,13 @@ syntax-check: $(local-check)
# Regular expression (ERE) denoting either a forbidden construct
# or a required construct. Those arguments are exclusive.
#
+# exclude
+#
+# Regular expression (ERE) denoting lines to ignore that matched
+# a prohibit construct. For example, this can be used to exclude
+# comments that mention why the nearby code uses an alternative
+# construct instead of the simpler prohibited construct.
+#
# in_vc_files | in_files
#
# grep-E-style regexp denoting the files to check. If no files
@@ -212,6 +219,17 @@ syntax-check: $(local-check)
# when filtering by name via in_files, we explicitly filter out matching
# names here as well.
+# Initialize each, so that envvar settings cannot interfere.
+export require =
+export prohibit =
+export exclude =
+export in_vc_files =
+export in_files =
+export containing =
+export non_containing =
+export halt =
+export with_grep_options =
+
# By default, _sc_search_regexp does not ignore case.
export ignore_case =
_ignore_case = $$(test -n "$$ignore_case" && printf %s -i || :)
@@ -231,6 +249,9 @@ define _sc_search_regexp
test -z "$$prohibit" && test -z "$$require" \
&& { msg='Should specify either prohibit or require' \
$(_sc_say_and_exit) } || :; \
+ test -z "$$prohibit" && test -n "$$exclude" \
+ && { msg='Use of exclude requires a prohibit pattern' \
+ $(_sc_say_and_exit) } || :; \
test -n "$$in_vc_files" && test -n "$$in_files" \
&& { msg='Cannot specify both in_vc_files and in_files' \
$(_sc_say_and_exit) } || :; \
@@ -258,6 +279,7 @@ define _sc_search_regexp
if test -n "$$files"; then \
if test -n "$$prohibit"; then \
grep $$with_grep_options $(_ignore_case) -nE "$$prohibit" $$files \
+ | grep -vE "$${exclude:-^$$}" \
&& { msg="$$halt" $(_sc_say_and_exit) } || :; \
else \
grep $$with_grep_options $(_ignore_case) -LE "$$require" $$files \
@@ -276,17 +298,17 @@ sc_avoid_if_before_free:
exit 1; } || :
sc_cast_of_argument_to_free:
- @prohibit='\<free *\( *\(' halt='don'\''t cast free argument' \
+ @prohibit='\<free *\( *\(' halt="don't cast free argument" \
$(_sc_search_regexp)
sc_cast_of_x_alloc_return_value:
@prohibit='\*\) *x(m|c|re)alloc\>' \
- halt='don'\''t cast x*alloc return value' \
+ halt="don't cast x*alloc return value" \
$(_sc_search_regexp)
sc_cast_of_alloca_return_value:
@prohibit='\*\) *alloca\>' \
- halt='don'\''t cast alloca return value' \
+ halt="don't cast alloca return value" \
$(_sc_search_regexp)
sc_space_tab:
@@ -303,12 +325,20 @@ sc_prohibit_atoi_atof:
$(_sc_search_regexp)
# Use STREQ rather than comparing strcmp == 0, or != 0.
+sp_ = strcmp *\(.+\)
sc_prohibit_strcmp:
- @grep -nE '! *str''cmp *\(|\<str''cmp *\(.+\) *[!=]=' \
- $$($(VC_LIST_EXCEPT)) \
- | grep -vE ':# *define STRN?EQ\(' && \
- { echo '$(ME): replace str''cmp calls above with STREQ/STRNEQ' \
- 1>&2; exit 1; } || :
+ @prohibit='! *strcmp *\(|\<$(sp_) *[!=]=|[!=]= *$(sp_)' \
+ exclude=':# *define STRN?EQ\(' \
+ halt='$(ME): replace strcmp calls above with STREQ/STRNEQ' \
+ $(_sc_search_regexp)
+
+# Really. You don't want to use this function.
+# It may fail to NUL-terminate the destination,
+# and always NUL-pads out to the specified length.
+sc_prohibit_strncpy:
+ @prohibit='\<strncpy *\(' \
+ halt='do not use strncpy, period' \
+ $(_sc_search_regexp)
# Pass EXIT_*, not number, to usage, exit, and error (when exiting)
# Convert all uses automatically, via these two commands:
@@ -433,7 +463,8 @@ sc_prohibit_quotearg_without_use:
# Don't include quote.h unless you use one of its functions.
sc_prohibit_quote_without_use:
- @h='quote.h' re='\<quote(_n)? *\(' $(_sc_header_without_use)
+ @h='quote.h' re='\<quote((_n)? *\(|_quoting_options\>)' \
+ $(_sc_header_without_use)
# Don't include this header unless you use one of its functions.
sc_prohibit_long_options_without_use:
@@ -502,7 +533,7 @@ sc_prohibit_same_without_use:
sc_prohibit_hash_pjw_without_use:
@h='hash-pjw.h' \
- re='\<hash_pjw *\(' \
+ re='\<hash_pjw\>' \
$(_sc_header_without_use)
sc_prohibit_safe_read_without_use:
@@ -516,7 +547,7 @@ sc_prohibit_argmatch_without_use:
sc_prohibit_canonicalize_without_use:
@h='canonicalize.h' \
-
re='CAN_(EXISTING|ALL_BUT_LAST|MISSING)|canonicalize_(mode_t|filename_mode)' \
+
re='CAN_(EXISTING|ALL_BUT_LAST|MISSING)|canonicalize_(mode_t|filename_mode|file_name)'
\
$(_sc_header_without_use)
sc_prohibit_root_dev_ino_without_use:
@@ -708,12 +739,10 @@ _gl_translatable_diag_func_re ?= error
# Look for diagnostics that aren't marked for translation.
# This won't find any for which error's format string is on a separate line.
sc_unmarked_diagnostics:
- @grep -nE \
- '\<$(_gl_translatable_diag_func_re) *\([^"]*"[^"]*[a-z]{3}' \
- $$($(VC_LIST_EXCEPT)) \
- | grep -Ev '(_|ngettext ?)\(' && \
- { echo '$(ME): found unmarked diagnostic(s)' 1>&2; \
- exit 1; } || :
+ @prohibit='\<$(_gl_translatable_diag_func_re) *\([^"]*"[^"]*[a-z]{3}' \
+ exclude='(_|ngettext ?)\(' \
+ halt='$(ME): found unmarked diagnostic(s)' \
+ $(_sc_search_regexp)
# Avoid useless parentheses like those in this example:
# #if defined (SYMBOL) || defined (SYM2)
@@ -911,8 +940,15 @@ sc_prohibit_doubled_word:
# A regular expression matching undesirable combinations of words like
# "can not"; this matches them even when the two words appear on different
# lines, but not when there is an intervening delimiter like "#" or "*".
+# Similarly undesirable, "See @xref{...}", since an @xref should start
+# a sentence. Explicitly prohibit any prefix of "see" or "also".
+# Also prohibit a prefix matching "\w+ +".
+# @pxref gets the same see/also treatment and should be parenthesized;
+# presume it must *not* start a sentence.
+bad_xref_re_ ?= (?:[\w,:;] +|(?:see|also)\s+)address@hidden
+bad_pxref_re_ ?= (?:[.!?]|(?:see|also))address@hidden
prohibit_undesirable_word_seq_RE_ ?= \
- /\bcan\s+not\b/gims
+ /(?:\bcan\s+not\b|$(bad_xref_re_)|$(bad_pxref_re_))/gims
prohibit_undesirable_word_seq_ = \
-e 'while ($(prohibit_undesirable_word_seq_RE_))' \
$(perl_filename_lineno_text_)
@@ -974,10 +1010,10 @@ sc_redundant_const:
$(_sc_search_regexp)
sc_const_long_option:
- @grep '^ *static.*struct option ' $$($(VC_LIST_EXCEPT)) \
- | grep -Ev 'const struct option|struct option const' && { \
- echo 1>&2 '$(ME): add "const" to the above declarations'; \
- exit 1; } || :
+ @prohibit='^ *static.*struct option ' \
+ exclude='const struct option|struct option const' \
+ halt='$(ME): add "const" to the above declarations' \
+ $(_sc_search_regexp)
NEWS_hash = \
$$(sed -n '/^\*.* $(PREV_VERSION_REGEXP) ([0-9-]*)/,$$p' \
@@ -1015,15 +1051,15 @@ update-NEWS-hash: NEWS
# setting this to ' && !/PRAGMA_SYSTEM_HEADER/'.
_makefile_at_at_check_exceptions ?=
sc_makefile_at_at_check:
- @perl -ne '/address@hidden@/' \
- -e ' && !/([A-Z_0-9]+)address@hidden@$$/' \
+ @perl -ne '/address@hidden@/'
\
+ -e ' && !/(\w+)address@hidden@$$/' \
-e ''$(_makefile_at_at_check_exceptions) \
-e 'and (print "$$ARGV:$$.: $$_"), $$m=1; END {exit !$$m}' \
$$($(VC_LIST_EXCEPT) | grep -E '(^|/)(Makefile\.am|[^/]+\.mk)$$') \
&& { echo '$(ME): use $$(...), not @...@' 1>&2; exit 1; } || :
news-check: NEWS
- if sed -n $(news-check-lines-spec)p $(srcdir)/NEWS \
+ if sed -n $(news-check-lines-spec)p $< \
| grep -E $(news-check-regexp) >/dev/null; then \
:; \
else \
@@ -1079,7 +1115,7 @@ sc_po_check:
# Sometimes it is useful to change the PATH environment variable
# in Makefiles. When doing so, it's better not to use the Unix-centric
# path separator of ':', but rather the automake-provided '$(PATH_SEPARATOR)'.
-msg = '$(ME): Do not use '\'':'\'' above; use $$(PATH_SEPARATOR) instead'
+msg = '$(ME): Do not use ":" above; use $$(PATH_SEPARATOR) instead'
sc_makefile_path_separator_check:
@prohibit='PATH[=].*:' \
in_vc_files='akefile|\.mk$$' \
@@ -1206,7 +1242,7 @@ bootstrap-tools ?= autoconf,automake,gnulib
gpg_key_ID ?= \
$$(git cat-file tag v$(VERSION) \
| gpgv --status-fd 1 --keyring /dev/null - - 2>/dev/null \
- | sed -n '/^\[GNUPG:\] ERRSIG /{s///;s/ .*//p;q}')
+ | awk '/^\[GNUPG:\] ERRSIG / {print $$3; exit}')
translation_project_ ?= address@hidden
@@ -1232,9 +1268,11 @@ announcement: NEWS ChangeLog $(rel-files)
--prev=$(PREV_VERSION) \
--curr=$(VERSION) \
--gpg-key-id=$(gpg_key_ID) \
+ --srcdir=$(srcdir) \
--news=$(srcdir)/NEWS \
--bootstrap-tools=$(bootstrap-tools) \
- --gnulib-version=$(gnulib-version) \
+ $$(case ,$(bootstrap-tools), in (*,gnulib,*) \
+ echo --gnulib-version=$(gnulib-version);; esac) \
--no-print-checksums \
$(addprefix --url-dir=, $(url_dir_list))
@@ -1311,7 +1349,7 @@ alpha beta stable: $(local-check) writable-files
$(submodule-checks)
$(MAKE) vc-diff-check
$(MAKE) news-check
$(MAKE) distcheck
- $(MAKE) dist XZ_OPT=-9ev
+ $(MAKE) dist
$(MAKE) $(release-prep-hook) RELEASE_TYPE=$@
$(MAKE) -s emit_upload_commands RELEASE_TYPE=$@
@@ -1330,7 +1368,7 @@ release-prep:
fi
echo $(VERSION) > $(prev_version_file)
$(MAKE) update-NEWS-hash
- perl -pi -e '$$. == 3 and print "$(gl_noteworthy_news_)\n\n\n"' NEWS
+ perl -pi -e '$$. == 3 and print "$(gl_noteworthy_news_)\n\n\n"'
$(srcdir)/NEWS
$(emit-commit-log) > .ci-msg
$(VC) commit -F .ci-msg -a
rm .ci-msg
@@ -1385,7 +1423,7 @@ refresh-po:
wget --no-verbose --directory-prefix $(PODIR) --no-directories
--recursive --level 1 --accept .po --accept .po.1 $(POURL) && \
echo 'address@hidden' > $(PODIR)/LINGUAS && \
echo 'address@hidden' >> $(PODIR)/LINGUAS && \
- ls $(PODIR)/*.po | sed 's/\.po//' | sed 's,$(PODIR)/,,' | sort >>
$(PODIR)/LINGUAS
+ ls $(PODIR)/*.po | sed 's/\.po//;s,$(PODIR)/,,' | sort >>
$(PODIR)/LINGUAS
# Running indent once is not idempotent, but running it twice is.
INDENT_SOURCES ?= $(C_SOURCES)
diff --git a/meta/Makefile.am b/meta/Makefile.am
index f26fc44..a05730d 100644
--- a/meta/Makefile.am
+++ b/meta/Makefile.am
@@ -1,7 +1,8 @@
## Process this file with Automake to create Makefile.in
## Jim Blandy <address@hidden> --- September 1997
##
-## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009, 2011 Free
Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009, 2011,
+## 2012 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -28,8 +29,12 @@ EXTRA_DIST= \
# What we now call `guild' used to be known as `guile-tools'.
install-data-hook:
- cd $(DESTDIR)$(bindir) && rm -f guile-tools$(EXEEXT) && \
- $(LN_S) guild$(EXEEXT) guile-tools$(EXEEXT)
+ guild="`echo $(ECHO_N) guild \
+ | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ; \
+ guile_tools="`echo $(ECHO_N) guile-tools \
+ | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ; \
+ cd $(DESTDIR)$(bindir) && rm -f "$$guile_tools" && \
+ $(LN_S) "$$guild" "$$guile_tools"
pkgconfigdir = $(libdir)/pkgconfig
pkgconfig_DATA = guile-2.0.pc
diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in
index 5fa0db0..567c6e2 100644
--- a/meta/uninstalled-env.in
+++ b/meta/uninstalled-env.in
@@ -1,6 +1,6 @@
#!/bin/sh
-# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011 Free Software
Foundation
+# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software
Foundation
#
# This file is part of GUILE.
#
@@ -57,12 +57,12 @@ if test "@cross_compiling@" = "no"
then
if [ x"$GUILE_LOAD_PATH" = x ]
then
-
GUILE_LOAD_PATH="${top_srcdir}/module:${top_srcdir}/guile-readline:${top_srcdir}"
+ GUILE_LOAD_PATH="${top_srcdir}/module:${top_srcdir}/guile-readline"
if test "${top_srcdir}" != "${top_builddir}"; then
-
GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
+
GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline"
fi
else
- for d in "/module" "/guile-readline" ""
+ for d in "/module" "/guile-readline"
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
@@ -82,9 +82,9 @@ then
if test "x$GUILE_LOAD_COMPILED_PATH" = "x"
then
-
GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
+
GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline"
else
- for d in "/module" "/guile-readline" ""
+ for d in "/module" "/guile-readline"
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
diff --git a/module/Makefile.am b/module/Makefile.am
index 14e46a5..12aa316 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -32,12 +32,18 @@ nobase_ccache_DATA += ice-9/eval.go
EXTRA_DIST += ice-9/eval.scm
ETAGS_ARGS += ice-9/eval.scm
+ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm
ice-9/r6rs-libraries.scm
+
# We can compile these in any order, but it's fastest if we compile
# psyntax and boot-9 first, then the compiler itself, then the rest of
# the code.
SOURCES = \
ice-9/psyntax-pp.scm \
ice-9/boot-9.scm \
+ ice-9/vlist.scm \
+ srfi/srfi-1.scm \
+ language/tree-il/peval.scm \
+ language/tree-il/cse.scm \
\
language/tree-il.scm \
language/glil.scm \
@@ -95,7 +101,7 @@ SCHEME_LANG_SOURCES =
\
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
- language/tree-il/peval.scm \
+ language/tree-il/effects.scm \
language/tree-il/fix-letrec.scm \
language/tree-il/optimize.scm \
language/tree-il/canonicalize.scm \
@@ -243,11 +249,9 @@ ICE_9_SOURCES = \
ice-9/weak-vector.scm \
ice-9/list.scm \
ice-9/serialize.scm \
- ice-9/vlist.scm \
ice-9/local-eval.scm
SRFI_SOURCES = \
- srfi/srfi-1.scm \
srfi/srfi-2.scm \
srfi/srfi-4.scm \
srfi/srfi-4/gnu.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 41ce924..5ed543a 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -780,7 +780,8 @@ information is unavailable."
(let ((proc (frame-procedure frame)))
(print-location frame port)
(format port "In procedure ~a:\n"
- (or (procedure-name proc) proc))))
+ (or (false-if-exception (procedure-name proc))
+ proc))))
(print-location frame port)
(catch #t
@@ -1049,16 +1050,13 @@ VALUE."
;; 0: type-name, 1: fields, 2: constructor
(define record-type-vtable
- ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for
- ;; that we need to expose the bare vtable-vtable to Scheme.
- (make-vtable-vtable "prprpw" 0
- (lambda (s p)
- (cond ((eq? s record-type-vtable)
- (display "#<record-type-vtable>" p))
- (else
- (display "#<record-type " p)
- (display (record-type-name s) p)
- (display ">" p))))))
+ (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
+ (lambda (s p)
+ (display "#<record-type " p)
+ (display (record-type-name s) p)
+ (display ">" p)))))
+ (set-struct-vtable-name! s 'record-type)
+ s))
(define (record-type? obj)
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
@@ -1523,55 +1521,7 @@ VALUE."
;;; Every module object is of the type 'module-type', which is a record
;;; consisting of the following members:
;;;
-;;; - eval-closure: the function that defines for its module the strategy that
-;;; shall be followed when looking up symbols in the module.
-;;;
-;;; An eval-closure is a function taking two arguments: the symbol to be
-;;; looked up and a boolean value telling whether a binding for the symbol
-;;; should be created if it does not exist yet. If the symbol lookup
-;;; succeeded (either because an existing binding was found or because a new
-;;; binding was created), a variable object representing the binding is
-;;; returned. Otherwise, the value #f is returned. Note that the eval
-;;; closure does not take the module to be searched as an argument: During
-;;; construction of the eval-closure, the eval-closure has to store the
-;;; module it belongs to in its environment. This means, that any
-;;; eval-closure can belong to only one module.
-;;;
-;;; The eval-closure of a module can be defined arbitrarily. However, three
-;;; special cases of eval-closures are to be distinguished: During startup
-;;; the module system is not yet activated. In this phase, no modules are
-;;; defined and all bindings are automatically stored by the system in the
-;;; pre-modules-obarray. Since no eval-closures exist at this time, the
-;;; functions which require an eval-closure as their argument need to be
-;;; passed the value #f.
-;;;
-;;; The other two special cases of eval-closures are the
-;;; standard-eval-closure and the standard-interface-eval-closure. Both
-;;; behave equally for the case that no new binding is to be created. The
-;;; difference between the two comes in, when the boolean argument to the
-;;; eval-closure indicates that a new binding shall be created if it is not
-;;; found.
-;;;
-;;; Given that no new binding shall be created, both standard eval-closures
-;;; define the following standard strategy of searching bindings in the
-;;; module: First, the module's obarray is searched for the symbol. Second,
-;;; if no binding for the symbol was found in the module's obarray, the
-;;; module's binder procedure is exececuted. If this procedure did not
-;;; return a binding for the symbol, the modules referenced in the module's
-;;; uses list are recursively searched for a binding of the symbol. If the
-;;; binding can not be found in these modules also, the symbol lookup has
-;;; failed.
-;;;
-;;; If a new binding shall be created, the standard-interface-eval-closure
-;;; immediately returns indicating failure. That is, it does not even try
-;;; to look up the symbol. In contrast, the standard-eval-closure would
-;;; first search the obarray, and if no binding was found there, would
-;;; create a new binding in the obarray, therefore not calling the binder
-;;; procedure or searching the modules in the uses list.
-;;;
-;;; The explanation of the following members obarray, binder and uses
-;;; assumes that the symbol lookup follows the strategy that is defined in
-;;; the standard-eval-closure and the standard-interface-eval-closure.
+;;; - eval-closure: A deprecated field, to be removed in Guile 2.2.
;;;
;;; - obarray: a hash table that maps symbols to variable objects. In this
;;; hash table, the definitions are found that are local to the module (that
@@ -1779,7 +1729,6 @@ VALUE."
;; NOTE: If you change the set of fields or their order, you also need to
;; change the constants in libguile/modules.h.
;;
- ;; NOTE: The getter `module-eval-closure' is used in libguile/modules.c.
;; NOTE: The getter `module-transfomer' is defined libguile/modules.c.
;; NOTE: The getter `module-name' is defined later, due to boot reasons.
;; NOTE: The getter `module-public-interface' is used in libguile/modules.c.
@@ -1823,20 +1772,13 @@ VALUE."
(error
"Lazy-binder expected to be a procedure or #f." binder))
- (let ((module (module-constructor (make-hash-table size)
- uses binder #f macroexpand
- #f #f #f
- (make-hash-table %default-import-size)
- '()
- (make-weak-key-hash-table 31) #f
- (make-hash-table 7) #f #f #f)))
-
- ;; We can't pass this as an argument to module-constructor,
- ;; because we need it to close over a pointer to the module
- ;; itself.
- (set-module-eval-closure! module (standard-eval-closure module))
-
- module))
+ (module-constructor (make-hash-table size)
+ uses binder #f macroexpand
+ #f #f #f
+ (make-hash-table %default-import-size)
+ '()
+ (make-weak-key-hash-table 31) #f
+ (make-hash-table 7) #f #f #f))
@@ -2430,9 +2372,6 @@ VALUE."
;;; better thought of as a root.
;;;
-(define (set-system-module! m s)
- (set-procedure-property! (module-eval-closure m) 'system-module s))
-
;; The root module uses the pre-modules-obarray as its obarray. This
;; special obarray accumulates all bindings that have been established
;; before the module system is fully booted.
@@ -2444,7 +2383,6 @@ VALUE."
(let ((m (make-module 0)))
(set-module-obarray! m (%get-pre-modules-obarray))
(set-module-name! m '(guile))
- (set-system-module! m #t)
m))
;; The root interface is a module that uses the same obarray as the
@@ -2453,10 +2391,8 @@ VALUE."
(define the-scm-module
(let ((m (make-module 0)))
(set-module-obarray! m (%get-pre-modules-obarray))
- (set-module-eval-closure! m (standard-interface-eval-closure m))
(set-module-name! m '(guile))
(set-module-kind! m 'interface)
- (set-system-module! m #t)
;; In Guile 1.8 and earlier M was its own public interface.
(set-module-public-interface! m m)
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index 8aed74e..62a2c9e 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law."))
(define* (version-etc package version #:key
(port (current-output-port))
;; FIXME: authors
- (copyright-year 2011)
+ (copyright-year 2012)
(copyright-holder "Free Software Foundation, Inc.")
(copyright (format #f "Copyright (C) ~a ~a"
copyright-year copyright-holder))
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 3d803e9..201ae39 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -17,11 +17,70 @@
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(use-modules (language tree-il)
- (language tree-il optimize)
+ (language tree-il primitives)
(language tree-il canonicalize)
+ (srfi srfi-1)
(ice-9 pretty-print)
(system syntax))
+;; Minimize a syntax-object such that it can no longer be used as the
+;; first argument to 'datum->syntax', but is otherwise equivalent.
+(define (squeeze-syntax-object! syn)
+ (define (ensure-list x) (if (vector? x) (vector->list x) x))
+ (let ((x (vector-ref syn 1))
+ (wrap (vector-ref syn 2))
+ (mod (vector-ref syn 3)))
+ (let ((marks (car wrap))
+ (subst (cdr wrap)))
+ (define (set-wrap! marks subst)
+ (vector-set! syn 2 (cons marks subst)))
+ (cond
+ ((symbol? x)
+ (let loop ((marks marks) (subst subst))
+ (cond
+ ((null? subst) (set-wrap! marks subst) syn)
+ ((eq? 'shift (car subst)) (loop (cdr marks) (cdr subst)))
+ ((find (lambda (entry) (and (eq? x (car entry))
+ (equal? marks (cadr entry))))
+ (apply map list (map ensure-list
+ (cdr (vector->list (car subst))))))
+ => (lambda (entry)
+ (set-wrap! marks
+ (list (list->vector
+ (cons 'ribcage
+ (map vector entry)))))
+ syn))
+ (else (loop marks (cdr subst))))))
+ ((or (pair? x) (vector? x))
+ syn)
+ (else x)))))
+
+(define (squeeze-constant! x)
+ (define (syntax-object? x)
+ (and (vector? x)
+ (= 4 (vector-length x))
+ (eq? 'syntax-object (vector-ref x 0))))
+ (cond ((syntax-object? x)
+ (squeeze-syntax-object! x))
+ ((pair? x)
+ (set-car! x (squeeze-constant! (car x)))
+ (set-cdr! x (squeeze-constant! (cdr x)))
+ x)
+ ((vector? x)
+ (for-each (lambda (i)
+ (vector-set! x i (squeeze-constant! (vector-ref x i))))
+ (iota (vector-length x)))
+ x)
+ (else x)))
+
+(define (squeeze-tree-il! x)
+ (post-order! (lambda (x)
+ (if (const? x)
+ (set! (const-exp x)
+ (squeeze-constant! (const-exp x))))
+ #f)
+ x))
+
;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
;; changing session identifiers.
(set! syntax-session-id (lambda () "*"))
@@ -40,12 +99,19 @@
(close-port in))
(begin
(pretty-print (tree-il->scheme
- (canonicalize!
- (optimize!
- (macroexpand x 'c '(compile load eval))
- (current-module)
- '())))
- out)
+ (squeeze-tree-il!
+ (canonicalize!
+ (resolve-primitives!
+ (macroexpand x 'c '(compile load eval))
+ (current-module))))
+ (current-module)
+ (list #:avoid-lambda? #f
+ #:use-case? #f
+ #:strip-numeric-suffixes? #t
+ #:use-derived-syntax?
+ (and (pair? x)
+ (eq? 'let (car x)))))
+ out #:width 120 #:max-expr-width 70)
(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 ef2bc24..9d80cfe 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -69,7 +69,8 @@
turn-on-debugging
read-hash-procedures
process-define-module
- fluid-let-syntax))
+ fluid-let-syntax
+ set-system-module!))
;;;; Deprecated definitions.
@@ -879,3 +880,19 @@ it.")
((_ ((k v) ...) body0 body ...)
#'(syntax-parameterize ((k v) ...)
body0 body ...)))))
+
+(define (close-io-port port)
+ (issue-deprecation-warning
+ "`close-io-port' is deprecated. Use `close-port' instead.")
+ (close-port port))
+
+(define (set-system-module! m s)
+ (issue-deprecation-warning
+ "`set-system-module!' is deprecated. There is no need to use it.")
+ (set-procedure-property! (module-eval-closure m) 'system-module s))
+
+(set! module-eval-closure
+ (lambda (m)
+ (issue-deprecation-warning
+ "`module-eval-closure' is deprecated. Use module-variable or
module-define! instead.")
+ (standard-eval-closure m)))
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 74b8532..81b9538 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -238,7 +238,14 @@
(define (set-procedure-arity! proc)
(let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
(if (not alt)
- (set-procedure-minimum-arity! proc nreq nopt rest?)
+ (begin
+ (set-procedure-property! proc 'arglist
+ (list nreq
+ nopt
+ (if kw (cdr kw) '())
+ (and kw (car kw))
+ (and rest? '_)))
+ (set-procedure-minimum-arity! proc nreq nopt rest?))
(let* ((nreq* (cadr alt))
(rest?* (if (null? (cddr alt)) #f (caddr alt)))
(tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr
alt)))
diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm
index 96422b5..6c9db27 100644
--- a/module/ice-9/ftw.scm
+++ b/module/ice-9/ftw.scm
@@ -538,26 +538,29 @@ of file names is sorted according to ENTRY<?, which
defaults to
(define (enter? dir stat result)
(and stat (string=? dir name)))
- (define (leaf name stat result)
- (if (select? name)
- (and (pair? result) ; must have a "." entry
- (cons (basename name) result))
+ (define (visit basename result)
+ (if (select? basename)
+ (cons basename result)
result))
+ (define (leaf name stat result)
+ (and result
+ (visit (basename name) result)))
+
(define (down name stat result)
- (list "."))
+ (visit "." '()))
(define (up name stat result)
- (cons ".." result))
+ (visit ".." result))
(define (skip name stat result)
;; All the sub-directories are skipped.
- (cons (basename name) result))
+ (visit (basename name) result))
(define (error name* stat errno result)
(if (string=? name name*) ; top-level NAME is unreadable
result
- (cons (basename name*) result)))
+ (visit (basename name*) result)))
(and=> (file-system-fold enter? leaf down up skip error #f name stat)
(lambda (files)
diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index 4b078c6..7fd191a 100644
--- a/module/ice-9/match.scm
+++ b/module/ice-9/match.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011, 2012 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
@@ -52,7 +52,7 @@
;; `match' doesn't support clauses of the form `(pat => exp)'.
;; Unmodified public domain code by Alex Shinn retrieved from
-;; the Chibi-Scheme repository, commit 876:528cdab3f818.
+;; the Chibi-Scheme repository, commit 1206:acd808700e91.
;;
;; Note: Make sure to update `match.test.upstream' when updating this
;; file.
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index 9786556..29f9dbe 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -210,6 +210,7 @@
;; performance can be found at
;; http://synthcode.com/scheme/match-cond-expand.scm
;;
+;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
;; the pattern (thanks to Stefan Israelsson Tampe)
;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
@@ -479,7 +480,8 @@
(match-one v p . x))
((_ v (p . q) g+s sk fk i)
;; match one and try the remaining on failure
- (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
+ (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
+ (match-one v p g+s sk (fk2) i)))
))
;; We match a pattern (p ...) by matching the pattern p in a loop on
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index b9debd4..7ca4868 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -1,6 +1,6 @@
;; popen emulation, for non-stdio based ports.
-;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011 Free
Software Foundation, Inc.
+;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012 Free
Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -21,6 +21,10 @@
:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
open-output-pipe open-input-output-pipe))
+(eval-when (load eval compile)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_popen"))
+
(define (make-rw-port read-port write-port)
(make-soft-port
(vector
@@ -38,100 +42,6 @@
;; a weak hash-table to store the process ids.
(define port/pid-table (make-weak-key-hash-table 31))
-(define (ensure-fdes port mode)
- (or (false-if-exception (fileno port))
- (open-fdes *null-device* mode)))
-
-;; run a process connected to an input, an output or an
-;; input/output port
-;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH
-;; returns port/pid pair.
-(define (open-process mode prog . args)
- (let* ((reading (or (equal? mode OPEN_READ)
- (equal? mode OPEN_BOTH)))
- (writing (or (equal? mode OPEN_WRITE)
- (equal? mode OPEN_BOTH)))
- (c2p (if reading (pipe) #f)) ; child to parent
- (p2c (if writing (pipe) #f))) ; parent to child
-
- (if c2p (setvbuf (cdr c2p) _IONBF))
- (if p2c (setvbuf (cdr p2c) _IONBF))
- (let ((pid (primitive-fork)))
- (cond ((= pid 0)
- ;; child
- (ensure-batch-mode!)
-
- ;; select the three file descriptors to be used as
- ;; standard descriptors 0, 1, 2 for the new
- ;; process. They are pipes to/from the parent or taken
- ;; from the current Scheme input/output/error ports if
- ;; possible.
-
- (let ((input-fdes (if writing
- (fileno (car p2c))
- (ensure-fdes (current-input-port)
- O_RDONLY)))
- (output-fdes (if reading
- (fileno (cdr c2p))
- (ensure-fdes (current-output-port)
- O_WRONLY)))
- (error-fdes (ensure-fdes (current-error-port)
- O_WRONLY)))
-
- ;; close all file descriptors in ports inherited from
- ;; the parent except for the three selected above.
- ;; this is to avoid causing problems for other pipes in
- ;; the parent.
-
- ;; use low-level system calls, not close-port or the
- ;; scsh routines, to avoid side-effects such as
- ;; flushing port buffers or evicting ports.
-
- (port-for-each (lambda (pt-entry)
- (false-if-exception
- (let ((pt-fileno (fileno pt-entry)))
- (if (not (or (= pt-fileno input-fdes)
- (= pt-fileno output-fdes)
- (= pt-fileno error-fdes)))
- (close-fdes pt-fileno))))))
-
- ;; Copy the three selected descriptors to the standard
- ;; descriptors 0, 1, 2, if not already there
-
- (cond ((not (= input-fdes 0))
- (if (= output-fdes 0)
- (set! output-fdes (dup->fdes 0)))
- (if (= error-fdes 0)
- (set! error-fdes (dup->fdes 0)))
- (dup2 input-fdes 0)
- ;; it's possible input-fdes is error-fdes
- (if (not (= input-fdes error-fdes))
- (close-fdes input-fdes))))
-
- (cond ((not (= output-fdes 1))
- (if (= error-fdes 1)
- (set! error-fdes (dup->fdes 1)))
- (dup2 output-fdes 1)
- ;; it's possible output-fdes is error-fdes
- (if (not (= output-fdes error-fdes))
- (close-fdes output-fdes))))
-
- (cond ((not (= error-fdes 2))
- (dup2 error-fdes 2)
- (close-fdes error-fdes)))
-
- (apply execlp prog prog args)))
-
- (else
- ;; parent
- (if c2p (close-port (cdr c2p)))
- (if p2c (close-port (car p2c)))
- (cons (cond ((not writing) (car c2p))
- ((not reading) (cdr p2c))
- (else (make-rw-port (car c2p)
- (cdr p2c))))
- pid))))))
-
(define (open-pipe* mode command . args)
"Executes the program @var{command} with optional arguments
@var{args} (all strings) in a subprocess.
@@ -213,3 +123,4 @@ information on how to interpret this value."
(define (open-input-output-pipe command)
"Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
(open-pipe command OPEN_BOTH))
+
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 8a0c0b8..5c23cb0 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -1,6 +1,7 @@
;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation,
Inc.
+;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010,
+;;;; 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -32,7 +33,8 @@
(define genwrite:newline-str (make-string 1 #\newline))
-(define (generic-write obj display? width per-line-prefix output)
+(define (generic-write
+ obj display? width max-expr-width per-line-prefix output)
(define (read-macro? l)
(define (length1? l) (and (pair? l) (null? (cdr l))))
@@ -93,7 +95,7 @@
(if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
(let ((result '())
(left (min (+ (- (- width col) extra) 1) max-expr-width)))
- (generic-write obj display? #f ""
+ (generic-write obj display? #f max-expr-width ""
(lambda (str)
(set! result (cons str result))
(set! left (- left (string-length str)))
@@ -223,12 +225,10 @@
(define max-call-head-width 5)
- (define max-expr-width 50)
-
(define (style head)
(case head
- ((lambda let* letrec define define-public
- define-syntax let-syntax letrec-syntax)
+ ((lambda lambda* let* letrec define define* define-public
+ define-syntax let-syntax letrec-syntax with-syntax)
pp-LAMBDA)
((if set!) pp-IF)
((cond) pp-COND)
@@ -273,6 +273,7 @@
#:key
(port (or port* (current-output-port)))
(width 79)
+ (max-expr-width 50)
(display? #f)
(per-line-prefix ""))
"Pretty-print OBJ on PORT, which is a keyword argument defaulting to
@@ -286,6 +287,7 @@ Instead of with a keyword argument, you can also specify
the output
port directly after OBJ, like (pretty-print OBJ PORT)."
(generic-write obj display?
(- width (string-length per-line-prefix))
+ max-expr-width
per-line-prefix
(lambda (s) (display s port) #t)))
@@ -318,9 +320,10 @@ sub-expression, via the @var{breadth-first?} keyword
argument."
(let ((e "â¦"))
(catch 'encoding-error
(lambda ()
- (with-output-to-string
- (lambda ()
- (display e))))
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (with-output-to-string
+ (lambda ()
+ (display e)))))
(lambda (key . args)
"..."))))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index dd6b6ca..68d1bf6 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1,26817 +1,3143 @@
(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
(if #f #f)
-(let ((session-id-4256 (if #f #f))
- (transformer-environment-4317 (if #f #f)))
- (letrec*
- ((top-level-eval-hook-4254
- (lambda (x-27424 mod-27425)
- (primitive-eval x-27424)))
- (get-global-definition-hook-4258
- (lambda (symbol-15687 module-15688)
- (begin
- (if (if (not module-15688) (current-module) #f)
- (warn "module system is booted, we should have a module"
- symbol-15687))
- (let ((v-15689
- (module-variable
- (if module-15688
- (resolve-module (cdr module-15688))
- (current-module))
- symbol-15687)))
- (if v-15689
- (if (variable-bound? v-15689)
- (let ((val-15691 (variable-ref v-15689)))
- (if (macro? val-15691)
- (if (macro-type val-15691)
- (cons (macro-type val-15691)
- (macro-binding val-15691))
- #f)
- #f))
- #f)
- #f)))))
- (maybe-name-value!-4260
- (lambda (name-15968 val-15969)
- (if (if (struct? val-15969)
- (eq? (struct-vtable val-15969)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((meta-15976 (struct-ref val-15969 1)))
- (if (not (assq 'name meta-15976))
- (let ((v-15981
- (cons (cons 'name name-15968) meta-15976)))
- (struct-set! val-15969 1 v-15981)))))))
- (build-application-4262
- (lambda (source-15693 fun-exp-15694 arg-exps-15695)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- source-15693
- fun-exp-15694
- arg-exps-15695)))
- (build-conditional-4263
- (lambda (source-15701
- test-exp-15702
- then-exp-15703
- else-exp-15704)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 10)
- source-15701
- test-exp-15702
- then-exp-15703
- else-exp-15704)))
- (build-dynlet-4264
- (lambda (source-15711 fluids-15712 vals-15713 body-15714)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 17)
- source-15711
- fluids-15712
- vals-15713
- body-15714)))
- (build-lexical-reference-4265
- (lambda (type-27426 source-27427 name-27428 var-27429)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- source-27427
- name-27428
- var-27429)))
- (build-lexical-assignment-4266
- (lambda (source-15721 name-15722 var-15723 exp-15724)
- (begin
- (if (if (struct? exp-15724)
- (eq? (struct-vtable exp-15724)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((meta-15740 (struct-ref exp-15724 1)))
- (if (not (assq 'name meta-15740))
- (let ((v-15747
- (cons (cons 'name name-15722) meta-15740)))
- (struct-set! exp-15724 1 v-15747)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 4)
- source-15721
- name-15722
- var-15723
- exp-15724))))
- (analyze-variable-4267
- (lambda (mod-27435
- var-27436
- modref-cont-27437
- bare-cont-27438)
- (if (not mod-27435)
- (bare-cont-27438 var-27436)
- (let ((kind-27439 (car mod-27435))
- (mod-27440 (cdr mod-27435)))
- (if (eqv? kind-27439 'public)
- (modref-cont-27437 mod-27440 var-27436 #t)
- (if (eqv? kind-27439 'private)
- (if (not (equal? mod-27440 (module-name (current-module))))
- (modref-cont-27437 mod-27440 var-27436 #f)
- (bare-cont-27438 var-27436))
- (if (eqv? kind-27439 'bare)
- (bare-cont-27438 var-27436)
- (if (eqv? kind-27439 'hygiene)
- (if (if (not (equal?
- mod-27440
- (module-name (current-module))))
- (module-variable
- (resolve-module mod-27440)
- var-27436)
- #f)
- (modref-cont-27437 mod-27440 var-27436 #f)
- (bare-cont-27438 var-27436))
- (syntax-violation
- #f
- "bad module kind"
- var-27436
- mod-27440)))))))))
- (build-global-reference-4268
- (lambda (source-27467 var-27468 mod-27469)
- (analyze-variable-4267
- mod-27469
- var-27468
- (lambda (mod-27472 var-27473 public?-27474)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- source-27467
- mod-27472
- var-27473
- public?-27474))
- (lambda (var-27482)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- source-27467
- var-27482)))))
- (build-global-assignment-4269
- (lambda (source-15756 var-15757 exp-15758 mod-15759)
- (begin
- (if (if (struct? exp-15758)
- (eq? (struct-vtable exp-15758)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((meta-15775 (struct-ref exp-15758 1)))
- (if (not (assq 'name meta-15775))
- (let ((v-15782
- (cons (cons 'name var-15757) meta-15775)))
- (struct-set! exp-15758 1 v-15782)))))
- (analyze-variable-4267
- mod-15759
- var-15757
- (lambda (mod-15787 var-15788 public?-15789)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 6)
- source-15756
- mod-15787
- var-15788
- public?-15789
- exp-15758))
- (lambda (var-15797)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 8)
- source-15756
- var-15797
- exp-15758))))))
- (build-global-definition-4270
- (lambda (source-27488 var-27489 exp-27490)
- (begin
- (if (if (struct? exp-27490)
- (eq? (struct-vtable exp-27490)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((meta-27506 (struct-ref exp-27490 1)))
- (if (not (assq 'name meta-27506))
- (let ((v-27513
- (cons (cons 'name var-27489) meta-27506)))
- (struct-set! exp-27490 1 v-27513)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 9)
- source-27488
- var-27489
- exp-27490))))
- (build-simple-lambda-4271
- (lambda (src-15803
- req-15804
- rest-15805
- vars-15806
- meta-15807
- exp-15808)
- (let ((body-15814
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- src-15803
- req-15804
- #f
- rest-15805
- #f
- '()
- vars-15806
- exp-15808
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- src-15803
- meta-15807
- body-15814))))
- (build-sequence-4276
- (lambda (src-27521 exps-27522)
- (if (null? (cdr exps-27522))
- (car exps-27522)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 12)
- src-27521
- exps-27522))))
- (build-let-4277
- (lambda (src-15826
- ids-15827
- vars-15828
- val-exps-15829
- body-exp-15830)
+(letrec*
+ ((make-void
+ (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src)))
+ (make-const
+ (lambda (src exp)
+ (make-struct (vector-ref %expanded-vtables 1) 0 src exp)))
+ (make-primitive-ref
+ (lambda (src name)
+ (make-struct (vector-ref %expanded-vtables 2) 0 src name)))
+ (make-lexical-ref
+ (lambda (src name gensym)
+ (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym)))
+ (make-lexical-set
+ (lambda (src name gensym exp)
+ (make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp)))
+ (make-module-ref
+ (lambda (src mod name public?)
+ (make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?)))
+ (make-module-set
+ (lambda (src mod name public? exp)
+ (make-struct
+ (vector-ref %expanded-vtables 6)
+ 0
+ src
+ mod
+ name
+ public?
+ exp)))
+ (make-toplevel-ref
+ (lambda (src name)
+ (make-struct (vector-ref %expanded-vtables 7) 0 src name)))
+ (make-toplevel-set
+ (lambda (src name exp)
+ (make-struct (vector-ref %expanded-vtables 8) 0 src name exp)))
+ (make-toplevel-define
+ (lambda (src name exp)
+ (make-struct (vector-ref %expanded-vtables 9) 0 src name exp)))
+ (make-conditional
+ (lambda (src test consequent alternate)
+ (make-struct
+ (vector-ref %expanded-vtables 10)
+ 0
+ src
+ test
+ consequent
+ alternate)))
+ (make-application
+ (lambda (src proc args)
+ (make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
+ (make-sequence
+ (lambda (src exps)
+ (make-struct (vector-ref %expanded-vtables 12) 0 src exps)))
+ (make-lambda
+ (lambda (src meta body)
+ (make-struct (vector-ref %expanded-vtables 13) 0 src meta body)))
+ (make-lambda-case
+ (lambda (src req opt rest kw inits gensyms body alternate)
+ (make-struct
+ (vector-ref %expanded-vtables 14)
+ 0
+ src
+ req
+ opt
+ rest
+ kw
+ inits
+ gensyms
+ body
+ alternate)))
+ (make-let
+ (lambda (src names gensyms vals body)
+ (make-struct
+ (vector-ref %expanded-vtables 15)
+ 0
+ src
+ names
+ gensyms
+ vals
+ body)))
+ (make-letrec
+ (lambda (src in-order? names gensyms vals body)
+ (make-struct
+ (vector-ref %expanded-vtables 16)
+ 0
+ src
+ in-order?
+ names
+ gensyms
+ vals
+ body)))
+ (make-dynlet
+ (lambda (src fluids vals body)
+ (make-struct
+ (vector-ref %expanded-vtables 17)
+ 0
+ src
+ fluids
+ vals
+ body)))
+ (lambda?
+ (lambda (x)
+ (and (struct? x)
+ (eq? (struct-vtable x) (vector-ref %expanded-vtables 13)))))
+ (lambda-meta (lambda (x) (struct-ref x 1)))
+ (set-lambda-meta! (lambda (x v) (struct-set! x 1 v)))
+ (top-level-eval-hook (lambda (x mod) (primitive-eval x)))
+ (local-eval-hook (lambda (x mod) (primitive-eval x)))
+ (session-id
+ (let ((v (module-variable (current-module) 'syntax-session-id)))
+ (lambda () ((variable-ref v)))))
+ (put-global-definition-hook
+ (lambda (symbol type val)
+ (module-define!
+ (current-module)
+ symbol
+ (make-syntax-transformer symbol type val))))
+ (get-global-definition-hook
+ (lambda (symbol module)
+ (if (and (not module) (current-module))
+ (warn "module system is booted, we should have a module" symbol))
+ (let ((v (module-variable
+ (if module (resolve-module (cdr module)) (current-module))
+ symbol)))
+ (and v
+ (variable-bound? v)
+ (let ((val (variable-ref v)))
+ (and (macro? val)
+ (macro-type val)
+ (cons (macro-type val) (macro-binding val))))))))
+ (decorate-source
+ (lambda (e s)
+ (if (and s (supports-source-properties? e))
+ (set-source-properties! e s))
+ e))
+ (maybe-name-value!
+ (lambda (name val)
+ (if (lambda? val)
+ (let ((meta (lambda-meta val)))
+ (if (not (assq 'name meta))
+ (set-lambda-meta! val (acons 'name name meta)))))))
+ (build-void (lambda (source) (make-void source)))
+ (build-application
+ (lambda (source fun-exp arg-exps)
+ (make-application source fun-exp arg-exps)))
+ (build-conditional
+ (lambda (source test-exp then-exp else-exp)
+ (make-conditional source test-exp then-exp else-exp)))
+ (build-dynlet
+ (lambda (source fluids vals body)
+ (make-dynlet source fluids vals body)))
+ (build-lexical-reference
+ (lambda (type source name var) (make-lexical-ref source name var)))
+ (build-lexical-assignment
+ (lambda (source name var exp)
+ (maybe-name-value! name exp)
+ (make-lexical-set source name var exp)))
+ (analyze-variable
+ (lambda (mod var modref-cont bare-cont)
+ (if (not mod)
+ (bare-cont var)
+ (let ((kind (car mod)) (mod (cdr mod)))
+ (let ((key kind))
+ (cond ((memv key '(public)) (modref-cont mod var #t))
+ ((memv key '(private))
+ (if (not (equal? mod (module-name (current-module))))
+ (modref-cont mod var #f)
+ (bare-cont var)))
+ ((memv key '(bare)) (bare-cont var))
+ ((memv key '(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))))))))
+ (build-global-reference
+ (lambda (source var mod)
+ (analyze-variable
+ mod
+ var
+ (lambda (mod var public?) (make-module-ref source mod var public?))
+ (lambda (var) (make-toplevel-ref source var)))))
+ (build-global-assignment
+ (lambda (source var exp mod)
+ (maybe-name-value! var exp)
+ (analyze-variable
+ mod
+ var
+ (lambda (mod var public?)
+ (make-module-set source mod var public? exp))
+ (lambda (var) (make-toplevel-set source var exp)))))
+ (build-global-definition
+ (lambda (source var exp)
+ (maybe-name-value! var exp)
+ (make-toplevel-define source var exp)))
+ (build-simple-lambda
+ (lambda (src req rest vars meta exp)
+ (make-lambda
+ src
+ meta
+ (make-lambda-case src req #f rest #f '() vars exp #f))))
+ (build-case-lambda
+ (lambda (src meta body) (make-lambda src meta body)))
+ (build-lambda-case
+ (lambda (src req opt rest kw inits vars body else-case)
+ (make-lambda-case src req opt rest kw inits vars body else-case)))
+ (build-primref
+ (lambda (src name)
+ (if (equal? (module-name (current-module)) '(guile))
+ (make-toplevel-ref src name)
+ (make-module-ref src '(guile) name #f))))
+ (build-data (lambda (src exp) (make-const src exp)))
+ (build-sequence
+ (lambda (src exps)
+ (if (null? (cdr exps)) (car exps) (make-sequence src exps))))
+ (build-let
+ (lambda (src ids vars val-exps body-exp)
+ (for-each maybe-name-value! ids val-exps)
+ (if (null? vars) body-exp (make-let src ids vars val-exps body-exp))))
+ (build-named-let
+ (lambda (src ids vars val-exps body-exp)
+ (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr
ids)))
+ (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
+ (maybe-name-value! f-name proc)
+ (for-each maybe-name-value! ids val-exps)
+ (make-letrec
+ src
+ #f
+ (list f-name)
+ (list f)
+ (list proc)
+ (build-application
+ src
+ (build-lexical-reference 'fun src f-name f)
+ val-exps))))))
+ (build-letrec
+ (lambda (src in-order? ids vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
(begin
- (for-each
- maybe-name-value!-4260
- ids-15827
- val-exps-15829)
- (if (null? vars-15828)
- body-exp-15830
- (make-struct/no-tail
- (vector-ref %expanded-vtables 15)
- src-15826
- ids-15827
- vars-15828
- val-exps-15829
- body-exp-15830)))))
- (build-named-let-4278
- (lambda (src-15854
- ids-15855
- vars-15856
- val-exps-15857
- body-exp-15858)
- (let ((f-15859 (car vars-15856))
- (f-name-15860 (car ids-15855))
- (vars-15861 (cdr vars-15856))
- (ids-15862 (cdr ids-15855)))
- (let ((proc-15863
- (let ((body-15883
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- src-15854
- ids-15862
- #f
- #f
- #f
- '()
- vars-15861
- body-exp-15858
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- src-15854
- '()
- body-15883))))
- (begin
- (if (if (struct? proc-15863)
- (eq? (struct-vtable proc-15863)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((meta-15907 (struct-ref proc-15863 1)))
- (if (not (assq 'name meta-15907))
- (let ((v-15914
- (cons (cons 'name f-name-15860) meta-15907)))
- (struct-set! proc-15863 1 v-15914)))))
- (for-each
- maybe-name-value!-4260
- ids-15862
- val-exps-15857)
- (let ((names-15938 (list f-name-15860))
- (gensyms-15939 (list f-15859))
- (vals-15940 (list proc-15863))
- (body-15941
- (let ((fun-exp-15945
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- src-15854
- f-name-15860
- f-15859)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- src-15854
- fun-exp-15945
- val-exps-15857))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 16)
- src-15854
- #f
- names-15938
- gensyms-15939
- vals-15940
- body-15941)))))))
- (build-letrec-4279
- (lambda (src-15961
- in-order?-15962
- ids-15963
- vars-15964
- val-exps-15965
- body-exp-15966)
- (if (null? vars-15964)
- body-exp-15966
- (begin
- (for-each
- maybe-name-value!-4260
- ids-15963
- val-exps-15965)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 16)
- src-15961
- in-order?-15962
- ids-15963
- vars-15964
- val-exps-15965
- body-exp-15966)))))
- (source-annotation-4288
- (lambda (x-15992)
- (if (if (vector? x-15992)
- (if (= (vector-length x-15992) 4)
- (eq? (vector-ref x-15992 0) 'syntax-object)
- #f)
- #f)
- (source-annotation-4288 (vector-ref x-15992 1))
- (let ((props-16007 (source-properties x-15992)))
- (if (pair? props-16007) props-16007 #f)))))
- (extend-env-4289
- (lambda (labels-16009 bindings-16010 r-16011)
- (if (null? labels-16009)
- r-16011
- (extend-env-4289
- (cdr labels-16009)
- (cdr bindings-16010)
- (cons (cons (car labels-16009) (car bindings-16010))
- r-16011)))))
- (extend-var-env-4290
- (lambda (labels-16012 vars-16013 r-16014)
- (if (null? labels-16012)
- r-16014
- (extend-var-env-4290
- (cdr labels-16012)
- (cdr vars-16013)
- (cons (cons (car labels-16012)
- (cons 'lexical (car vars-16013)))
- r-16014)))))
- (macros-only-env-4291
- (lambda (r-16015)
- (if (null? r-16015)
- '()
- (let ((a-16016 (car r-16015)))
- (if (eq? (car (cdr a-16016)) 'macro)
- (cons a-16016
- (macros-only-env-4291 (cdr r-16015)))
- (macros-only-env-4291 (cdr r-16015)))))))
- (global-extend-4293
- (lambda (type-16018 sym-16019 val-16020)
- (module-define!
- (current-module)
- sym-16019
- (make-syntax-transformer
- sym-16019
- type-16018
- val-16020))))
- (id?-4295
- (lambda (x-9601)
- (if (symbol? x-9601)
- #t
- (if (if (vector? x-9601)
- (if (= (vector-length x-9601) 4)
- (eq? (vector-ref x-9601 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-9601 1))
- #f))))
- (gen-labels-4298
- (lambda (ls-16030)
- (if (null? ls-16030)
- '()
- (cons (string-append
- "l-"
- (session-id-4256)
- (symbol->string (gensym "-")))
- (gen-labels-4298 (cdr ls-16030))))))
- (make-binding-wrap-4309
- (lambda (ids-16034 labels-16035 w-16036)
- (if (null? ids-16034)
- w-16036
- (cons (car w-16036)
- (cons (let ((labelvec-16037 (list->vector labels-16035)))
- (let ((n-16038 (vector-length labelvec-16037)))
- (let ((symnamevec-16039 (make-vector n-16038))
- (marksvec-16040 (make-vector n-16038)))
- (begin
- (letrec*
- ((f-16041
- (lambda (ids-16044 i-16045)
- (if (not (null? ids-16044))
- (call-with-values
- (lambda ()
- (let ((x-16048 (car ids-16044)))
- (if (if (vector? x-16048)
- (if (= (vector-length
- x-16048)
- 4)
- (eq? (vector-ref
- x-16048
- 0)
- 'syntax-object)
- #f)
- #f)
- (values
- (vector-ref x-16048 1)
- (let ((m1-16064
- (car w-16036))
- (m2-16065
- (car (vector-ref
- x-16048
- 2))))
- (if (null? m2-16065)
- m1-16064
- (append
- m1-16064
- m2-16065))))
- (values
- x-16048
- (car w-16036)))))
- (lambda (symname-16085 marks-16086)
- (begin
- (vector-set!
- symnamevec-16039
- i-16045
- symname-16085)
- (vector-set!
- marksvec-16040
- i-16045
- marks-16086)
- (f-16041
- (cdr ids-16044)
- (#{1+}# i-16045)))))))))
- (f-16041 ids-16034 0))
- (vector
- 'ribcage
- symnamevec-16039
- marksvec-16040
- labelvec-16037)))))
- (cdr w-16036))))))
- (join-wraps-4311
- (lambda (w1-16095 w2-16096)
- (let ((m1-16097 (car w1-16095))
- (s1-16098 (cdr w1-16095)))
- (if (null? m1-16097)
- (if (null? s1-16098)
- w2-16096
- (cons (car w2-16096)
- (let ((m2-16105 (cdr w2-16096)))
- (if (null? m2-16105)
- s1-16098
- (append s1-16098 m2-16105)))))
- (cons (let ((m2-16114 (car w2-16096)))
- (if (null? m2-16114)
- m1-16097
- (append m1-16097 m2-16114)))
- (let ((m2-16123 (cdr w2-16096)))
- (if (null? m2-16123)
- s1-16098
- (append s1-16098 m2-16123))))))))
- (same-marks?-4313
- (lambda (x-16128 y-16129)
- (if (eq? x-16128 y-16129)
- (eq? x-16128 y-16129)
- (if (not (null? x-16128))
- (if (not (null? y-16129))
- (if (eq? (car x-16128) (car y-16129))
- (same-marks?-4313 (cdr x-16128) (cdr y-16129))
- #f)
- #f)
- #f))))
- (id-var-name-4314
- (lambda (id-16137 w-16138)
- (letrec*
- ((search-16139
- (lambda (sym-16200 subst-16201 marks-16202)
- (if (null? subst-16201)
- (values #f marks-16202)
- (let ((fst-16203 (car subst-16201)))
- (if (eq? fst-16203 'shift)
- (search-16139
- sym-16200
- (cdr subst-16201)
- (cdr marks-16202))
- (let ((symnames-16205 (vector-ref fst-16203 1)))
- (if (vector? symnames-16205)
- (let ((n-16217 (vector-length symnames-16205)))
- (letrec*
- ((f-16218
- (lambda (i-16220)
- (if (= i-16220 n-16217)
- (search-16139
- sym-16200
- (cdr subst-16201)
- marks-16202)
- (if (if (eq? (vector-ref
- symnames-16205
- i-16220)
- sym-16200)
- (same-marks?-4313
- marks-16202
- (vector-ref
- (vector-ref fst-16203 2)
- i-16220))
- #f)
- (values
- (vector-ref
- (vector-ref fst-16203 3)
- i-16220)
- marks-16202)
- (f-16218 (#{1+}# i-16220)))))))
- (f-16218 0)))
- (letrec*
- ((f-16253
- (lambda (symnames-16255 i-16256)
- (if (null? symnames-16255)
- (search-16139
- sym-16200
- (cdr subst-16201)
- marks-16202)
- (if (if (eq? (car symnames-16255) sym-16200)
- (same-marks?-4313
- marks-16202
- (list-ref
- (vector-ref fst-16203 2)
- i-16256))
- #f)
- (values
- (list-ref
- (vector-ref fst-16203 3)
- i-16256)
- marks-16202)
- (f-16253
- (cdr symnames-16255)
- (#{1+}# i-16256)))))))
- (f-16253 symnames-16205 0))))))))))
- (if (symbol? id-16137)
- (let ((t-16142
- (search-16139
- id-16137
- (cdr w-16138)
- (car w-16138))))
- (if t-16142 t-16142 id-16137))
- (if (if (vector? id-16137)
- (if (= (vector-length id-16137) 4)
- (eq? (vector-ref id-16137 0) 'syntax-object)
- #f)
- #f)
- (let ((id-16157 (vector-ref id-16137 1))
- (w1-16158 (vector-ref id-16137 2)))
- (let ((marks-16159
- (let ((m1-16169 (car w-16138))
- (m2-16170 (car w1-16158)))
- (if (null? m2-16170)
- m1-16169
- (append m1-16169 m2-16170)))))
- (call-with-values
- (lambda ()
- (search-16139 id-16157 (cdr w-16138) marks-16159))
- (lambda (new-id-16186 marks-16187)
- (if new-id-16186
- new-id-16186
- (let ((t-16195
- (search-16139
- id-16157
- (cdr w1-16158)
- marks-16187)))
- (if t-16195 t-16195 id-16157)))))))
- (syntax-violation
- 'id-var-name
- "invalid id"
- id-16137))))))
- (locally-bound-identifiers-4315
- (lambda (w-16278 mod-16279)
- (letrec*
- ((scan-16280
- (lambda (subst-16285 results-16286)
- (if (null? subst-16285)
- results-16286
- (let ((fst-16287 (car subst-16285)))
- (if (eq? fst-16287 'shift)
- (scan-16280 (cdr subst-16285) results-16286)
- (let ((symnames-16289 (vector-ref fst-16287 1))
- (marks-16290 (vector-ref fst-16287 2)))
- (if (vector? symnames-16289)
- (scan-vector-rib-16282
- subst-16285
- symnames-16289
- marks-16290
- results-16286)
- (scan-list-rib-16281
- subst-16285
- symnames-16289
- marks-16290
- results-16286))))))))
- (scan-list-rib-16281
- (lambda (subst-16388
- symnames-16389
- marks-16390
- results-16391)
- (letrec*
- ((f-16392
- (lambda (symnames-16492 marks-16493 results-16494)
- (if (null? symnames-16492)
- (scan-16280 (cdr subst-16388) results-16494)
- (f-16392
- (cdr symnames-16492)
- (cdr marks-16493)
- (cons (wrap-4324
- (car symnames-16492)
- (let ((w-16502
- (cons (car marks-16493)
- subst-16388)))
- (cons (cons #f (car w-16502))
- (cons 'shift (cdr w-16502))))
- mod-16279)
- results-16494))))))
- (f-16392
- symnames-16389
- marks-16390
- results-16391))))
- (scan-vector-rib-16282
- (lambda (subst-16503
- symnames-16504
- marks-16505
- results-16506)
- (let ((n-16507 (vector-length symnames-16504)))
- (letrec*
- ((f-16508
- (lambda (i-16591 results-16592)
- (if (= i-16591 n-16507)
- (scan-16280 (cdr subst-16503) results-16592)
- (f-16508
- (#{1+}# i-16591)
- (cons (wrap-4324
- (vector-ref symnames-16504 i-16591)
- (let ((w-16600
- (cons (vector-ref
- marks-16505
- i-16591)
- subst-16503)))
- (cons (cons #f (car w-16600))
- (cons 'shift (cdr w-16600))))
- mod-16279)
- results-16592))))))
- (f-16508 0 results-16506))))))
- (scan-16280 (cdr w-16278) '()))))
- (valid-bound-ids?-4321
- (lambda (ids-16601)
- (if (letrec*
- ((all-ids?-16602
- (lambda (ids-16764)
- (if (null? ids-16764)
- (null? ids-16764)
- (if (let ((x-16775 (car ids-16764)))
- (if (symbol? x-16775)
- #t
- (if (if (vector? x-16775)
- (if (= (vector-length x-16775) 4)
- (eq? (vector-ref x-16775 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-16775 1))
- #f)))
- (all-ids?-16602 (cdr ids-16764))
- #f)))))
- (all-ids?-16602 ids-16601))
- (distinct-bound-ids?-4322 ids-16601)
- #f)))
- (distinct-bound-ids?-4322
- (lambda (ids-16903)
- (letrec*
- ((distinct?-16904
- (lambda (ids-17016)
- (if (null? ids-17016)
- (null? ids-17016)
- (if (not (bound-id-member?-4323
- (car ids-17016)
- (cdr ids-17016)))
- (distinct?-16904 (cdr ids-17016))
- #f)))))
- (distinct?-16904 ids-16903))))
- (bound-id-member?-4323
- (lambda (x-17226 list-17227)
- (if (not (null? list-17227))
- (let ((t-17228
- (let ((j-17309 (car list-17227)))
- (if (if (if (vector? x-17226)
- (if (= (vector-length x-17226) 4)
- (eq? (vector-ref x-17226 0) 'syntax-object)
- #f)
- #f)
- (if (vector? j-17309)
- (if (= (vector-length j-17309) 4)
- (eq? (vector-ref j-17309 0) 'syntax-object)
- #f)
- #f)
- #f)
- (if (eq? (vector-ref x-17226 1)
- (vector-ref j-17309 1))
- (same-marks?-4313
- (car (vector-ref x-17226 2))
- (car (vector-ref j-17309 2)))
- #f)
- (eq? x-17226 j-17309)))))
- (if t-17228
- t-17228
- (bound-id-member?-4323 x-17226 (cdr list-17227))))
- #f)))
- (wrap-4324
- (lambda (x-17353 w-17354 defmod-17355)
- (if (if (null? (car w-17354))
- (null? (cdr w-17354))
- #f)
- x-17353
- (if (if (vector? x-17353)
- (if (= (vector-length x-17353) 4)
- (eq? (vector-ref x-17353 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-17369 (vector-ref x-17353 1))
- (wrap-17370
- (join-wraps-4311 w-17354 (vector-ref x-17353 2)))
- (module-17371 (vector-ref x-17353 3)))
- (vector
- 'syntax-object
- expression-17369
- wrap-17370
- module-17371))
- (if (null? x-17353)
- x-17353
- (vector
- 'syntax-object
- x-17353
- w-17354
- defmod-17355))))))
- (source-wrap-4325
- (lambda (x-17388 w-17389 s-17390 defmod-17391)
- (wrap-4324
- (begin
- (if (if s-17390
- (supports-source-properties? x-17388)
- #f)
- (set-source-properties! x-17388 s-17390))
- x-17388)
- w-17389
- defmod-17391)))
- (expand-sequence-4326
- (lambda (body-27527 r-27528 w-27529 s-27530 mod-27531)
- (build-sequence-4276
- s-27530
- (letrec*
- ((dobody-27611
- (lambda (body-27951 r-27952 w-27953 mod-27954)
- (if (null? body-27951)
- '()
- (let ((first-27955
- (let ((e-27959 (car body-27951)))
- (call-with-values
- (lambda ()
- (syntax-type-4330
- e-27959
- r-27952
- w-27953
- (source-annotation-4288 e-27959)
- #f
- mod-27954
- #f))
- (lambda (type-27966
- value-27967
- form-27968
- e-27969
- w-27970
- s-27971
- mod-27972)
- (expand-expr-4332
- type-27966
- value-27967
- form-27968
- e-27969
- r-27952
- w-27970
- s-27971
- mod-27972))))))
- (cons first-27955
- (dobody-27611
- (cdr body-27951)
- r-27952
- w-27953
- mod-27954)))))))
- (dobody-27611
- body-27527
- r-27528
- w-27529
- mod-27531)))))
- (expand-top-sequence-4327
- (lambda (body-17409
- r-17410
- w-17411
- s-17412
- m-17413
- esew-17414
- mod-17415)
- (letrec*
- ((scan-17416
- (lambda (body-17547
- r-17548
- w-17549
- s-17550
- m-17551
- esew-17552
- mod-17553
- exps-17554)
- (if (null? body-17547)
- exps-17554
- (call-with-values
- (lambda ()
- (call-with-values
- (lambda ()
- (let ((e-17555 (car body-17547)))
- (syntax-type-4330
- e-17555
- r-17548
- w-17549
- (let ((t-17559 (source-annotation-4288 e-17555)))
- (if t-17559 t-17559 s-17550))
- #f
- mod-17553
- #f)))
- (lambda (type-17794
- value-17795
- form-17796
- e-17797
- w-17798
- s-17799
- mod-17800)
- (if (eqv? type-17794 'begin-form)
- (let ((tmp-17809 ($sc-dispatch e-17797 '(_))))
- (if tmp-17809
- (@apply (lambda () exps-17554) tmp-17809)
- (let ((tmp-17813
- ($sc-dispatch
- e-17797
- '(_ any . each-any))))
- (if tmp-17813
- (@apply
- (lambda (e1-17817 e2-17818)
- (scan-17416
- (cons e1-17817 e2-17818)
- r-17548
- w-17798
- s-17799
- m-17551
- esew-17552
- mod-17800
- exps-17554))
- tmp-17813)
- (syntax-violation
- #f
- "source expression failed to match any
pattern"
- e-17797)))))
- (if (eqv? type-17794 'local-syntax-form)
- (expand-local-syntax-4336
- value-17795
- e-17797
- r-17548
- w-17798
- s-17799
- mod-17800
- (lambda (body-17836
- r-17837
- w-17838
- s-17839
- mod-17840)
- (scan-17416
- body-17836
- r-17837
- w-17838
- s-17839
- m-17551
- esew-17552
- mod-17840
- exps-17554)))
- (if (eqv? type-17794 'eval-when-form)
- (let ((tmp-17848
- ($sc-dispatch
- e-17797
- '(_ each-any any . each-any))))
- (if tmp-17848
- (@apply
- (lambda (x-17852 e1-17853 e2-17854)
- (let ((when-list-17855
- (parse-when-list-4329
- e-17797
- x-17852))
- (body-17856
- (cons e1-17853 e2-17854)))
- (if (eq? m-17551 'e)
- (if (memq 'eval when-list-17855)
- (scan-17416
- body-17856
- r-17548
- w-17798
- s-17799
- (if (memq 'expand
- when-list-17855)
- 'c&e
- 'e)
- '(eval)
- mod-17800
- exps-17554)
- (begin
- (if (memq 'expand
- when-list-17855)
- (let ((x-17933
-
(expand-top-sequence-4327
- body-17856
- r-17548
- w-17798
- s-17799
- 'e
- '(eval)
- mod-17800)))
- (primitive-eval x-17933)))
- exps-17554))
- (if (memq 'load when-list-17855)
- (if (let ((t-17959
- (memq 'compile
-
when-list-17855)))
- (if t-17959
- t-17959
- (let ((t-18008
- (memq 'expand
-
when-list-17855)))
- (if t-18008
- t-18008
- (if (eq? m-17551
- 'c&e)
- (memq 'eval
-
when-list-17855)
- #f)))))
- (scan-17416
- body-17856
- r-17548
- w-17798
- s-17799
- 'c&e
- '(compile load)
- mod-17800
- exps-17554)
- (if (if (eq? m-17551 'c)
- #t
- (eq? m-17551 'c&e))
- (scan-17416
- body-17856
- r-17548
- w-17798
- s-17799
- 'c
- '(load)
- mod-17800
- exps-17554)
- exps-17554))
- (if (let ((t-18137
- (memq 'compile
-
when-list-17855)))
- (if t-18137
- t-18137
- (let ((t-18186
- (memq 'expand
-
when-list-17855)))
- (if t-18186
- t-18186
- (if (eq? m-17551
- 'c&e)
- (memq 'eval
-
when-list-17855)
- #f)))))
- (begin
- (let ((x-18310
-
(expand-top-sequence-4327
- body-17856
- r-17548
- w-17798
- s-17799
- 'e
- '(eval)
- mod-17800)))
- (primitive-eval x-18310))
- exps-17554)
- exps-17554)))))
- tmp-17848)
- (syntax-violation
- #f
- "source expression failed to match any
pattern"
- e-17797)))
- (if (if (eqv? type-17794 'define-syntax-form)
- #t
- (eqv? type-17794
- 'define-syntax-parameter-form))
- (let ((n-18359
- (id-var-name-4314
- value-17795
- w-17798))
- (r-18360
- (macros-only-env-4291 r-17548)))
- (if (eqv? m-17551 'c)
- (if (memq 'compile esew-17552)
- (let ((e-18368
- (expand-install-global-4328
- n-18359
- (expand-4331
- e-17797
- r-18360
- w-17798
- mod-17800))))
- (begin
- (top-level-eval-hook-4254
- e-18368
- mod-17800)
- (if (memq 'load esew-17552)
- (cons e-18368 exps-17554)
- exps-17554)))
- (if (memq 'load esew-17552)
- (cons (expand-install-global-4328
- n-18359
- (expand-4331
- e-17797
- r-18360
- w-17798
- mod-17800))
- exps-17554)
- exps-17554))
- (if (eqv? m-17551 'c&e)
- (let ((e-19013
- (expand-install-global-4328
- n-18359
- (expand-4331
- e-17797
- r-18360
- w-17798
- mod-17800))))
- (begin
- (top-level-eval-hook-4254
- e-19013
- mod-17800)
- (cons e-19013 exps-17554)))
- (begin
- (if (memq 'eval esew-17552)
- (top-level-eval-hook-4254
- (expand-install-global-4328
- n-18359
- (expand-4331
- e-17797
- r-18360
- w-17798
- mod-17800))
- mod-17800))
- exps-17554))))
- (if (eqv? type-17794 'define-form)
- (let ((n-19690
- (id-var-name-4314
- value-17795
- w-17798)))
- (let ((type-19691
- (car (let ((t-19699
- (assq n-19690
- r-17548)))
- (if t-19699
- (cdr t-19699)
- (if (symbol? n-19690)
- (let ((t-19705
-
(get-global-definition-hook-4258
- n-19690
- mod-17800)))
- (if t-19705
- t-19705
- '(global)))
-
'(displaced-lexical)))))))
- (if (if (eqv? type-19691 'global)
- #t
- (if (eqv? type-19691 'core)
- #t
- (if (eqv? type-19691 'macro)
- #t
- (eqv? type-19691
- 'module-ref))))
- (begin
- (if (if (if (eq? m-17551 'c)
- #t
- (eq? m-17551 'c&e))
- (if (not
(module-local-variable
- (current-module)
- n-19690))
- (current-module)
- #f)
- #f)
- (let ((old-19738
- (module-variable
- (current-module)
- n-19690)))
- (if (if (variable? old-19738)
- (variable-bound?
- old-19738)
- #f)
- (module-define!
- (current-module)
- n-19690
- (variable-ref old-19738))
- (module-add!
- (current-module)
- n-19690
-
(make-undefined-variable)))))
- (cons (if (eq? m-17551 'c&e)
- (let ((x-20179
-
(build-global-definition-4270
- s-17799
- n-19690
- (expand-4331
- e-17797
- r-17548
- w-17798
- mod-17800))))
- (begin
-
(top-level-eval-hook-4254
- x-20179
- mod-17800)
- x-20179))
- (lambda ()
-
(build-global-definition-4270
- s-17799
- n-19690
- (expand-4331
- e-17797
- r-17548
- w-17798
- mod-17800))))
- exps-17554))
- (if (eqv? type-19691
- 'displaced-lexical)
- (syntax-violation
- #f
- "identifier out of context"
- (wrap-4324
- (begin
- (if (if s-17799
-
(supports-source-properties?
- form-17796)
- #f)
- (set-source-properties!
- form-17796
- s-17799))
- form-17796)
- w-17798
- mod-17800)
- (wrap-4324
- value-17795
- w-17798
- mod-17800))
- (syntax-violation
- #f
- "cannot define keyword at top
level"
- (wrap-4324
- (begin
- (if (if s-17799
-
(supports-source-properties?
- form-17796)
- #f)
- (set-source-properties!
- form-17796
- s-17799))
- form-17796)
- w-17798
- mod-17800)
- (wrap-4324
- value-17795
- w-17798
- mod-17800))))))
- (cons (if (eq? m-17551 'c&e)
- (let ((x-20681
- (expand-expr-4332
- type-17794
- value-17795
- form-17796
- e-17797
- r-17548
- w-17798
- s-17799
- mod-17800)))
- (begin
- (primitive-eval x-20681)
- x-20681))
- (lambda ()
- (expand-expr-4332
- type-17794
- value-17795
- form-17796
- e-17797
- r-17548
- w-17798
- s-17799
- mod-17800)))
- exps-17554)))))))))
- (lambda (exps-20686)
- (scan-17416
- (cdr body-17547)
- r-17548
- w-17549
- s-17550
- m-17551
- esew-17552
- mod-17553
- exps-20686)))))))
- (call-with-values
- (lambda ()
- (scan-17416
- body-17409
- r-17410
- w-17411
- s-17412
- m-17413
- esew-17414
- mod-17415
- '()))
- (lambda (exps-17419)
- (if (null? exps-17419)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- s-17412)
- (build-sequence-4276
- s-17412
- (letrec*
- ((lp-17459
- (lambda (in-17543 out-17544)
- (if (null? in-17543)
- out-17544
- (let ((e-17545 (car in-17543)))
- (lp-17459
- (cdr in-17543)
- (cons (if (procedure? e-17545)
- (e-17545)
- e-17545)
- out-17544)))))))
- (lp-17459 exps-17419 '())))))))))
- (expand-install-global-4328
- (lambda (name-20687 e-20688)
- (let ((exp-20694
- (let ((fun-exp-20704
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'make-syntax-transformer)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'make-syntax-transformer
- #f)))
- (arg-exps-20705
- (list (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- name-20687)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- 'macro)
- e-20688)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- fun-exp-20704
- arg-exps-20705))))
- (begin
- (if (if (struct? exp-20694)
- (eq? (struct-vtable exp-20694)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((meta-20746 (struct-ref exp-20694 1)))
- (if (not (assq 'name meta-20746))
- (let ((v-20753
- (cons (cons 'name name-20687) meta-20746)))
- (struct-set! exp-20694 1 v-20753)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 9)
- #f
- name-20687
- exp-20694)))))
- (parse-when-list-4329
- (lambda (e-20764 when-list-20765)
- (let ((result-20766 (strip-4344 when-list-20765 '(()))))
- (letrec*
- ((lp-20767
- (lambda (l-20821)
- (if (null? l-20821)
- result-20766
- (if (let ((t-20823 (car l-20821)))
- (if (eq? t-20823 'compile)
- #t
- (if (eq? t-20823 'load)
- #t
- (if (eq? t-20823 'eval)
- #t
- (eq? t-20823 'expand)))))
- (lp-20767 (cdr l-20821))
- (syntax-violation
- 'eval-when
- "invalid situation"
- e-20764
- (car l-20821)))))))
- (lp-20767 result-20766)))))
- (syntax-type-4330
- (lambda (e-20825
- r-20826
- w-20827
- s-20828
- rib-20829
- mod-20830
- for-car?-20831)
- (if (symbol? e-20825)
- (let ((n-20832 (id-var-name-4314 e-20825 w-20827)))
- (let ((b-20833
- (let ((t-20842 (assq n-20832 r-20826)))
- (if t-20842
- (cdr t-20842)
- (if (symbol? n-20832)
- (let ((t-20848
- (get-global-definition-hook-4258
- n-20832
- mod-20830)))
- (if t-20848 t-20848 '(global)))
- '(displaced-lexical))))))
- (let ((type-20834 (car b-20833)))
- (if (eqv? type-20834 'lexical)
- (values
- type-20834
- (cdr b-20833)
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? type-20834 'global)
- (values
- type-20834
- n-20832
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? type-20834 'macro)
- (if for-car?-20831
- (values
- type-20834
- (cdr b-20833)
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (syntax-type-4330
- (expand-macro-4334
- (cdr b-20833)
- e-20825
- r-20826
- w-20827
- s-20828
- rib-20829
- mod-20830)
- r-20826
- '(())
- s-20828
- rib-20829
- mod-20830
- #f))
- (values
- type-20834
- (cdr b-20833)
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)))))))
- (if (pair? e-20825)
- (let ((first-20876 (car e-20825)))
- (call-with-values
- (lambda ()
- (syntax-type-4330
- first-20876
- r-20826
- w-20827
- s-20828
- rib-20829
- mod-20830
- #t))
- (lambda (ftype-20878
- fval-20879
- fform-20880
- fe-20881
- fw-20882
- fs-20883
- fmod-20884)
- (if (eqv? ftype-20878 'lexical)
- (values
- 'lexical-call
- fval-20879
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'global)
- (values
- 'global-call
- (vector
- 'syntax-object
- fval-20879
- w-20827
- fmod-20884)
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'macro)
- (syntax-type-4330
- (expand-macro-4334
- fval-20879
- e-20825
- r-20826
- w-20827
- s-20828
- rib-20829
- mod-20830)
- r-20826
- '(())
- s-20828
- rib-20829
- mod-20830
- for-car?-20831)
- (if (eqv? ftype-20878 'module-ref)
- (call-with-values
- (lambda () (fval-20879 e-20825 r-20826 w-20827))
- (lambda (e-20918
- r-20919
- w-20920
- s-20921
- mod-20922)
- (syntax-type-4330
- e-20918
- r-20919
- w-20920
- s-20921
- rib-20829
- mod-20922
- for-car?-20831)))
- (if (eqv? ftype-20878 'core)
- (values
- 'core-form
- fval-20879
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'local-syntax)
- (values
- 'local-syntax-form
- fval-20879
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'begin)
- (values
- 'begin-form
- #f
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'eval-when)
- (values
- 'eval-when-form
- #f
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'define)
- (let ((tmp-20954
- ($sc-dispatch
- e-20825
- '(_ any any))))
- (if (if tmp-20954
- (@apply
- (lambda (name-20958 val-20959)
- (if (symbol? name-20958)
- #t
- (if (if (vector? name-20958)
- (if (= (vector-length
- name-20958)
- 4)
- (eq? (vector-ref
- name-20958
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- name-20958
- 1))
- #f)))
- tmp-20954)
- #f)
- (@apply
- (lambda (name-20986 val-20987)
- (values
- 'define-form
- name-20986
- e-20825
- val-20987
- w-20827
- s-20828
- mod-20830))
- tmp-20954)
- (let ((tmp-20988
- ($sc-dispatch
- e-20825
- '(_ (any . any)
- any
- .
- each-any))))
- (if (if tmp-20988
- (@apply
- (lambda (name-20992
- args-20993
- e1-20994
- e2-20995)
- (if (if (symbol?
- name-20992)
- #t
- (if (if (vector?
-
name-20992)
- (if (=
(vector-length
-
name-20992)
- 4)
- (eq?
(vector-ref
-
name-20992
- 0)
-
'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- name-20992
- 1))
- #f))
- (valid-bound-ids?-4321
- (letrec*
- ((lvl-21144
- (lambda
(vars-21146
- ls-21147
- w-21148)
- (if (pair?
vars-21146)
- (lvl-21144
- (cdr
vars-21146)
- (cons
(wrap-4324
-
(car vars-21146)
-
w-21148
- #f)
-
ls-21147)
- w-21148)
- (if (if
(symbol?
-
vars-21146)
- #t
- (if
(if (vector?
-
vars-21146)
-
(if (= (vector-length
-
vars-21146)
-
4)
-
(eq? (vector-ref
-
vars-21146
-
0)
-
'syntax-object)
-
#f)
-
#f)
-
(symbol?
-
(vector-ref
-
vars-21146
-
1))
- #f))
- (cons
(wrap-4324
-
vars-21146
-
w-21148
- #f)
-
ls-21147)
- (if (null?
vars-21146)
- ls-21147
- (if (if
(vector?
-
vars-21146)
-
(if (= (vector-length
-
vars-21146)
-
4)
-
(eq? (vector-ref
-
vars-21146
-
0)
-
'syntax-object)
-
#f)
- #f)
-
(lvl-21144
-
(vector-ref
-
vars-21146
- 1)
-
ls-21147
-
(join-wraps-4311
-
w-21148
-
(vector-ref
-
vars-21146
-
2)))
- (cons
vars-21146
-
ls-21147))))))))
- (lvl-21144
- args-20993
- '()
- '(()))))
- #f))
- tmp-20988)
- #f)
- (@apply
- (lambda (name-21192
- args-21193
- e1-21194
- e2-21195)
- (values
- 'define-form
- (wrap-4324
- name-21192
- w-20827
- mod-20830)
- (wrap-4324
- e-20825
- w-20827
- mod-20830)
- (let ((e-21203
- (cons
'#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(name
- args
- e1
- e2)
- #((top)
- (top)
- (top)
- (top))
-
#("l-*-1902"
-
"l-*-1903"
-
"l-*-1904"
-
"l-*-1905"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(key)
-
#((m-*-1867
-
top))
-
#("l-*-1868"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(ftype
- fval
- fform
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
-
#("l-*-1860"
-
"l-*-1861"
-
"l-*-1862"
-
"l-*-1863"
-
"l-*-1864"
-
"l-*-1865"
-
"l-*-1866"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(first)
- #((top))
-
#("l-*-1851"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
-
for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
-
#("l-*-1827"
-
"l-*-1828"
-
"l-*-1829"
-
"l-*-1830"
-
"l-*-1831"
-
"l-*-1832"
-
"l-*-1833"))
- #(ribcage
-
(lambda-var-list
-
gen-var
- strip
-
expand-lambda-case
-
lambda*-formals
-
expand-simple-lambda
-
lambda-formals
-
ellipsis?
-
expand-void
-
eval-local-transformer
-
expand-local-syntax
-
expand-body
-
expand-macro
-
expand-application
-
expand-expr
- expand
-
syntax-type
-
parse-when-list
-
expand-install-global
-
expand-top-sequence
-
expand-sequence
-
source-wrap
- wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
-
bound-id=?
-
free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
-
id-var-name
-
same-marks?
-
join-marks
-
join-wraps
-
smart-append
-
make-binding-wrap
-
extend-ribcage!
-
make-empty-ribcage
-
new-mark
-
anti-mark
-
the-anti-mark
-
top-marked?
-
top-wrap
-
empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
-
ribcage-labels
-
ribcage-marks
-
ribcage-symnames
-
ribcage?
-
make-ribcage
-
gen-labels
-
gen-label
-
make-rename
-
rename-marks
-
rename-new
-
rename-old
-
subst-rename?
-
wrap-subst
-
wrap-marks
-
make-wrap
-
id-sym-name&marks
-
id-sym-name
- id?
-
nonsymbol-id?
-
global-extend
- lookup
-
macros-only-env
-
extend-var-env
-
extend-env
-
null-env
-
binding-value
-
binding-type
-
make-binding
-
arg-check
-
source-annotation
-
no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
-
syntax-object?
-
make-syntax-object
-
build-lexical-var
-
build-letrec
-
build-named-let
-
build-let
-
build-sequence
-
build-data
-
build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
-
build-dynlet
-
build-conditional
-
build-application
-
build-void
-
maybe-name-value!
-
decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
-
session-id
-
local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
-
set-lambda-meta!
-
lambda-meta
-
lambda?
-
make-dynlet
-
make-letrec
-
make-let
-
make-lambda-case
-
make-lambda
-
make-sequence
-
make-application
-
make-conditional
-
make-toplevel-define
-
make-toplevel-set
-
make-toplevel-ref
-
make-module-set
-
make-module-ref
-
make-lexical-set
-
make-lexical-ref
-
make-primitive-ref
-
make-const
-
make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
-
("l-*-476"
-
"l-*-474"
-
"l-*-472"
-
"l-*-470"
-
"l-*-468"
-
"l-*-466"
-
"l-*-464"
-
"l-*-462"
-
"l-*-460"
-
"l-*-458"
-
"l-*-456"
-
"l-*-454"
-
"l-*-452"
-
"l-*-450"
-
"l-*-448"
-
"l-*-446"
-
"l-*-444"
-
"l-*-442"
-
"l-*-440"
-
"l-*-438"
-
"l-*-436"
-
"l-*-434"
-
"l-*-432"
-
"l-*-430"
-
"l-*-428"
-
"l-*-426"
-
"l-*-424"
-
"l-*-422"
-
"l-*-420"
-
"l-*-418"
-
"l-*-416"
-
"l-*-414"
-
"l-*-412"
-
"l-*-410"
-
"l-*-408"
-
"l-*-406"
-
"l-*-404"
-
"l-*-402"
-
"l-*-400"
-
"l-*-399"
-
"l-*-397"
-
"l-*-394"
-
"l-*-393"
-
"l-*-392"
-
"l-*-390"
-
"l-*-389"
-
"l-*-387"
-
"l-*-385"
-
"l-*-383"
-
"l-*-381"
-
"l-*-379"
-
"l-*-377"
-
"l-*-375"
-
"l-*-373"
-
"l-*-370"
-
"l-*-368"
-
"l-*-367"
-
"l-*-365"
-
"l-*-363"
-
"l-*-361"
-
"l-*-359"
-
"l-*-358"
-
"l-*-357"
-
"l-*-356"
-
"l-*-354"
-
"l-*-353"
-
"l-*-350"
-
"l-*-348"
-
"l-*-346"
-
"l-*-344"
-
"l-*-342"
-
"l-*-340"
-
"l-*-338"
-
"l-*-337"
-
"l-*-336"
-
"l-*-334"
-
"l-*-332"
-
"l-*-331"
-
"l-*-328"
-
"l-*-327"
-
"l-*-325"
-
"l-*-323"
-
"l-*-321"
-
"l-*-319"
-
"l-*-317"
-
"l-*-315"
-
"l-*-313"
-
"l-*-311"
-
"l-*-309"
-
"l-*-306"
-
"l-*-304"
-
"l-*-302"
-
"l-*-300"
-
"l-*-298"
-
"l-*-296"
-
"l-*-294"
-
"l-*-292"
-
"l-*-290"
-
"l-*-288"
-
"l-*-286"
-
"l-*-284"
-
"l-*-282"
-
"l-*-280"
-
"l-*-278"
-
"l-*-276"
-
"l-*-274"
-
"l-*-272"
-
"l-*-270"
-
"l-*-268"
-
"l-*-266"
-
"l-*-264"
-
"l-*-262"
-
"l-*-260"
-
"l-*-258"
-
"l-*-256"
-
"l-*-255"
-
"l-*-254"
-
"l-*-253"
-
"l-*-252"
-
"l-*-250"
-
"l-*-248"
-
"l-*-246"
-
"l-*-243"
-
"l-*-241"
-
"l-*-239"
-
"l-*-237"
-
"l-*-235"
-
"l-*-233"
-
"l-*-231"
-
"l-*-229"
-
"l-*-227"
-
"l-*-225"
-
"l-*-223"
-
"l-*-221"
-
"l-*-219"
-
"l-*-217"
-
"l-*-215"
-
"l-*-213"
-
"l-*-211"
-
"l-*-209"))
- #(ribcage
-
(define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top)
- (top)
- (top))
-
("l-*-47"
-
"l-*-46"
-
"l-*-45")))
- (hygiene
- guile))
- (wrap-4324
- (cons
args-21193
- (cons
e1-21194
-
e2-21195))
- w-20827
-
mod-20830))))
- (begin
- (if (if s-20828
-
(supports-source-properties?
- e-21203)
- #f)
-
(set-source-properties!
- e-21203
- s-20828))
- e-21203))
- '(())
- s-20828
- mod-20830))
- tmp-20988)
- (let ((tmp-21210
- ($sc-dispatch
- e-20825
- '(_ any))))
- (if (if tmp-21210
- (@apply
- (lambda (name-21214)
- (if (symbol?
- name-21214)
- #t
- (if (if (vector?
-
name-21214)
- (if (=
(vector-length
-
name-21214)
- 4)
- (eq?
(vector-ref
-
name-21214
- 0)
-
'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- name-21214
- 1))
- #f)))
- tmp-21210)
- #f)
- (@apply
- (lambda (name-21241)
- (values
- 'define-form
- (wrap-4324
- name-21241
- w-20827
- mod-20830)
- (wrap-4324
- e-20825
- w-20827
- mod-20830)
- '(#(syntax-object
- if
- ((top)
- #(ribcage
- #(name)
- #((top))
- #("l-*-1915"))
- #(ribcage () () ())
- #(ribcage
- #(key)
- #((m-*-1867 top))
- #("l-*-1868"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ftype
- fval
- fform
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1860"
- "l-*-1861"
- "l-*-1862"
- "l-*-1863"
- "l-*-1864"
- "l-*-1865"
- "l-*-1866"))
- #(ribcage () () ())
- #(ribcage
- #(first)
- #((top))
- #("l-*-1851"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1827"
- "l-*-1828"
- "l-*-1829"
- "l-*-1830"
- "l-*-1831"
- "l-*-1832"
- "l-*-1833"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
-
expand-lambda-case
- lambda*-formals
-
expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
-
expand-local-syntax
- expand-body
- expand-macro
-
expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
-
expand-top-sequence
- expand-sequence
- source-wrap
- wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
-
make-binding-wrap
- extend-ribcage!
-
make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
-
ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
-
id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
-
source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
- syntax-object?
-
make-syntax-object
-
build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
-
build-conditional
-
build-application
- build-void
-
maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
-
set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
-
make-lambda-case
- make-lambda
- make-sequence
-
make-application
-
make-conditional
-
make-toplevel-define
-
make-toplevel-set
-
make-toplevel-ref
- make-module-set
- make-module-ref
-
make-lexical-set
-
make-lexical-ref
-
make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- #(syntax-object
- #f
- ((top)
- #(ribcage
- #(name)
- #((top))
- #("l-*-1915"))
- #(ribcage () () ())
- #(ribcage
- #(key)
- #((m-*-1867 top))
- #("l-*-1868"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ftype
- fval
- fform
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1860"
- "l-*-1861"
- "l-*-1862"
- "l-*-1863"
- "l-*-1864"
- "l-*-1865"
- "l-*-1866"))
- #(ribcage () () ())
- #(ribcage
- #(first)
- #((top))
- #("l-*-1851"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1827"
- "l-*-1828"
- "l-*-1829"
- "l-*-1830"
- "l-*-1831"
- "l-*-1832"
- "l-*-1833"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
-
expand-lambda-case
- lambda*-formals
-
expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
-
expand-local-syntax
- expand-body
- expand-macro
-
expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
-
expand-top-sequence
- expand-sequence
- source-wrap
- wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
-
make-binding-wrap
- extend-ribcage!
-
make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
-
ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
-
id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
-
source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
- syntax-object?
-
make-syntax-object
-
build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
-
build-conditional
-
build-application
- build-void
-
maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
-
set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
-
make-lambda-case
- make-lambda
- make-sequence
-
make-application
-
make-conditional
-
make-toplevel-define
-
make-toplevel-set
-
make-toplevel-ref
- make-module-set
- make-module-ref
-
make-lexical-set
-
make-lexical-ref
-
make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- #(syntax-object
- #f
- ((top)
- #(ribcage
- #(name)
- #((top))
- #("l-*-1915"))
- #(ribcage () () ())
- #(ribcage
- #(key)
- #((m-*-1867 top))
- #("l-*-1868"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ftype
- fval
- fform
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1860"
- "l-*-1861"
- "l-*-1862"
- "l-*-1863"
- "l-*-1864"
- "l-*-1865"
- "l-*-1866"))
- #(ribcage () () ())
- #(ribcage
- #(first)
- #((top))
- #("l-*-1851"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-1827"
- "l-*-1828"
- "l-*-1829"
- "l-*-1830"
- "l-*-1831"
- "l-*-1832"
- "l-*-1833"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
-
expand-lambda-case
- lambda*-formals
-
expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
-
expand-local-syntax
- expand-body
- expand-macro
-
expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
-
expand-top-sequence
- expand-sequence
- source-wrap
- wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
-
make-binding-wrap
- extend-ribcage!
-
make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
-
ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
-
id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
-
source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
- syntax-object?
-
make-syntax-object
-
build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
-
build-conditional
-
build-application
- build-void
-
maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
-
set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
-
make-lambda-case
- make-lambda
- make-sequence
-
make-application
-
make-conditional
-
make-toplevel-define
-
make-toplevel-set
-
make-toplevel-ref
- make-module-set
- make-module-ref
-
make-lexical-set
-
make-lexical-ref
-
make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile)))
- '(())
- s-20828
- mod-20830))
- tmp-21210)
- (syntax-violation
- #f
- "source expression failed
to match any pattern"
- e-20825)))))))
- (if (eqv? ftype-20878 'define-syntax)
- (let ((tmp-21265
- ($sc-dispatch
- e-20825
- '(_ any any))))
- (if (if tmp-21265
- (@apply
- (lambda (name-21269 val-21270)
- (if (symbol? name-21269)
- #t
- (if (if (vector?
- name-21269)
- (if (=
(vector-length
- name-21269)
- 4)
- (eq? (vector-ref
- name-21269
- 0)
-
'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- name-21269
- 1))
- #f)))
- tmp-21265)
- #f)
- (@apply
- (lambda (name-21297 val-21298)
- (values
- 'define-syntax-form
- name-21297
- e-20825
- val-21298
- w-20827
- s-20828
- mod-20830))
- tmp-21265)
- (syntax-violation
- #f
- "source expression failed to
match any pattern"
- e-20825)))
- (if (eqv? ftype-20878
- 'define-syntax-parameter)
- (let ((tmp-21312
- ($sc-dispatch
- e-20825
- '(_ any any))))
- (if (if tmp-21312
- (@apply
- (lambda (name-21316
- val-21317)
- (if (symbol? name-21316)
- #t
- (if (if (vector?
- name-21316)
- (if (=
(vector-length
-
name-21316)
- 4)
- (eq? (vector-ref
-
name-21316
- 0)
-
'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- name-21316
- 1))
- #f)))
- tmp-21312)
- #f)
- (@apply
- (lambda (name-21344 val-21345)
- (values
-
'define-syntax-parameter-form
- name-21344
- e-20825
- val-21345
- w-20827
- s-20828
- mod-20830))
- tmp-21312)
+ (for-each maybe-name-value! ids val-exps)
+ (make-letrec src in-order? ids vars val-exps body-exp)))))
+ (make-syntax-object
+ (lambda (expression wrap module)
+ (vector 'syntax-object expression wrap module)))
+ (syntax-object?
+ (lambda (x)
+ (and (vector? x)
+ (= (vector-length x) 4)
+ (eq? (vector-ref x 0) 'syntax-object))))
+ (syntax-object-expression (lambda (x) (vector-ref x 1)))
+ (syntax-object-wrap (lambda (x) (vector-ref x 2)))
+ (syntax-object-module (lambda (x) (vector-ref x 3)))
+ (set-syntax-object-expression!
+ (lambda (x update) (vector-set! x 1 update)))
+ (set-syntax-object-wrap!
+ (lambda (x update) (vector-set! x 2 update)))
+ (set-syntax-object-module!
+ (lambda (x update) (vector-set! x 3 update)))
+ (source-annotation
+ (lambda (x)
+ (let ((props (source-properties
+ (if (syntax-object? x) (syntax-object-expression x) x))))
+ (and (pair? props) props))))
+ (extend-env
+ (lambda (labels bindings r)
+ (if (null? labels)
+ r
+ (extend-env
+ (cdr labels)
+ (cdr bindings)
+ (cons (cons (car labels) (car bindings)) r)))))
+ (extend-var-env
+ (lambda (labels vars r)
+ (if (null? labels)
+ r
+ (extend-var-env
+ (cdr labels)
+ (cdr vars)
+ (cons (cons (car labels) (cons 'lexical (car vars))) r)))))
+ (macros-only-env
+ (lambda (r)
+ (if (null? r)
+ '()
+ (let ((a (car r)))
+ (if (eq? (cadr a) 'macro)
+ (cons a (macros-only-env (cdr r)))
+ (macros-only-env (cdr r)))))))
+ (lookup
+ (lambda (x r mod)
+ (let ((t (assq x r)))
+ (cond (t (cdr t))
+ ((symbol? x) (or (get-global-definition-hook x mod) '(global)))
+ (else '(displaced-lexical))))))
+ (global-extend
+ (lambda (type sym val) (put-global-definition-hook sym type val)))
+ (nonsymbol-id?
+ (lambda (x)
+ (and (syntax-object? x) (symbol? (syntax-object-expression x)))))
+ (id? (lambda (x)
+ (if (symbol? x)
+ #t
+ (and (syntax-object? x) (symbol? (syntax-object-expression x))))))
+ (id-sym-name&marks
+ (lambda (x w)
+ (if (syntax-object? x)
+ (values
+ (syntax-object-expression x)
+ (join-marks (car w) (car (syntax-object-wrap x))))
+ (values x (car w)))))
+ (gen-label
+ (lambda ()
+ (string-append "l-" (session-id) (symbol->string (gensym "-")))))
+ (gen-labels
+ (lambda (ls)
+ (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
+ (make-ribcage
+ (lambda (symnames marks labels)
+ (vector 'ribcage symnames marks labels)))
+ (ribcage?
+ (lambda (x)
+ (and (vector? x)
+ (= (vector-length x) 4)
+ (eq? (vector-ref x 0) 'ribcage))))
+ (ribcage-symnames (lambda (x) (vector-ref x 1)))
+ (ribcage-marks (lambda (x) (vector-ref x 2)))
+ (ribcage-labels (lambda (x) (vector-ref x 3)))
+ (set-ribcage-symnames! (lambda (x update) (vector-set! x 1 update)))
+ (set-ribcage-marks! (lambda (x update) (vector-set! x 2 update)))
+ (set-ribcage-labels! (lambda (x update) (vector-set! x 3 update)))
+ (anti-mark
+ (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w)))))
+ (extend-ribcage!
+ (lambda (ribcage id label)
+ (set-ribcage-symnames!
+ ribcage
+ (cons (syntax-object-expression id) (ribcage-symnames ribcage)))
+ (set-ribcage-marks!
+ ribcage
+ (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage)))
+ (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage)))))
+ (make-binding-wrap
+ (lambda (ids labels w)
+ (if (null? ids)
+ w
+ (cons (car w)
+ (cons (let* ((labelvec (list->vector labels)) (n (vector-length
labelvec)))
+ (let ((symnamevec (make-vector n)) (marksvec
(make-vector n)))
+ (let f ((ids ids) (i 0))
+ (if (not (null? ids))
+ (call-with-values
+ (lambda () (id-sym-name&marks (car ids) w))
+ (lambda (symname marks)
+ (vector-set! symnamevec i symname)
+ (vector-set! marksvec i marks)
+ (f (cdr ids) (+ i 1))))))
+ (make-ribcage symnamevec marksvec labelvec)))
+ (cdr w))))))
+ (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2))))
+ (join-wraps
+ (lambda (w1 w2)
+ (let ((m1 (car w1)) (s1 (cdr w1)))
+ (if (null? m1)
+ (if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr w2))))
+ (cons (smart-append m1 (car w2)) (smart-append s1 (cdr w2)))))))
+ (join-marks (lambda (m1 m2) (smart-append m1 m2)))
+ (same-marks?
+ (lambda (x y)
+ (or (eq? x y)
+ (and (not (null? x))
+ (not (null? y))
+ (eq? (car x) (car y))
+ (same-marks? (cdr x) (cdr y))))))
+ (id-var-name
+ (lambda (id w)
+ (letrec*
+ ((search
+ (lambda (sym subst marks)
+ (if (null? subst)
+ (values #f marks)
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (search sym (cdr subst) (cdr marks))
+ (let ((symnames (ribcage-symnames fst)))
+ (if (vector? symnames)
+ (search-vector-rib sym subst marks symnames fst)
+ (search-list-rib sym subst marks symnames fst))))))))
+ (search-list-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let f ((symnames symnames) (i 0))
+ (cond ((null? symnames) (search sym (cdr subst) marks))
+ ((and (eq? (car symnames) sym)
+ (same-marks? marks (list-ref (ribcage-marks
ribcage) i)))
+ (values (list-ref (ribcage-labels ribcage) i) marks))
+ (else (f (cdr symnames) (+ i 1)))))))
+ (search-vector-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0))
+ (cond ((= i n) (search sym (cdr subst) marks))
+ ((and (eq? (vector-ref symnames i) sym)
+ (same-marks? marks (vector-ref (ribcage-marks
ribcage) i)))
+ (values (vector-ref (ribcage-labels ribcage) i)
marks))
+ (else (f (+ i 1)))))))))
+ (cond ((symbol? id) (or (search id (cdr w) (car w)) id))
+ ((syntax-object? id)
+ (let ((id (syntax-object-expression id)) (w1
(syntax-object-wrap id)))
+ (let ((marks (join-marks (car w) (car w1))))
+ (call-with-values
+ (lambda () (search id (cdr w) marks))
+ (lambda (new-id marks) (or new-id (search id (cdr w1)
marks) id))))))
+ (else (syntax-violation 'id-var-name "invalid id" id))))))
+ (locally-bound-identifiers
+ (lambda (w mod)
+ (letrec*
+ ((scan (lambda (subst results)
+ (if (null? subst)
+ results
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (scan (cdr subst) results)
+ (let ((symnames (ribcage-symnames fst)) (marks
(ribcage-marks fst)))
+ (if (vector? symnames)
+ (scan-vector-rib subst symnames marks results)
+ (scan-list-rib subst symnames marks results))))))))
+ (scan-list-rib
+ (lambda (subst symnames marks results)
+ (let f ((symnames symnames) (marks marks) (results results))
+ (if (null? symnames)
+ (scan (cdr subst) results)
+ (f (cdr symnames)
+ (cdr marks)
+ (cons (wrap (car symnames) (anti-mark (cons (car marks)
subst)) mod)
+ results))))))
+ (scan-vector-rib
+ (lambda (subst symnames marks results)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0) (results results))
+ (if (= i n)
+ (scan (cdr subst) results)
+ (f (+ i 1)
+ (cons (wrap (vector-ref symnames i)
+ (anti-mark (cons (vector-ref marks i)
subst))
+ mod)
+ results))))))))
+ (scan (cdr w) '()))))
+ (resolve-identifier
+ (lambda (id w r mod)
+ (letrec*
+ ((resolve-global
+ (lambda (var mod)
+ (let ((b (or (get-global-definition-hook var mod) '(global))))
+ (if (eq? (car b) 'global)
+ (values 'global var mod)
+ (values (car b) (cdr b) mod)))))
+ (resolve-lexical
+ (lambda (label mod)
+ (let ((b (or (assq-ref r label) '(displaced-lexical))))
+ (values (car b) (cdr b) mod)))))
+ (let ((n (id-var-name id w)))
+ (cond ((symbol? n)
+ (resolve-global
+ n
+ (if (syntax-object? id) (syntax-object-module id) mod)))
+ ((string? n)
+ (resolve-lexical
+ n
+ (if (syntax-object? id) (syntax-object-module id) mod)))
+ (else (error "unexpected id-var-name" id w n)))))))
+ (transformer-environment
+ (make-fluid
+ (lambda (k)
+ (error "called outside the dynamic extent of a syntax transformer"))))
+ (with-transformer-environment
+ (lambda (k) ((fluid-ref transformer-environment) k)))
+ (free-id=?
+ (lambda (i j)
+ (and (eq? (let ((x i)) (if (syntax-object? x) (syntax-object-expression
x) x))
+ (let ((x j)) (if (syntax-object? x) (syntax-object-expression
x) x)))
+ (eq? (id-var-name i '(())) (id-var-name j '(()))))))
+ (bound-id=?
+ (lambda (i j)
+ (if (and (syntax-object? i) (syntax-object? j))
+ (and (eq? (syntax-object-expression i) (syntax-object-expression j))
+ (same-marks?
+ (car (syntax-object-wrap i))
+ (car (syntax-object-wrap j))))
+ (eq? i j))))
+ (valid-bound-ids?
+ (lambda (ids)
+ (and (let all-ids? ((ids ids))
+ (or (null? ids) (and (id? (car ids)) (all-ids? (cdr ids)))))
+ (distinct-bound-ids? ids))))
+ (distinct-bound-ids?
+ (lambda (ids)
+ (let distinct? ((ids ids))
+ (or (null? ids)
+ (and (not (bound-id-member? (car ids) (cdr ids)))
+ (distinct? (cdr ids)))))))
+ (bound-id-member?
+ (lambda (x list)
+ (and (not (null? list))
+ (or (bound-id=? x (car list)) (bound-id-member? x (cdr list))))))
+ (wrap (lambda (x w defmod)
+ (cond ((and (null? (car w)) (null? (cdr w))) x)
+ ((syntax-object? x)
+ (make-syntax-object
+ (syntax-object-expression x)
+ (join-wraps w (syntax-object-wrap x))
+ (syntax-object-module x)))
+ ((null? x) x)
+ (else (make-syntax-object x w defmod)))))
+ (source-wrap
+ (lambda (x w s defmod) (wrap (decorate-source x s) w defmod)))
+ (expand-sequence
+ (lambda (body r w s mod)
+ (build-sequence
+ s
+ (let dobody ((body body) (r r) (w w) (mod mod))
+ (if (null? body)
+ '()
+ (let ((first (expand (car body) r w mod)))
+ (cons first (dobody (cdr body) r w mod))))))))
+ (expand-top-sequence
+ (lambda (body r w s m esew mod)
+ (letrec*
+ ((scan (lambda (body r w s m esew mod exps)
+ (if (null? body)
+ exps
+ (call-with-values
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (let ((e (car body)))
+ (syntax-type e r w (or (source-annotation e) s)
#f mod #f)))
+ (lambda (type value form e w s mod)
+ (let ((key type))
+ (cond ((memv key '(begin-form))
+ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp
'(_))))
+ (if tmp-1
+ (apply (lambda () exps) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_
any . each-any))))
+ (if tmp-1
+ (apply (lambda (e1 e2) (scan
(cons e1 e2) r w s m esew mod exps))
+ tmp-1)
(syntax-violation
#f
"source expression failed to
match any pattern"
- e-20825)))
- (values
- 'call
+ tmp))))))
+ ((memv key '(local-syntax-form))
+ (expand-local-syntax
+ value
+ e
+ r
+ w
+ s
+ mod
+ (lambda (body r w s mod) (scan body r w
s m esew mod exps))))
+ ((memv key '(eval-when-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1
'(_ each-any any . each-any))))
+ (if tmp
+ (apply (lambda (x e1 e2)
+ (let ((when-list
(parse-when-list e x)) (body (cons e1 e2)))
+ (cond ((eq? m 'e)
+ (if (memq 'eval
when-list)
+ (scan body
+ r
+ w
+ s
+ (if (memq
'expand when-list) 'c&e 'e)
+ '(eval)
+ mod
+ exps)
+ (begin
+ (if (memq
'expand when-list)
+
(top-level-eval-hook
+
(expand-top-sequence body r w s 'e '(eval) mod)
+ mod))
+ (values exps))))
+ ((memq 'load
when-list)
+ (cond ((or (memq
'compile when-list)
+ (memq
'expand when-list)
+ (and
(eq? m 'c&e) (memq 'eval when-list)))
+ (scan body r
w s 'c&e '(compile load) mod exps))
+ ((memq m '(c
c&e))
+ (scan body r
w s 'c '(load) mod exps))
+ (else (values
exps))))
+ ((or (memq 'compile
when-list)
+ (memq 'expand
when-list)
+ (and (eq? m
'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+
(expand-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ (values exps))
+ (else (values
exps)))))
+ tmp)
+ (syntax-violation
#f
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)))))))))))))))
- (if (if (vector? e-20825)
- (if (= (vector-length e-20825) 4)
- (eq? (vector-ref e-20825 0) 'syntax-object)
- #f)
- #f)
- (syntax-type-4330
- (vector-ref e-20825 1)
- r-20826
- (join-wraps-4311 w-20827 (vector-ref e-20825 2))
- (let ((t-21372 (source-annotation-4288 e-20825)))
- (if t-21372 t-21372 s-20828))
- rib-20829
- (let ((t-21607 (vector-ref e-20825 3)))
- (if t-21607 t-21607 mod-20830))
- for-car?-20831)
- (if (self-evaluating? e-20825)
- (values
- 'constant
- #f
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (values
- 'other
- #f
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)))))))
- (expand-4331
- (lambda (e-21616 r-21617 w-21618 mod-21619)
+ "source expression failed to match
any pattern"
+ tmp-1))))
+ ((memv key '(define-syntax-form
define-syntax-parameter-form))
+ (let ((n (id-var-name value w)) (r
(macros-only-env r)))
+ (let ((key m))
+ (cond ((memv key '(c))
+ (cond ((memq 'compile esew)
+ (let ((e
(expand-install-global n (expand e r w mod))))
+ (top-level-eval-hook
e mod)
+ (if (memq 'load esew)
(values (cons e exps)) (values exps))))
+ ((memq 'load esew)
+ (values
+ (cons
(expand-install-global n (expand e r w mod)) exps)))
+ (else (values exps))))
+ ((memv key '(c&e))
+ (let ((e
(expand-install-global n (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (values (cons e exps))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global n
(expand e r w mod))
+ mod))
+ (values exps))))))
+ ((memv key '(define-form))
+ (let* ((n (id-var-name value w)) (type
(car (lookup n r mod))) (key type))
+ (cond ((memv key '(global core macro
module-ref))
+ (if (and (memq m '(c c&e))
+ (not
(module-local-variable (current-module) n))
+ (current-module))
+ (let ((old (module-variable
(current-module) n)))
+ (if (and (variable? old)
(variable-bound? old))
+ (module-define!
(current-module) n (variable-ref old))
+ (module-add!
(current-module) n (make-undefined-variable)))))
+ (values
+ (cons (if (eq? m 'c&e)
+ (let ((x
(build-global-definition s n (expand e r w mod))))
+ (top-level-eval-hook
x mod)
+ x)
+ (lambda ()
(build-global-definition s n (expand e r w mod))))
+ exps)))
+ ((memv key '(displaced-lexical))
+ (syntax-violation
+ #f
+ "identifier out of context"
+ (source-wrap form w s mod)
+ (wrap value w mod)))
+ (else
+ (syntax-violation
+ #f
+ "cannot define keyword at top
level"
+ (source-wrap form w s mod)
+ (wrap value w mod))))))
+ (else
+ (values
+ (cons (if (eq? m 'c&e)
+ (let ((x (expand-expr type
value form e r w s mod)))
+ (top-level-eval-hook x mod)
+ x)
+ (lambda () (expand-expr type
value form e r w s mod)))
+ exps))))))))
+ (lambda (exps) (scan (cdr body) r w s m esew mod
exps)))))))
(call-with-values
- (lambda ()
- (syntax-type-4330
- e-21616
- r-21617
- w-21618
- (source-annotation-4288 e-21616)
- #f
- mod-21619
- #f))
- (lambda (type-21774
- value-21775
- form-21776
- e-21777
- w-21778
- s-21779
- mod-21780)
- (expand-expr-4332
- type-21774
- value-21775
- form-21776
- e-21777
- r-21617
- w-21778
- s-21779
- mod-21780)))))
- (expand-expr-4332
- (lambda (type-21783
- value-21784
- form-21785
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790)
- (if (eqv? type-21783 'lexical)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- s-21789
- e-21786
- value-21784)
- (if (if (eqv? type-21783 'core)
- #t
- (eqv? type-21783 'core-form))
- (value-21784
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790)
- (if (eqv? type-21783 'module-ref)
- (call-with-values
- (lambda () (value-21784 e-21786 r-21787 w-21788))
- (lambda (e-21826 r-21827 w-21828 s-21829 mod-21830)
- (expand-4331 e-21826 r-21827 w-21828 mod-21830)))
- (if (eqv? type-21783 'lexical-call)
- (expand-application-4333
- (let ((id-21908 (car e-21786)))
- (build-lexical-reference-4265
- 'fun
- (source-annotation-4288 id-21908)
- (if (if (vector? id-21908)
- (if (= (vector-length id-21908) 4)
- (eq? (vector-ref id-21908 0) 'syntax-object)
- #f)
- #f)
- (syntax->datum id-21908)
- id-21908)
- value-21784))
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790)
- (if (eqv? type-21783 'global-call)
- (expand-application-4333
- (build-global-reference-4268
- (source-annotation-4288 (car e-21786))
- (if (if (vector? value-21784)
- (if (= (vector-length value-21784) 4)
- (eq? (vector-ref value-21784 0) 'syntax-object)
- #f)
- #f)
- (vector-ref value-21784 1)
- value-21784)
- (if (if (vector? value-21784)
- (if (= (vector-length value-21784) 4)
- (eq? (vector-ref value-21784 0) 'syntax-object)
- #f)
- #f)
- (vector-ref value-21784 3)
- mod-21790))
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790)
- (if (eqv? type-21783 'constant)
- (let ((exp-22251
- (strip-4344
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties? e-21786)
- #f)
- (set-source-properties! e-21786 s-21789))
- e-21786)
- w-21788
- mod-21790)
- '(()))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- s-21789
- exp-22251))
- (if (eqv? type-21783 'global)
- (analyze-variable-4267
- mod-21790
- value-21784
- (lambda (mod-22290 var-22291 public?-22292)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- s-21789
- mod-22290
- var-22291
- public?-22292))
- (lambda (var-22301)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- s-21789
- var-22301)))
- (if (eqv? type-21783 'call)
- (expand-application-4333
- (expand-4331
- (car e-21786)
- r-21787
- w-21788
- mod-21790)
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790)
- (if (eqv? type-21783 'begin-form)
- (let ((tmp-22382
- ($sc-dispatch e-21786 '(_ any . each-any))))
- (if tmp-22382
- (@apply
- (lambda (e1-22386 e2-22387)
- (expand-sequence-4326
- (cons e1-22386 e2-22387)
- r-21787
- w-21788
- s-21789
- mod-21790))
- tmp-22382)
- (let ((tmp-22474 ($sc-dispatch e-21786 '(_))))
- (if tmp-22474
- (@apply
- (lambda ()
- (if (include-deprecated-features)
- (begin
- (issue-deprecation-warning
- "Sequences of zero expressions
are deprecated. Use *unspecified*.")
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #f))
+ (lambda () (scan body r w s m esew mod '()))
+ (lambda (exps)
+ (if (null? exps)
+ (build-void s)
+ (build-sequence
+ s
+ (let lp ((in exps) (out '()))
+ (if (null? in)
+ out
+ (let ((e (car in)))
+ (lp (cdr in) (cons (if (procedure? e) (e) e)
out))))))))))))
+ (expand-install-global
+ (lambda (name e)
+ (build-global-definition
+ #f
+ name
+ (build-application
+ #f
+ (build-primref #f 'make-syntax-transformer)
+ (list (build-data #f name) (build-data #f 'macro) e)))))
+ (parse-when-list
+ (lambda (e when-list)
+ (let ((result (strip when-list '(()))))
+ (let lp ((l result))
+ (cond ((null? l) result)
+ ((memq (car l) '(compile load eval expand)) (lp (cdr l)))
+ (else (syntax-violation 'eval-when "invalid situation" e (car
l))))))))
+ (syntax-type
+ (lambda (e r w s rib mod for-car?)
+ (cond ((symbol? e)
+ (let* ((n (id-var-name e w))
+ (b (lookup n r mod))
+ (type (car b))
+ (key type))
+ (cond ((memv key '(lexical)) (values type (cdr b) e e w s mod))
+ ((memv key '(global)) (values type n e e w s mod))
+ ((memv key '(macro))
+ (if for-car?
+ (values type (cdr b) e e w s mod)
+ (syntax-type
+ (expand-macro (cdr b) e r w s rib mod)
+ r
+ '(())
+ s
+ rib
+ mod
+ #f)))
+ (else (values type (cdr b) e e w s mod)))))
+ ((pair? e)
+ (let ((first (car e)))
+ (call-with-values
+ (lambda () (syntax-type first r w s rib mod #t))
+ (lambda (ftype fval fform fe fw fs fmod)
+ (let ((key ftype))
+ (cond ((memv key '(lexical)) (values 'lexical-call fval
e e w s mod))
+ ((memv key '(global))
+ (values 'global-call (make-syntax-object fval w
fmod) e e w s mod))
+ ((memv key '(macro))
+ (syntax-type
+ (expand-macro fval e r w s rib mod)
+ r
+ '(())
+ s
+ rib
+ mod
+ for-car?))
+ ((memv key '(module-ref))
+ (call-with-values
+ (lambda () (fval e r w))
+ (lambda (e r w s mod) (syntax-type e r w s rib
mod for-car?))))
+ ((memv key '(core)) (values 'core-form fval e e w
s mod))
+ ((memv key '(local-syntax))
+ (values 'local-syntax-form fval e e w s mod))
+ ((memv key '(begin)) (values 'begin-form #f e e w
s mod))
+ ((memv key '(eval-when)) (values 'eval-when-form
#f e e w s mod))
+ ((memv key '(define))
+ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any
any))))
+ (if (and tmp-1 (apply (lambda (name val) (id?
name)) tmp-1))
+ (apply (lambda (name val) (values
'define-form name e val w s mod))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ (any .
any) any . each-any))))
+ (if (and tmp-1
+ (apply (lambda (name args e1 e2)
+ (and (id? name)
(valid-bound-ids? (lambda-var-list args))))
+ tmp-1))
+ (apply (lambda (name args e1 e2)
+ (values
+ 'define-form
+ (wrap name w mod)
+ (wrap e w mod)
+ (decorate-source
+ (cons '#(syntax-object
lambda ((top)) (hygiene guile))
+ (wrap (cons args (cons
e1 e2)) w mod))
+ s)
+ '(())
+ s
+ mod))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ any))))
+ (if (and tmp-1 (apply (lambda (name)
(id? name)) tmp-1))
+ (apply (lambda (name)
+ (values
+ 'define-form
+ (wrap name w mod)
+ (wrap e w mod)
+ '(#(syntax-object if
((top)) (hygiene guile)) #f #f)
+ '(())
+ s
+ mod))
+ tmp-1)
(syntax-violation
#f
- "sequence of zero expressions"
- (wrap-4324
- (begin
- (if (if s-21789
-
(supports-source-properties?
- e-21786)
- #f)
- (set-source-properties!
- e-21786
- s-21789))
- e-21786)
- w-21788
- mod-21790))))
- tmp-22474)
- (syntax-violation
- #f
- "source expression failed to match any
pattern"
- e-21786)))))
- (if (eqv? type-21783 'local-syntax-form)
- (expand-local-syntax-4336
- value-21784
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790
- expand-sequence-4326)
- (if (eqv? type-21783 'eval-when-form)
- (let ((tmp-22591
- ($sc-dispatch
- e-21786
- '(_ each-any any . each-any))))
- (if tmp-22591
- (@apply
- (lambda (x-22595 e1-22596 e2-22597)
- (let ((when-list-22598
- (parse-when-list-4329
- e-21786
- x-22595)))
- (if (memq 'eval when-list-22598)
- (expand-sequence-4326
- (cons e1-22596 e2-22597)
- r-21787
- w-21788
- s-21789
- mod-21790)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #f))))
- tmp-22591)
- (syntax-violation
- #f
- "source expression failed to match any
pattern"
- e-21786)))
- (if (if (eqv? type-21783 'define-form)
- #t
- (if (eqv? type-21783 'define-syntax-form)
- #t
- (eqv? type-21783
- 'define-syntax-parameter-form)))
+ "source expression failed to match
any pattern"
+ tmp))))))))
+ ((memv key '(define-syntax))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any
any))))
+ (if (and tmp (apply (lambda (name val) (id?
name)) tmp))
+ (apply (lambda (name val) (values
'define-syntax-form name e val w s mod))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ tmp-1))))
+ ((memv key '(define-syntax-parameter))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any
any))))
+ (if (and tmp (apply (lambda (name val) (id?
name)) tmp))
+ (apply (lambda (name val)
+ (values
'define-syntax-parameter-form name e val w s mod))
+ tmp)
(syntax-violation
#f
- "definition in expression context, where
definitions are not allowed,"
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties?
- form-21785)
- #f)
- (set-source-properties!
- form-21785
- s-21789))
- form-21785)
- w-21788
- mod-21790))
- (if (eqv? type-21783 'syntax)
+ "source expression failed to match any
pattern"
+ tmp-1))))
+ (else (values 'call #f e e w s mod))))))))
+ ((syntax-object? e)
+ (syntax-type
+ (syntax-object-expression e)
+ r
+ (join-wraps w (syntax-object-wrap e))
+ (or (source-annotation e) s)
+ rib
+ (or (syntax-object-module e) mod)
+ for-car?))
+ ((self-evaluating? e) (values 'constant #f e e w s mod))
+ (else (values 'other #f e e w s mod)))))
+ (expand
+ (lambda (e r w mod)
+ (call-with-values
+ (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
+ (lambda (type value form e w s mod)
+ (expand-expr type value form e r w s mod)))))
+ (expand-expr
+ (lambda (type value form e r w s mod)
+ (let ((key type))
+ (cond ((memv key '(lexical)) (build-lexical-reference 'value s e
value))
+ ((memv key '(core core-form)) (value e r w s mod))
+ ((memv key '(module-ref))
+ (call-with-values
+ (lambda () (value e r w))
+ (lambda (e r w s mod) (expand e r w mod))))
+ ((memv key '(lexical-call))
+ (expand-application
+ (let ((id (car e)))
+ (build-lexical-reference
+ 'fun
+ (source-annotation id)
+ (if (syntax-object? id) (syntax->datum id) id)
+ value))
+ e
+ r
+ w
+ s
+ mod))
+ ((memv key '(global-call))
+ (expand-application
+ (build-global-reference
+ (source-annotation (car e))
+ (if (syntax-object? value) (syntax-object-expression
value) value)
+ (if (syntax-object? value) (syntax-object-module value)
mod))
+ e
+ r
+ w
+ s
+ mod))
+ ((memv key '(constant))
+ (build-data s (strip (source-wrap e w s mod) '(()))))
+ ((memv key '(global)) (build-global-reference s value mod))
+ ((memv key '(call))
+ (expand-application (expand (car e) r w mod) e r w s mod))
+ ((memv key '(begin-form))
+ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
+ (if tmp-1
+ (apply (lambda (e1 e2) (expand-sequence (cons e1 e2) r w s
mod))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_))))
+ (if tmp-1
+ (apply (lambda ()
+ (if (include-deprecated-features)
+ (begin
+ (issue-deprecation-warning
+ "Sequences of zero expressions are
deprecated. Use *unspecified*.")
+ (expand-void))
(syntax-violation
#f
- "reference to pattern variable outside
syntax form"
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties?
- e-21786)
- #f)
- (set-source-properties!
- e-21786
- s-21789))
- e-21786)
- w-21788
- mod-21790))
- (if (eqv? type-21783 'displaced-lexical)
- (syntax-violation
- #f
- "reference to identifier outside its
scope"
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties?
- e-21786)
- #f)
- (set-source-properties!
- e-21786
- s-21789))
- e-21786)
- w-21788
- mod-21790))
- (syntax-violation
- #f
- "unexpected syntax"
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties?
- e-21786)
- #f)
- (set-source-properties!
- e-21786
- s-21789))
- e-21786)
- w-21788
- mod-21790))))))))))))))))))
- (expand-application-4333
- (lambda (x-22867
- e-22868
- r-22869
- w-22870
- s-22871
- mod-22872)
- (let ((tmp-22874
- ($sc-dispatch e-22868 '(any . each-any))))
- (if tmp-22874
- (@apply
- (lambda (e0-22878 e1-22879)
- (build-application-4262
- s-22871
- x-22867
- (map (lambda (e-22959)
- (expand-4331 e-22959 r-22869 w-22870 mod-22872))
- e1-22879)))
- tmp-22874)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-22868)))))
- (expand-macro-4334
- (lambda (p-23035
- e-23036
- r-23037
- w-23038
- s-23039
- rib-23040
- mod-23041)
- (letrec*
- ((rebuild-macro-output-23042
- (lambda (x-23075 m-23076)
- (if (pair? x-23075)
- (let ((e-23080
- (cons (rebuild-macro-output-23042
- (car x-23075)
- m-23076)
- (rebuild-macro-output-23042
- (cdr x-23075)
- m-23076))))
- (begin
- (if (if s-23039
- (supports-source-properties? e-23080)
- #f)
- (set-source-properties! e-23080 s-23039))
- e-23080))
- (if (if (vector? x-23075)
- (if (= (vector-length x-23075) 4)
- (eq? (vector-ref x-23075 0) 'syntax-object)
- #f)
- #f)
- (let ((w-23096 (vector-ref x-23075 2)))
- (let ((ms-23097 (car w-23096))
- (ss-23098 (cdr w-23096)))
- (if (if (pair? ms-23097) (eq? (car ms-23097) #f) #f)
- (let ((expression-23106 (vector-ref x-23075 1))
- (wrap-23107
- (cons (cdr ms-23097)
- (if rib-23040
- (cons rib-23040 (cdr ss-23098))
- (cdr ss-23098))))
- (module-23108 (vector-ref x-23075 3)))
- (vector
- 'syntax-object
- expression-23106
- wrap-23107
- module-23108))
- (let ((expression-23118
- (let ((e-23123 (vector-ref x-23075 1)))
- (begin
- (if (if s-23039
- (supports-source-properties?
- e-23123)
- #f)
- (set-source-properties!
- e-23123
- s-23039))
- e-23123)))
- (wrap-23119
- (cons (cons m-23076 ms-23097)
- (if rib-23040
- (cons rib-23040
- (cons 'shift ss-23098))
- (cons 'shift ss-23098))))
- (module-23120 (vector-ref x-23075 3)))
- (vector
- 'syntax-object
- expression-23118
- wrap-23119
- module-23120)))))
- (if (vector? x-23075)
- (let ((n-23135 (vector-length x-23075)))
- (let ((v-23136
- (let ((e-23144 (make-vector n-23135)))
- (begin
- (if (if s-23039
- (supports-source-properties? e-23144)
- #f)
- (set-source-properties! e-23144 s-23039))
- e-23144))))
- (letrec*
- ((loop-23137
- (lambda (i-23189)
- (if (= i-23189 n-23135)
- v-23136
- (begin
- (vector-set!
- v-23136
- i-23189
- (rebuild-macro-output-23042
- (vector-ref x-23075 i-23189)
- m-23076))
- (loop-23137 (#{1+}# i-23189)))))))
- (loop-23137 0))))
- (if (symbol? x-23075)
- (syntax-violation
- #f
- "encountered raw symbol in macro output"
- (let ((s-23195 (cdr w-23038)))
- (wrap-4324
- (begin
- (if (if s-23195
- (supports-source-properties? e-23036)
- #f)
- (set-source-properties! e-23036 s-23195))
- e-23036)
- w-23038
- mod-23041))
- x-23075)
- (begin
- (if (if s-23039
- (supports-source-properties? x-23075)
- #f)
- (set-source-properties! x-23075 s-23039))
- x-23075))))))))
- (with-fluids
- ((transformer-environment-4317
- (lambda (k-23043)
- (k-23043
- e-23036
- r-23037
- w-23038
- s-23039
- rib-23040
- mod-23041))))
- (rebuild-macro-output-23042
- (p-23035
- (let ((w-23050
- (cons (cons #f (car w-23038))
- (cons 'shift (cdr w-23038)))))
- (wrap-4324
- (begin
- (if (if s-23039
- (supports-source-properties? e-23036)
- #f)
- (set-source-properties! e-23036 s-23039))
- e-23036)
- w-23050
- mod-23041)))
- (gensym
- (string-append "m-" (session-id-4256) "-")))))))
- (expand-body-4335
- (lambda (body-23227
- outer-form-23228
- r-23229
- w-23230
- mod-23231)
- (let ((r-23232
- (cons '("placeholder" placeholder) r-23229)))
- (let ((ribcage-23233 (vector 'ribcage '() '() '())))
- (let ((w-23234
- (cons (car w-23230)
- (cons ribcage-23233 (cdr w-23230)))))
- (letrec*
- ((parse-23235
- (lambda (body-23248
- ids-23249
- labels-23250
- var-ids-23251
- vars-23252
- vals-23253
- bindings-23254)
- (if (null? body-23248)
- (syntax-violation
- #f
- "no expressions in body"
- outer-form-23228)
- (let ((e-23255 (cdr (car body-23248)))
- (er-23256 (car (car body-23248))))
- (call-with-values
- (lambda ()
- (syntax-type-4330
- e-23255
- er-23256
- '(())
- (source-annotation-4288 er-23256)
- ribcage-23233
- mod-23231
- #f))
- (lambda (type-23413
- value-23414
- form-23415
- e-23416
- w-23417
- s-23418
- mod-23419)
- (if (eqv? type-23413 'define-form)
- (let ((id-23427
- (wrap-4324
- value-23414
- w-23417
- mod-23419))
- (label-23428
- (string-append
- "l-"
- (session-id-4256)
- (symbol->string (gensym "-")))))
- (let ((var-23429
- (let ((id-23489
- (if (if (vector? id-23427)
- (if (= (vector-length
- id-23427)
- 4)
- (eq? (vector-ref
- id-23427
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-23427 1)
- id-23427)))
- (gensym
- (string-append
- (symbol->string id-23489)
- "-")))))
- (begin
- (let ((update-23479
- (cons (vector-ref id-23427 1)
- (vector-ref
- ribcage-23233
- 1))))
- (vector-set!
- ribcage-23233
- 1
- update-23479))
- (let ((update-23481
- (cons (car (vector-ref
- id-23427
- 2))
- (vector-ref
- ribcage-23233
- 2))))
- (vector-set!
- ribcage-23233
- 2
- update-23481))
- (let ((update-23483
- (cons label-23428
- (vector-ref
- ribcage-23233
- 3))))
- (vector-set!
- ribcage-23233
- 3
- update-23483))
- (parse-23235
- (cdr body-23248)
- (cons id-23427 ids-23249)
- (cons label-23428 labels-23250)
- (cons id-23427 var-ids-23251)
- (cons var-23429 vars-23252)
- (cons (cons er-23256
- (wrap-4324
- e-23416
- w-23417
- mod-23419))
- vals-23253)
- (cons (cons 'lexical var-23429)
- bindings-23254)))))
- (if (if (eqv? type-23413 'define-syntax-form)
- #t
- (eqv? type-23413
- 'define-syntax-parameter-form))
- (let ((id-23525
- (wrap-4324
- value-23414
- w-23417
- mod-23419))
- (label-23526
- (string-append
- "l-"
- (session-id-4256)
- (symbol->string (gensym "-")))))
- (begin
- (let ((update-23576
- (cons (vector-ref id-23525 1)
- (vector-ref
- ribcage-23233
- 1))))
- (vector-set!
- ribcage-23233
- 1
- update-23576))
- (let ((update-23578
- (cons (car (vector-ref
- id-23525
- 2))
- (vector-ref
- ribcage-23233
- 2))))
- (vector-set!
- ribcage-23233
- 2
- update-23578))
- (let ((update-23580
- (cons label-23526
- (vector-ref
- ribcage-23233
- 3))))
- (vector-set!
- ribcage-23233
- 3
- update-23580))
- (parse-23235
- (cdr body-23248)
- (cons id-23525 ids-23249)
- (cons label-23526 labels-23250)
- var-ids-23251
- vars-23252
- vals-23253
- (cons (cons 'macro
- (cons er-23256
- (wrap-4324
- e-23416
- w-23417
- mod-23419)))
- bindings-23254))))
- (if (eqv? type-23413 'begin-form)
- (let ((tmp-23591
- ($sc-dispatch
- e-23416
- '(_ . each-any))))
- (if tmp-23591
- (@apply
- (lambda (e1-23595)
- (parse-23235
- (letrec*
- ((f-23596
- (lambda (forms-23659)
- (if (null? forms-23659)
- (cdr body-23248)
- (cons (cons er-23256
- (wrap-4324
- (car
forms-23659)
- w-23417
-
mod-23419))
- (f-23596
- (cdr
forms-23659)))))))
- (f-23596 e1-23595))
- ids-23249
- labels-23250
- var-ids-23251
- vars-23252
- vals-23253
- bindings-23254))
- tmp-23591)
- (syntax-violation
- #f
- "source expression failed to match
any pattern"
- e-23416)))
- (if (eqv? type-23413 'local-syntax-form)
- (expand-local-syntax-4336
- value-23414
- e-23416
- er-23256
- w-23417
- s-23418
- mod-23419
- (lambda (forms-23676
- er-23677
- w-23678
- s-23679
- mod-23680)
- (parse-23235
- (letrec*
- ((f-23681
- (lambda (forms-23744)
- (if (null? forms-23744)
- (cdr body-23248)
- (cons (cons er-23677
- (wrap-4324
- (car
forms-23744)
- w-23678
- mod-23680))
- (f-23681
- (cdr
forms-23744)))))))
- (f-23681 forms-23676))
- ids-23249
- labels-23250
- var-ids-23251
- vars-23252
- vals-23253
- bindings-23254)))
- (if (null? ids-23249)
- (build-sequence-4276
- #f
- (map (lambda (x-23809)
- (let ((e-23813 (cdr x-23809))
- (r-23814 (car x-23809)))
- (call-with-values
- (lambda ()
- (syntax-type-4330
- e-23813
- r-23814
- '(())
-
(source-annotation-4288
- e-23813)
- #f
- mod-23419
- #f))
- (lambda (type-23818
- value-23819
- form-23820
- e-23821
- w-23822
- s-23823
- mod-23824)
- (expand-expr-4332
- type-23818
- value-23819
- form-23820
- e-23821
- r-23814
- w-23822
- s-23823
- mod-23824)))))
- (cons (cons er-23256
- (wrap-4324
- (begin
- (if (if s-23418
-
(supports-source-properties?
- e-23416)
- #f)
-
(set-source-properties!
- e-23416
- s-23418))
- e-23416)
- w-23417
- mod-23419))
- (cdr body-23248))))
- (begin
- (if (not (valid-bound-ids?-4321
- ids-23249))
- (syntax-violation
- #f
- "invalid or duplicate identifier
in definition"
- outer-form-23228))
- (letrec*
- ((loop-23925
- (lambda (bs-23928
- er-cache-23929
- r-cache-23930)
- (if (not (null? bs-23928))
- (let ((b-23931
- (car bs-23928)))
- (if (eq? (car b-23931)
- 'macro)
- (let ((er-23933
- (car (cdr
b-23931))))
- (let ((r-cache-23934
- (if (eq?
er-23933
-
er-cache-23929)
-
r-cache-23930
-
(macros-only-env-4291
-
er-23933))))
- (begin
- (set-cdr!
- b-23931
-
(eval-local-transformer-4337
- (expand-4331
- (cdr (cdr
b-23931))
-
r-cache-23934
- '(())
- mod-23419)
- mod-23419))
- (loop-23925
- (cdr bs-23928)
- er-23933
-
r-cache-23934))))
- (loop-23925
- (cdr bs-23928)
- er-cache-23929
- r-cache-23930)))))))
- (loop-23925 bindings-23254 #f #f))
- (set-cdr!
- r-23232
- (extend-env-4289
- labels-23250
- bindings-23254
- (cdr r-23232)))
- (build-letrec-4279
- #f
- #t
- (reverse
- (map syntax->datum
- var-ids-23251))
- (reverse vars-23252)
- (map (lambda (x-24277)
- (let ((e-24281
- (cdr x-24277))
- (r-24282
- (car x-24277)))
- (call-with-values
- (lambda ()
- (syntax-type-4330
- e-24281
- r-24282
- '(())
-
(source-annotation-4288
- e-24281)
- #f
- mod-23419
- #f))
- (lambda (type-24286
- value-24287
- form-24288
- e-24289
- w-24290
- s-24291
- mod-24292)
- (expand-expr-4332
- type-24286
- value-24287
- form-24288
- e-24289
- r-24282
- w-24290
- s-24291
- mod-24292)))))
- (reverse vals-23253))
- (let ((exps-24298
- (map (lambda (x-24299)
- (let ((e-24302
- (cdr
x-24299))
- (r-24303
- (car
x-24299)))
- (call-with-values
- (lambda ()
-
(syntax-type-4330
- e-24302
- r-24303
- '(())
-
(source-annotation-4288
- e-24302)
- #f
- mod-23419
- #f))
- (lambda
(type-24307
-
value-24308
-
form-24309
- e-24310
- w-24311
- s-24312
-
mod-24313)
-
(expand-expr-4332
- type-24307
- value-24308
- form-24309
- e-24310
- r-24303
- w-24311
- s-24312
-
mod-24313)))))
- (cons (cons er-23256
- (wrap-4324
- (begin
- (if
(if s-23418
-
(supports-source-properties?
-
e-23416)
-
#f)
-
(set-source-properties!
-
e-23416
-
s-23418))
-
e-23416)
- w-23417
-
mod-23419))
- (cdr
body-23248)))))
- (if (null? (cdr exps-24298))
- (car exps-24298)
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 12)
- #f
- exps-24298)))))))))))))))))
- (parse-23235
- (map (lambda (x-23238)
- (cons r-23232
- (wrap-4324 x-23238 w-23234 mod-23231)))
- body-23227)
- '()
- '()
- '()
- '()
- '()
- '())))))))
- (expand-local-syntax-4336
- (lambda (rec?-24339
- e-24340
- r-24341
- w-24342
- s-24343
- mod-24344
- k-24345)
- (let ((tmp-24347
- ($sc-dispatch
- e-24340
- '(_ #(each (any any)) any . each-any))))
- (if tmp-24347
- (@apply
- (lambda (id-24351 val-24352 e1-24353 e2-24354)
- (if (not (valid-bound-ids?-4321 id-24351))
- (syntax-violation
- #f
- "duplicate bound keyword"
- e-24340)
- (let ((labels-24444 (gen-labels-4298 id-24351)))
- (let ((new-w-24445
- (make-binding-wrap-4309
- id-24351
- labels-24444
- w-24342)))
- (k-24345
- (cons e1-24353 e2-24354)
- (extend-env-4289
- labels-24444
- (let ((trans-r-24481
- (macros-only-env-4291 r-24341)))
- (begin
- (if rec?-24339 new-w-24445 w-24342)
- (map (lambda (x-24482)
- (cons 'macro
- (eval-local-transformer-4337
- (expand-4331
- x-24482
- trans-r-24481
- (values
- (if rec?-24339
- new-w-24445
- w-24342))
- mod-24344)
- mod-24344)))
- val-24352)))
- r-24341)
- new-w-24445
- s-24343
- mod-24344)))))
- tmp-24347)
- (syntax-violation
- #f
- "bad local syntax definition"
- (wrap-4324
- (begin
- (if (if s-24343
- (supports-source-properties? e-24340)
- #f)
- (set-source-properties! e-24340 s-24343))
- e-24340)
- w-24342
- mod-24344))))))
- (eval-local-transformer-4337
- (lambda (expanded-24762 mod-24763)
- (let ((p-24764 (primitive-eval expanded-24762)))
- (if (procedure? p-24764)
- p-24764
- (syntax-violation
- #f
- "nonprocedure transformer"
- p-24764)))))
- (ellipsis?-4339
- (lambda (x-5000)
- (if (if (if (vector? x-5000)
- (if (= (vector-length x-5000) 4)
- (eq? (vector-ref x-5000 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-5000 1))
- #f)
- (if (eq? (if (if (vector? x-5000)
- (if (= (vector-length x-5000) 4)
- (eq? (vector-ref x-5000 0) 'syntax-object)
- #f)
- #f)
- (vector-ref x-5000 1)
- x-5000)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314 x-5000 '(()))
- (id-var-name-4314
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- #f)))
- (lambda-formals-4340
- (lambda (orig-args-24769)
- (letrec*
- ((req-24770
- (lambda (args-24774 rreq-24775)
- (let ((tmp-24777 ($sc-dispatch args-24774 '())))
- (if tmp-24777
- (@apply
- (lambda () (check-24771 (reverse rreq-24775) #f))
- tmp-24777)
- (let ((tmp-24900
- ($sc-dispatch args-24774 '(any . any))))
- (if (if tmp-24900
- (@apply
- (lambda (a-24904 b-24905)
- (if (symbol? a-24904)
- #t
- (if (if (vector? a-24904)
- (if (= (vector-length a-24904) 4)
- (eq? (vector-ref a-24904 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-24904 1))
- #f)))
- tmp-24900)
- #f)
- (@apply
- (lambda (a-24932 b-24933)
- (req-24770 b-24933 (cons a-24932 rreq-24775)))
- tmp-24900)
- (let ((tmp-24934 (list args-24774)))
- (if (@apply
- (lambda (r-24936)
- (if (symbol? r-24936)
- #t
- (if (if (vector? r-24936)
- (if (= (vector-length r-24936) 4)
- (eq? (vector-ref r-24936 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref r-24936 1))
- #f)))
- tmp-24934)
- (@apply
- (lambda (r-24966)
- (check-24771 (reverse rreq-24775) r-24966))
- tmp-24934)
- (syntax-violation
- 'lambda
- "invalid argument list"
- orig-args-24769
- args-24774)))))))))
- (check-24771
- (lambda (req-25097 rest-25098)
- (if (distinct-bound-ids?-4322
- (if rest-25098
- (cons rest-25098 req-25097)
- req-25097))
- (values req-25097 #f rest-25098 #f)
- (syntax-violation
- 'lambda
- "duplicate identifier in argument list"
- orig-args-24769)))))
- (req-24770 orig-args-24769 '()))))
- (expand-simple-lambda-4341
- (lambda (e-25214
- r-25215
- w-25216
- s-25217
- mod-25218
- req-25219
- rest-25220
- meta-25221
- body-25222)
- (let ((ids-25223
- (if rest-25220
- (append req-25219 (list rest-25220))
- req-25219)))
- (let ((vars-25224 (map gen-var-4345 ids-25223)))
- (let ((labels-25225 (gen-labels-4298 ids-25223)))
- (build-simple-lambda-4271
- s-25217
- (map syntax->datum req-25219)
- (if rest-25220 (syntax->datum rest-25220) #f)
- vars-25224
- meta-25221
- (expand-body-4335
- body-25222
- (wrap-4324
- (begin
- (if (if s-25217
- (supports-source-properties? e-25214)
- #f)
- (set-source-properties! e-25214 s-25217))
- e-25214)
- w-25216
- mod-25218)
- (extend-var-env-4290
- labels-25225
- vars-25224
- r-25215)
- (make-binding-wrap-4309
- ids-25223
- labels-25225
- w-25216)
- mod-25218)))))))
- (lambda*-formals-4342
- (lambda (orig-args-25505)
- (letrec*
- ((req-25506
- (lambda (args-25513 rreq-25514)
- (let ((tmp-25516 ($sc-dispatch args-25513 '())))
- (if tmp-25516
- (@apply
- (lambda ()
- (check-25510 (reverse rreq-25514) '() #f '()))
- tmp-25516)
- (let ((tmp-25522
- ($sc-dispatch args-25513 '(any . any))))
- (if (if tmp-25522
- (@apply
- (lambda (a-25526 b-25527)
- (if (symbol? a-25526)
- #t
- (if (if (vector? a-25526)
- (if (= (vector-length a-25526) 4)
- (eq? (vector-ref a-25526 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-25526 1))
- #f)))
- tmp-25522)
- #f)
- (@apply
- (lambda (a-25554 b-25555)
- (req-25506 b-25555 (cons a-25554 rreq-25514)))
- tmp-25522)
- (let ((tmp-25556
- ($sc-dispatch args-25513 '(any . any))))
- (if (if tmp-25556
- (@apply
- (lambda (a-25560 b-25561)
- (eq? (syntax->datum a-25560) #:optional))
- tmp-25556)
- #f)
- (@apply
- (lambda (a-25562 b-25563)
- (opt-25507 b-25563 (reverse rreq-25514) '()))
- tmp-25556)
- (let ((tmp-25566
- ($sc-dispatch args-25513 '(any . any))))
- (if (if tmp-25566
- (@apply
- (lambda (a-25570 b-25571)
- (eq? (syntax->datum a-25570) #:key))
- tmp-25566)
- #f)
- (@apply
- (lambda (a-25572 b-25573)
- (key-25508
- b-25573
- (reverse rreq-25514)
- '()
- '()))
- tmp-25566)
- (let ((tmp-25576
- ($sc-dispatch args-25513 '(any any))))
- (if (if tmp-25576
- (@apply
- (lambda (a-25580 b-25581)
- (eq? (syntax->datum a-25580)
- #:rest))
- tmp-25576)
- #f)
- (@apply
- (lambda (a-25582 b-25583)
- (rest-25509
- b-25583
- (reverse rreq-25514)
- '()
- '()))
- tmp-25576)
- (let ((tmp-25586 (list args-25513)))
- (if (@apply
- (lambda (r-25588)
- (if (symbol? r-25588)
- #t
- (if (if (vector? r-25588)
- (if (= (vector-length
- r-25588)
- 4)
- (eq? (vector-ref
- r-25588
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref r-25588 1))
- #f)))
- tmp-25586)
- (@apply
- (lambda (r-25618)
- (rest-25509
- r-25618
- (reverse rreq-25514)
- '()
- '()))
- tmp-25586)
- (syntax-violation
- 'lambda*
- "invalid argument list"
- orig-args-25505
- args-25513)))))))))))))))
- (opt-25507
- (lambda (args-25637 req-25638 ropt-25639)
- (let ((tmp-25641 ($sc-dispatch args-25637 '())))
- (if tmp-25641
- (@apply
- (lambda ()
- (check-25510
- req-25638
- (reverse ropt-25639)
- #f
- '()))
- tmp-25641)
- (let ((tmp-25647
- ($sc-dispatch args-25637 '(any . any))))
- (if (if tmp-25647
- (@apply
- (lambda (a-25651 b-25652)
- (if (symbol? a-25651)
- #t
- (if (if (vector? a-25651)
- (if (= (vector-length a-25651) 4)
- (eq? (vector-ref a-25651 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-25651 1))
- #f)))
- tmp-25647)
- #f)
- (@apply
- (lambda (a-25679 b-25680)
- (opt-25507
- b-25680
- req-25638
- (cons (cons a-25679
- '(#(syntax-object
- #f
- ((top)
- #(ribcage
- #(a b)
- #((top) (top))
- #("l-*-2404" "l-*-2405"))
- #(ribcage () () ())
- #(ribcage
- #(args req ropt)
- #((top) (top) (top))
- #("l-*-2394"
- "l-*-2395"
- "l-*-2396"))
- #(ribcage
- (check rest key opt req)
- ((top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-2340"
- "l-*-2338"
- "l-*-2336"
- "l-*-2334"
- "l-*-2332"))
- #(ribcage
- #(orig-args)
- #((top))
- #("l-*-2331"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
-
set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))))
- ropt-25639)))
- tmp-25647)
- (let ((tmp-25681
- ($sc-dispatch args-25637 '((any any) . any))))
- (if (if tmp-25681
- (@apply
- (lambda (a-25685 init-25686 b-25687)
- (if (symbol? a-25685)
- #t
- (if (if (vector? a-25685)
- (if (= (vector-length a-25685) 4)
- (eq? (vector-ref a-25685 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-25685 1))
- #f)))
- tmp-25681)
- #f)
- (@apply
- (lambda (a-25714 init-25715 b-25716)
- (opt-25507
- b-25716
- req-25638
- (cons (list a-25714 init-25715) ropt-25639)))
- tmp-25681)
- (let ((tmp-25717
- ($sc-dispatch args-25637 '(any . any))))
- (if (if tmp-25717
- (@apply
- (lambda (a-25721 b-25722)
- (eq? (syntax->datum a-25721) #:key))
- tmp-25717)
- #f)
- (@apply
- (lambda (a-25723 b-25724)
- (key-25508
- b-25724
- req-25638
- (reverse ropt-25639)
- '()))
- tmp-25717)
- (let ((tmp-25727
- ($sc-dispatch args-25637 '(any any))))
- (if (if tmp-25727
- (@apply
- (lambda (a-25731 b-25732)
- (eq? (syntax->datum a-25731)
- #:rest))
- tmp-25727)
- #f)
- (@apply
- (lambda (a-25733 b-25734)
- (rest-25509
- b-25734
- req-25638
- (reverse ropt-25639)
- '()))
- tmp-25727)
- (let ((tmp-25737 (list args-25637)))
- (if (@apply
- (lambda (r-25739)
- (if (symbol? r-25739)
- #t
- (if (if (vector? r-25739)
- (if (= (vector-length
- r-25739)
- 4)
- (eq? (vector-ref
- r-25739
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref r-25739 1))
- #f)))
- tmp-25737)
- (@apply
- (lambda (r-25769)
- (rest-25509
- r-25769
- req-25638
- (reverse ropt-25639)
- '()))
- tmp-25737)
- (syntax-violation
- 'lambda*
- "invalid optional argument list"
- orig-args-25505
- args-25637)))))))))))))))
- (key-25508
- (lambda (args-25788 req-25789 opt-25790 rkey-25791)
- (let ((tmp-25793 ($sc-dispatch args-25788 '())))
- (if tmp-25793
- (@apply
- (lambda ()
- (check-25510
- req-25789
- opt-25790
- #f
- (cons #f (reverse rkey-25791))))
- tmp-25793)
- (let ((tmp-25799
- ($sc-dispatch args-25788 '(any . any))))
- (if (if tmp-25799
- (@apply
- (lambda (a-25803 b-25804)
- (if (symbol? a-25803)
- #t
- (if (if (vector? a-25803)
- (if (= (vector-length a-25803) 4)
- (eq? (vector-ref a-25803 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-25803 1))
- #f)))
- tmp-25799)
- #f)
- (@apply
- (lambda (a-25831 b-25832)
- (let ((tmp-25833
- (symbol->keyword (syntax->datum a-25831))))
- (key-25508
- b-25832
- req-25789
- opt-25790
- (cons (cons tmp-25833
- (cons a-25831
- '(#(syntax-object
- #f
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(k)
- #((top))
- #("l-*-2467"))
- #(ribcage
- #(a b)
- #((top) (top))
- #("l-*-2461"
- "l-*-2462"))
- #(ribcage () () ())
- #(ribcage
- #(args req opt rkey)
- #((top)
- (top)
- (top)
- (top))
- #("l-*-2450"
- "l-*-2451"
- "l-*-2452"
- "l-*-2453"))
- #(ribcage
- (check rest
- key
- opt
- req)
- ((top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-2340"
- "l-*-2338"
- "l-*-2336"
- "l-*-2334"
- "l-*-2332"))
- #(ribcage
- #(orig-args)
- #((top))
- #("l-*-2331"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
- resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
-
syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
- analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile)))))
- rkey-25791))))
- tmp-25799)
- (let ((tmp-25836
- ($sc-dispatch args-25788 '((any any) . any))))
- (if (if tmp-25836
- (@apply
- (lambda (a-25840 init-25841 b-25842)
- (if (symbol? a-25840)
- #t
- (if (if (vector? a-25840)
- (if (= (vector-length a-25840) 4)
- (eq? (vector-ref a-25840 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref a-25840 1))
- #f)))
- tmp-25836)
- #f)
- (@apply
- (lambda (a-25869 init-25870 b-25871)
- (let ((tmp-25872
- (symbol->keyword
- (syntax->datum a-25869))))
- (key-25508
- b-25871
- req-25789
- opt-25790
- (cons (list tmp-25872 a-25869 init-25870)
- rkey-25791))))
- tmp-25836)
- (let ((tmp-25875
- ($sc-dispatch
- args-25788
- '((any any any) . any))))
- (if (if tmp-25875
- (@apply
- (lambda (a-25879
- init-25880
- k-25881
- b-25882)
- (if (if (symbol? a-25879)
- #t
- (if (if (vector? a-25879)
- (if (= (vector-length
- a-25879)
- 4)
- (eq? (vector-ref
- a-25879
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref a-25879 1))
- #f))
- (keyword? (syntax->datum k-25881))
- #f))
- tmp-25875)
- #f)
- (@apply
- (lambda (a-25909 init-25910 k-25911 b-25912)
- (key-25508
- b-25912
- req-25789
- opt-25790
- (cons (list k-25911 a-25909 init-25910)
- rkey-25791)))
- tmp-25875)
- (let ((tmp-25913
- ($sc-dispatch args-25788 '(any))))
- (if (if tmp-25913
- (@apply
- (lambda (aok-25917)
- (eq? (syntax->datum aok-25917)
- #:allow-other-keys))
- tmp-25913)
- #f)
- (@apply
- (lambda (aok-25918)
- (check-25510
- req-25789
- opt-25790
- #f
- (cons #t (reverse rkey-25791))))
- tmp-25913)
- (let ((tmp-25921
- ($sc-dispatch
- args-25788
- '(any any any))))
- (if (if tmp-25921
- (@apply
- (lambda (aok-25925
- a-25926
- b-25927)
- (if (eq? (syntax->datum
- aok-25925)
- #:allow-other-keys)
- (eq? (syntax->datum a-25926)
- #:rest)
- #f))
- tmp-25921)
- #f)
- (@apply
- (lambda (aok-25928 a-25929 b-25930)
- (rest-25509
- b-25930
- req-25789
- opt-25790
- (cons #t (reverse rkey-25791))))
- tmp-25921)
- (let ((tmp-25933
- ($sc-dispatch
- args-25788
- '(any . any))))
- (if (if tmp-25933
- (@apply
- (lambda (aok-25937 r-25938)
- (if (eq? (syntax->datum
- aok-25937)
-
#:allow-other-keys)
- (if (symbol? r-25938)
- #t
- (if (if (vector?
- r-25938)
- (if (=
(vector-length
- r-25938)
- 4)
- (eq?
(vector-ref
- r-25938
- 0)
-
'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- r-25938
- 1))
- #f))
- #f))
- tmp-25933)
- #f)
- (@apply
- (lambda (aok-25965 r-25966)
- (rest-25509
- r-25966
- req-25789
- opt-25790
- (cons #t
- (reverse rkey-25791))))
- tmp-25933)
- (let ((tmp-25969
- ($sc-dispatch
- args-25788
- '(any any))))
- (if (if tmp-25969
- (@apply
- (lambda (a-25973 b-25974)
- (eq? (syntax->datum
- a-25973)
- #:rest))
- tmp-25969)
- #f)
- (@apply
- (lambda (a-25975 b-25976)
- (rest-25509
- b-25976
- req-25789
- opt-25790
- (cons #f
- (reverse
- rkey-25791))))
- tmp-25969)
- (let ((tmp-25979
- (list args-25788)))
- (if (@apply
- (lambda (r-25981)
- (if (symbol? r-25981)
- #t
- (if (if (vector?
- r-25981)
- (if (=
(vector-length
-
r-25981)
- 4)
- (eq?
(vector-ref
-
r-25981
- 0)
-
'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- r-25981
- 1))
- #f)))
- tmp-25979)
- (@apply
- (lambda (r-26011)
- (rest-25509
- r-26011
- req-25789
- opt-25790
- (cons #f
- (reverse
-
rkey-25791))))
- tmp-25979)
- (syntax-violation
- 'lambda*
- "invalid keyword
argument list"
- orig-args-25505
-
args-25788)))))))))))))))))))))
- (rest-25509
- (lambda (args-26039 req-26040 opt-26041 kw-26042)
- (let ((tmp-26044 (list args-26039)))
- (if (@apply
- (lambda (r-26046)
- (if (symbol? r-26046)
- #t
- (if (if (vector? r-26046)
- (if (= (vector-length r-26046) 4)
- (eq? (vector-ref r-26046 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref r-26046 1))
- #f)))
- tmp-26044)
- (@apply
- (lambda (r-26076)
- (check-25510
- req-26040
- opt-26041
- r-26076
- kw-26042))
- tmp-26044)
- (syntax-violation
- 'lambda*
- "invalid rest argument"
- orig-args-25505
- args-26039)))))
- (check-25510
- (lambda (req-26080 opt-26081 rest-26082 kw-26083)
- (if (distinct-bound-ids?-4322
- (append
- req-26080
- (map car opt-26081)
- (if rest-26082 (list rest-26082) '())
- (if (pair? kw-26083)
- (map cadr (cdr kw-26083))
- '())))
- (values req-26080 opt-26081 rest-26082 kw-26083)
- (syntax-violation
- 'lambda*
- "duplicate identifier in argument list"
- orig-args-25505)))))
- (req-25506 orig-args-25505 '()))))
- (expand-lambda-case-4343
- (lambda (e-26199
- r-26200
- w-26201
- s-26202
- mod-26203
- get-formals-26204
- clauses-26205)
- (letrec*
- ((parse-req-26206
- (lambda (req-26337
- opt-26338
- rest-26339
- kw-26340
- body-26341)
- (let ((vars-26342 (map gen-var-4345 req-26337))
- (labels-26343 (gen-labels-4298 req-26337)))
- (let ((r*-26344
- (extend-var-env-4290
- labels-26343
- vars-26342
- r-26200))
- (w*-26345
- (make-binding-wrap-4309
- req-26337
- labels-26343
- w-26201)))
- (parse-opt-26207
- (map syntax->datum req-26337)
- opt-26338
- rest-26339
- kw-26340
- body-26341
- (reverse vars-26342)
- r*-26344
- w*-26345
- '()
- '())))))
- (parse-opt-26207
- (lambda (req-26531
- opt-26532
- rest-26533
- kw-26534
- body-26535
- vars-26536
- r*-26537
- w*-26538
- out-26539
- inits-26540)
- (if (pair? opt-26532)
- (let ((tmp-26541 (car opt-26532)))
- (let ((tmp-26542 ($sc-dispatch tmp-26541 '(any any))))
- (if tmp-26542
- (@apply
- (lambda (id-26544 i-26545)
- (let ((v-26546
- (let ((id-26554
- (if (if (vector? id-26544)
- (if (= (vector-length
- id-26544)
- 4)
- (eq? (vector-ref
- id-26544
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-26544 1)
- id-26544)))
- (gensym
- (string-append
- (symbol->string id-26554)
- "-")))))
- (let ((l-26547 (gen-labels-4298 (list v-26546))))
- (let ((r**-26548
- (extend-var-env-4290
- l-26547
- (list v-26546)
- r*-26537)))
- (let ((w**-26549
- (make-binding-wrap-4309
- (list id-26544)
- l-26547
- w*-26538)))
- (parse-opt-26207
- req-26531
- (cdr opt-26532)
- rest-26533
- kw-26534
- body-26535
- (cons v-26546 vars-26536)
- r**-26548
- w**-26549
- (cons (syntax->datum id-26544) out-26539)
- (cons (expand-4331
- i-26545
- r*-26537
- w*-26538
- mod-26203)
- inits-26540)))))))
- tmp-26542)
+ "sequence of zero expressions"
+ (source-wrap e w s mod))))
+ tmp-1)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-26541))))
- (if rest-26533
- (let ((v-26792
- (let ((id-26802
- (if (if (vector? rest-26533)
- (if (= (vector-length rest-26533) 4)
- (eq? (vector-ref rest-26533 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref rest-26533 1)
- rest-26533)))
- (gensym
- (string-append
- (symbol->string id-26802)
- "-")))))
- (let ((l-26793 (gen-labels-4298 (list v-26792))))
- (let ((r*-26794
- (extend-var-env-4290
- l-26793
- (list v-26792)
- r*-26537)))
- (let ((w*-26795
- (make-binding-wrap-4309
- (list rest-26533)
- l-26793
- w*-26538)))
- (parse-kw-26208
- req-26531
- (if (pair? out-26539) (reverse out-26539) #f)
- (syntax->datum rest-26533)
- (if (pair? kw-26534) (cdr kw-26534) kw-26534)
- body-26535
- (cons v-26792 vars-26536)
- r*-26794
- w*-26795
- (if (pair? kw-26534) (car kw-26534) #f)
- '()
- inits-26540)))))
- (parse-kw-26208
- req-26531
- (if (pair? out-26539) (reverse out-26539) #f)
+ tmp))))))
+ ((memv key '(local-syntax-form))
+ (expand-local-syntax value e r w s mod expand-sequence))
+ ((memv key '(eval-when-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any .
each-any))))
+ (if tmp
+ (apply (lambda (x e1 e2)
+ (let ((when-list (parse-when-list e x)))
+ (if (memq 'eval when-list)
+ (expand-sequence (cons e1 e2) r w s mod)
+ (expand-void))))
+ tmp)
+ (syntax-violation
#f
- (if (pair? kw-26534) (cdr kw-26534) kw-26534)
- body-26535
- vars-26536
- r*-26537
- w*-26538
- (if (pair? kw-26534) (car kw-26534) #f)
- '()
- inits-26540)))))
- (parse-kw-26208
- (lambda (req-26973
- opt-26974
- rest-26975
- kw-26976
- body-26977
- vars-26978
- r*-26979
- w*-26980
- aok-26981
- out-26982
- inits-26983)
- (if (pair? kw-26976)
- (let ((tmp-26984 (car kw-26976)))
- (let ((tmp-26985
- ($sc-dispatch tmp-26984 '(any any any))))
- (if tmp-26985
- (@apply
- (lambda (k-26987 id-26988 i-26989)
- (let ((v-26990
- (let ((id-26998
- (if (if (vector? id-26988)
- (if (= (vector-length
- id-26988)
- 4)
- (eq? (vector-ref
- id-26988
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-26988 1)
- id-26988)))
- (gensym
- (string-append
- (symbol->string id-26998)
- "-")))))
- (let ((l-26991 (gen-labels-4298 (list v-26990))))
- (let ((r**-26992
- (extend-var-env-4290
- l-26991
- (list v-26990)
- r*-26979)))
- (let ((w**-26993
- (make-binding-wrap-4309
- (list id-26988)
- l-26991
- w*-26980)))
- (parse-kw-26208
- req-26973
- opt-26974
- rest-26975
- (cdr kw-26976)
- body-26977
- (cons v-26990 vars-26978)
- r**-26992
- w**-26993
- aok-26981
- (cons (list (syntax->datum k-26987)
- (syntax->datum id-26988)
- v-26990)
- out-26982)
- (cons (expand-4331
- i-26989
- r*-26979
- w*-26980
- mod-26203)
- inits-26983)))))))
- tmp-26985)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-26984))))
- (parse-body-26209
- req-26973
- opt-26974
- rest-26975
- (if (if aok-26981 aok-26981 (pair? out-26982))
- (cons aok-26981 (reverse out-26982))
- #f)
- body-26977
- (reverse vars-26978)
- r*-26979
- w*-26980
- (reverse inits-26983)
- '()))))
- (parse-body-26209
- (lambda (req-27245
- opt-27246
- rest-27247
- kw-27248
- body-27249
- vars-27250
- r*-27251
- w*-27252
- inits-27253
- meta-27254)
- (let ((tmp-27256
- ($sc-dispatch body-27249 '(any any . each-any))))
- (if (if tmp-27256
- (@apply
- (lambda (docstring-27260 e1-27261 e2-27262)
- (string? (syntax->datum docstring-27260)))
- tmp-27256)
- #f)
- (@apply
- (lambda (docstring-27263 e1-27264 e2-27265)
- (parse-body-26209
- req-27245
- opt-27246
- rest-27247
- kw-27248
- (cons e1-27264 e2-27265)
- vars-27250
- r*-27251
- w*-27252
- inits-27253
- (append
- meta-27254
- (list (cons 'documentation
- (syntax->datum docstring-27263))))))
- tmp-27256)
- (let ((tmp-27266
- ($sc-dispatch
- body-27249
- '(#(vector #(each (any . any)))
- any
- .
- each-any))))
- (if tmp-27266
- (@apply
- (lambda (k-27270 v-27271 e1-27272 e2-27273)
- (parse-body-26209
- req-27245
- opt-27246
- rest-27247
- kw-27248
- (cons e1-27272 e2-27273)
- vars-27250
- r*-27251
- w*-27252
- inits-27253
- (append
- meta-27254
- (syntax->datum (map cons k-27270 v-27271)))))
- tmp-27266)
- (let ((tmp-27274
- ($sc-dispatch body-27249 '(any . each-any))))
- (if tmp-27274
- (@apply
- (lambda (e1-27278 e2-27279)
- (values
- meta-27254
- req-27245
- opt-27246
- rest-27247
- kw-27248
- inits-27253
- vars-27250
- (expand-body-4335
- (cons e1-27278 e2-27279)
- (wrap-4324
- (begin
- (if (if s-26202
- (supports-source-properties?
- e-26199)
- #f)
- (set-source-properties!
- e-26199
- s-26202))
- e-26199)
- w-26201
- mod-26203)
- r*-27251
- w*-27252
- mod-26203)))
- tmp-27274)
- (syntax-violation
+ "source expression failed to match any pattern"
+ tmp-1))))
+ ((memv key
+ '(define-form define-syntax-form
define-syntax-parameter-form))
+ (syntax-violation
+ #f
+ "definition in expression context, where definitions are not
allowed,"
+ (source-wrap form w s mod)))
+ ((memv key '(syntax))
+ (syntax-violation
+ #f
+ "reference to pattern variable outside syntax form"
+ (source-wrap e w s mod)))
+ ((memv key '(displaced-lexical))
+ (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)))))))
+ (expand-application
+ (lambda (x e r w s mod)
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any))))
+ (if tmp
+ (apply (lambda (e0 e1)
+ (build-application s x (map (lambda (e) (expand e r w
mod)) e1)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ (expand-macro
+ (lambda (p e r w s rib mod)
+ (letrec*
+ ((rebuild-macro-output
+ (lambda (x m)
+ (cond ((pair? x)
+ (decorate-source
+ (cons (rebuild-macro-output (car x) m)
+ (rebuild-macro-output (cdr x) m))
+ s))
+ ((syntax-object? x)
+ (let ((w (syntax-object-wrap x)))
+ (let ((ms (car w)) (ss (cdr w)))
+ (if (and (pair? ms) (eq? (car ms) #f))
+ (make-syntax-object
+ (syntax-object-expression x)
+ (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr
ss)))
+ (syntax-object-module x))
+ (make-syntax-object
+ (decorate-source (syntax-object-expression x) s)
+ (cons (cons m ms)
+ (if rib (cons rib (cons 'shift ss)) (cons
'shift ss)))
+ (syntax-object-module x))))))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (decorate-source
(make-vector n) s)))
+ (let loop ((i 0))
+ (if (= i n)
+ (begin (if #f #f) v)
+ (begin
+ (vector-set! v i (rebuild-macro-output
(vector-ref x i) m))
+ (loop (+ i 1)))))))
+ ((symbol? x)
+ (syntax-violation
+ #f
+ "encountered raw symbol in macro output"
+ (source-wrap e w (cdr w) mod)
+ x))
+ (else (decorate-source x s))))))
+ (with-fluids
+ ((transformer-environment (lambda (k) (k e r w s rib mod))))
+ (rebuild-macro-output
+ (p (source-wrap e (anti-mark w) s mod))
+ (gensym (string-append "m-" (session-id) "-")))))))
+ (expand-body
+ (lambda (body outer-form r w mod)
+ (let* ((r (cons '("placeholder" placeholder) r))
+ (ribcage (make-ribcage '() '() '()))
+ (w (cons (car w) (cons ribcage (cdr w)))))
+ (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
+ (ids '())
+ (labels '())
+ (var-ids '())
+ (vars '())
+ (vals '())
+ (bindings '()))
+ (if (null? body)
+ (syntax-violation #f "no expressions in body" outer-form)
+ (let ((e (cdar body)) (er (caar body)))
+ (call-with-values
+ (lambda ()
+ (syntax-type e er '(()) (source-annotation er) ribcage mod
#f))
+ (lambda (type value form e w s mod)
+ (let ((key type))
+ (cond ((memv key '(define-form))
+ (let ((id (wrap value w mod)) (label (gen-label)))
+ (let ((var (gen-var id)))
+ (extend-ribcage! ribcage id label)
+ (parse (cdr body)
+ (cons id ids)
+ (cons label labels)
+ (cons id var-ids)
+ (cons var vars)
+ (cons (cons er (wrap e w mod)) vals)
+ (cons (cons 'lexical var) bindings)))))
+ ((memv key '(define-syntax-form
define-syntax-parameter-form))
+ (let ((id (wrap value w mod)) (label (gen-label)))
+ (extend-ribcage! ribcage id label)
+ (parse (cdr body)
+ (cons id ids)
+ (cons label labels)
+ var-ids
+ vars
+ vals
+ (cons (cons 'macro (cons er (wrap e w
mod))) bindings))))
+ ((memv key '(begin-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ .
each-any))))
+ (if tmp
+ (apply (lambda (e1)
+ (parse (let f ((forms e1))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car
forms) w mod)) (f (cdr forms)))))
+ ids
+ labels
+ var-ids
+ vars
+ vals
+ bindings))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ tmp-1))))
+ ((memv key '(local-syntax-form))
+ (expand-local-syntax
+ value
+ e
+ er
+ w
+ s
+ mod
+ (lambda (forms er w s mod)
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w
mod)) (f (cdr forms)))))
+ ids
+ labels
+ var-ids
+ vars
+ vals
+ bindings))))
+ ((null? ids)
+ (build-sequence
#f
- "source expression failed to match any pattern"
- body-27249))))))))))
- (let ((tmp-26211 ($sc-dispatch clauses-26205 '())))
- (if tmp-26211
- (@apply (lambda () (values '() #f)) tmp-26211)
- (let ((tmp-26215
- ($sc-dispatch
- clauses-26205
- '((any any . each-any)
- .
- #(each (any any . each-any))))))
- (if tmp-26215
- (@apply
- (lambda (args-26219
- e1-26220
- e2-26221
- args*-26222
- e1*-26223
- e2*-26224)
- (call-with-values
- (lambda () (get-formals-26204 args-26219))
- (lambda (req-26225 opt-26226 rest-26227 kw-26228)
- (call-with-values
- (lambda ()
- (parse-req-26206
- req-26225
- opt-26226
- rest-26227
- kw-26228
- (cons e1-26220 e2-26221)))
- (lambda (meta-26293
- req-26294
- opt-26295
- rest-26296
- kw-26297
- inits-26298
- vars-26299
- body-26300)
- (call-with-values
- (lambda ()
- (expand-lambda-case-4343
- e-26199
- r-26200
- w-26201
- s-26202
- mod-26203
- get-formals-26204
- (map (lambda (tmp-2802-26301
- tmp-2801-26302
- tmp-2800-26303)
- (cons tmp-2800-26303
- (cons tmp-2801-26302
- tmp-2802-26301)))
- e2*-26224
- e1*-26223
- args*-26222)))
- (lambda (meta*-26304 else*-26305)
- (values
- (append meta-26293 meta*-26304)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- s-26202
- req-26294
- opt-26295
- rest-26296
- kw-26297
- inits-26298
- vars-26299
- body-26300
- else*-26305)))))))))
- tmp-26215)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- clauses-26205))))))))
- (strip-4344
- (lambda (x-27316 w-27317)
- (if (memq 'top (car w-27317))
- x-27316
- (letrec*
- ((f-27318
- (lambda (x-27321)
- (if (if (vector? x-27321)
- (if (= (vector-length x-27321) 4)
- (eq? (vector-ref x-27321 0) 'syntax-object)
- #f)
- #f)
- (strip-4344
- (vector-ref x-27321 1)
- (vector-ref x-27321 2))
- (if (pair? x-27321)
- (let ((a-27340 (f-27318 (car x-27321)))
- (d-27341 (f-27318 (cdr x-27321))))
- (if (if (eq? a-27340 (car x-27321))
- (eq? d-27341 (cdr x-27321))
- #f)
- x-27321
- (cons a-27340 d-27341)))
- (if (vector? x-27321)
- (let ((old-27344 (vector->list x-27321)))
- (let ((new-27345 (map f-27318 old-27344)))
- (letrec*
- ((lp-27346
- (lambda (l1-27422 l2-27423)
- (if (null? l1-27422)
- x-27321
- (if (eq? (car l1-27422) (car l2-27423))
- (lp-27346 (cdr l1-27422) (cdr l2-27423))
- (list->vector new-27345))))))
- (lp-27346 old-27344 new-27345))))
- x-27321))))))
- (f-27318 x-27316)))))
- (gen-var-4345
- (lambda (id-26349)
- (let ((id-26350
- (if (if (vector? id-26349)
- (if (= (vector-length id-26349) 4)
- (eq? (vector-ref id-26349 0) 'syntax-object)
- #f)
- #f)
- (vector-ref id-26349 1)
- id-26349)))
- (gensym
- (string-append (symbol->string id-26350) "-"))))))
- (begin
- (set! session-id-4256
- (let ((v-15685
- (module-variable
- (current-module)
- 'syntax-session-id)))
- (lambda () ((variable-ref v-15685)))))
- (set! transformer-environment-4317
- (make-fluid
- (lambda (k-14717)
- (error "called outside the dynamic extent of a syntax
transformer"))))
- (module-define!
- (current-module)
- 'letrec-syntax
- (make-syntax-transformer
- 'letrec-syntax
- 'local-syntax
- #t))
- (module-define!
- (current-module)
- 'let-syntax
- (make-syntax-transformer
- 'let-syntax
- 'local-syntax
- #f))
- (global-extend-4293
- 'core
- 'syntax-parameterize
- (lambda (e-4466 r-4467 w-4468 s-4469 mod-4470)
- (let ((tmp-4472
- ($sc-dispatch
- e-4466
- '(_ #(each (any any)) any . each-any))))
- (if (if tmp-4472
- (@apply
- (lambda (var-4476 val-4477 e1-4478 e2-4479)
- (valid-bound-ids?-4321 var-4476))
- tmp-4472)
- #f)
- (@apply
- (lambda (var-4557 val-4558 e1-4559 e2-4560)
- (let ((names-4561
- (map (lambda (x-4611)
- (id-var-name-4314 x-4611 w-4468))
- var-4557)))
- (begin
- (for-each
- (lambda (id-4562 n-4563)
- (let ((key-4564
- (car (let ((t-4571 (assq n-4563 r-4467)))
- (if t-4571
- (cdr t-4571)
- (if (symbol? n-4563)
- (let ((t-4576
-
(get-global-definition-hook-4258
- n-4563
- mod-4470)))
- (if t-4576 t-4576 '(global)))
- '(displaced-lexical)))))))
- (if (eqv? key-4564 'displaced-lexical)
+ (map (lambda (x) (expand (cdr x) (car x) '(())
mod))
+ (cons (cons er (source-wrap e w s mod))
(cdr body)))))
+ (else
+ (if (not (valid-bound-ids? ids))
(syntax-violation
- 'syntax-parameterize
- "identifier out of context"
- e-4466
- (wrap-4324
- (begin
- (if (if s-4469
- (supports-source-properties? id-4562)
- #f)
- (set-source-properties! id-4562 s-4469))
- id-4562)
- w-4468
- mod-4470)))))
- var-4557
- names-4561)
- (expand-body-4335
- (cons e1-4559 e2-4560)
- (wrap-4324
- (begin
- (if (if s-4469
- (supports-source-properties? e-4466)
- #f)
- (set-source-properties! e-4466 s-4469))
- e-4466)
- w-4468
- mod-4470)
- (extend-env-4289
- names-4561
- (let ((trans-r-4697 (macros-only-env-4291 r-4467)))
- (map (lambda (x-4698)
- (cons 'macro
- (eval-local-transformer-4337
- (expand-4331
- x-4698
- trans-r-4697
- w-4468
- mod-4470)
- mod-4470)))
- val-4558))
- r-4467)
- w-4468
- mod-4470))))
- tmp-4472)
- (syntax-violation
- 'syntax-parameterize
- "bad syntax"
- (wrap-4324
- (begin
- (if (if s-4469
- (supports-source-properties? e-4466)
- #f)
- (set-source-properties! e-4466 s-4469))
- e-4466)
- w-4468
- mod-4470))))))
- (module-define!
- (current-module)
- 'quote
- (make-syntax-transformer
- 'quote
- 'core
- (lambda (e-4907 r-4908 w-4909 s-4910 mod-4911)
- (let ((tmp-4913 ($sc-dispatch e-4907 '(_ any))))
- (if tmp-4913
- (@apply
- (lambda (e-4916)
- (let ((exp-4920 (strip-4344 e-4916 w-4909)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- s-4910
- exp-4920)))
- tmp-4913)
- (syntax-violation
- 'quote
- "bad syntax"
- (wrap-4324
- (begin
- (if (if s-4910
- (supports-source-properties? e-4907)
- #f)
- (set-source-properties! e-4907 s-4910))
- e-4907)
- w-4909
- mod-4911)))))))
- (global-extend-4293
- 'core
- 'syntax
- (letrec*
- ((gen-syntax-5140
- (lambda (src-5242
- e-5243
- r-5244
- maps-5245
- ellipsis?-5246
- mod-5247)
- (if (if (symbol? e-5243)
- #t
- (if (if (vector? e-5243)
- (if (= (vector-length e-5243) 4)
- (eq? (vector-ref e-5243 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref e-5243 1))
- #f))
- (let ((label-5274 (id-var-name-4314 e-5243 '(()))))
- (let ((b-5275
- (let ((t-5282 (assq label-5274 r-5244)))
- (if t-5282
- (cdr t-5282)
- (if (symbol? label-5274)
- (let ((t-5288
- (get-global-definition-hook-4258
- label-5274
- mod-5247)))
- (if t-5288 t-5288 '(global)))
- '(displaced-lexical))))))
- (if (eq? (car b-5275) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev-5297 (cdr b-5275)))
- (gen-ref-5141
- src-5242
- (car var.lev-5297)
- (cdr var.lev-5297)
- maps-5245)))
- (lambda (var-5301 maps-5302)
- (values (list 'ref var-5301) maps-5302)))
- (if (ellipsis?-5246 e-5243)
+ #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)))
+ (if (eq? (car b) 'macro)
+ (let* ((er (cadr b))
+ (r-cache (if (eq? er er-cache)
r-cache (macros-only-env er))))
+ (set-cdr!
+ b
+ (eval-local-transformer (expand (cddr
b) r-cache '(()) mod) mod))
+ (loop (cdr bs) er r-cache))
+ (loop (cdr bs) er-cache r-cache)))))
+ (set-cdr! r (extend-env labels bindings (cdr r)))
+ (build-letrec
+ #f
+ #t
+ (reverse (map syntax->datum var-ids))
+ (reverse vars)
+ (map (lambda (x) (expand (cdr x) (car x) '(())
mod)) (reverse vals))
+ (build-sequence
+ #f
+ (map (lambda (x) (expand (cdr x) (car x) '(())
mod))
+ (cons (cons er (source-wrap e w s mod))
(cdr body))))))))))))))))
+ (expand-local-syntax
+ (lambda (rec? e r w s mod k)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+ (if tmp
+ (apply (lambda (id val e1 e2)
+ (let ((ids id))
+ (if (not (valid-bound-ids? ids))
+ (syntax-violation #f "duplicate bound keyword" e)
+ (let* ((labels (gen-labels ids)) (new-w
(make-binding-wrap ids labels w)))
+ (k (cons e1 e2)
+ (extend-env
+ labels
+ (let ((w (if rec? new-w w)) (trans-r
(macros-only-env r)))
+ (map (lambda (x)
+ (cons 'macro (eval-local-transformer
(expand x trans-r w mod) mod)))
+ val))
+ r)
+ new-w
+ s
+ mod)))))
+ tmp)
+ (syntax-violation
+ #f
+ "bad local syntax definition"
+ (source-wrap e w s mod))))))
+ (eval-local-transformer
+ (lambda (expanded mod)
+ (let ((p (local-eval-hook expanded mod)))
+ (if (procedure? p)
+ p
+ (syntax-violation #f "nonprocedure transformer" p)))))
+ (expand-void (lambda () (build-void #f)))
+ (ellipsis?
+ (lambda (x)
+ (and (nonsymbol-id? x)
+ (free-id=? x '#(syntax-object ... ((top)) (hygiene guile))))))
+ (lambda-formals
+ (lambda (orig-args)
+ (letrec*
+ ((req (lambda (args rreq)
+ (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (check (reverse rreq) #f)) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+ (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
+ (let ((tmp-1 (list tmp)))
+ (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
+ (apply (lambda (r) (check (reverse rreq) r))
tmp-1)
+ (let ((else tmp))
+ (syntax-violation 'lambda "invalid argument
list" orig-args args))))))))))
+ (check (lambda (req rest)
+ (if (distinct-bound-ids? (if rest (cons rest req) req))
+ (values req #f rest #f)
+ (syntax-violation
+ 'lambda
+ "duplicate identifier in argument list"
+ orig-args)))))
+ (req orig-args '()))))
+ (expand-simple-lambda
+ (lambda (e r w s mod req rest meta body)
+ (let* ((ids (if rest (append req (list rest)) req))
+ (vars (map gen-var ids))
+ (labels (gen-labels ids)))
+ (build-simple-lambda
+ s
+ (map syntax->datum req)
+ (and rest (syntax->datum rest))
+ vars
+ meta
+ (expand-body
+ body
+ (source-wrap e w s mod)
+ (extend-var-env labels vars r)
+ (make-binding-wrap ids labels w)
+ mod)))))
+ (lambda*-formals
+ (lambda (orig-args)
+ (letrec*
+ ((req (lambda (args rreq)
+ (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (check (reverse rreq) '() #f '()))
tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+ (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq? (syntax->datum
a) #:optional)) tmp-1))
+ (apply (lambda (a b) (opt b (reverse rreq) '()))
tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq?
(syntax->datum a) #:key)) tmp-1))
+ (apply (lambda (a b) (key b (reverse rreq)
'() '())) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq?
(syntax->datum a) #:rest)) tmp-1))
+ (apply (lambda (a b) (rest b (reverse
rreq) '() '())) tmp-1)
+ (let ((tmp-1 (list tmp)))
+ (if (and tmp-1 (apply (lambda (r) (id?
r)) tmp-1))
+ (apply (lambda (r) (rest r (reverse
rreq) '() '())) tmp-1)
+ (let ((else tmp))
+ (syntax-violation
+ 'lambda*
+ "invalid argument list"
+ orig-args
+ args))))))))))))))))
+ (opt (lambda (args req ropt)
+ (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (check req (reverse ropt) #f '()))
tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+ (apply (lambda (a b) (opt b req (cons (cons a '(#f))
ropt))) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
+ (if (and tmp-1 (apply (lambda (a init b) (id? a))
tmp-1))
+ (apply (lambda (a init b) (opt b req (cons (list
a init) ropt)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq?
(syntax->datum a) #:key)) tmp-1))
+ (apply (lambda (a b) (key b req (reverse
ropt) '())) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any))))
+ (if (and tmp-1
+ (apply (lambda (a b) (eq?
(syntax->datum a) #:rest)) tmp-1))
+ (apply (lambda (a b) (rest b req (reverse
ropt) '())) tmp-1)
+ (let ((tmp-1 (list tmp)))
+ (if (and tmp-1 (apply (lambda (r) (id?
r)) tmp-1))
+ (apply (lambda (r) (rest r req
(reverse ropt) '())) tmp-1)
+ (let ((else tmp))
+ (syntax-violation
+ 'lambda*
+ "invalid optional argument list"
+ orig-args
+ args))))))))))))))))
+ (key (lambda (args req opt rkey)
+ (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (check req opt #f (cons #f (reverse
rkey)))) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
+ (apply (lambda (a b)
+ (let* ((tmp (symbol->keyword (syntax->datum
a))) (k tmp))
+ (key b req opt (cons (cons k (cons a
'(#f))) rkey))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
+ (if (and tmp-1 (apply (lambda (a init b) (id? a))
tmp-1))
+ (apply (lambda (a init b)
+ (let* ((tmp (symbol->keyword
(syntax->datum a))) (k tmp))
+ (key b req opt (cons (list k a init)
rkey))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '((any any any) .
any))))
+ (if (and tmp-1
+ (apply (lambda (a init k b) (and (id?
a) (keyword? (syntax->datum k))))
+ tmp-1))
+ (apply (lambda (a init k b) (key b req opt
(cons (list k a init) rkey)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any))))
+ (if (and tmp-1
+ (apply (lambda (aok) (eq?
(syntax->datum aok) #:allow-other-keys))
+ tmp-1))
+ (apply (lambda (aok) (check req opt #f
(cons #t (reverse rkey))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any
any))))
+ (if (and tmp-1
+ (apply (lambda (aok a b)
+ (and (eq?
(syntax->datum aok) #:allow-other-keys)
+ (eq?
(syntax->datum a) #:rest)))
+ tmp-1))
+ (apply (lambda (aok a b) (rest b req
opt (cons #t (reverse rkey))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any
. any))))
+ (if (and tmp-1
+ (apply (lambda (aok r)
+ (and (eq?
(syntax->datum aok) #:allow-other-keys) (id? r)))
+ tmp-1))
+ (apply (lambda (aok r) (rest r
req opt (cons #t (reverse rkey))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp
'(any any))))
+ (if (and tmp-1
+ (apply (lambda (a b)
(eq? (syntax->datum a) #:rest)) tmp-1))
+ (apply (lambda (a b) (rest b
req opt (cons #f (reverse rkey))))
+ tmp-1)
+ (let ((tmp-1 (list tmp)))
+ (if (and tmp-1 (apply
(lambda (r) (id? r)) tmp-1))
+ (apply (lambda (r) (rest
r req opt (cons #f (reverse rkey))))
+ tmp-1)
+ (let ((else tmp))
+ (syntax-violation
+ 'lambda*
+ "invalid keyword
argument list"
+ orig-args
+
args))))))))))))))))))))))
+ (rest (lambda (args req opt kw)
+ (let* ((tmp-1 args) (tmp (list tmp-1)))
+ (if (and tmp (apply (lambda (r) (id? r)) tmp))
+ (apply (lambda (r) (check req opt r kw)) tmp)
+ (let ((else tmp-1))
+ (syntax-violation 'lambda* "invalid rest argument"
orig-args args))))))
+ (check (lambda (req opt rest kw)
+ (if (distinct-bound-ids?
+ (append
+ req
+ (map car opt)
+ (if rest (list rest) '())
+ (if (pair? kw) (map cadr (cdr kw)) '())))
+ (values req opt rest kw)
+ (syntax-violation
+ 'lambda*
+ "duplicate identifier in argument list"
+ orig-args)))))
+ (req orig-args '()))))
+ (expand-lambda-case
+ (lambda (e r w s mod get-formals clauses)
+ (letrec*
+ ((parse-req
+ (lambda (req opt rest kw body)
+ (let ((vars (map gen-var req)) (labels (gen-labels req)))
+ (let ((r* (extend-var-env labels vars r))
+ (w* (make-binding-wrap req labels w)))
+ (parse-opt
+ (map syntax->datum req)
+ opt
+ rest
+ kw
+ body
+ (reverse vars)
+ r*
+ w*
+ '()
+ '())))))
+ (parse-opt
+ (lambda (req opt rest kw body vars r* w* out inits)
+ (cond ((pair? opt)
+ (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any
any))))
+ (if tmp
+ (apply (lambda (id i)
+ (let* ((v (gen-var id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list id) l
w*)))
+ (parse-opt
+ req
+ (cdr opt)
+ rest
+ kw
+ body
+ (cons v vars)
+ r**
+ w**
+ (cons (syntax->datum id) out)
+ (cons (expand i r* w* mod) inits))))
+ tmp)
(syntax-violation
- 'syntax
- "misplaced ellipsis"
- src-5242)
- (values (list 'quote e-5243) maps-5245)))))
- (let ((tmp-5304 ($sc-dispatch e-5243 '(any any))))
- (if (if tmp-5304
- (@apply
- (lambda (dots-5308 e-5309)
- (ellipsis?-5246 dots-5308))
- tmp-5304)
- #f)
- (@apply
- (lambda (dots-5310 e-5311)
- (gen-syntax-5140
- src-5242
- e-5311
- r-5244
- maps-5245
- (lambda (x-5312) #f)
- mod-5247))
- tmp-5304)
- (let ((tmp-5313 ($sc-dispatch e-5243 '(any any . any))))
- (if (if tmp-5313
- (@apply
- (lambda (x-5317 dots-5318 y-5319)
- (ellipsis?-5246 dots-5318))
- tmp-5313)
- #f)
- (@apply
- (lambda (x-5320 dots-5321 y-5322)
- (letrec*
- ((f-5323
- (lambda (y-5331 k-5332)
- (let ((tmp-5334
- ($sc-dispatch
- y-5331
- '(any . any))))
- (if (if tmp-5334
- (@apply
- (lambda (dots-5338 y-5339)
- (ellipsis?-5246 dots-5338))
- tmp-5334)
- #f)
- (@apply
- (lambda (dots-5340 y-5341)
- (f-5323
- y-5341
- (lambda (maps-5342)
- (call-with-values
- (lambda ()
- (k-5332
- (cons '() maps-5342)))
- (lambda (x-5343 maps-5344)
- (if (null? (car maps-5344))
- (syntax-violation
- 'syntax
- "extra ellipsis"
- src-5242)
- (values
- (let ((map-env-5348
- (car
maps-5344)))
- (list 'apply
- '(primitive
- append)
- (gen-map-5143
- x-5343
-
map-env-5348)))
- (cdr maps-5344))))))))
- tmp-5334)
- (call-with-values
- (lambda ()
- (gen-syntax-5140
- src-5242
- y-5331
- r-5244
- maps-5245
- ellipsis?-5246
- mod-5247))
- (lambda (y-5351 maps-5352)
- (call-with-values
- (lambda () (k-5332 maps-5352))
- (lambda (x-5353 maps-5354)
- (values
- (if (equal? y-5351 ''())
- x-5353
- (list 'append
- x-5353
- y-5351))
- maps-5354))))))))))
- (f-5323
- y-5322
- (lambda (maps-5326)
- (call-with-values
- (lambda ()
- (gen-syntax-5140
- src-5242
- x-5320
- r-5244
- (cons '() maps-5326)
- ellipsis?-5246
- mod-5247))
- (lambda (x-5327 maps-5328)
- (if (null? (car maps-5328))
- (syntax-violation
- 'syntax
- "extra ellipsis"
- src-5242)
- (values
- (gen-map-5143
- x-5327
- (car maps-5328))
- (cdr maps-5328)))))))))
- tmp-5313)
- (let ((tmp-5370 ($sc-dispatch e-5243 '(any . any))))
- (if tmp-5370
- (@apply
- (lambda (x-5374 y-5375)
- (call-with-values
- (lambda ()
- (gen-syntax-5140
- src-5242
- x-5374
- r-5244
- maps-5245
- ellipsis?-5246
- mod-5247))
- (lambda (x-5376 maps-5377)
- (call-with-values
- (lambda ()
- (gen-syntax-5140
- src-5242
- y-5375
- r-5244
- maps-5377
- ellipsis?-5246
- mod-5247))
- (lambda (y-5378 maps-5379)
- (values
- (let ((key-5384 (car y-5378)))
- (if (eqv? key-5384 'quote)
- (if (eq? (car x-5376) 'quote)
- (list 'quote
- (cons (car (cdr x-5376))
- (car (cdr
y-5378))))
- (if (eq? (car (cdr y-5378))
- '())
- (list 'list x-5376)
- (list 'cons x-5376 y-5378)))
- (if (eqv? key-5384 'list)
- (cons 'list
- (cons x-5376
- (cdr y-5378)))
- (list 'cons x-5376 y-5378))))
- maps-5379))))))
- tmp-5370)
- (let ((tmp-5413
- ($sc-dispatch
- e-5243
- '#(vector (any . each-any)))))
- (if tmp-5413
- (@apply
- (lambda (e1-5417 e2-5418)
- (call-with-values
- (lambda ()
- (gen-syntax-5140
- src-5242
- (cons e1-5417 e2-5418)
- r-5244
- maps-5245
- ellipsis?-5246
- mod-5247))
- (lambda (e-5419 maps-5420)
- (values
- (if (eq? (car e-5419) 'list)
- (cons 'vector (cdr e-5419))
- (if (eq? (car e-5419) 'quote)
- (list 'quote
- (list->vector
- (car (cdr e-5419))))
- (list 'list->vector e-5419)))
- maps-5420))))
- tmp-5413)
- (values
- (list 'quote e-5243)
- maps-5245))))))))))))
- (gen-ref-5141
- (lambda (src-5447 var-5448 level-5449 maps-5450)
- (if (= level-5449 0)
- (values var-5448 maps-5450)
- (if (null? maps-5450)
- (syntax-violation
- 'syntax
- "missing ellipsis"
- src-5447)
- (call-with-values
- (lambda ()
- (gen-ref-5141
- src-5447
- var-5448
- (#{1-}# level-5449)
- (cdr maps-5450)))
- (lambda (outer-var-5451 outer-maps-5452)
- (let ((b-5453 (assq outer-var-5451 (car maps-5450))))
- (if b-5453
- (values (cdr b-5453) maps-5450)
- (let ((inner-var-5455
- (gensym
- (string-append
- (symbol->string 'tmp)
- "-"))))
- (values
- inner-var-5455
- (cons (cons (cons outer-var-5451 inner-var-5455)
- (car maps-5450))
- outer-maps-5452)))))))))))
- (gen-map-5143
- (lambda (e-5469 map-env-5470)
- (let ((formals-5471 (map cdr map-env-5470))
- (actuals-5472
- (map (lambda (x-5474) (list 'ref (car x-5474)))
- map-env-5470)))
- (if (eq? (car e-5469) 'ref)
- (car actuals-5472)
- (if (and-map
- (lambda (x-5475)
- (if (eq? (car x-5475) 'ref)
- (memq (car (cdr x-5475)) formals-5471)
- #f))
- (cdr e-5469))
- (cons 'map
- (cons (list 'primitive (car e-5469))
- (map (let ((r-5477
- (map cons
- formals-5471
- actuals-5472)))
- (lambda (x-5478)
- (cdr (assq (car (cdr x-5478))
- r-5477))))
- (cdr e-5469))))
- (cons 'map
- (cons (list 'lambda formals-5471 e-5469)
- actuals-5472)))))))
- (regen-5147
- (lambda (x-5480)
- (let ((key-5481 (car x-5480)))
- (if (eqv? key-5481 'ref)
- (let ((name-5491 (car (cdr x-5480)))
- (var-5492 (car (cdr x-5480))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- #f
- name-5491
- var-5492))
- (if (eqv? key-5481 'primitive)
- (let ((name-5504 (car (cdr x-5480))))
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- name-5504)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
#f
- '(guile)
- name-5504
- #f)))
- (if (eqv? key-5481 'quote)
- (let ((exp-5522 (car (cdr x-5480))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- exp-5522))
- (if (eqv? key-5481 'lambda)
- (if (list? (car (cdr x-5480)))
- (let ((req-5533 (car (cdr x-5480)))
- (vars-5535 (car (cdr x-5480)))
- (exp-5537
- (regen-5147 (car (cdr (cdr x-5480))))))
- (let ((body-5542
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #f
- req-5533
- #f
- #f
- #f
- '()
- vars-5535
- exp-5537
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #f
- '()
- body-5542)))
- (error "how did we get here" x-5480))
- (let ((fun-exp-5558
- (let ((name-5567 (car x-5480)))
- (if (equal?
- (module-name (current-module))
- '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- name-5567)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- name-5567
- #f))))
- (arg-exps-5559 (map regen-5147 (cdr x-5480))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- fun-exp-5558
- arg-exps-5559))))))))))
- (lambda (e-5148 r-5149 w-5150 s-5151 mod-5152)
- (let ((e-5153
- (wrap-4324
- (begin
- (if (if s-5151
- (supports-source-properties? e-5148)
- #f)
- (set-source-properties! e-5148 s-5151))
- e-5148)
- w-5150
- mod-5152)))
- (let ((tmp-5155 ($sc-dispatch e-5153 '(_ any))))
- (if tmp-5155
- (@apply
- (lambda (x-5180)
+ "source expression failed to match any pattern"
+ tmp-1))))
+ (rest
+ (let* ((v (gen-var rest))
+ (l (gen-labels (list v)))
+ (r* (extend-var-env l (list v) r*))
+ (w* (make-binding-wrap (list rest) l w*)))
+ (parse-kw
+ req
+ (and (pair? out) (reverse out))
+ (syntax->datum rest)
+ (if (pair? kw) (cdr kw) kw)
+ body
+ (cons v vars)
+ r*
+ w*
+ (and (pair? kw) (car kw))
+ '()
+ inits)))
+ (else
+ (parse-kw
+ req
+ (and (pair? out) (reverse out))
+ #f
+ (if (pair? kw) (cdr kw) kw)
+ body
+ vars
+ r*
+ w*
+ (and (pair? kw) (car kw))
+ '()
+ inits)))))
+ (parse-kw
+ (lambda (req opt rest kw body vars r* w* aok out inits)
+ (if (pair? kw)
+ (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any
any))))
+ (if tmp
+ (apply (lambda (k id i)
+ (let* ((v (gen-var id))
+ (l (gen-labels (list v)))
+ (r** (extend-var-env l (list v) r*))
+ (w** (make-binding-wrap (list id) l w*)))
+ (parse-kw
+ req
+ opt
+ rest
+ (cdr kw)
+ body
+ (cons v vars)
+ r**
+ w**
+ aok
+ (cons (list (syntax->datum k) (syntax->datum
id) v) out)
+ (cons (expand i r* w* mod) inits))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))
+ (parse-body
+ req
+ opt
+ rest
+ (and (or aok (pair? out)) (cons aok (reverse out)))
+ body
+ (reverse vars)
+ r*
+ w*
+ (reverse inits)
+ '()))))
+ (parse-body
+ (lambda (req opt rest kw body vars r* w* inits meta)
+ (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any .
each-any))))
+ (if (and tmp-1
+ (apply (lambda (docstring e1 e2) (string?
(syntax->datum docstring)))
+ tmp-1))
+ (apply (lambda (docstring e1 e2)
+ (parse-body
+ req
+ opt
+ rest
+ kw
+ (cons e1 e2)
+ vars
+ r*
+ w*
+ inits
+ (append meta (list (cons 'documentation
(syntax->datum docstring))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any .
any))) any . each-any))))
+ (if tmp-1
+ (apply (lambda (k v e1 e2)
+ (parse-body
+ req
+ opt
+ rest
+ kw
+ (cons e1 e2)
+ vars
+ r*
+ w*
+ inits
+ (append meta (syntax->datum (map cons k v)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
+ (if tmp-1
+ (apply (lambda (e1 e2)
+ (values
+ meta
+ req
+ opt
+ rest
+ kw
+ inits
+ vars
+ (expand-body (cons e1 e2) (source-wrap e
w s mod) r* w* mod)))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))))
+ (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (values '() #f)) tmp-1)
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ '((any any . each-any) . #(each (any any .
each-any))))))
+ (if tmp-1
+ (apply (lambda (args e1 e2 args* e1* e2*)
+ (call-with-values
+ (lambda () (get-formals args))
+ (lambda (req opt rest kw)
+ (call-with-values
+ (lambda () (parse-req req opt rest kw (cons e1
e2)))
+ (lambda (meta req opt rest kw inits vars body)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case
+ e
+ r
+ w
+ s
+ mod
+ get-formals
+ (map (lambda (tmp-2 tmp-1 tmp) (cons
tmp (cons tmp-1 tmp-2)))
+ e2*
+ e1*
+ args*)))
+ (lambda (meta* else*)
+ (values
+ (append meta meta*)
+ (build-lambda-case s req opt rest kw
inits vars body else*)))))))))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))
+ (strip (lambda (x w)
+ (if (memq 'top (car w))
+ 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)) (new (map f old)))
+ (let lp ((l1 old) (l2 new))
+ (cond ((null? l1) x)
+ ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr
l2)))
+ (else (list->vector new))))))
+ (else x))))))
+ (gen-var
+ (lambda (id)
+ (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+ (gensym (string-append (symbol->string id) "-")))))
+ (lambda-var-list
+ (lambda (vars)
+ (let lvl ((vars vars) (ls '()) (w '(())))
+ (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls)
w))
+ ((id? vars) (cons (wrap vars w #f) ls))
+ ((null? vars) ls)
+ ((syntax-object? vars)
+ (lvl (syntax-object-expression vars)
+ ls
+ (join-wraps w (syntax-object-wrap vars))))
+ (else (cons vars ls)))))))
+ (global-extend 'local-syntax 'letrec-syntax #t)
+ (global-extend 'local-syntax 'let-syntax #f)
+ (global-extend
+ 'core
+ 'syntax-parameterize
+ (lambda (e r w s mod)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+ (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var))
tmp))
+ (apply (lambda (var val e1 e2)
+ (let ((names (map (lambda (x) (id-var-name x w)) var)))
+ (for-each
+ (lambda (id n)
+ (let ((key (car (lookup n r mod))))
+ (if (memv key '(displaced-lexical))
+ (syntax-violation
+ 'syntax-parameterize
+ "identifier out of context"
+ e
+ (source-wrap id w s mod)))))
+ var
+ names)
+ (expand-body
+ (cons e1 e2)
+ (source-wrap e w s mod)
+ (extend-env
+ names
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (cons 'macro (eval-local-transformer (expand
x trans-r w mod) mod)))
+ val))
+ r)
+ w
+ mod)))
+ tmp)
+ (syntax-violation
+ 'syntax-parameterize
+ "bad syntax"
+ (source-wrap e w s mod))))))
+ (global-extend
+ 'core
+ 'quote
+ (lambda (e r w s mod)
+ (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
+ (if tmp
+ (apply (lambda (e) (build-data s (strip e w))) tmp)
+ (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
+ (global-extend
+ 'core
+ 'syntax
+ (letrec*
+ ((gen-syntax
+ (lambda (src e r maps ellipsis? mod)
+ (if (id? e)
+ (let* ((label (id-var-name e '(()))) (b (lookup label r mod)))
+ (cond ((eq? (car b) 'syntax)
(call-with-values
(lambda ()
- (gen-syntax-5140
- e-5153
- x-5180
- r-5149
- '()
- ellipsis?-4339
- mod-5152))
- (lambda (e-5234 maps-5235) (regen-5147 e-5234))))
- tmp-5155)
- (syntax-violation
- 'syntax
- "bad `syntax' form"
- e-5153)))))))
- (global-extend-4293
- 'core
- 'lambda
- (lambda (e-5755 r-5756 w-5757 s-5758 mod-5759)
- (let ((tmp-5761
- ($sc-dispatch e-5755 '(_ any any . each-any))))
- (if tmp-5761
- (@apply
- (lambda (args-5765 e1-5766 e2-5767)
- (call-with-values
- (lambda () (lambda-formals-4340 args-5765))
- (lambda (req-5770 opt-5771 rest-5772 kw-5773)
- (letrec*
- ((lp-5774
- (lambda (body-5777 meta-5778)
- (let ((tmp-5780
- ($sc-dispatch
- body-5777
- '(any any . each-any))))
- (if (if tmp-5780
- (@apply
- (lambda (docstring-5784 e1-5785 e2-5786)
- (string?
- (syntax->datum docstring-5784)))
- tmp-5780)
- #f)
- (@apply
- (lambda (docstring-5787 e1-5788 e2-5789)
- (lp-5774
- (cons e1-5788 e2-5789)
- (append
- meta-5778
- (list (cons 'documentation
- (syntax->datum
- docstring-5787))))))
- tmp-5780)
- (let ((tmp-5790
- ($sc-dispatch
- body-5777
- '(#(vector #(each (any . any)))
- any
- .
- each-any))))
- (if tmp-5790
- (@apply
- (lambda (k-5794 v-5795 e1-5796 e2-5797)
- (lp-5774
- (cons e1-5796 e2-5797)
- (append
- meta-5778
- (syntax->datum
- (map cons k-5794 v-5795)))))
- tmp-5790)
- (expand-simple-lambda-4341
- e-5755
- r-5756
- w-5757
- s-5758
- mod-5759
- req-5770
- rest-5772
- meta-5778
- body-5777))))))))
- (lp-5774 (cons e1-5766 e2-5767) '())))))
- tmp-5761)
- (syntax-violation 'lambda "bad lambda" e-5755)))))
- (global-extend-4293
- 'core
- 'lambda*
- (lambda (e-6086 r-6087 w-6088 s-6089 mod-6090)
- (let ((tmp-6092
- ($sc-dispatch e-6086 '(_ any any . each-any))))
- (if tmp-6092
- (@apply
- (lambda (args-6096 e1-6097 e2-6098)
- (call-with-values
- (lambda ()
- (expand-lambda-case-4343
- e-6086
- r-6087
- w-6088
- s-6089
- mod-6090
- lambda*-formals-4342
- (list (cons args-6096 (cons e1-6097 e2-6098)))))
- (lambda (meta-6101 lcase-6102)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- s-6089
- meta-6101
- lcase-6102))))
- tmp-6092)
- (syntax-violation 'lambda "bad lambda*" e-6086)))))
- (global-extend-4293
- 'core
- 'case-lambda
- (lambda (e-6272 r-6273 w-6274 s-6275 mod-6276)
- (let ((tmp-6278
- ($sc-dispatch
- e-6272
- '(_ (any any . each-any)
- .
- #(each (any any . each-any))))))
- (if tmp-6278
- (@apply
- (lambda (args-6282
- e1-6283
- e2-6284
- args*-6285
- e1*-6286
- e2*-6287)
- (call-with-values
- (lambda ()
- (expand-lambda-case-4343
- e-6272
- r-6273
- w-6274
- s-6275
- mod-6276
- lambda-formals-4340
- (cons (cons args-6282 (cons e1-6283 e2-6284))
- (map (lambda (tmp-3270-6290
- tmp-3269-6291
- tmp-3268-6292)
- (cons tmp-3268-6292
- (cons tmp-3269-6291 tmp-3270-6290)))
- e2*-6287
- e1*-6286
- args*-6285))))
- (lambda (meta-6293 lcase-6294)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- s-6275
- meta-6293
- lcase-6294))))
- tmp-6278)
- (syntax-violation
- 'case-lambda
- "bad case-lambda"
- e-6272)))))
- (global-extend-4293
- 'core
- 'case-lambda*
- (lambda (e-6456 r-6457 w-6458 s-6459 mod-6460)
- (let ((tmp-6462
- ($sc-dispatch
- e-6456
- '(_ (any any . each-any)
- .
- #(each (any any . each-any))))))
- (if tmp-6462
- (@apply
- (lambda (args-6466
- e1-6467
- e2-6468
- args*-6469
- e1*-6470
- e2*-6471)
+ (let ((var.lev (cdr b)))
+ (gen-ref src (car var.lev) (cdr var.lev) maps)))
+ (lambda (var maps) (values (list 'ref var) maps))))
+ ((ellipsis? e) (syntax-violation 'syntax "misplaced
ellipsis" src))
+ (else (values (list 'quote e) maps))))
+ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
+ (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1))
+ (apply (lambda (dots e) (gen-syntax src e r maps (lambda (x)
#f) mod))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
+ (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots))
tmp-1))
+ (apply (lambda (x dots y)
+ (let f ((y y)
+ (k (lambda (maps)
+ (call-with-values
+ (lambda () (gen-syntax src x r
(cons '() maps) ellipsis? mod))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax
"extra ellipsis" src)
+ (values (gen-map x (car
maps)) (cdr maps))))))))
+ (let* ((tmp y) (tmp ($sc-dispatch tmp '(any .
any))))
+ (if (and tmp (apply (lambda (dots y)
(ellipsis? dots)) tmp))
+ (apply (lambda (dots y)
+ (f y
+ (lambda (maps)
+ (call-with-values
+ (lambda () (k (cons '()
maps)))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation
'syntax "extra ellipsis" src)
+ (values (gen-mappend x
(car maps)) (cdr maps))))))))
+ tmp)
+ (call-with-values
+ (lambda () (gen-syntax src y r maps
ellipsis? mod))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k maps))
+ (lambda (x maps) (values (gen-append
x y) maps)))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply (lambda (x y)
+ (call-with-values
+ (lambda () (gen-syntax src x r maps
ellipsis? mod))
+ (lambda (x maps)
+ (call-with-values
+ (lambda () (gen-syntax src y r maps
ellipsis? mod))
+ (lambda (y maps) (values (gen-cons x
y) maps))))))
+ tmp-1)
+ (let ((tmp ($sc-dispatch tmp '#(vector (any .
each-any)))))
+ (if tmp
+ (apply (lambda (e1 e2)
+ (call-with-values
+ (lambda () (gen-syntax src (cons e1
e2) r maps ellipsis? mod))
+ (lambda (e maps) (values (gen-vector
e) maps))))
+ tmp)
+ (values (list 'quote e) maps))))))))))))
+ (gen-ref
+ (lambda (src var level maps)
+ (cond ((= level 0) (values var maps))
+ ((null? maps) (syntax-violation 'syntax "missing ellipsis"
src))
+ (else
(call-with-values
- (lambda ()
- (expand-lambda-case-4343
- e-6456
- r-6457
- w-6458
- s-6459
- mod-6460
- lambda*-formals-4342
- (cons (cons args-6466 (cons e1-6467 e2-6468))
- (map (lambda (tmp-3305-6474
- tmp-3304-6475
- tmp-3303-6476)
- (cons tmp-3303-6476
- (cons tmp-3304-6475 tmp-3305-6474)))
- e2*-6471
- e1*-6470
- args*-6469))))
- (lambda (meta-6477 lcase-6478)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- s-6459
- meta-6477
- lcase-6478))))
- tmp-6462)
- (syntax-violation
- 'case-lambda
- "bad case-lambda*"
- e-6456)))))
- (global-extend-4293
- 'core
- 'let
- (letrec*
- ((expand-let-6669
- (lambda (e-6818
- r-6819
- w-6820
- s-6821
- mod-6822
- constructor-6823
- ids-6824
- vals-6825
- exps-6826)
- (if (not (valid-bound-ids?-4321 ids-6824))
- (syntax-violation
- 'let
- "duplicate bound variable"
- e-6818)
- (let ((labels-6904 (gen-labels-4298 ids-6824))
- (new-vars-6905 (map gen-var-4345 ids-6824)))
- (let ((nw-6906
- (make-binding-wrap-4309
- ids-6824
- labels-6904
- w-6820))
- (nr-6907
- (extend-var-env-4290
- labels-6904
- new-vars-6905
- r-6819)))
- (constructor-6823
- s-6821
- (map syntax->datum ids-6824)
- new-vars-6905
- (map (lambda (x-6924)
- (expand-4331 x-6924 r-6819 w-6820 mod-6822))
- vals-6825)
- (expand-body-4335
- exps-6826
- (source-wrap-4325 e-6818 nw-6906 s-6821 mod-6822)
- nr-6907
- nw-6906
- mod-6822))))))))
- (lambda (e-6670 r-6671 w-6672 s-6673 mod-6674)
- (let ((tmp-6676
- ($sc-dispatch
- e-6670
- '(_ #(each (any any)) any . each-any))))
- (if (if tmp-6676
- (@apply
- (lambda (id-6680 val-6681 e1-6682 e2-6683)
- (and-map id?-4295 id-6680))
- tmp-6676)
- #f)
- (@apply
- (lambda (id-6699 val-6700 e1-6701 e2-6702)
- (expand-let-6669
- e-6670
- r-6671
- w-6672
- s-6673
- mod-6674
- build-let-4277
- id-6699
- val-6700
- (cons e1-6701 e2-6702)))
- tmp-6676)
- (let ((tmp-6732
- ($sc-dispatch
- e-6670
- '(_ any #(each (any any)) any . each-any))))
- (if (if tmp-6732
- (@apply
- (lambda (f-6736 id-6737 val-6738 e1-6739 e2-6740)
- (if (if (symbol? f-6736)
- #t
- (if (if (vector? f-6736)
- (if (= (vector-length f-6736) 4)
- (eq? (vector-ref f-6736 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref f-6736 1))
- #f))
- (and-map id?-4295 id-6737)
- #f))
- tmp-6732)
- #f)
- (@apply
- (lambda (f-6782 id-6783 val-6784 e1-6785 e2-6786)
- (expand-let-6669
- e-6670
- r-6671
- w-6672
- s-6673
- mod-6674
- build-named-let-4278
- (cons f-6782 id-6783)
- val-6784
- (cons e1-6785 e2-6786)))
- tmp-6732)
- (syntax-violation
- 'let
- "bad let"
- (wrap-4324
- (begin
- (if (if s-6673
- (supports-source-properties? e-6670)
- #f)
- (set-source-properties! e-6670 s-6673))
- e-6670)
- w-6672
- mod-6674)))))))))
- (global-extend-4293
- 'core
- 'letrec
- (lambda (e-7336 r-7337 w-7338 s-7339 mod-7340)
- (let ((tmp-7342
- ($sc-dispatch
- e-7336
- '(_ #(each (any any)) any . each-any))))
- (if (if tmp-7342
- (@apply
- (lambda (id-7346 val-7347 e1-7348 e2-7349)
- (and-map id?-4295 id-7346))
- tmp-7342)
- #f)
- (@apply
- (lambda (id-7365 val-7366 e1-7367 e2-7368)
- (if (not (valid-bound-ids?-4321 id-7365))
- (syntax-violation
- 'letrec
- "duplicate bound variable"
- e-7336)
- (let ((labels-7458 (gen-labels-4298 id-7365))
- (new-vars-7459 (map gen-var-4345 id-7365)))
- (let ((w-7460
- (make-binding-wrap-4309
- id-7365
- labels-7458
- w-7338))
- (r-7461
- (extend-var-env-4290
- labels-7458
- new-vars-7459
- r-7337)))
- (build-letrec-4279
- s-7339
- #f
- (map syntax->datum id-7365)
- new-vars-7459
- (map (lambda (x-7546)
- (expand-4331 x-7546 r-7461 w-7460 mod-7340))
- val-7366)
- (expand-body-4335
- (cons e1-7367 e2-7368)
- (wrap-4324
- (begin
- (if (if s-7339
- (supports-source-properties? e-7336)
- #f)
- (set-source-properties! e-7336 s-7339))
- e-7336)
- w-7460
- mod-7340)
- r-7461
- w-7460
- mod-7340))))))
- tmp-7342)
- (syntax-violation
- 'letrec
- "bad letrec"
- (wrap-4324
- (begin
- (if (if s-7339
- (supports-source-properties? e-7336)
- #f)
- (set-source-properties! e-7336 s-7339))
- e-7336)
- w-7338
- mod-7340))))))
- (global-extend-4293
- 'core
- 'letrec*
- (lambda (e-7941 r-7942 w-7943 s-7944 mod-7945)
- (let ((tmp-7947
- ($sc-dispatch
- e-7941
- '(_ #(each (any any)) any . each-any))))
- (if (if tmp-7947
- (@apply
- (lambda (id-7951 val-7952 e1-7953 e2-7954)
- (and-map id?-4295 id-7951))
- tmp-7947)
- #f)
- (@apply
- (lambda (id-7970 val-7971 e1-7972 e2-7973)
- (if (not (valid-bound-ids?-4321 id-7970))
- (syntax-violation
- 'letrec*
- "duplicate bound variable"
- e-7941)
- (let ((labels-8063 (gen-labels-4298 id-7970))
- (new-vars-8064 (map gen-var-4345 id-7970)))
- (let ((w-8065
- (make-binding-wrap-4309
- id-7970
- labels-8063
- w-7943))
- (r-8066
- (extend-var-env-4290
- labels-8063
- new-vars-8064
- r-7942)))
- (build-letrec-4279
- s-7944
- #t
- (map syntax->datum id-7970)
- new-vars-8064
- (map (lambda (x-8151)
- (expand-4331 x-8151 r-8066 w-8065 mod-7945))
- val-7971)
- (expand-body-4335
- (cons e1-7972 e2-7973)
- (wrap-4324
- (begin
- (if (if s-7944
- (supports-source-properties? e-7941)
- #f)
- (set-source-properties! e-7941 s-7944))
- e-7941)
- w-8065
- mod-7945)
- r-8066
- w-8065
- mod-7945))))))
- tmp-7947)
- (syntax-violation
- 'letrec*
- "bad letrec*"
- (wrap-4324
- (begin
- (if (if s-7944
- (supports-source-properties? e-7941)
- #f)
- (set-source-properties! e-7941 s-7944))
- e-7941)
- w-7943
- mod-7945))))))
- (global-extend-4293
- 'core
- 'set!
- (lambda (e-8585 r-8586 w-8587 s-8588 mod-8589)
- (let ((tmp-8591 ($sc-dispatch e-8585 '(_ any any))))
- (if (if tmp-8591
- (@apply
- (lambda (id-8595 val-8596)
- (if (symbol? id-8595)
- #t
- (if (if (vector? id-8595)
- (if (= (vector-length id-8595) 4)
- (eq? (vector-ref id-8595 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-8595 1))
- #f)))
- tmp-8591)
- #f)
- (@apply
- (lambda (id-8623 val-8624)
- (let ((n-8625 (id-var-name-4314 id-8623 w-8587))
- (id-mod-8626
- (if (if (vector? id-8623)
- (if (= (vector-length id-8623) 4)
- (eq? (vector-ref id-8623 0) 'syntax-object)
- #f)
- #f)
- (vector-ref id-8623 3)
- mod-8589)))
- (let ((b-8627
- (let ((t-8668 (assq n-8625 r-8586)))
- (if t-8668
- (cdr t-8668)
- (if (symbol? n-8625)
- (let ((t-8673
- (get-global-definition-hook-4258
- n-8625
- id-mod-8626)))
- (if t-8673 t-8673 '(global)))
- '(displaced-lexical))))))
- (let ((key-8628 (car b-8627)))
- (if (eqv? key-8628 'lexical)
- (build-lexical-assignment-4266
- s-8588
- (syntax->datum id-8623)
- (cdr b-8627)
- (expand-4331 val-8624 r-8586 w-8587 mod-8589))
- (if (eqv? key-8628 'global)
- (build-global-assignment-4269
- s-8588
- n-8625
- (expand-4331 val-8624 r-8586 w-8587 mod-8589)
- id-mod-8626)
- (if (eqv? key-8628 'macro)
- (let ((p-8987 (cdr b-8627)))
- (if (procedure-property
- p-8987
- 'variable-transformer)
- (expand-4331
- (expand-macro-4334
- p-8987
- e-8585
- r-8586
- w-8587
- s-8588
- #f
- mod-8589)
- r-8586
- '(())
- mod-8589)
+ (lambda () (gen-ref src var (- level 1) (cdr maps)))
+ (lambda (outer-var outer-maps)
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values
+ inner-var
+ (cons (cons (cons outer-var inner-var) (car
maps)) outer-maps)))))))))))
+ (gen-mappend
+ (lambda (e map-env)
+ (list 'apply '(primitive append) (gen-map e map-env))))
+ (gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) (list 'ref (car x))) map-env)))
+ (cond ((eq? (car e) 'ref) (car actuals))
+ ((and-map
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x)
formals)))
+ (cdr e))
+ (cons 'map
+ (cons (list 'primitive (car e))
+ (map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e)))))
+ (else (cons 'map (cons (list 'lambda formals e)
actuals)))))))
+ (gen-cons
+ (lambda (x y)
+ (let ((key (car y)))
+ (cond ((memv key '(quote))
+ (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x)
(cadr y))))
+ ((eq? (cadr y) '()) (list 'list x))
+ (else (list 'cons x y))))
+ ((memv key '(list)) (cons 'list (cons x (cdr y))))
+ (else (list 'cons x y))))))
+ (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y))))
+ (gen-vector
+ (lambda (x)
+ (cond ((eq? (car x) 'list) (cons 'vector (cdr x)))
+ ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x))))
+ (else (list 'list->vector x)))))
+ (regen (lambda (x)
+ (let ((key (car x)))
+ (cond ((memv key '(ref))
+ (build-lexical-reference 'value #f (cadr x) (cadr x)))
+ ((memv key '(primitive)) (build-primref #f (cadr x)))
+ ((memv key '(quote)) (build-data #f (cadr x)))
+ ((memv key '(lambda))
+ (if (list? (cadr x))
+ (build-simple-lambda #f (cadr x) #f (cadr x) '()
(regen (caddr x)))
+ (error "how did we get here" x)))
+ (else
+ (build-application #f (build-primref #f (car x)) (map
regen (cdr x)))))))))
+ (lambda (e r w s mod)
+ (let* ((e (source-wrap e w s mod))
+ (tmp e)
+ (tmp ($sc-dispatch tmp '(_ any))))
+ (if tmp
+ (apply (lambda (x)
+ (call-with-values
+ (lambda () (gen-syntax e x r '() ellipsis? mod))
+ (lambda (e maps) (regen e))))
+ tmp)
+ (syntax-violation 'syntax "bad `syntax' form" e))))))
+ (global-extend
+ 'core
+ 'lambda
+ (lambda (e r w s mod)
+ (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
+ (if tmp
+ (apply (lambda (args e1 e2)
+ (call-with-values
+ (lambda () (lambda-formals args))
+ (lambda (req opt rest kw)
+ (let lp ((body (cons e1 e2)) (meta '()))
+ (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any
any . each-any))))
+ (if (and tmp
+ (apply (lambda (docstring e1 e2) (string?
(syntax->datum docstring)))
+ tmp))
+ (apply (lambda (docstring e1 e2)
+ (lp (cons e1 e2)
+ (append meta (list (cons
'documentation (syntax->datum docstring))))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each
(any . any))) any . each-any))))
+ (if tmp
+ (apply (lambda (k v e1 e2)
+ (lp (cons e1 e2) (append meta
(syntax->datum (map cons k v)))))
+ tmp)
+ (expand-simple-lambda e r w s mod req rest
meta body)))))))))
+ tmp)
+ (syntax-violation 'lambda "bad lambda" e)))))
+ (global-extend
+ 'core
+ 'lambda*
+ (lambda (e r w s mod)
+ (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
+ (if tmp
+ (apply (lambda (args e1 e2)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case
+ e
+ r
+ w
+ s
+ mod
+ lambda*-formals
+ (list (cons args (cons e1 e2)))))
+ (lambda (meta lcase) (build-case-lambda s meta lcase))))
+ tmp)
+ (syntax-violation 'lambda "bad lambda*" e)))))
+ (global-extend
+ 'core
+ 'case-lambda
+ (lambda (e r w s mod)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch
+ tmp
+ '(_ (any any . each-any) . #(each (any any . each-any))))))
+ (if tmp
+ (apply (lambda (args e1 e2 args* e1* e2*)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case
+ e
+ r
+ w
+ s
+ mod
+ lambda-formals
+ (cons (cons args (cons e1 e2))
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons
tmp-1 tmp-2)))
+ e2*
+ e1*
+ args*))))
+ (lambda (meta lcase) (build-case-lambda s meta lcase))))
+ tmp)
+ (syntax-violation 'case-lambda "bad case-lambda" e)))))
+ (global-extend
+ 'core
+ 'case-lambda*
+ (lambda (e r w s mod)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch
+ tmp
+ '(_ (any any . each-any) . #(each (any any . each-any))))))
+ (if tmp
+ (apply (lambda (args e1 e2 args* e1* e2*)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case
+ e
+ r
+ w
+ s
+ mod
+ lambda*-formals
+ (cons (cons args (cons e1 e2))
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons
tmp-1 tmp-2)))
+ e2*
+ e1*
+ args*))))
+ (lambda (meta lcase) (build-case-lambda s meta lcase))))
+ tmp)
+ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
+ (global-extend
+ 'core
+ 'let
+ (letrec*
+ ((expand-let
+ (lambda (e r w s mod constructor ids vals exps)
+ (if (not (valid-bound-ids? ids))
+ (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) (expand x r w mod)) vals)
+ (expand-body exps (source-wrap e nw s mod) nr nw mod))))))))
+ (lambda (e r w s mod)
+ (let* ((tmp-1 e)
+ (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any .
each-any))))
+ (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
+ (apply (lambda (id val e1 e2)
+ (expand-let e r w s mod build-let id val (cons e1 e2)))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any .
each-any))))
+ (if (and tmp
+ (apply (lambda (f id val e1 e2) (and (id? f) (and-map
id? id))) tmp))
+ (apply (lambda (f id val e1 e2)
+ (expand-let e r w s mod build-named-let (cons f id)
val (cons e1 e2)))
+ tmp)
+ (syntax-violation 'let "bad let" (source-wrap e w s
mod)))))))))
+ (global-extend
+ 'core
+ 'letrec
+ (lambda (e r w s mod)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+ (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
+ (apply (lambda (id val e1 e2)
+ (let ((ids id))
+ (if (not (valid-bound-ids? ids))
+ (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
+ #f
+ (map syntax->datum ids)
+ new-vars
+ (map (lambda (x) (expand x r w mod)) val)
+ (expand-body (cons e1 e2) (source-wrap e w s mod)
r w mod)))))))
+ tmp)
+ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
+ (global-extend
+ 'core
+ 'letrec*
+ (lambda (e r w s mod)
+ (let* ((tmp e)
+ (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+ (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
+ (apply (lambda (id val e1 e2)
+ (let ((ids id))
+ (if (not (valid-bound-ids? ids))
+ (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
+ #t
+ (map syntax->datum ids)
+ new-vars
+ (map (lambda (x) (expand x r w mod)) val)
+ (expand-body (cons e1 e2) (source-wrap e w s mod)
r w mod)))))))
+ tmp)
+ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
+ (global-extend
+ 'core
+ 'set!
+ (lambda (e r w s mod)
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
+ (if (and tmp (apply (lambda (id val) (id? id)) tmp))
+ (apply (lambda (id val)
+ (let ((n (id-var-name id w))
+ (id-mod (if (syntax-object? id) (syntax-object-module
id) mod)))
+ (let* ((b (lookup n r id-mod)) (key (car b)))
+ (cond ((memv key '(lexical))
+ (build-lexical-assignment
+ s
+ (syntax->datum id)
+ (cdr b)
+ (expand val r w mod)))
+ ((memv key '(global))
+ (build-global-assignment s n (expand val r w
mod) id-mod))
+ ((memv key '(macro))
+ (let ((p (cdr b)))
+ (if (procedure-property p
'variable-transformer)
+ (expand (expand-macro p e r w s #f mod) r
'(()) mod)
(syntax-violation
'set!
"not a variable transformer"
- (wrap-4324 e-8585 w-8587 mod-8589)
- (wrap-4324 id-8623 w-8587 id-mod-8626))))
- (if (eqv? key-8628 'displaced-lexical)
- (syntax-violation
- 'set!
- "identifier out of context"
- (wrap-4324 id-8623 w-8587 mod-8589))
- (syntax-violation
- 'set!
- "bad set!"
- (wrap-4324
- (begin
- (if (if s-8588
- (supports-source-properties?
- e-8585)
- #f)
- (set-source-properties! e-8585 s-8588))
- e-8585)
- w-8587
- mod-8589))))))))))
- tmp-8591)
- (let ((tmp-9082
- ($sc-dispatch e-8585 '(_ (any . each-any) any))))
- (if tmp-9082
- (@apply
- (lambda (head-9086 tail-9087 val-9088)
- (call-with-values
- (lambda ()
- (syntax-type-4330
- head-9086
- r-8586
- '(())
- #f
- #f
- mod-8589
- #t))
- (lambda (type-9091
- value-9092
- formform-9093
- ee-9094
- ww-9095
- ss-9096
- modmod-9097)
- (if (eqv? type-9091 'module-ref)
- (let ((val-9103
- (expand-4331
- val-9088
- r-8586
- w-8587
- mod-8589)))
- (call-with-values
- (lambda ()
- (value-9092
- (cons head-9086 tail-9087)
- r-8586
- w-8587))
- (lambda (e-9104 r-9105 w-9106 s*-9107 mod-9108)
- (let ((tmp-9110 (list e-9104)))
- (if (@apply
- (lambda (e-9112)
- (if (symbol? e-9112)
- #t
- (if (if (vector? e-9112)
- (if (= (vector-length
- e-9112)
- 4)
- (eq? (vector-ref
- e-9112
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref e-9112 1))
- #f)))
- tmp-9110)
- (@apply
- (lambda (e-9142)
- (build-global-assignment-4269
- s-8588
- (syntax->datum e-9142)
- val-9103
- mod-9108))
- tmp-9110)
- (syntax-violation
- #f
- "source expression failed to match any
pattern"
- e-9104))))))
- (build-application-4262
- s-8588
- (let ((e-9367
- (list '#(syntax-object
- setter
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(key)
- #((m-*-3554 top))
- #("l-*-3555"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(type
- value
- formform
- ee
- ww
- ss
- modmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3547"
- "l-*-3548"
- "l-*-3549"
- "l-*-3550"
- "l-*-3551"
- "l-*-3552"
- "l-*-3553"))
- #(ribcage
- #(head tail val)
- #((top) (top) (top))
- #("l-*-3532"
- "l-*-3533"
- "l-*-3534"))
- #(ribcage () () ())
- #(ribcage
- #(e r w s mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3501"
- "l-*-3502"
- "l-*-3503"
- "l-*-3504"
- "l-*-3505"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
-
set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- head-9086)))
- (call-with-values
- (lambda ()
- (syntax-type-4330
- e-9367
- r-8586
- w-8587
- (source-annotation-4288 e-9367)
- #f
- mod-8589
- #f))
- (lambda (type-9374
- value-9375
- form-9376
- e-9377
- w-9378
- s-9379
- mod-9380)
- (expand-expr-4332
- type-9374
- value-9375
- form-9376
- e-9377
- r-8586
- w-9378
- s-9379
- mod-9380))))
- (map (lambda (e-9384)
- (call-with-values
- (lambda ()
- (syntax-type-4330
- e-9384
- r-8586
- w-8587
- (source-annotation-4288 e-9384)
+ (wrap e w mod)
+ (wrap id w id-mod)))))
+ ((memv key '(displaced-lexical))
+ (syntax-violation 'set! "identifier out of
context" (wrap id w mod)))
+ (else (syntax-violation 'set! "bad set!"
(source-wrap e w s mod)))))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any))))
+ (if tmp
+ (apply (lambda (head tail val)
+ (call-with-values
+ (lambda () (syntax-type head r '(()) #f #f mod #t))
+ (lambda (type value formform ee ww ss modmod)
+ (let ((key type))
+ (if (memv key '(module-ref))
+ (let ((val (expand val r w mod)))
+ (call-with-values
+ (lambda () (value (cons head tail) r w))
+ (lambda (e r w s* mod)
+ (let* ((tmp-1 e) (tmp (list tmp-1)))
+ (if (and tmp (apply (lambda (e) (id?
e)) tmp))
+ (apply (lambda (e)
(build-global-assignment s (syntax->datum e) val mod))
+ tmp)
+ (syntax-violation
#f
- mod-8589
- #f))
- (lambda (type-9399
- value-9400
- form-9401
- e-9402
- w-9403
- s-9404
- mod-9405)
- (expand-expr-4332
- type-9399
- value-9400
- form-9401
- e-9402
- r-8586
- w-9403
- s-9404
- mod-9405))))
- (append tail-9087 (list val-9088))))))))
- tmp-9082)
- (syntax-violation
- 'set!
- "bad set!"
- (wrap-4324
- (begin
- (if (if s-8588
- (supports-source-properties? e-8585)
- #f)
- (set-source-properties! e-8585 s-8588))
- e-8585)
- w-8587
- mod-8589))))))))
- (module-define!
- (current-module)
- '@
- (make-syntax-transformer
- '@
- 'module-ref
- (lambda (e-9448 r-9449 w-9450)
- (let ((tmp-9452
- ($sc-dispatch e-9448 '(_ each-any any))))
- (if (if tmp-9452
- (@apply
- (lambda (mod-9455 id-9456)
- (if (and-map id?-4295 mod-9455)
- (if (symbol? id-9456)
- #t
- (if (if (vector? id-9456)
- (if (= (vector-length id-9456) 4)
- (eq? (vector-ref id-9456 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-9456 1))
- #f))
- #f))
- tmp-9452)
- #f)
- (@apply
- (lambda (mod-9496 id-9497)
- (values
- (syntax->datum id-9497)
- r-9449
- w-9450
- #f
- (syntax->datum
- (cons '#(syntax-object
- public
- ((top)
- #(ribcage
- #(mod id)
- #((top) (top))
- #("l-*-3596" "l-*-3597"))
- #(ribcage () () ())
- #(ribcage
- #(e r w)
- #((top) (top) (top))
- #("l-*-3584" "l-*-3585" "l-*-3586"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- mod-9496))))
- tmp-9452)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-9448))))))
- (global-extend-4293
- 'module-ref
- '@@
- (lambda (e-9589 r-9590 w-9591)
- (letrec*
- ((remodulate-9592
- (lambda (x-9627 mod-9628)
- (if (pair? x-9627)
- (cons (remodulate-9592 (car x-9627) mod-9628)
- (remodulate-9592 (cdr x-9627) mod-9628))
- (if (if (vector? x-9627)
- (if (= (vector-length x-9627) 4)
- (eq? (vector-ref x-9627 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-9642
- (remodulate-9592 (vector-ref x-9627 1) mod-9628))
- (wrap-9643 (vector-ref x-9627 2)))
- (vector
- 'syntax-object
- expression-9642
- wrap-9643
- mod-9628))
- (if (vector? x-9627)
- (let ((n-9651 (vector-length x-9627)))
- (let ((v-9652 (make-vector n-9651)))
- (letrec*
- ((loop-9653
- (lambda (i-9700)
- (if (= i-9700 n-9651)
- v-9652
- (begin
- (vector-set!
- v-9652
- i-9700
- (remodulate-9592
- (vector-ref x-9627 i-9700)
- mod-9628))
- (loop-9653 (#{1+}# i-9700)))))))
- (loop-9653 0))))
- x-9627))))))
- (let ((tmp-9594
- ($sc-dispatch e-9589 '(_ each-any any))))
- (if (if tmp-9594
- (@apply
- (lambda (mod-9598 exp-9599)
- (and-map id?-4295 mod-9598))
- tmp-9594)
- #f)
- (@apply
- (lambda (mod-9615 exp-9616)
- (let ((mod-9617
- (syntax->datum
- (cons '#(syntax-object
- private
- ((top)
- #(ribcage
- #(mod exp)
- #((top) (top))
- #("l-*-3634" "l-*-3635"))
- #(ribcage
- (remodulate)
- ((top))
- ("l-*-3607"))
- #(ribcage
- #(e r w)
- #((top) (top) (top))
- #("l-*-3604" "l-*-3605" "l-*-3606"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- mod-9615))))
- (values
- (remodulate-9592 exp-9616 mod-9617)
- r-9590
- w-9591
- (source-annotation-4288 exp-9616)
- mod-9617)))
- tmp-9594)
+ "source expression failed to match
any pattern"
+ tmp-1))))))
+ (build-application
+ s
+ (expand
+ (list '#(syntax-object setter ((top))
(hygiene guile)) head)
+ r
+ w
+ mod)
+ (map (lambda (e) (expand e r w mod)) (append
tail (list val)))))))))
+ tmp)
+ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
+ (global-extend
+ 'module-ref
+ '@
+ (lambda (e r w)
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
+ (if (and tmp
+ (apply (lambda (mod id) (and (and-map id? mod) (id? id)))
tmp))
+ (apply (lambda (mod id)
+ (values
+ (syntax->datum id)
+ r
+ '((top))
+ #f
+ (syntax->datum
+ (cons '#(syntax-object public ((top)) (hygiene guile))
mod))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ (global-extend
+ 'module-ref
+ '@@
+ (lambda (e r w)
+ (letrec*
+ ((remodulate
+ (lambda (x mod)
+ (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr
x) mod)))
+ ((syntax-object? x)
+ (make-syntax-object
+ (remodulate (syntax-object-expression x) mod)
+ (syntax-object-wrap x)
+ mod))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (make-vector n)))
+ (let loop ((i 0))
+ (if (= i n)
+ (begin (if #f #f) v)
+ (begin
+ (vector-set! v i (remodulate (vector-ref x i) mod))
+ (loop (+ i 1)))))))
+ (else x)))))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
+ (if (and tmp
+ (apply (lambda (mod id) (and (and-map id? mod) (id? id)))
tmp))
+ (apply (lambda (mod id)
+ (values
+ (syntax->datum id)
+ r
+ '((top))
+ #f
+ (syntax->datum
+ (cons '#(syntax-object private ((top)) (hygiene
guile)) mod))))
+ tmp)
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(_ #(free-id #(syntax-object @@ ((top)) (hygiene
guile)))
+ each-any
+ any))))
+ (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
+ (apply (lambda (mod exp)
+ (let ((mod (syntax->datum
+ (cons '#(syntax-object private ((top))
(hygiene guile)) mod))))
+ (values (remodulate exp mod) r w (source-annotation
exp) mod)))
+ tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-9589))))))
- (global-extend-4293
- 'core
- 'if
- (lambda (e-9801 r-9802 w-9803 s-9804 mod-9805)
- (let ((tmp-9807 ($sc-dispatch e-9801 '(_ any any))))
- (if tmp-9807
- (@apply
- (lambda (test-9811 then-9812)
- (build-conditional-4263
- s-9804
- (expand-4331 test-9811 r-9802 w-9803 mod-9805)
- (expand-4331 then-9812 r-9802 w-9803 mod-9805)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #f)))
- tmp-9807)
- (let ((tmp-10037
- ($sc-dispatch e-9801 '(_ any any any))))
- (if tmp-10037
- (@apply
- (lambda (test-10041 then-10042 else-10043)
- (build-conditional-4263
- s-9804
- (expand-4331 test-10041 r-9802 w-9803 mod-9805)
- (expand-4331 then-10042 r-9802 w-9803 mod-9805)
- (expand-4331 else-10043 r-9802 w-9803 mod-9805)))
- tmp-10037)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-9801)))))))
- (global-extend-4293
- 'core
- 'with-fluids
- (lambda (e-10442 r-10443 w-10444 s-10445 mod-10446)
- (let ((tmp-10448
- ($sc-dispatch
- e-10442
- '(_ #(each (any any)) any . each-any))))
- (if tmp-10448
- (@apply
- (lambda (fluid-10452 val-10453 b-10454 b*-10455)
- (build-dynlet-4264
- s-10445
- (map (lambda (x-10536)
- (expand-4331 x-10536 r-10443 w-10444 mod-10446))
- fluid-10452)
- (map (lambda (x-10606)
- (expand-4331 x-10606 r-10443 w-10444 mod-10446))
- val-10453)
- (expand-body-4335
- (cons b-10454 b*-10455)
- (wrap-4324
- (begin
- (if (if s-10445
- (supports-source-properties? e-10442)
- #f)
- (set-source-properties! e-10442 s-10445))
- e-10442)
- w-10444
- mod-10446)
- r-10443
- w-10444
- mod-10446)))
- tmp-10448)
+ tmp-1))))))))
+ (global-extend
+ 'core
+ 'if
+ (lambda (e r w s mod)
+ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
+ (if tmp-1
+ (apply (lambda (test then)
+ (build-conditional
+ s
+ (expand test r w mod)
+ (expand then r w mod)
+ (build-void #f)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ any any any))))
+ (if tmp-1
+ (apply (lambda (test then else)
+ (build-conditional
+ s
+ (expand test r w mod)
+ (expand then r w mod)
+ (expand else r w mod)))
+ tmp-1)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-10442)))))
- (module-define!
- (current-module)
- 'begin
- (make-syntax-transformer 'begin 'begin '()))
- (module-define!
- (current-module)
- 'define
- (make-syntax-transformer 'define 'define '()))
- (module-define!
- (current-module)
- 'define-syntax
- (make-syntax-transformer
- 'define-syntax
- 'define-syntax
- '()))
- (module-define!
- (current-module)
- 'define-syntax-parameter
- (make-syntax-transformer
- 'define-syntax-parameter
- 'define-syntax-parameter
- '()))
- (module-define!
- (current-module)
- 'eval-when
- (make-syntax-transformer
- 'eval-when
- 'eval-when
- '()))
- (global-extend-4293
- 'core
- 'syntax-case
- (letrec*
- ((convert-pattern-10974
- (lambda (pattern-12571 keys-12572)
- (letrec*
- ((cvt*-12573
- (lambda (p*-13197 n-13198 ids-13199)
- (if (not (pair? p*-13197))
- (cvt-12575 p*-13197 n-13198 ids-13199)
+ tmp)))))))
+ (global-extend
+ 'core
+ 'with-fluids
+ (lambda (e r w s mod)
+ (let* ((tmp-1 e)
+ (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
+ (if tmp
+ (apply (lambda (fluid val b b*)
+ (build-dynlet
+ s
+ (map (lambda (x) (expand x r w mod)) fluid)
+ (map (lambda (x) (expand x r w mod)) val)
+ (expand-body (cons b b*) (source-wrap e w s mod) r w
mod)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ (global-extend 'begin 'begin '())
+ (global-extend 'define 'define '())
+ (global-extend 'define-syntax 'define-syntax '())
+ (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
+ (global-extend 'eval-when 'eval-when '())
+ (global-extend
+ 'core
+ 'syntax-case
+ (letrec*
+ ((convert-pattern
+ (lambda (pattern keys)
+ (letrec*
+ ((cvt* (lambda (p* n ids)
+ (if (not (pair? p*))
+ (cvt p* n ids)
(call-with-values
- (lambda ()
- (cvt*-12573 (cdr p*-13197) n-13198 ids-13199))
- (lambda (y-13202 ids-13203)
+ (lambda () (cvt* (cdr p*) n ids))
+ (lambda (y ids)
(call-with-values
- (lambda ()
- (cvt-12575 (car p*-13197) n-13198 ids-13203))
- (lambda (x-13206 ids-13207)
- (values
- (cons x-13206 y-13202)
- ids-13207))))))))
- (v-reverse-12574
- (lambda (x-13208)
- (letrec*
- ((loop-13209
- (lambda (r-13289 x-13290)
- (if (not (pair? x-13290))
- (values r-13289 x-13290)
- (loop-13209
- (cons (car x-13290) r-13289)
- (cdr x-13290))))))
- (loop-13209 '() x-13208))))
- (cvt-12575
- (lambda (p-12578 n-12579 ids-12580)
- (if (if (symbol? p-12578)
- #t
- (if (if (vector? p-12578)
- (if (= (vector-length p-12578) 4)
- (eq? (vector-ref p-12578 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref p-12578 1))
- #f))
- (if (bound-id-member?-4323 p-12578 keys-12572)
- (values (vector 'free-id p-12578) ids-12580)
- (if (if (eq? (if (if (vector? p-12578)
- (if (= (vector-length p-12578) 4)
- (eq? (vector-ref p-12578 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref p-12578 1)
- p-12578)
- (if (if (= (vector-length
- '#(syntax-object
- _
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p n ids)
- #((top) (top) (top))
- #("l-*-3735"
- "l-*-3736"
- "l-*-3737"))
- #(ribcage
- (cvt v-reverse cvt*)
- ((top) (top) (top))
- ("l-*-3708"
- "l-*-3706"
- "l-*-3704"))
- #(ribcage
- #(pattern keys)
- #((top) (top))
- #("l-*-3702"
- "l-*-3703"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top)
- (top)
- (top)
- (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
-
expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
- resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
- syntax-object-wrap
-
syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
- analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
-
make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile)))
- 4)
- #t
- #f)
- '_
- '#(syntax-object
- _
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p n ids)
- #((top) (top) (top))
- #("l-*-3735"
- "l-*-3736"
- "l-*-3737"))
- #(ribcage
- (cvt v-reverse cvt*)
- ((top) (top) (top))
- ("l-*-3708"
- "l-*-3706"
- "l-*-3704"))
- #(ribcage
- #(pattern keys)
- #((top) (top))
- #("l-*-3702" "l-*-3703"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314 p-12578 '(()))
- (id-var-name-4314
- '#(syntax-object
- _
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p n ids)
- #((top) (top) (top))
- #("l-*-3735"
- "l-*-3736"
- "l-*-3737"))
- #(ribcage
- (cvt v-reverse cvt*)
- ((top) (top) (top))
- ("l-*-3708"
- "l-*-3706"
- "l-*-3704"))
- #(ribcage
- #(pattern keys)
- #((top) (top))
- #("l-*-3702" "l-*-3703"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- (values '_ ids-12580)
- (values
- 'any
- (cons (cons p-12578 n-12579) ids-12580))))
- (let ((tmp-12900 ($sc-dispatch p-12578 '(any any))))
- (if (if tmp-12900
- (@apply
- (lambda (x-12904 dots-12905)
- (if (if (if (vector? dots-12905)
- (if (= (vector-length dots-12905)
- 4)
- (eq? (vector-ref dots-12905 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref dots-12905 1))
- #f)
- (if (eq? (if (if (vector? dots-12905)
- (if (= (vector-length
- dots-12905)
- 4)
- (eq? (vector-ref
- dots-12905
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref dots-12905 1)
- dots-12905)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
-
#("l-*-2267"))
- #(ribcage
-
(lambda-var-list
- gen-var
- strip
-
expand-lambda-case
-
lambda*-formals
-
expand-simple-lambda
-
lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
-
expand-local-syntax
- expand-body
-
expand-macro
-
expand-application
- expand-expr
- expand
- syntax-type
-
parse-when-list
-
expand-install-global
-
expand-top-sequence
-
expand-sequence
- source-wrap
- wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
-
smart-append
-
make-binding-wrap
-
extend-ribcage!
-
make-empty-ribcage
- new-mark
- anti-mark
-
the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
-
ribcage-labels
-
ribcage-marks
-
ribcage-symnames
- ribcage?
-
make-ribcage
- gen-labels
- gen-label
- make-rename
-
rename-marks
- rename-new
- rename-old
-
subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
-
id-sym-name&marks
- id-sym-name
- id?
-
nonsymbol-id?
-
global-extend
- lookup
-
macros-only-env
-
extend-var-env
- extend-env
- null-env
-
binding-value
-
binding-type
-
make-binding
- arg-check
-
source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
-
syntax-object?
-
make-syntax-object
-
build-lexical-var
-
build-letrec
-
build-named-let
- build-let
-
build-sequence
- build-data
-
build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
-
build-dynlet
-
build-conditional
-
build-application
- build-void
-
maybe-name-value!
-
decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
-
local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
-
set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
-
make-lambda-case
- make-lambda
-
make-sequence
-
make-application
-
make-conditional
-
make-toplevel-define
-
make-toplevel-set
-
make-toplevel-ref
-
make-module-set
-
make-module-ref
-
make-lexical-set
-
make-lexical-ref
-
make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
-
(define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
- resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
-
syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
-
build-global-definition
-
build-global-assignment
- build-global-reference
- analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314
- dots-12905
- '(()))
- (id-var-name-4314
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
- transformer-environment
- resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
-
set-syntax-object-module!
- set-syntax-object-wrap!
-
set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- #f))
- tmp-12900)
- #f)
- (@apply
- (lambda (x-13005 dots-13006)
- (call-with-values
- (lambda ()
- (cvt-12575
- x-13005
- (#{1+}# n-12579)
- ids-12580))
- (lambda (p-13007 ids-13008)
- (values
- (if (eq? p-13007 'any)
- 'each-any
- (vector 'each p-13007))
- ids-13008))))
- tmp-12900)
- (let ((tmp-13009
- ($sc-dispatch p-12578 '(any any . any))))
- (if (if tmp-13009
- (@apply
- (lambda (x-13013 dots-13014 ys-13015)
- (if (if (if (vector? dots-13014)
- (if (= (vector-length
- dots-13014)
- 4)
- (eq? (vector-ref
- dots-13014
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref dots-13014 1))
- #f)
- (if (eq? (if (if (vector? dots-13014)
- (if (= (vector-length
- dots-13014)
- 4)
- (eq? (vector-ref
- dots-13014
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref dots-13014 1)
- dots-13014)
- (if (if (= (vector-length
-
'#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
-
#("l-*-2267"))
- #(ribcage
-
(lambda-var-list
- gen-var
- strip
-
expand-lambda-case
-
lambda*-formals
-
expand-simple-lambda
-
lambda-formals
-
ellipsis?
-
expand-void
-
eval-local-transformer
-
expand-local-syntax
-
expand-body
-
expand-macro
-
expand-application
-
expand-expr
- expand
-
syntax-type
-
parse-when-list
-
expand-install-global
-
expand-top-sequence
-
expand-sequence
-
source-wrap
- wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
-
bound-id=?
-
free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
-
id-var-name
-
same-marks?
-
join-marks
-
join-wraps
-
smart-append
-
make-binding-wrap
-
extend-ribcage!
-
make-empty-ribcage
-
new-mark
-
anti-mark
-
the-anti-mark
-
top-marked?
-
top-wrap
-
empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
-
ribcage-labels
-
ribcage-marks
-
ribcage-symnames
-
ribcage?
-
make-ribcage
-
gen-labels
-
gen-label
-
make-rename
-
rename-marks
-
rename-new
-
rename-old
-
subst-rename?
-
wrap-subst
-
wrap-marks
-
make-wrap
-
id-sym-name&marks
-
id-sym-name
- id?
-
nonsymbol-id?
-
global-extend
- lookup
-
macros-only-env
-
extend-var-env
-
extend-env
-
null-env
-
binding-value
-
binding-type
-
make-binding
-
arg-check
-
source-annotation
-
no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
-
syntax-object?
-
make-syntax-object
-
build-lexical-var
-
build-letrec
-
build-named-let
-
build-let
-
build-sequence
-
build-data
-
build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
-
build-dynlet
-
build-conditional
-
build-application
-
build-void
-
maybe-name-value!
-
decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
-
session-id
-
local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
-
set-lambda-meta!
-
lambda-meta
- lambda?
-
make-dynlet
-
make-letrec
-
make-let
-
make-lambda-case
-
make-lambda
-
make-sequence
-
make-application
-
make-conditional
-
make-toplevel-define
-
make-toplevel-set
-
make-toplevel-ref
-
make-module-set
-
make-module-ref
-
make-lexical-set
-
make-lexical-ref
-
make-primitive-ref
-
make-const
-
make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
-
("l-*-476"
-
"l-*-474"
-
"l-*-472"
-
"l-*-470"
-
"l-*-468"
-
"l-*-466"
-
"l-*-464"
-
"l-*-462"
-
"l-*-460"
-
"l-*-458"
-
"l-*-456"
-
"l-*-454"
-
"l-*-452"
-
"l-*-450"
-
"l-*-448"
-
"l-*-446"
-
"l-*-444"
-
"l-*-442"
-
"l-*-440"
-
"l-*-438"
-
"l-*-436"
-
"l-*-434"
-
"l-*-432"
-
"l-*-430"
-
"l-*-428"
-
"l-*-426"
-
"l-*-424"
-
"l-*-422"
-
"l-*-420"
-
"l-*-418"
-
"l-*-416"
-
"l-*-414"
-
"l-*-412"
-
"l-*-410"
-
"l-*-408"
-
"l-*-406"
-
"l-*-404"
-
"l-*-402"
-
"l-*-400"
-
"l-*-399"
-
"l-*-397"
-
"l-*-394"
-
"l-*-393"
-
"l-*-392"
-
"l-*-390"
-
"l-*-389"
-
"l-*-387"
-
"l-*-385"
-
"l-*-383"
-
"l-*-381"
-
"l-*-379"
-
"l-*-377"
-
"l-*-375"
-
"l-*-373"
-
"l-*-370"
-
"l-*-368"
-
"l-*-367"
-
"l-*-365"
-
"l-*-363"
-
"l-*-361"
-
"l-*-359"
-
"l-*-358"
-
"l-*-357"
-
"l-*-356"
-
"l-*-354"
-
"l-*-353"
-
"l-*-350"
-
"l-*-348"
-
"l-*-346"
-
"l-*-344"
-
"l-*-342"
-
"l-*-340"
-
"l-*-338"
-
"l-*-337"
-
"l-*-336"
-
"l-*-334"
-
"l-*-332"
-
"l-*-331"
-
"l-*-328"
-
"l-*-327"
-
"l-*-325"
-
"l-*-323"
-
"l-*-321"
-
"l-*-319"
-
"l-*-317"
-
"l-*-315"
-
"l-*-313"
-
"l-*-311"
-
"l-*-309"
-
"l-*-306"
-
"l-*-304"
-
"l-*-302"
-
"l-*-300"
-
"l-*-298"
-
"l-*-296"
-
"l-*-294"
-
"l-*-292"
-
"l-*-290"
-
"l-*-288"
-
"l-*-286"
-
"l-*-284"
-
"l-*-282"
-
"l-*-280"
-
"l-*-278"
-
"l-*-276"
-
"l-*-274"
-
"l-*-272"
-
"l-*-270"
-
"l-*-268"
-
"l-*-266"
-
"l-*-264"
-
"l-*-262"
-
"l-*-260"
-
"l-*-258"
-
"l-*-256"
-
"l-*-255"
-
"l-*-254"
-
"l-*-253"
-
"l-*-252"
-
"l-*-250"
-
"l-*-248"
-
"l-*-246"
-
"l-*-243"
-
"l-*-241"
-
"l-*-239"
-
"l-*-237"
-
"l-*-235"
-
"l-*-233"
-
"l-*-231"
-
"l-*-229"
-
"l-*-227"
-
"l-*-225"
-
"l-*-223"
-
"l-*-221"
-
"l-*-219"
-
"l-*-217"
-
"l-*-215"
-
"l-*-213"
-
"l-*-211"
-
"l-*-209"))
- #(ribcage
-
(define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
-
"l-*-45")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
-
expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
-
expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
-
expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
-
distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
- resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
-
set-ribcage-labels!
- set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
- syntax-object-wrap
-
syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
- analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
-
make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314
- dots-13014
- '(()))
- (id-var-name-4314
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
- resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
-
syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
- analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- #f))
- tmp-13009)
- #f)
- (@apply
- (lambda (x-13115 dots-13116 ys-13117)
+ (lambda () (cvt (car p*) n ids))
+ (lambda (x ids) (values (cons x y) ids))))))))
+ (v-reverse
+ (lambda (x)
+ (let loop ((r '()) (x x))
+ (if (not (pair? x)) (values r x) (loop (cons (car x) r)
(cdr x))))))
+ (cvt (lambda (p n ids)
+ (if (id? p)
+ (cond ((bound-id-member? p keys) (values (vector
'free-id p) ids))
+ ((free-id=? p '#(syntax-object _ ((top)) (hygiene
guile)))
+ (values '_ ids))
+ (else (values 'any (cons (cons p n) ids))))
+ (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any))))
+ (if (and tmp-1 (apply (lambda (x dots) (ellipsis?
dots)) tmp-1))
+ (apply (lambda (x dots)
(call-with-values
- (lambda ()
- (cvt*-12573
- ys-13117
- n-12579
- ids-12580))
- (lambda (ys-13120 ids-13121)
+ (lambda () (cvt x (+ n 1) ids))
+ (lambda (p ids)
+ (values (if (eq? p 'any) 'each-any
(vector 'each p)) ids))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
+ (if (and tmp-1 (apply (lambda (x dots ys)
(ellipsis? dots)) tmp-1))
+ (apply (lambda (x dots ys)
(call-with-values
- (lambda ()
- (cvt-12575
- x-13115
- (#{1+}# n-12579)
- ids-13121))
- (lambda (x-13122 ids-13123)
+ (lambda () (cvt* ys n ids))
+ (lambda (ys ids)
(call-with-values
- (lambda ()
- (v-reverse-12574 ys-13120))
- (lambda (ys-13156 e-13157)
- (values
- (vector
- 'each+
- x-13122
- ys-13156
- e-13157)
- ids-13123))))))))
- tmp-13009)
- (let ((tmp-13158
- ($sc-dispatch p-12578 '(any . any))))
- (if tmp-13158
- (@apply
- (lambda (x-13162 y-13163)
- (call-with-values
- (lambda ()
- (cvt-12575
- y-13163
- n-12579
- ids-12580))
- (lambda (y-13164 ids-13165)
+ (lambda () (cvt x (+ n 1) ids))
+ (lambda (x ids)
+ (call-with-values
+ (lambda () (v-reverse ys))
+ (lambda (ys e) (values
(vector 'each+ x ys e) ids))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply (lambda (x y)
(call-with-values
- (lambda ()
- (cvt-12575
- x-13162
- n-12579
- ids-13165))
- (lambda (x-13166 ids-13167)
- (values
- (cons x-13166 y-13164)
- ids-13167))))))
- tmp-13158)
- (let ((tmp-13168
- ($sc-dispatch p-12578 '())))
- (if tmp-13168
- (@apply
- (lambda () (values '() ids-12580))
- tmp-13168)
- (let ((tmp-13172
- ($sc-dispatch
- p-12578
- '#(vector each-any))))
- (if tmp-13172
- (@apply
- (lambda (x-13176)
+ (lambda () (cvt y n ids))
+ (lambda (y ids)
(call-with-values
- (lambda ()
- (cvt-12575
- x-13176
- n-12579
- ids-12580))
- (lambda (p-13177 ids-13178)
- (values
- (vector 'vector p-13177)
- ids-13178))))
- tmp-13172)
- (values
- (vector
- 'atom
- (strip-4344 p-12578 '(())))
- ids-12580)))))))))))))))
- (cvt-12575 pattern-12571 0 '()))))
- (build-dispatch-call-10975
- (lambda (pvars-13291 exp-13292 y-13293 r-13294 mod-13295)
- (let ((ids-13296 (map car pvars-13291)))
- (begin
- (map cdr pvars-13291)
- (let ((labels-13298 (gen-labels-4298 ids-13296))
- (new-vars-13299 (map gen-var-4345 ids-13296)))
- (build-application-4262
- #f
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'apply)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'apply
- #f))
- (list (build-simple-lambda-4271
- #f
- (map syntax->datum ids-13296)
- #f
- new-vars-13299
- '()
- (expand-4331
- exp-13292
- (extend-env-4289
- labels-13298
- (map (lambda (var-13622 level-13623)
- (cons 'syntax
- (cons var-13622 level-13623)))
- new-vars-13299
- (map cdr pvars-13291))
- r-13294)
- (make-binding-wrap-4309
- ids-13296
- labels-13298
- '(()))
- mod-13295))
- y-13293)))))))
- (gen-clause-10976
- (lambda (x-11943
- keys-11944
- clauses-11945
- r-11946
- pat-11947
- fender-11948
- exp-11949
- mod-11950)
- (call-with-values
- (lambda ()
- (convert-pattern-10974 pat-11947 keys-11944))
- (lambda (p-12105 pvars-12106)
- (if (not (distinct-bound-ids?-4322 (map car pvars-12106)))
- (syntax-violation
- 'syntax-case
- "duplicate pattern variable"
- pat-11947)
- (if (not (and-map
- (lambda (x-12222)
- (not (let ((x-12226 (car x-12222)))
- (if (if (if (vector? x-12226)
- (if (= (vector-length
- x-12226)
- 4)
- (eq? (vector-ref
- x-12226
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-12226 1))
- #f)
- (if (eq? (if (if (vector? x-12226)
- (if (= (vector-length
- x-12226)
- 4)
- (eq? (vector-ref
- x-12226
- 0)
-
'syntax-object)
- #f)
- #f)
- (vector-ref x-12226 1)
- x-12226)
- (if (if (= (vector-length
-
'#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
-
#("l-*-2267"))
- #(ribcage
-
(lambda-var-list
-
gen-var
- strip
-
expand-lambda-case
-
lambda*-formals
-
expand-simple-lambda
-
lambda-formals
-
ellipsis?
-
expand-void
-
eval-local-transformer
-
expand-local-syntax
-
expand-body
-
expand-macro
-
expand-application
-
expand-expr
- expand
-
syntax-type
-
parse-when-list
-
expand-install-global
-
expand-top-sequence
-
expand-sequence
-
source-wrap
- wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
-
bound-id=?
-
free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
-
id-var-name
-
same-marks?
-
join-marks
-
join-wraps
-
smart-append
-
make-binding-wrap
-
extend-ribcage!
-
make-empty-ribcage
-
new-mark
-
anti-mark
-
the-anti-mark
-
top-marked?
-
top-wrap
-
empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
-
ribcage-labels
-
ribcage-marks
-
ribcage-symnames
-
ribcage?
-
make-ribcage
-
gen-labels
-
gen-label
-
make-rename
-
rename-marks
-
rename-new
-
rename-old
-
subst-rename?
-
wrap-subst
-
wrap-marks
-
make-wrap
-
id-sym-name&marks
-
id-sym-name
- id?
-
nonsymbol-id?
-
global-extend
- lookup
-
macros-only-env
-
extend-var-env
-
extend-env
-
null-env
-
binding-value
-
binding-type
-
make-binding
-
arg-check
-
source-annotation
-
no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
-
syntax-object?
-
make-syntax-object
-
build-lexical-var
-
build-letrec
-
build-named-let
-
build-let
-
build-sequence
-
build-data
-
build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
-
build-dynlet
-
build-conditional
-
build-application
-
build-void
-
maybe-name-value!
-
decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
-
session-id
-
local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
-
set-lambda-meta!
-
lambda-meta
-
lambda?
-
make-dynlet
-
make-letrec
-
make-let
-
make-lambda-case
-
make-lambda
-
make-sequence
-
make-application
-
make-conditional
-
make-toplevel-define
-
make-toplevel-set
-
make-toplevel-ref
-
make-module-set
-
make-module-ref
-
make-lexical-set
-
make-lexical-ref
-
make-primitive-ref
-
make-const
-
make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
-
("l-*-476"
-
"l-*-474"
-
"l-*-472"
-
"l-*-470"
-
"l-*-468"
-
"l-*-466"
-
"l-*-464"
-
"l-*-462"
-
"l-*-460"
-
"l-*-458"
-
"l-*-456"
-
"l-*-454"
-
"l-*-452"
-
"l-*-450"
-
"l-*-448"
-
"l-*-446"
-
"l-*-444"
-
"l-*-442"
-
"l-*-440"
-
"l-*-438"
-
"l-*-436"
-
"l-*-434"
-
"l-*-432"
-
"l-*-430"
-
"l-*-428"
-
"l-*-426"
-
"l-*-424"
-
"l-*-422"
-
"l-*-420"
-
"l-*-418"
-
"l-*-416"
-
"l-*-414"
-
"l-*-412"
-
"l-*-410"
-
"l-*-408"
-
"l-*-406"
-
"l-*-404"
-
"l-*-402"
-
"l-*-400"
-
"l-*-399"
-
"l-*-397"
-
"l-*-394"
-
"l-*-393"
-
"l-*-392"
-
"l-*-390"
-
"l-*-389"
-
"l-*-387"
-
"l-*-385"
-
"l-*-383"
-
"l-*-381"
-
"l-*-379"
-
"l-*-377"
-
"l-*-375"
-
"l-*-373"
-
"l-*-370"
-
"l-*-368"
-
"l-*-367"
-
"l-*-365"
-
"l-*-363"
-
"l-*-361"
-
"l-*-359"
-
"l-*-358"
-
"l-*-357"
-
"l-*-356"
-
"l-*-354"
-
"l-*-353"
-
"l-*-350"
-
"l-*-348"
-
"l-*-346"
-
"l-*-344"
-
"l-*-342"
-
"l-*-340"
-
"l-*-338"
-
"l-*-337"
-
"l-*-336"
-
"l-*-334"
-
"l-*-332"
-
"l-*-331"
-
"l-*-328"
-
"l-*-327"
-
"l-*-325"
-
"l-*-323"
-
"l-*-321"
-
"l-*-319"
-
"l-*-317"
-
"l-*-315"
-
"l-*-313"
-
"l-*-311"
-
"l-*-309"
-
"l-*-306"
-
"l-*-304"
-
"l-*-302"
-
"l-*-300"
-
"l-*-298"
-
"l-*-296"
-
"l-*-294"
-
"l-*-292"
-
"l-*-290"
-
"l-*-288"
-
"l-*-286"
-
"l-*-284"
-
"l-*-282"
-
"l-*-280"
-
"l-*-278"
-
"l-*-276"
-
"l-*-274"
-
"l-*-272"
-
"l-*-270"
-
"l-*-268"
-
"l-*-266"
-
"l-*-264"
-
"l-*-262"
-
"l-*-260"
-
"l-*-258"
-
"l-*-256"
-
"l-*-255"
-
"l-*-254"
-
"l-*-253"
-
"l-*-252"
-
"l-*-250"
-
"l-*-248"
-
"l-*-246"
-
"l-*-243"
-
"l-*-241"
-
"l-*-239"
-
"l-*-237"
-
"l-*-235"
-
"l-*-233"
-
"l-*-231"
-
"l-*-229"
-
"l-*-227"
-
"l-*-225"
-
"l-*-223"
-
"l-*-221"
-
"l-*-219"
-
"l-*-217"
-
"l-*-215"
-
"l-*-213"
-
"l-*-211"
-
"l-*-209"))
- #(ribcage
-
(define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top)
- (top)
- (top))
-
("l-*-47"
-
"l-*-46"
-
"l-*-45")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
-
expand-lambda-case
- lambda*-formals
-
expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
-
expand-local-syntax
- expand-body
- expand-macro
-
expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
-
expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
-
distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
-
make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
- syntax-object?
-
make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
- analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
-
make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
-
make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314
- x-12226
- '(()))
- (id-var-name-4314
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
-
expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
- resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
- syntax-object-wrap
-
syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
- analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
-
make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- #f))))
- pvars-12106))
- (syntax-violation
- 'syntax-case
- "misplaced ellipsis"
- pat-11947)
- (let ((y-12302
- (gensym
- (string-append (symbol->string 'tmp) "-"))))
- (build-application-4262
- #f
- (let ((req-12445 (list 'tmp))
- (vars-12447 (list y-12302))
- (exp-12449
- (let ((y-12466
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- #f
- 'tmp
- y-12302)))
- (let ((test-exp-12470
- (let ((tmp-12479
- ($sc-dispatch
- fender-11948
- '#(atom #t))))
- (if tmp-12479
- (@apply
- (lambda () y-12466)
- tmp-12479)
- (let ((then-exp-12497
-
(build-dispatch-call-10975
- pvars-12106
- fender-11948
- y-12466
- r-11946
- mod-11950))
- (else-exp-12498
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 1)
- #f
- #f)))
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 10)
- #f
- y-12466
- then-exp-12497
- else-exp-12498)))))
- (then-exp-12471
- (build-dispatch-call-10975
- pvars-12106
- exp-11949
- y-12466
- r-11946
- mod-11950))
- (else-exp-12472
- (gen-syntax-case-10977
- x-11943
- keys-11944
- clauses-11945
- r-11946
- mod-11950)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 10)
- #f
- test-exp-12470
- then-exp-12471
- else-exp-12472)))))
- (let ((body-12454
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #f
- req-12445
- #f
- #f
- #f
- '()
- vars-12447
- exp-12449
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #f
- '()
- body-12454)))
- (list (if (eq? p-12105 'any)
- (let ((fun-exp-12520
- (if (equal?
- (module-name (current-module))
- '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'list)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'list
- #f)))
- (arg-exps-12521 (list x-11943)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- fun-exp-12520
- arg-exps-12521))
- (let ((fun-exp-12544
- (if (equal?
- (module-name (current-module))
- '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- '$sc-dispatch)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- '$sc-dispatch
- #f)))
- (arg-exps-12545
- (list x-11943
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 1)
- #f
- p-12105))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- fun-exp-12544
- arg-exps-12545))))))))))))
- (gen-syntax-case-10977
- (lambda (x-11376
- keys-11377
- clauses-11378
- r-11379
- mod-11380)
- (if (null? clauses-11378)
- (let ((fun-exp-11385
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
+ (lambda () (cvt x n ids))
+ (lambda (x ids) (values
(cons x y) ids))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () (values '() ids))
tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp
'#(vector each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (call-with-values
+ (lambda () (cvt x n ids))
+ (lambda (p ids) (values
(vector 'vector p) ids))))
+ tmp-1)
+ (let ((x tmp)) (values (vector
'atom (strip p '(()))) ids))))))))))))))))
+ (cvt pattern 0 '()))))
+ (build-dispatch-call
+ (lambda (pvars exp y r mod)
+ (let ((ids (map car pvars)) (levels (map cdr pvars)))
+ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+ (build-application
+ #f
+ (build-primref #f 'apply)
+ (list (build-simple-lambda
+ #f
+ (map syntax->datum ids)
+ #f
+ new-vars
+ '()
+ (expand
+ exp
+ (extend-env
+ labels
+ (map (lambda (var level) (cons 'syntax (cons var
level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels '(()))
+ mod))
+ y))))))
+ (gen-clause
+ (lambda (x keys clauses r pat fender exp mod)
+ (call-with-values
+ (lambda () (convert-pattern pat keys))
+ (lambda (p pvars)
+ (cond ((not (distinct-bound-ids? (map car pvars)))
+ (syntax-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)))
+ (build-application
+ #f
+ (build-simple-lambda
+ #f
+ (list 'tmp)
+ #f
+ (list y)
+ '()
+ (let ((y (build-lexical-reference 'value #f 'tmp
y)))
+ (build-conditional
+ #f
+ (let* ((tmp fender) (tmp ($sc-dispatch tmp
'#(atom #t))))
+ (if tmp
+ (apply (lambda () y) tmp)
+ (build-conditional
+ #f
+ y
+ (build-dispatch-call pvars fender y r
mod)
+ (build-data #f #f))))
+ (build-dispatch-call pvars exp y r mod)
+ (gen-syntax-case x keys clauses r mod))))
+ (list (if (eq? p 'any)
+ (build-application #f (build-primref #f
'list) (list x))
+ (build-application
+ #f
+ (build-primref #f '$sc-dispatch)
+ (list x (build-data #f p)))))))))))))
+ (gen-syntax-case
+ (lambda (x keys clauses r mod)
+ (if (null? clauses)
+ (build-application
+ #f
+ (build-primref #f 'syntax-violation)
+ (list (build-data #f #f)
+ (build-data #f "source expression failed to match any
pattern")
+ x))
+ (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any
any))))
+ (if tmp
+ (apply (lambda (pat exp)
+ (if (and (id? pat)
+ (and-map
+ (lambda (x) (not (free-id=? pat x)))
+ (cons '#(syntax-object ... ((top))
(hygiene guile)) keys)))
+ (if (free-id=? pat '#(syntax-object _ ((top))
(hygiene guile)))
+ (expand exp r '(()) mod)
+ (let ((labels (list (gen-label))) (var (gen-var
pat)))
+ (build-application
+ #f
+ (build-simple-lambda
+ #f
+ (list (syntax->datum pat))
+ #f
+ (list var)
+ '()
+ (expand
+ exp
+ (extend-env labels (list (cons 'syntax
(cons var 0))) r)
+ (make-binding-wrap (list pat) labels
'(()))
+ mod))
+ (list x))))
+ (gen-clause x keys (cdr clauses) r pat #t exp
mod)))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(any any any))))
+ (if tmp
+ (apply (lambda (pat fender exp)
+ (gen-clause x keys (cdr clauses) r pat fender
exp mod))
+ tmp)
+ (syntax-violation 'syntax-case "invalid clause" (car
clauses))))))))))
+ (lambda (e r w s mod)
+ (let* ((e (source-wrap e w s mod))
+ (tmp-1 e)
+ (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
+ (if tmp
+ (apply (lambda (val key m)
+ (if (and-map (lambda (x) (and (id? x) (not (ellipsis?
x)))) key)
+ (let ((x (gen-var 'tmp)))
+ (build-application
+ s
+ (build-simple-lambda
#f
- 'syntax-violation)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
+ (list 'tmp)
#f
- '(guile)
- 'syntax-violation
- #f)))
- (arg-exps-11386
- (list (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- #f)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- "source expression failed to match any
pattern")
- x-11376)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- fun-exp-11385
- arg-exps-11386))
- (let ((tmp-11419 (car clauses-11378)))
- (let ((tmp-11420 ($sc-dispatch tmp-11419 '(any any))))
- (if tmp-11420
- (@apply
- (lambda (pat-11422 exp-11423)
- (if (if (if (symbol? pat-11422)
- #t
- (if (if (vector? pat-11422)
- (if (= (vector-length pat-11422) 4)
- (eq? (vector-ref pat-11422 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref pat-11422 1))
- #f))
- (and-map
- (lambda (x-11450)
- (not (if (eq? (if (if (vector? pat-11422)
- (if (= (vector-length
- pat-11422)
- 4)
- (eq? (vector-ref
- pat-11422
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref pat-11422 1)
- pat-11422)
- (if (if (vector? x-11450)
- (if (= (vector-length
- x-11450)
- 4)
- (eq? (vector-ref
- x-11450
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref x-11450 1)
- x-11450))
- (eq? (id-var-name-4314
- pat-11422
- '(()))
- (id-var-name-4314
- x-11450
- '(())))
- #f)))
- (cons '#(syntax-object
- ...
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891" "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top) (top) (top) (top) (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- keys-11377))
- #f)
- (if (if (eq? (if (if (= (vector-length
- '#(syntax-object
- pad
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891"
- "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x
- keys
- clauses
- r
- mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
-
build-dispatch-call
- convert-pattern)
- ((top)
- (top)
- (top)
- (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
-
expand-lambda-case
- lambda*-formals
-
expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
-
expand-local-syntax
- expand-body
- expand-macro
-
expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
-
expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
-
distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
-
make-binding-wrap
- extend-ribcage!
-
make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
-
id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
-
source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
- syntax-object?
-
make-syntax-object
-
build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
- analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
-
build-conditional
-
build-application
- build-void
-
maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
-
make-toplevel-define
-
make-toplevel-set
-
make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
-
make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile)))
- 4)
- #t
- #f)
- 'pad
- '#(syntax-object
- pad
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891" "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
-
set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile)))
- (if (if (= (vector-length
- '#(syntax-object
- _
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891"
- "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x
- keys
- clauses
- r
- mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
-
build-dispatch-call
- convert-pattern)
- ((top)
- (top)
- (top)
- (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
-
expand-lambda-case
- lambda*-formals
-
expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
-
expand-local-syntax
- expand-body
- expand-macro
-
expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
-
expand-install-global
-
expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
-
distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
-
make-binding-wrap
- extend-ribcage!
-
make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
-
id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
-
source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
- syntax-object?
-
make-syntax-object
-
build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
- analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
-
build-conditional
-
build-application
- build-void
-
maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
-
make-toplevel-define
-
make-toplevel-set
-
make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
-
make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile)))
- 4)
- #t
- #f)
- '_
- '#(syntax-object
- _
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891" "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
-
set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314
- '#(syntax-object
- pad
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891" "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- '(()))
- (id-var-name-4314
- '#(syntax-object
- _
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891" "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- (expand-4331 exp-11423 r-11379 '(()) mod-11380)
- (let ((labels-11626
- (list (string-append
- "l-"
- (session-id-4256)
- (symbol->string (gensym "-")))))
- (var-11627
- (let ((id-11665
- (if (if (vector? pat-11422)
- (if (= (vector-length
- pat-11422)
- 4)
- (eq? (vector-ref
- pat-11422
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref pat-11422 1)
- pat-11422)))
- (gensym
- (string-append
- (symbol->string id-11665)
- "-")))))
- (build-application-4262
- #f
- (build-simple-lambda-4271
- #f
- (list (syntax->datum pat-11422))
- #f
- (list var-11627)
- '()
- (expand-4331
- exp-11423
- (extend-env-4289
- labels-11626
- (list (cons 'syntax
- (cons var-11627 0)))
- r-11379)
- (make-binding-wrap-4309
- (list pat-11422)
- labels-11626
- '(()))
- mod-11380))
- (list x-11376))))
- (gen-clause-10976
- x-11376
- keys-11377
- (cdr clauses-11378)
- r-11379
- pat-11422
- #t
- exp-11423
- mod-11380)))
- tmp-11420)
- (let ((tmp-11935
- ($sc-dispatch tmp-11419 '(any any any))))
- (if tmp-11935
- (@apply
- (lambda (pat-11937 fender-11938 exp-11939)
- (gen-clause-10976
- x-11376
- keys-11377
- (cdr clauses-11378)
- r-11379
- pat-11937
- fender-11938
- exp-11939
- mod-11380))
- tmp-11935)
- (syntax-violation
- 'syntax-case
- "invalid clause"
- (car clauses-11378)))))))))))
- (lambda (e-10978 r-10979 w-10980 s-10981 mod-10982)
- (let ((e-10983
- (wrap-4324
- (begin
- (if (if s-10981
- (supports-source-properties? e-10978)
- #f)
- (set-source-properties! e-10978 s-10981))
- e-10978)
- w-10980
- mod-10982)))
- (let ((tmp-10985
- ($sc-dispatch
- e-10983
- '(_ any each-any . each-any))))
- (if tmp-10985
- (@apply
- (lambda (val-11010 key-11011 m-11012)
- (if (and-map
- (lambda (x-11013)
- (if (if (symbol? x-11013)
- #t
- (if (if (vector? x-11013)
- (if (= (vector-length x-11013) 4)
- (eq? (vector-ref x-11013 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-11013 1))
- #f))
- (not (if (if (if (vector? x-11013)
- (if (= (vector-length x-11013)
- 4)
- (eq? (vector-ref x-11013 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-11013 1))
- #f)
- (if (eq? (if (if (vector? x-11013)
- (if (= (vector-length
- x-11013)
- 4)
- (eq? (vector-ref
- x-11013
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref x-11013 1)
- x-11013)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
-
#("l-*-2267"))
- #(ribcage
-
(lambda-var-list
- gen-var
- strip
-
expand-lambda-case
-
lambda*-formals
-
expand-simple-lambda
-
lambda-formals
- ellipsis?
-
expand-void
-
eval-local-transformer
-
expand-local-syntax
-
expand-body
-
expand-macro
-
expand-application
-
expand-expr
- expand
-
syntax-type
-
parse-when-list
-
expand-install-global
-
expand-top-sequence
-
expand-sequence
-
source-wrap
- wrap
-
bound-id-member?
-
distinct-bound-ids?
-
valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
-
resolve-identifier
-
locally-bound-identifiers
-
id-var-name
-
same-marks?
- join-marks
- join-wraps
-
smart-append
-
make-binding-wrap
-
extend-ribcage!
-
make-empty-ribcage
- new-mark
- anti-mark
-
the-anti-mark
-
top-marked?
- top-wrap
- empty-wrap
-
set-ribcage-labels!
-
set-ribcage-marks!
-
set-ribcage-symnames!
-
ribcage-labels
-
ribcage-marks
-
ribcage-symnames
- ribcage?
-
make-ribcage
- gen-labels
- gen-label
-
make-rename
-
rename-marks
- rename-new
- rename-old
-
subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
-
id-sym-name&marks
-
id-sym-name
- id?
-
nonsymbol-id?
-
global-extend
- lookup
-
macros-only-env
-
extend-var-env
- extend-env
- null-env
-
binding-value
-
binding-type
-
make-binding
- arg-check
-
source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
-
syntax-object-module
-
syntax-object-wrap
-
syntax-object-expression
-
syntax-object?
-
make-syntax-object
-
build-lexical-var
-
build-letrec
-
build-named-let
- build-let
-
build-sequence
- build-data
-
build-primref
-
build-lambda-case
-
build-case-lambda
-
build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
-
analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
-
build-dynlet
-
build-conditional
-
build-application
- build-void
-
maybe-name-value!
-
decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
-
local-eval-hook
-
top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
-
set-lambda-meta!
-
lambda-meta
- lambda?
-
make-dynlet
-
make-letrec
- make-let
-
make-lambda-case
-
make-lambda
-
make-sequence
-
make-application
-
make-conditional
-
make-toplevel-define
-
make-toplevel-set
-
make-toplevel-ref
-
make-module-set
-
make-module-ref
-
make-lexical-set
-
make-lexical-ref
-
make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
-
(define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
-
eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
-
transformer-environment
- resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
-
set-syntax-object-module!
-
set-syntax-object-wrap!
-
set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
-
syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
-
build-global-definition
-
build-global-assignment
-
build-global-reference
- analyze-variable
-
build-lexical-assignment
-
build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314 x-11013 '(()))
- (id-var-name-4314
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
-
with-transformer-environment
- transformer-environment
- resolve-identifier
-
locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
-
set-syntax-object-module!
- set-syntax-object-wrap!
-
set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
-
syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
-
build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
-
get-global-definition-hook
-
put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
-
define-expansion-accessors
-
define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- #f))
- #f))
- key-11011)
- (let ((x-11139
- (gensym
- (string-append (symbol->string 'tmp) "-"))))
- (build-application-4262
- s-10981
- (let ((req-11269 (list 'tmp))
- (vars-11271 (list x-11139))
- (exp-11273
- (gen-syntax-case-10977
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- #f
- 'tmp
- x-11139)
- key-11011
- m-11012
- r-10979
- mod-10982)))
- (let ((body-11278
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #f
- req-11269
- #f
- #f
- #f
- '()
- vars-11271
- exp-11273
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #f
- '()
- body-11278)))
- (list (expand-4331
- val-11010
- r-10979
- '(())
- mod-10982))))
- (syntax-violation
- 'syntax-case
- "invalid literals list"
- e-10983)))
- tmp-10985)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-10983)))))))
- (set! macroexpand
- (lambda*
- (x-13696
- #:optional
- (m-13697 'e)
- (esew-13698 '(eval)))
- (expand-top-sequence-4327
- (list x-13696)
- '()
- '((top))
- #f
- m-13697
- esew-13698
- (cons 'hygiene (module-name (current-module))))))
- (set! identifier?
- (lambda (x-13701)
- (if (if (vector? x-13701)
- (if (= (vector-length x-13701) 4)
- (eq? (vector-ref x-13701 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-13701 1))
- #f)))
- (set! datum->syntax
- (lambda (id-13726 datum-13727)
- (let ((wrap-13732 (vector-ref id-13726 2))
- (module-13733 (vector-ref id-13726 3)))
- (vector
- 'syntax-object
- datum-13727
- wrap-13732
- module-13733))))
- (set! syntax->datum
- (lambda (x-13740) (strip-4344 x-13740 '(()))))
- (set! syntax-source
- (lambda (x-13743)
- (source-annotation-4288 x-13743)))
- (set! generate-temporaries
- (lambda (ls-13896)
- (begin
- (if (not (list? ls-13896))
- (syntax-violation
- 'generate-temporaries
- "invalid argument"
- ls-13896))
- (let ((mod-13904
- (cons 'hygiene (module-name (current-module)))))
- (map (lambda (x-13905)
- (wrap-4324 (gensym "t-") '((top)) mod-13904))
- ls-13896)))))
- (set! free-identifier=?
- (lambda (x-13909 y-13910)
- (begin
- (if (not (if (if (vector? x-13909)
- (if (= (vector-length x-13909) 4)
- (eq? (vector-ref x-13909 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-13909 1))
- #f))
- (syntax-violation
- 'free-identifier=?
- "invalid argument"
- x-13909))
- (if (not (if (if (vector? y-13910)
- (if (= (vector-length y-13910) 4)
- (eq? (vector-ref y-13910 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref y-13910 1))
- #f))
- (syntax-violation
- 'free-identifier=?
- "invalid argument"
- y-13910))
- (if (eq? (if (if (vector? x-13909)
- (if (= (vector-length x-13909) 4)
- (eq? (vector-ref x-13909 0) 'syntax-object)
- #f)
- #f)
- (vector-ref x-13909 1)
- x-13909)
- (if (if (vector? y-13910)
- (if (= (vector-length y-13910) 4)
- (eq? (vector-ref y-13910 0) 'syntax-object)
- #f)
- #f)
- (vector-ref y-13910 1)
- y-13910))
- (eq? (id-var-name-4314 x-13909 '(()))
- (id-var-name-4314 y-13910 '(())))
- #f))))
- (set! bound-identifier=?
- (lambda (x-14060 y-14061)
- (begin
- (if (not (if (if (vector? x-14060)
- (if (= (vector-length x-14060) 4)
- (eq? (vector-ref x-14060 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-14060 1))
- #f))
- (syntax-violation
- 'bound-identifier=?
- "invalid argument"
- x-14060))
- (if (not (if (if (vector? y-14061)
- (if (= (vector-length y-14061) 4)
- (eq? (vector-ref y-14061 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref y-14061 1))
- #f))
- (syntax-violation
- 'bound-identifier=?
- "invalid argument"
- y-14061))
- (if (if (if (vector? x-14060)
- (if (= (vector-length x-14060) 4)
- (eq? (vector-ref x-14060 0) 'syntax-object)
- #f)
- #f)
- (if (vector? y-14061)
- (if (= (vector-length y-14061) 4)
- (eq? (vector-ref y-14061 0) 'syntax-object)
- #f)
- #f)
- #f)
- (if (eq? (vector-ref x-14060 1)
- (vector-ref y-14061 1))
- (same-marks?-4313
- (car (vector-ref x-14060 2))
- (car (vector-ref y-14061 2)))
- #f)
- (eq? x-14060 y-14061)))))
- (set! syntax-violation
- (lambda*
- (who-14194
- message-14195
- form-14196
- #:optional
- (subform-14197 #f))
- (begin
- (if (not (if (not who-14194)
- (not who-14194)
- (let ((t-14215 (string? who-14194)))
- (if t-14215 t-14215 (symbol? who-14194)))))
- (syntax-violation
- 'syntax-violation
- "invalid argument"
- who-14194))
- (if (not (string? message-14195))
- (syntax-violation
- 'syntax-violation
- "invalid argument"
- message-14195))
- (throw 'syntax-error
- who-14194
- message-14195
- (let ((t-14246 (source-annotation-4288 subform-14197)))
- (if t-14246
- t-14246
- (source-annotation-4288 form-14196)))
- (strip-4344 form-14196 '(()))
- (if subform-14197
- (strip-4344 subform-14197 '(()))
- #f)))))
- (letrec*
- ((syntax-local-binding-14638
- (lambda (id-14771)
- (begin
- (if (not (if (if (vector? id-14771)
- (if (= (vector-length id-14771) 4)
- (eq? (vector-ref id-14771 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-14771 1))
- #f))
- (syntax-violation
- 'syntax-local-binding
- "invalid argument"
- id-14771))
- ((fluid-ref transformer-environment-4317)
- (lambda (e-14811
- r-14812
- w-14813
- s-14814
- rib-14815
- mod-14816)
+ (list x)
+ '()
+ (gen-syntax-case
+ (build-lexical-reference 'value #f 'tmp x)
+ key
+ m
+ r
+ mod))
+ (list (expand val r '(()) mod))))
+ (syntax-violation 'syntax-case "invalid literals list"
e)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))
+ (set! macroexpand
+ (lambda* (x #:optional (m 'e) (esew '(eval)))
+ (expand-top-sequence
+ (list x)
+ '()
+ '((top))
+ #f
+ m
+ esew
+ (cons 'hygiene (module-name (current-module))))))
+ (set! identifier? (lambda (x) (nonsymbol-id? x)))
+ (set! datum->syntax
+ (lambda (id datum)
+ (make-syntax-object
+ datum
+ (syntax-object-wrap id)
+ (syntax-object-module id))))
+ (set! syntax->datum (lambda (x) (strip x '(()))))
+ (set! syntax-source (lambda (x) (source-annotation x)))
+ (set! generate-temporaries
+ (lambda (ls)
+ (let ((x ls))
+ (if (not (list? x))
+ (syntax-violation 'generate-temporaries "invalid argument" x)))
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ (map (lambda (x) (wrap (gensym "t-") '((top)) mod)) ls))))
+ (set! free-identifier=?
+ (lambda (x y)
+ (let ((x x))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'free-identifier=? "invalid argument" x)))
+ (let ((x y))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'free-identifier=? "invalid argument" x)))
+ (free-id=? x y)))
+ (set! bound-identifier=?
+ (lambda (x y)
+ (let ((x x))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'bound-identifier=? "invalid argument" x)))
+ (let ((x y))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'bound-identifier=? "invalid argument" x)))
+ (bound-id=? x y)))
+ (set! syntax-violation
+ (lambda* (who message form #:optional (subform #f))
+ (let ((x who))
+ (if (not (let ((x x)) (or (not x) (string? x) (symbol? x))))
+ (syntax-violation 'syntax-violation "invalid argument" x)))
+ (let ((x message))
+ (if (not (string? x))
+ (syntax-violation 'syntax-violation "invalid argument" x)))
+ (throw 'syntax-error
+ who
+ message
+ (or (source-annotation subform) (source-annotation form))
+ (strip form '(()))
+ (and subform (strip subform '(()))))))
+ (letrec*
+ ((syntax-module
+ (lambda (id)
+ (let ((x id))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'syntax-module "invalid argument" x)))
+ (cdr (syntax-object-module id))))
+ (syntax-local-binding
+ (lambda (id)
+ (let ((x id))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation 'syntax-local-binding "invalid argument" x)))
+ (with-transformer-environment
+ (lambda (e r w s rib mod)
+ (letrec*
+ ((strip-anti-mark
+ (lambda (w)
+ (let ((ms (car w)) (s (cdr w)))
+ (if (and (pair? ms) (eq? (car ms) #f))
+ (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
+ (cons ms (if rib (cons rib s) s)))))))
+ (call-with-values
+ (lambda ()
+ (resolve-identifier
+ (syntax-object-expression id)
+ (strip-anti-mark (syntax-object-wrap id))
+ r
+ (syntax-object-module id)))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond ((memv key '(lexical)) (values 'lexical value))
+ ((memv key '(macro)) (values 'macro value))
+ ((memv key '(syntax)) (values 'pattern-variable
value))
+ ((memv key '(displaced-lexical)) (values
'displaced-lexical #f))
+ ((memv key '(global)) (values 'global (cons value
(cdr mod))))
+ (else (values 'other #f)))))))))))
+ (syntax-locally-bound-identifiers
+ (lambda (id)
+ (let ((x id))
+ (if (not (nonsymbol-id? x))
+ (syntax-violation
+ 'syntax-locally-bound-identifiers
+ "invalid argument"
+ x)))
+ (locally-bound-identifiers
+ (syntax-object-wrap id)
+ (syntax-object-module id)))))
+ (define! 'syntax-module syntax-module)
+ (define! 'syntax-local-binding syntax-local-binding)
+ (define!
+ 'syntax-locally-bound-identifiers
+ syntax-locally-bound-identifiers))
+ (letrec*
+ ((match-each
+ (lambda (e p w mod)
+ (cond ((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))))
+ (match-each+
+ (lambda (e x-pat y-pat z-pat w r mod)
+ (let f ((e e) (w w))
+ (cond ((pair? e)
(call-with-values
- (lambda ()
- (let ((id-14819 (vector-ref id-14771 1))
- (w-14820
- (let ((w-14831 (vector-ref id-14771 2)))
- (let ((ms-14832 (car w-14831))
- (s-14833 (cdr w-14831)))
- (if (if (pair? ms-14832)
- (eq? (car ms-14832) #f)
- #f)
- (cons (cdr ms-14832)
- (if rib-14815
- (cons rib-14815 (cdr s-14833))
- (cdr s-14833)))
- (cons ms-14832
- (if rib-14815
- (cons rib-14815 s-14833)
- s-14833))))))
- (mod-14822 (vector-ref id-14771 3)))
- (let ((n-14825 (id-var-name-4314 id-14819 w-14820)))
- (if (symbol? n-14825)
- (let ((mod-14839
- (if (if (vector? id-14819)
- (if (= (vector-length id-14819) 4)
- (eq? (vector-ref id-14819 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-14819 3)
- mod-14822)))
- (let ((b-14840
- (let ((t-14841
- (get-global-definition-hook-4258
- n-14825
- mod-14839)))
- (if t-14841 t-14841 '(global)))))
- (if (eq? (car b-14840) 'global)
- (values 'global n-14825 mod-14839)
- (values
- (car b-14840)
- (cdr b-14840)
- mod-14839))))
- (if (string? n-14825)
- (let ((mod-14867
- (if (if (vector? id-14819)
- (if (= (vector-length id-14819) 4)
- (eq? (vector-ref id-14819 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-14819 3)
- mod-14822)))
- (let ((b-14868
- (let ((t-14869
- (assq-ref r-14812 n-14825)))
- (if t-14869
- t-14869
- '(displaced-lexical)))))
- (values
- (car b-14868)
- (cdr b-14868)
- mod-14867)))
- (error "unexpected id-var-name"
- id-14819
- w-14820
- n-14825))))))
- (lambda (type-14882 value-14883 mod-14884)
- (if (eqv? type-14882 'lexical)
- (values 'lexical value-14883)
- (if (eqv? type-14882 'macro)
- (values 'macro value-14883)
- (if (eqv? type-14882 'syntax)
- (values 'pattern-variable value-14883)
- (if (eqv? type-14882 'displaced-lexical)
- (values 'displaced-lexical #f)
- (if (eqv? type-14882 'global)
- (values
- 'global
- (cons value-14883 (cdr mod-14884)))
- (values 'other #f)))))))))))))
- (syntax-locally-bound-identifiers-14639
- (lambda (id-14906)
- (begin
- (if (not (if (if (vector? id-14906)
- (if (= (vector-length id-14906) 4)
- (eq? (vector-ref id-14906 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-14906 1))
- #f))
- (syntax-violation
- 'syntax-locally-bound-identifiers
- "invalid argument"
- id-14906))
- (locally-bound-identifiers-4315
- (vector-ref id-14906 2)
- (vector-ref id-14906 3))))))
- (begin
- (define!
- 'syntax-module
- (lambda (id-14641)
- (begin
- (if (not (if (if (vector? id-14641)
- (if (= (vector-length id-14641) 4)
- (eq? (vector-ref id-14641 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-14641 1))
- #f))
- (syntax-violation
- 'syntax-module
- "invalid argument"
- id-14641))
- (cdr (vector-ref id-14641 3)))))
- (define!
- 'syntax-local-binding
- syntax-local-binding-14638)
- (define!
- 'syntax-locally-bound-identifiers
- syntax-locally-bound-identifiers-14639)))
- (letrec*
- ((match-each-15013
- (lambda (e-15600 p-15601 w-15602 mod-15603)
- (if (pair? e-15600)
- (let ((first-15604
- (match-15019
- (car e-15600)
- p-15601
- w-15602
- '()
- mod-15603)))
- (if first-15604
- (let ((rest-15607
- (match-each-15013
- (cdr e-15600)
- p-15601
- w-15602
- mod-15603)))
- (if rest-15607 (cons first-15604 rest-15607) #f))
- #f))
- (if (null? e-15600)
- '()
- (if (if (vector? e-15600)
- (if (= (vector-length e-15600) 4)
- (eq? (vector-ref e-15600 0) 'syntax-object)
- #f)
- #f)
- (match-each-15013
- (vector-ref e-15600 1)
- p-15601
- (join-wraps-4311 w-15602 (vector-ref e-15600 2))
- (vector-ref e-15600 3))
- #f)))))
- (match-each-any-15015
- (lambda (e-15635 w-15636 mod-15637)
- (if (pair? e-15635)
- (let ((l-15638
- (match-each-any-15015
- (cdr e-15635)
- w-15636
- mod-15637)))
- (if l-15638
- (cons (wrap-4324 (car e-15635) w-15636 mod-15637)
- l-15638)
- #f))
- (if (null? e-15635)
- '()
- (if (if (vector? e-15635)
- (if (= (vector-length e-15635) 4)
- (eq? (vector-ref e-15635 0) 'syntax-object)
- #f)
- #f)
- (match-each-any-15015
- (vector-ref e-15635 1)
- (join-wraps-4311 w-15636 (vector-ref e-15635 2))
- mod-15637)
- #f)))))
- (match-empty-15016
- (lambda (p-15662 r-15663)
- (if (null? p-15662)
- r-15663
- (if (eq? p-15662 '_)
- r-15663
- (if (eq? p-15662 'any)
- (cons '() r-15663)
- (if (pair? p-15662)
- (match-empty-15016
- (car p-15662)
- (match-empty-15016 (cdr p-15662) r-15663))
- (if (eq? p-15662 'each-any)
- (cons '() r-15663)
- (let ((key-15664 (vector-ref p-15662 0)))
- (if (eqv? key-15664 'each)
- (match-empty-15016
- (vector-ref p-15662 1)
- r-15663)
- (if (eqv? key-15664 'each+)
- (match-empty-15016
- (vector-ref p-15662 1)
- (match-empty-15016
- (reverse (vector-ref p-15662 2))
- (match-empty-15016
- (vector-ref p-15662 3)
- r-15663)))
- (if (if (eqv? key-15664 'free-id)
- #t
- (eqv? key-15664 'atom))
- r-15663
- (if (eqv? key-15664 'vector)
- (match-empty-15016
- (vector-ref p-15662 1)
- r-15663)))))))))))))
- (combine-15017
- (lambda (r*-15683 r-15684)
- (if (null? (car r*-15683))
- r-15684
- (cons (map car r*-15683)
- (combine-15017 (map cdr r*-15683) r-15684)))))
- (match*-15018
- (lambda (e-15048 p-15049 w-15050 r-15051 mod-15052)
- (if (null? p-15049)
- (if (null? e-15048) r-15051 #f)
- (if (pair? p-15049)
- (if (pair? e-15048)
- (match-15019
- (car e-15048)
- (car p-15049)
- w-15050
- (match-15019
- (cdr e-15048)
- (cdr p-15049)
- w-15050
- r-15051
- mod-15052)
- mod-15052)
- #f)
- (if (eq? p-15049 'each-any)
- (let ((l-15057
- (match-each-any-15015 e-15048 w-15050 mod-15052)))
- (if l-15057 (cons l-15057 r-15051) #f))
- (let ((key-15062 (vector-ref p-15049 0)))
- (if (eqv? key-15062 'each)
- (if (null? e-15048)
- (match-empty-15016
- (vector-ref p-15049 1)
- r-15051)
- (let ((l-15069
- (match-each-15013
- e-15048
- (vector-ref p-15049 1)
- w-15050
- mod-15052)))
- (if l-15069
- (letrec*
- ((collect-15072
- (lambda (l-15123)
- (if (null? (car l-15123))
- r-15051
- (cons (map car l-15123)
- (collect-15072
- (map cdr l-15123)))))))
- (collect-15072 l-15069))
- #f)))
- (if (eqv? key-15062 'each+)
+ (lambda () (f (cdr e) w))
+ (lambda (xr* y-pat r)
+ (if r
+ (if (null? y-pat)
+ (let ((xr (match (car e) x-pat w '() mod)))
+ (if xr (values (cons xr xr*) y-pat r) (values #f
#f #f)))
+ (values '() (cdr y-pat) (match (car e) (car y-pat) w
r mod)))
+ (values #f #f #f)))))
+ ((syntax-object? e)
+ (f (syntax-object-expression e) (join-wraps w e)))
+ (else (values '() y-pat (match e z-pat w r mod)))))))
+ (match-each-any
+ (lambda (e w mod)
+ (cond ((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))))
+ (match-empty
+ (lambda (p r)
+ (cond ((null? p) r)
+ ((eq? p '_) r)
+ ((eq? p 'any) (cons '() r))
+ ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
+ ((eq? p 'each-any) (cons '() r))
+ (else
+ (let ((key (vector-ref p 0)))
+ (cond ((memv key '(each)) (match-empty (vector-ref p 1) r))
+ ((memv key '(each+))
+ (match-empty
+ (vector-ref p 1)
+ (match-empty
+ (reverse (vector-ref p 2))
+ (match-empty (vector-ref p 3) r))))
+ ((memv key '(free-id atom)) r)
+ ((memv key '(vector)) (match-empty (vector-ref p 1)
r))))))))
+ (combine
+ (lambda (r* r)
+ (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r)))))
+ (match*
+ (lambda (e p w r mod)
+ (cond ((null? p) (and (null? e) r))
+ ((pair? p)
+ (and (pair? e)
+ (match (car e) (car p) w (match (cdr e) (cdr p) w r mod)
mod)))
+ ((eq? p 'each-any)
+ (let ((l (match-each-any e w mod))) (and l (cons l r))))
+ (else
+ (let ((key (vector-ref p 0)))
+ (cond ((memv key '(each))
+ (if (null? e)
+ (match-empty (vector-ref p 1) r)
+ (let ((l (match-each e (vector-ref p 1) w mod)))
+ (and l
+ (let collect ((l l))
+ (if (null? (car l)) r (cons (map car l)
(collect (map cdr l)))))))))
+ ((memv key '(each+))
(call-with-values
(lambda ()
- (let ((x-pat-15132 (vector-ref p-15049 1))
- (y-pat-15133 (vector-ref p-15049 2))
- (z-pat-15134 (vector-ref p-15049 3)))
- (letrec*
- ((f-15138
- (lambda (e-15140 w-15141)
- (if (pair? e-15140)
- (call-with-values
- (lambda ()
- (f-15138 (cdr e-15140) w-15141))
- (lambda (xr*-15142
- y-pat-15143
- r-15144)
- (if r-15144
- (if (null? y-pat-15143)
- (let ((xr-15145
- (match-15019
- (car e-15140)
- x-pat-15132
- w-15141
- '()
- mod-15052)))
- (if xr-15145
- (values
- (cons xr-15145 xr*-15142)
- y-pat-15143
- r-15144)
- (values #f #f #f)))
- (values
- '()
- (cdr y-pat-15143)
- (match-15019
- (car e-15140)
- (car y-pat-15143)
- w-15141
- r-15144
- mod-15052)))
- (values #f #f #f))))
- (if (if (vector? e-15140)
- (if (= (vector-length e-15140) 4)
- (eq? (vector-ref e-15140 0)
- 'syntax-object)
- #f)
- #f)
- (f-15138
- (vector-ref e-15140 1)
- (join-wraps-4311 w-15141 e-15140))
- (values
- '()
- y-pat-15133
- (match-15019
- e-15140
- z-pat-15134
- w-15141
- r-15051
- mod-15052)))))))
- (f-15138 e-15048 w-15050))))
- (lambda (xr*-15171 y-pat-15172 r-15173)
- (if r-15173
- (if (null? y-pat-15172)
- (if (null? xr*-15171)
- (match-empty-15016
- (vector-ref p-15049 1)
- r-15173)
- (combine-15017 xr*-15171 r-15173))
- #f)
- #f)))
- (if (eqv? key-15062 'free-id)
- (if (if (symbol? e-15048)
- #t
- (if (if (vector? e-15048)
- (if (= (vector-length e-15048) 4)
- (eq? (vector-ref e-15048 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref e-15048 1))
- #f))
- (if (let ((i-15504
- (wrap-4324 e-15048 w-15050 mod-15052))
- (j-15505 (vector-ref p-15049 1)))
- (if (eq? (if (if (vector? i-15504)
- (if (= (vector-length
- i-15504)
- 4)
- (eq? (vector-ref i-15504 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref i-15504 1)
- i-15504)
- (if (if (vector? j-15505)
- (if (= (vector-length
- j-15505)
- 4)
- (eq? (vector-ref j-15505 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref j-15505 1)
- j-15505))
- (eq? (id-var-name-4314 i-15504 '(()))
- (id-var-name-4314 j-15505 '(())))
- #f))
- r-15051
- #f)
- #f)
- (if (eqv? key-15062 'atom)
- (if (equal?
- (vector-ref p-15049 1)
- (strip-4344 e-15048 w-15050))
- r-15051
- #f)
- (if (eqv? key-15062 'vector)
- (if (vector? e-15048)
- (match-15019
- (vector->list e-15048)
- (vector-ref p-15049 1)
- w-15050
- r-15051
- mod-15052)
- #f))))))))))))
- (match-15019
- (lambda (e-15565 p-15566 w-15567 r-15568 mod-15569)
- (if (not r-15568)
- #f
- (if (eq? p-15566 '_)
- r-15568
- (if (eq? p-15566 'any)
- (cons (wrap-4324 e-15565 w-15567 mod-15569)
- r-15568)
- (if (if (vector? e-15565)
- (if (= (vector-length e-15565) 4)
- (eq? (vector-ref e-15565 0) 'syntax-object)
- #f)
- #f)
- (match*-15018
- (vector-ref e-15565 1)
- p-15566
- (join-wraps-4311 w-15567 (vector-ref e-15565 2))
- r-15568
- (vector-ref e-15565 3))
- (match*-15018
- e-15565
- p-15566
- w-15567
- r-15568
- mod-15569))))))))
- (set! $sc-dispatch
- (lambda (e-15020 p-15021)
- (if (eq? p-15021 'any)
- (list e-15020)
- (if (eq? p-15021 '_)
- '()
- (if (if (vector? e-15020)
- (if (= (vector-length e-15020) 4)
- (eq? (vector-ref e-15020 0) 'syntax-object)
- #f)
- #f)
- (match*-15018
- (vector-ref e-15020 1)
- p-15021
- (vector-ref e-15020 2)
- '()
- (vector-ref e-15020 3))
- (match*-15018 e-15020 p-15021 '(()) '() #f))))))))))
+ (match-each+
+ e
+ (vector-ref p 1)
+ (vector-ref p 2)
+ (vector-ref p 3)
+ w
+ r
+ mod))
+ (lambda (xr* y-pat r)
+ (and r
+ (null? y-pat)
+ (if (null? xr*) (match-empty (vector-ref p
1) r) (combine xr* r))))))
+ ((memv key '(free-id))
+ (and (id? e) (free-id=? (wrap e w mod) (vector-ref p
1)) r))
+ ((memv key '(atom)) (and (equal? (vector-ref p 1)
(strip e w)) r))
+ ((memv key '(vector))
+ (and (vector? e) (match (vector->list e) (vector-ref
p 1) w r mod)))))))))
+ (match (lambda (e p w r mod)
+ (cond ((not r) #f)
+ ((eq? p '_) r)
+ ((eq? p 'any) (cons (wrap e w mod) r))
+ ((syntax-object? e)
+ (match*
+ (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))
+ ((eq? p '_) '())
+ ((syntax-object? e)
+ (match*
+ (syntax-object-expression e)
+ p
+ (syntax-object-wrap e)
+ '()
+ (syntax-object-module e)))
+ (else (match* e p '(()) '() #f)))))))
(define with-syntax
(make-syntax-transformer
'with-syntax
'macro
- (lambda (x-28007)
- (let ((tmp-28009
- ($sc-dispatch x-28007 '(_ () any . each-any))))
- (if tmp-28009
- (@apply
- (lambda (e1-28013 e2-28014)
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-27980" "l-*-27981"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-27977")))
- (hygiene guile))
- (cons '() (cons e1-28013 e2-28014))))
- tmp-28009)
- (let ((tmp-28015
- ($sc-dispatch
- x-28007
- '(_ ((any any)) any . each-any))))
- (if tmp-28015
- (@apply
- (lambda (out-28019 in-28020 e1-28021 e2-28022)
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(out in e1 e2)
- #((top) (top) (top) (top))
- #("l-*-27986"
- "l-*-27987"
- "l-*-27988"
- "l-*-27989"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-27977")))
- (hygiene guile))
- in-28020
- '()
- (list out-28019
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage
- #(out in e1 e2)
- #((top) (top) (top) (top))
- #("l-*-27986"
- "l-*-27987"
- "l-*-27988"
- "l-*-27989"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-27977")))
- (hygiene guile))
- (cons '() (cons e1-28021 e2-28022))))))
- tmp-28015)
- (let ((tmp-28023
- ($sc-dispatch
- x-28007
- '(_ #(each (any any)) any . each-any))))
- (if tmp-28023
- (@apply
- (lambda (out-28027 in-28028 e1-28029 e2-28030)
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(out in e1 e2)
- #((top) (top) (top) (top))
- #("l-*-27996"
- "l-*-27997"
- "l-*-27998"
- "l-*-27999"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-27977")))
- (hygiene guile))
- (cons '#(syntax-object
- list
- ((top)
- #(ribcage
- #(out in e1 e2)
- #((top) (top) (top) (top))
- #("l-*-27996"
- "l-*-27997"
- "l-*-27998"
- "l-*-27999"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-27977")))
- (hygiene guile))
- in-28028)
- '()
- (list out-28027
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage
- #(out in e1 e2)
- #((top) (top) (top) (top))
- #("l-*-27996"
- "l-*-27997"
- "l-*-27998"
- "l-*-27999"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-27977")))
- (hygiene guile))
- (cons '() (cons e1-28029 e2-28030))))))
- tmp-28023)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-28007))))))))))
+ (lambda (x)
+ (let ((tmp x))
+ (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any))))
+ (if tmp-1
+ (apply (lambda (e1 e2)
+ (cons '#(syntax-object let ((top)) (hygiene guile))
+ (cons '() (cons e1 e2))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any))))
+ (if tmp-1
+ (apply (lambda (out in e1 e2)
+ (list '#(syntax-object syntax-case ((top)) (hygiene
guile))
+ in
+ '()
+ (list out
+ (cons '#(syntax-object let ((top))
(hygiene guile))
+ (cons '() (cons e1 e2))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any .
each-any))))
+ (if tmp-1
+ (apply (lambda (out in e1 e2)
+ (list '#(syntax-object syntax-case ((top))
(hygiene guile))
+ (cons '#(syntax-object list ((top))
(hygiene guile)) in)
+ '()
+ (list out
+ (cons '#(syntax-object let ((top))
(hygiene guile))
+ (cons '() (cons e1 e2))))))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp)))))))))))
(define syntax-rules
(make-syntax-transformer
'syntax-rules
'macro
- (lambda (x-28084)
- (let ((tmp-28086
- ($sc-dispatch
- x-28084
- '(_ each-any . #(each ((any . any) any))))))
- (if tmp-28086
- (@apply
- (lambda (k-28090
- keyword-28091
- pattern-28092
- template-28093)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile)))
- (vector
- '(#(syntax-object
- macro-type
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile))
- .
- #(syntax-object
- syntax-rules
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile)))
- (cons '#(syntax-object
- patterns
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile))
- pattern-28092))
- (cons '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile))
- (cons '#(syntax-object
- x
- ((top)
- #(ribcage
- #(k keyword pattern template)
- #((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile))
- (cons k-28090
- (map (lambda (tmp-28058-28094
- tmp-28057-28095)
- (list (cons '#(syntax-object
- dummy
- ((top)
- #(ribcage
- #(k
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28044")))
- (hygiene guile))
- tmp-28057-28095)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(k
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28044")))
- (hygiene guile))
- tmp-28058-28094)))
- template-28093
- pattern-28092))))))
- tmp-28086)
- (let ((tmp-28096
- ($sc-dispatch
- x-28084
- '(_ each-any any . #(each ((any . any) any))))))
- (if (if tmp-28096
- (@apply
- (lambda (k-28100
- docstring-28101
- keyword-28102
- pattern-28103
- template-28104)
- (string? (syntax->datum docstring-28101)))
- tmp-28096)
- #f)
- (@apply
- (lambda (k-28105
- docstring-28106
- keyword-28107
- pattern-28108
- template-28109)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile)))
- docstring-28106
- (vector
- '(#(syntax-object
- macro-type
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile))
- .
- #(syntax-object
- syntax-rules
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile)))
- (cons '#(syntax-object
- patterns
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile))
- pattern-28108))
- (cons '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(k docstring keyword pattern template)
- #((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
- (hygiene guile))
- (cons '#(syntax-object
- x
- ((top)
- #(ribcage
- #(k
- docstring
- keyword
- pattern
- template)
- #((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28044")))
- (hygiene guile))
- (cons k-28105
- (map (lambda (tmp-28083-28110
- tmp-28082-28111)
- (list (cons '#(syntax-object
- dummy
- ((top)
- #(ribcage
- #(k
- docstring
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top)
- (top))
-
#("l-*-28070"
-
"l-*-28071"
-
"l-*-28072"
-
"l-*-28073"
-
"l-*-28074"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
-
#("l-*-28044")))
- (hygiene
- guile))
- tmp-28082-28111)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(k
- docstring
- keyword
- pattern
- template)
- #((top)
- (top)
- (top)
- (top)
- (top))
-
#("l-*-28070"
-
"l-*-28071"
-
"l-*-28072"
-
"l-*-28073"
-
"l-*-28074"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
-
#("l-*-28044")))
- (hygiene
- guile))
- tmp-28083-28110)))
- template-28109
- pattern-28108))))))
- tmp-28096)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-28084))))))))
+ (lambda (xx)
+ (let ((tmp-1 xx))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ each-any . #(each ((any . any)
any))))))
+ (if tmp
+ (apply (lambda (k keyword pattern template)
+ (list '#(syntax-object lambda ((top)) (hygiene guile))
+ '(#(syntax-object x ((top)) (hygiene guile)))
+ (vector
+ '(#(syntax-object macro-type ((top)) (hygiene
guile))
+ .
+ #(syntax-object syntax-rules ((top)) (hygiene
guile)))
+ (cons '#(syntax-object patterns ((top)) (hygiene
guile)) pattern))
+ (cons '#(syntax-object syntax-case ((top)) (hygiene
guile))
+ (cons '#(syntax-object x ((top)) (hygiene
guile))
+ (cons k
+ (map (lambda (tmp-1 tmp)
+ (list (cons
'#(syntax-object dummy ((top)) (hygiene guile)) tmp)
+ (list
'#(syntax-object syntax ((top)) (hygiene guile))
+ tmp-1)))
+ template
+ pattern))))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any .
any) any))))))
+ (if (if tmp
+ (apply (lambda (k docstring keyword pattern template)
+ (string? (syntax->datum docstring)))
+ tmp)
+ #f)
+ (apply (lambda (k docstring keyword pattern template)
+ (list '#(syntax-object lambda ((top)) (hygiene guile))
+ '(#(syntax-object x ((top)) (hygiene guile)))
+ docstring
+ (vector
+ '(#(syntax-object macro-type ((top)) (hygiene
guile))
+ .
+ #(syntax-object syntax-rules ((top))
(hygiene guile)))
+ (cons '#(syntax-object patterns ((top))
(hygiene guile)) pattern))
+ (cons '#(syntax-object syntax-case ((top))
(hygiene guile))
+ (cons '#(syntax-object x ((top)) (hygiene
guile))
+ (cons k
+ (map (lambda (tmp-1 tmp)
+ (list (cons
'#(syntax-object dummy ((top)) (hygiene guile)) tmp)
+ (list
'#(syntax-object syntax ((top)) (hygiene guile))
+ tmp-1)))
+ template
+ pattern))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))
(define define-syntax-rule
(make-syntax-transformer
'define-syntax-rule
'macro
- (lambda (x-28148)
- (let ((tmp-28150
- ($sc-dispatch x-28148 '(_ (any . any) any))))
- (if tmp-28150
- (@apply
- (lambda (name-28154 pattern-28155 template-28156)
- (list '#(syntax-object
- define-syntax
- ((top)
- #(ribcage
- #(name pattern template)
- #((top) (top) (top))
- #("l-*-28125" "l-*-28126" "l-*-28127"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28122")))
- (hygiene guile))
- name-28154
- (list '#(syntax-object
- syntax-rules
- ((top)
- #(ribcage
- #(name pattern template)
- #((top) (top) (top))
- #("l-*-28125" "l-*-28126" "l-*-28127"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28122")))
- (hygiene guile))
- '()
- (list (cons '#(syntax-object
- _
- ((top)
- #(ribcage
- #(name pattern template)
- #((top) (top) (top))
- #("l-*-28125"
- "l-*-28126"
- "l-*-28127"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28122")))
- (hygiene guile))
- pattern-28155)
- template-28156))))
- tmp-28150)
- (let ((tmp-28157
- ($sc-dispatch x-28148 '(_ (any . any) any any))))
- (if (if tmp-28157
- (@apply
- (lambda (name-28161
- pattern-28162
- docstring-28163
- template-28164)
- (string? (syntax->datum docstring-28163)))
- tmp-28157)
- #f)
- (@apply
- (lambda (name-28165
- pattern-28166
- docstring-28167
- template-28168)
- (list '#(syntax-object
- define-syntax
- ((top)
- #(ribcage
- #(name pattern docstring template)
- #((top) (top) (top) (top))
- #("l-*-28140"
- "l-*-28141"
- "l-*-28142"
- "l-*-28143"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28122")))
- (hygiene guile))
- name-28165
- (list '#(syntax-object
- syntax-rules
- ((top)
- #(ribcage
- #(name pattern docstring template)
- #((top) (top) (top) (top))
- #("l-*-28140"
- "l-*-28141"
- "l-*-28142"
- "l-*-28143"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28122")))
- (hygiene guile))
- '()
- docstring-28167
- (list (cons '#(syntax-object
- _
- ((top)
- #(ribcage
- #(name
- pattern
- docstring
- template)
- #((top) (top) (top) (top))
- #("l-*-28140"
- "l-*-28141"
- "l-*-28142"
- "l-*-28143"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28122")))
- (hygiene guile))
- pattern-28166)
- template-28168))))
- tmp-28157)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-28148))))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any))))
+ (if tmp
+ (apply (lambda (name pattern template)
+ (list '#(syntax-object define-syntax ((top)) (hygiene
guile))
+ name
+ (list '#(syntax-object syntax-rules ((top))
(hygiene guile))
+ '()
+ (list (cons '#(syntax-object _ ((top))
(hygiene guile)) pattern)
+ template))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any))))
+ (if (if tmp
+ (apply (lambda (name pattern docstring template)
+ (string? (syntax->datum docstring)))
+ tmp)
+ #f)
+ (apply (lambda (name pattern docstring template)
+ (list '#(syntax-object define-syntax ((top)) (hygiene
guile))
+ name
+ (list '#(syntax-object syntax-rules ((top))
(hygiene guile))
+ '()
+ docstring
+ (list (cons '#(syntax-object _ ((top))
(hygiene guile)) pattern)
+ template))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))
(define let*
(make-syntax-transformer
'let*
'macro
- (lambda (x-28217)
- (let ((tmp-28219
- ($sc-dispatch
- x-28217
- '(any #(each (any any)) any . each-any))))
- (if (if tmp-28219
- (@apply
- (lambda (let*-28223 x-28224 v-28225 e1-28226 e2-28227)
- (and-map identifier? x-28224))
- tmp-28219)
- #f)
- (@apply
- (lambda (let*-28228 x-28229 v-28230 e1-28231 e2-28232)
- (letrec*
- ((f-28233
- (lambda (bindings-28236)
- (if (null? bindings-28236)
- (cons '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(f bindings)
- #((top) (top))
- #("l-*-28203" "l-*-28204"))
- #(ribcage
- #(let* x v e1 e2)
- #((top) (top) (top) (top) (top))
- #("l-*-28193"
- "l-*-28194"
- "l-*-28195"
- "l-*-28196"
- "l-*-28197"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28179")))
- (hygiene guile))
- (cons '() (cons e1-28231 e2-28232)))
- (let ((tmp-28237
- (list (f-28233 (cdr bindings-28236))
- (car bindings-28236))))
- (let ((tmp-28238 ($sc-dispatch tmp-28237 '(any any))))
- (if tmp-28238
- (@apply
- (lambda (body-28240 binding-28241)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(body binding)
- #((top) (top))
- #("l-*-28213" "l-*-28214"))
- #(ribcage () () ())
- #(ribcage
- #(f bindings)
- #((top) (top))
- #("l-*-28203" "l-*-28204"))
- #(ribcage
- #(let* x v e1 e2)
- #((top) (top) (top) (top) (top))
- #("l-*-28193"
- "l-*-28194"
- "l-*-28195"
- "l-*-28196"
- "l-*-28197"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28179")))
- (hygiene guile))
- (list binding-28241)
- body-28240))
- tmp-28238)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-28237))))))))
- (f-28233 (map list x-28229 v-28230))))
- tmp-28219)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-28217))))))
-
-(define do
- (make-syntax-transformer
- 'do
- 'macro
- (lambda (orig-x-28299)
- (let ((tmp-28301
- ($sc-dispatch
- orig-x-28299
- '(_ #(each (any any . any))
- (any . each-any)
- .
- each-any))))
- (if tmp-28301
- (@apply
- (lambda (var-28305
- init-28306
- step-28307
- e0-28308
- e1-28309
- c-28310)
- (let ((tmp-28311
- (map (lambda (v-28314 s-28315)
- (let ((tmp-28317 ($sc-dispatch s-28315 '())))
- (if tmp-28317
- (@apply (lambda () v-28314) tmp-28317)
- (let ((tmp-28320
- ($sc-dispatch s-28315 '(any))))
- (if tmp-28320
- (@apply
- (lambda (e-28323) e-28323)
- tmp-28320)
- (syntax-violation
- 'do
- "bad step expression"
- orig-x-28299
- s-28315))))))
- var-28305
- step-28307)))
- (let ((tmp-28312 ($sc-dispatch tmp-28311 'each-any)))
- (if tmp-28312
- (@apply
- (lambda (step-28329)
- (let ((tmp-28331 ($sc-dispatch e1-28309 '())))
- (if tmp-28331
- (@apply
- (lambda ()
- (list '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-28267"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-28249")))
- (hygiene guile))
- '#(syntax-object
- doloop
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-28267"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-28249")))
- (hygiene guile))
- (map list var-28305 init-28306)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-28267"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-28249")))
- (hygiene guile))
- (list '#(syntax-object
- not
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-28267"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-28249")))
- (hygiene guile))
- e0-28308)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-28267"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-28249")))
- (hygiene guile))
- (append
- c-28310
- (list (cons
'#(syntax-object
- doloop
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(step)
- #((top))
-
#("l-*-28267"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
-
#("l-*-28252"
-
"l-*-28253"
-
"l-*-28254"
-
"l-*-28255"
-
"l-*-28256"
-
"l-*-28257"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(orig-x)
- #((top))
-
#("l-*-28249")))
- (hygiene
- guile))
-
step-28329)))))))
- tmp-28331)
- (let ((tmp-28335
- ($sc-dispatch e1-28309 '(any . each-any))))
- (if tmp-28335
- (@apply
- (lambda (e1-28339 e2-28340)
- (list '#(syntax-object
- let
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-28276" "l-*-28277"))
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-28267"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-28249")))
- (hygiene guile))
- '#(syntax-object
- doloop
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-28276" "l-*-28277"))
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-28267"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-28249")))
- (hygiene guile))
- (map list var-28305 init-28306)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-28276"
- "l-*-28277"))
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-28267"))
- #(ribcage
- #(var init step e0 e1 c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-28249")))
- (hygiene guile))
- e0-28308
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-28276"
- "l-*-28277"))
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-28267"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-28249")))
- (hygiene guile))
- (cons e1-28339 e2-28340))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-28276"
- "l-*-28277"))
- #(ribcage () () ())
- #(ribcage
- #(step)
- #((top))
- #("l-*-28267"))
- #(ribcage
- #(var
- init
- step
- e0
- e1
- c)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
- #(ribcage () () ())
- #(ribcage
- #(orig-x)
- #((top))
- #("l-*-28249")))
- (hygiene guile))
- (append
- c-28310
- (list (cons
'#(syntax-object
- doloop
- ((top)
-
#(ribcage
- #(e1
- e2)
-
#((top)
-
(top))
-
#("l-*-28276"
-
"l-*-28277"))
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
-
#(step)
-
#((top))
-
#("l-*-28267"))
-
#(ribcage
- #(var
-
init
-
step
- e0
- e1
- c)
-
#((top)
-
(top)
-
(top)
-
(top)
-
(top)
-
(top))
-
#("l-*-28252"
-
"l-*-28253"
-
"l-*-28254"
-
"l-*-28255"
-
"l-*-28256"
-
"l-*-28257"))
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
-
#(orig-x)
-
#((top))
-
#("l-*-28249")))
- (hygiene
-
guile))
-
step-28329)))))))
- tmp-28335)
- (syntax-violation
- #f
- "source expression failed to match any
pattern"
- e1-28309))))))
- tmp-28312)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-28311)))))
- tmp-28301)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- orig-x-28299))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(any #(each (any any)) any .
each-any))))
+ (if (if tmp
+ (apply (lambda (let* x v e1 e2) (and-map identifier? x)) tmp)
+ #f)
+ (apply (lambda (let* x v e1 e2)
+ (let f ((bindings (map list x v)))
+ (if (null? bindings)
+ (cons '#(syntax-object let ((top)) (hygiene guile))
+ (cons '() (cons e1 e2)))
+ (let ((tmp-1 (list (f (cdr bindings)) (car
bindings))))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (body binding)
+ (list '#(syntax-object let ((top))
(hygiene guile))
+ (list binding)
+ body))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ tmp-1)))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
(define quasiquote
(make-syntax-transformer
'quasiquote
'macro
(letrec*
- ((quasi-28620
- (lambda (p-28644 lev-28645)
- (let ((tmp-28647
- ($sc-dispatch
- p-28644
- '(#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- any))))
- (if tmp-28647
- (@apply
- (lambda (p-28651)
- (if (= lev-28645 0)
- (list '#(syntax-object
- "value"
- ((top)
- #(ribcage #(p) #((top)) #("l-*-28376"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- p-28651)
- (quasicons-28622
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage #(p) #((top)) #("l-*-28376"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- #(syntax-object
- unquote
- ((top)
- #(ribcage #(p) #((top)) #("l-*-28376"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- (quasi-28620 (list p-28651) (#{1-}# lev-28645)))))
- tmp-28647)
- (let ((tmp-28654
- ($sc-dispatch
- p-28644
- '(#(free-id
- #(syntax-object
- quasiquote
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- any))))
- (if tmp-28654
- (@apply
- (lambda (p-28658)
- (quasicons-28622
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage #(p) #((top)) #("l-*-28379"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- #(syntax-object
- quasiquote
- ((top)
- #(ribcage #(p) #((top)) #("l-*-28379"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- (quasi-28620 (list p-28658) (#{1+}# lev-28645))))
- tmp-28654)
- (let ((tmp-28661 ($sc-dispatch p-28644 '(any . any))))
- (if tmp-28661
- (@apply
- (lambda (p-28665 q-28666)
- (let ((tmp-28668
- ($sc-dispatch
- p-28665
- '(#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28382" "l-*-28383"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- .
- each-any))))
- (if tmp-28668
- (@apply
- (lambda (p-28672)
- (if (= lev-28645 0)
- (quasilist*-28624
- (map (lambda (tmp-28390-28708)
- (list '#(syntax-object
- "value"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-28388"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28382"
- "l-*-28383"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372"
- "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- tmp-28390-28708))
- p-28672)
- (quasi-28620 q-28666 lev-28645))
- (quasicons-28622
- (quasicons-28622
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-28388"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28382" "l-*-28383"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- #(syntax-object
- unquote
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-28388"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28382" "l-*-28383"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- (quasi-28620
- p-28672
- (#{1-}# lev-28645)))
- (quasi-28620 q-28666 lev-28645))))
- tmp-28668)
- (let ((tmp-28713
- ($sc-dispatch
- p-28665
- '(#(free-id
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28382" "l-*-28383"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- .
- each-any))))
- (if tmp-28713
- (@apply
- (lambda (p-28717)
- (if (= lev-28645 0)
- (quasiappend-28623
- (map (lambda (tmp-28395-28720)
- (list '#(syntax-object
- "value"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-28393"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28382"
- "l-*-28383"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372"
- "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- tmp-28395-28720))
- p-28717)
- (quasi-28620 q-28666 lev-28645))
- (quasicons-28622
- (quasicons-28622
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-28393"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28382" "l-*-28383"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-28393"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28382" "l-*-28383"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- (quasi-28620
- p-28717
- (#{1-}# lev-28645)))
- (quasi-28620 q-28666 lev-28645))))
- tmp-28713)
- (quasicons-28622
- (quasi-28620 p-28665 lev-28645)
- (quasi-28620 q-28666 lev-28645)))))))
- tmp-28661)
- (let ((tmp-28734
- ($sc-dispatch p-28644 '#(vector each-any))))
- (if tmp-28734
- (@apply
- (lambda (x-28738)
- (let ((x-28741
- (vquasi-28621 x-28738 lev-28645)))
- (let ((tmp-28743
- ($sc-dispatch
- x-28741
- '(#(atom "quote") each-any))))
- (if tmp-28743
- (@apply
- (lambda (x-28747)
- (list '#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(x)
- #((top))
- #("l-*-28494"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28491"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- (list->vector x-28747)))
- tmp-28743)
- (letrec*
- ((f-28749
- (lambda (y-28761 k-28762)
- (let ((tmp-28764
- ($sc-dispatch
- y-28761
- '(#(atom "quote")
+ ((quasi (lambda (p lev)
+ (let ((tmp p))
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ '(#(free-id #(syntax-object unquote ((top))
(hygiene guile))) any))))
+ (if tmp-1
+ (apply (lambda (p)
+ (if (= lev 0)
+ (list "value" p)
+ (quasicons
+ '("quote" #(syntax-object unquote ((top))
(hygiene guile)))
+ (quasi (list p) (- lev 1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ '(#(free-id #(syntax-object quasiquote
((top)) (hygiene guile))) any))))
+ (if tmp-1
+ (apply (lambda (p)
+ (quasicons
+ '("quote" #(syntax-object quasiquote
((top)) (hygiene guile)))
+ (quasi (list p) (+ lev 1))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply (lambda (p q)
+ (let ((tmp-1 p))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(#(free-id
#(syntax-object unquote ((top)) (hygiene guile)))
+ .
each-any))))
- (if tmp-28764
- (@apply
- (lambda (y-28767)
- (k-28762
- (map (lambda
(tmp-28519-28768)
- (list
'#(syntax-object
- "quote"
- ((top)
-
#(ribcage
- #(y)
-
#((top))
-
#("l-*-28517"))
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- #(f
- y
- k)
-
#((top)
-
(top)
-
(top))
-
#("l-*-28499"
-
"l-*-28500"
-
"l-*-28501"))
-
#(ribcage
- #(_)
-
#((top))
-
#("l-*-28497"))
-
#(ribcage
- ()
- ()
- ())
-
#(ribcage
- #(x)
-
#((top))
-
#("l-*-28491"))
-
#(ribcage
- (emit
quasivector
-
quasilist*
-
quasiappend
-
quasicons
-
vquasi
-
quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
-
(top))
-
("l-*-28368"
-
"l-*-28366"
-
"l-*-28364"
-
"l-*-28362"
-
"l-*-28360"
-
"l-*-28358"
-
"l-*-28356")))
- (hygiene
- guile))
-
tmp-28519-28768))
- y-28767)))
- tmp-28764)
- (let ((tmp-28769
- ($sc-dispatch
- y-28761
- '(#(atom "list")
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasilist*
+ (map (lambda (tmp)
(list "value" tmp)) p)
+ (quasi q lev))
+ (quasicons
+ (quasicons
+ '("quote"
#(syntax-object unquote ((top)) (hygiene guile)))
+ (quasi p (- lev
1)))
+ (quasi q lev))))
+ tmp)
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(#(free-id
+ #(syntax-object
unquote-splicing ((top)) (hygiene guile)))
.
each-any))))
- (if tmp-28769
- (@apply
- (lambda (y-28772)
- (k-28762 y-28772))
- tmp-28769)
- (let ((tmp-28773
- ($sc-dispatch
- y-28761
- '(#(atom "list*")
- .
- #(each+
- any
- (any)
- ())))))
- (if tmp-28773
- (@apply
- (lambda (y-28776
- z-28777)
- (f-28749
- z-28777
- (lambda
(ls-28778)
- (k-28762
- (append
- y-28776
-
ls-28778)))))
- tmp-28773)
- (list '#(syntax-object
- "list->vector"
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(t-28534)
-
#((m-*-28535
- top))
-
#("l-*-28538"))
- #(ribcage
- #(else)
- #((top))
-
#("l-*-28532"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f y k)
- #((top)
- (top)
- (top))
-
#("l-*-28499"
-
"l-*-28500"
-
"l-*-28501"))
- #(ribcage
- #(_)
- #((top))
-
#("l-*-28497"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
-
#("l-*-28491"))
- #(ribcage
- (emit
quasivector
-
quasilist*
-
quasiappend
-
quasicons
-
vquasi
-
quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
-
("l-*-28368"
-
"l-*-28366"
-
"l-*-28364"
-
"l-*-28362"
-
"l-*-28360"
-
"l-*-28358"
-
"l-*-28356")))
- (hygiene
- guile))
- x-28741))))))))))
- (f-28749
- x-28741
- (lambda (ls-28751)
- (let ((tmp-28753
- ($sc-dispatch
- ls-28751
- 'each-any)))
- (if tmp-28753
- (@apply
- (lambda (t-28507-28756)
- (cons '#(syntax-object
- "vector"
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(t-28507)
- #((m-*-28508
- top))
- #("l-*-28512"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(ls)
- #((top))
- #("l-*-28506"))
- #(ribcage
- #(_)
- #((top))
- #("l-*-28497"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28491"))
- #(ribcage
- (emit
quasivector
- quasilist*
-
quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- t-28507-28756))
- tmp-28753)
- (syntax-violation
- #f
- "source expression failed to
match any pattern"
- ls-28751))))))))))
- tmp-28734)
- (list '#(syntax-object
- "quote"
- ((top)
- #(ribcage #(p) #((top)) #("l-*-28403"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28372" "l-*-28373"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- p-28644)))))))))))
- (vquasi-28621
- (lambda (p-28806 lev-28807)
- (let ((tmp-28809 ($sc-dispatch p-28806 '(any . any))))
- (if tmp-28809
- (@apply
- (lambda (p-28813 q-28814)
- (let ((tmp-28816
- ($sc-dispatch
- p-28813
- '(#(free-id
- #(syntax-object
- unquote
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28411" "l-*-28412"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28407" "l-*-28408"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- .
- each-any))))
- (if tmp-28816
- (@apply
- (lambda (p-28820)
- (if (= lev-28807 0)
- (quasilist*-28624
- (map (lambda (tmp-28419-28856)
- (list '#(syntax-object
- "value"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-28417"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28411" "l-*-28412"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28407" "l-*-28408"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- tmp-28419-28856))
- p-28820)
- (vquasi-28621 q-28814 lev-28807))
- (quasicons-28622
- (quasicons-28622
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage #(p) #((top)) #("l-*-28417"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28411" "l-*-28412"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28407" "l-*-28408"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- #(syntax-object
- unquote
- ((top)
- #(ribcage #(p) #((top)) #("l-*-28417"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28411" "l-*-28412"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28407" "l-*-28408"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- (quasi-28620 p-28820 (#{1-}# lev-28807)))
- (vquasi-28621 q-28814 lev-28807))))
- tmp-28816)
- (let ((tmp-28863
- ($sc-dispatch
- p-28813
- '(#(free-id
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28411" "l-*-28412"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28407" "l-*-28408"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- .
- each-any))))
- (if tmp-28863
- (@apply
- (lambda (p-28867)
- (if (= lev-28807 0)
- (quasiappend-28623
- (map (lambda (tmp-28424-28870)
- (list '#(syntax-object
- "value"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-28422"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28411"
- "l-*-28412"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28407"
- "l-*-28408"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- tmp-28424-28870))
- p-28867)
- (vquasi-28621 q-28814 lev-28807))
- (quasicons-28622
- (quasicons-28622
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-28422"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28411" "l-*-28412"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28407" "l-*-28408"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- #(syntax-object
- unquote-splicing
- ((top)
- #(ribcage
- #(p)
- #((top))
- #("l-*-28422"))
- #(ribcage
- #(p q)
- #((top) (top))
- #("l-*-28411" "l-*-28412"))
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28407" "l-*-28408"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile)))
- (quasi-28620 p-28867 (#{1-}# lev-28807)))
- (vquasi-28621 q-28814 lev-28807))))
- tmp-28863)
- (quasicons-28622
- (quasi-28620 p-28813 lev-28807)
- (vquasi-28621 q-28814 lev-28807)))))))
- tmp-28809)
- (let ((tmp-28888 ($sc-dispatch p-28806 '())))
- (if tmp-28888
- (@apply
- (lambda ()
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p lev)
- #((top) (top))
- #("l-*-28407" "l-*-28408"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- ()))
- tmp-28888)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- p-28806)))))))
- (quasicons-28622
- (lambda (x-28901 y-28902)
- (let ((tmp-28903 (list x-28901 y-28902)))
- (let ((tmp-28904 ($sc-dispatch tmp-28903 '(any any))))
- (if tmp-28904
- (@apply
- (lambda (x-28906 y-28907)
- (let ((tmp-28909
- ($sc-dispatch y-28907 '(#(atom "quote") any))))
- (if tmp-28909
- (@apply
- (lambda (dy-28913)
- (let ((tmp-28915
- ($sc-dispatch
- x-28906
- '(#(atom "quote") any))))
- (if tmp-28915
- (@apply
- (lambda (dx-28919)
- (list '#(syntax-object
- "quote"
- ((top)
- #(ribcage
- #(dx)
- #((top))
- #("l-*-28446"))
- #(ribcage
- #(dy)
- #((top))
- #("l-*-28442"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28436" "l-*-28437"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28431" "l-*-28432"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- (cons dx-28919 dy-28913)))
- tmp-28915)
- (if (null? dy-28913)
- (list '#(syntax-object
- "list"
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("l-*-28448"))
- #(ribcage
- #(dy)
- #((top))
- #("l-*-28442"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28436" "l-*-28437"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28431" "l-*-28432"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- x-28906)
- (list '#(syntax-object
- "list*"
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("l-*-28448"))
- #(ribcage
- #(dy)
- #((top))
- #("l-*-28442"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28436" "l-*-28437"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28431" "l-*-28432"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- x-28906
- y-28907)))))
- tmp-28909)
- (let ((tmp-28924
- ($sc-dispatch
- y-28907
- '(#(atom "list") . any))))
- (if tmp-28924
- (@apply
- (lambda (stuff-28928)
- (cons '#(syntax-object
- "list"
- ((top)
- #(ribcage
- #(stuff)
- #((top))
- #("l-*-28451"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28436" "l-*-28437"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28431" "l-*-28432"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- (cons x-28906 stuff-28928)))
- tmp-28924)
- (let ((tmp-28929
- ($sc-dispatch
- y-28907
- '(#(atom "list*") . any))))
- (if tmp-28929
- (@apply
- (lambda (stuff-28933)
- (cons '#(syntax-object
- "list*"
- ((top)
- #(ribcage
- #(stuff)
- #((top))
- #("l-*-28454"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28436" "l-*-28437"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28431" "l-*-28432"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- (cons x-28906 stuff-28933)))
- tmp-28929)
- (list '#(syntax-object
- "list*"
- ((top)
- #(ribcage
- #(_)
- #((top))
- #("l-*-28456"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28436" "l-*-28437"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28431" "l-*-28432"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- x-28906
- y-28907))))))))
- tmp-28904)
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasiappend
+ (map (lambda
(tmp) (list "value" tmp)) p)
+ (quasi q lev))
+ (quasicons
+ (quasicons
+ '("quote"
+
#(syntax-object
+
unquote-splicing
+ ((top))
+ (hygiene
guile)))
+ (quasi p (-
lev 1)))
+ (quasi q lev))))
+ tmp)
+ (quasicons (quasi p lev)
(quasi q lev))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '#(vector
each-any))))
+ (if tmp-1
+ (apply (lambda (x) (quasivector (vquasi x
lev))) tmp-1)
+ (let ((p tmp)) (list "quote" p)))))))))))))
+ (vquasi
+ (lambda (p lev)
+ (let ((tmp p))
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply (lambda (p q)
+ (let ((tmp-1 p))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(#(free-id #(syntax-object unquote
((top)) (hygiene guile)))
+ .
+ each-any))))
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasilist* (map (lambda (tmp)
(list "value" tmp)) p) (vquasi q lev))
+ (quasicons
+ (quasicons
+ '("quote" #(syntax-object
unquote ((top)) (hygiene guile)))
+ (quasi p (- lev 1)))
+ (vquasi q lev))))
+ tmp)
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(#(free-id #(syntax-object
unquote-splicing ((top)) (hygiene guile)))
+ .
+ each-any))))
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasiappend
+ (map (lambda (tmp) (list
"value" tmp)) p)
+ (vquasi q lev))
+ (quasicons
+ (quasicons
+ '("quote" #(syntax-object
unquote-splicing ((top)) (hygiene guile)))
+ (quasi p (- lev 1)))
+ (vquasi q lev))))
+ tmp)
+ (quasicons (quasi p lev) (vquasi q
lev))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () '("quote" ())) tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))
+ (quasicons
+ (lambda (x y)
+ (let ((tmp-1 (list x y)))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (x y)
+ (let ((tmp y))
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
any))))
+ (if tmp-1
+ (apply (lambda (dy)
+ (let ((tmp x))
+ (let ((tmp ($sc-dispatch tmp
'(#(atom "quote") any))))
+ (if tmp
+ (apply (lambda (dx) (list
"quote" (cons dx dy))) tmp)
+ (if (null? dy) (list "list" x)
(list "list*" x y))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom
"list") . any))))
+ (if tmp-1
+ (apply (lambda (stuff) (cons "list" (cons
x stuff))) tmp-1)
+ (let ((tmp ($sc-dispatch tmp '(#(atom
"list*") . any))))
+ (if tmp
+ (apply (lambda (stuff) (cons "list*"
(cons x stuff))) tmp)
+ (list "list*" x y)))))))))
+ tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-28903))))))
- (quasiappend-28623
- (lambda (x-28944 y-28945)
- (let ((tmp-28947
- ($sc-dispatch y-28945 '(#(atom "quote") ()))))
- (if tmp-28947
- (@apply
- (lambda ()
- (if (null? x-28944)
- '(#(syntax-object
- "quote"
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28460" "l-*-28461"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- ())
- (if (null? (cdr x-28944))
- (car x-28944)
- (let ((tmp-28952 ($sc-dispatch x-28944 'each-any)))
- (if tmp-28952
- (@apply
- (lambda (p-28956)
- (cons '#(syntax-object
- "append"
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p)
- #((top))
- #("l-*-28468"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28460" "l-*-28461"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- p-28956))
- tmp-28952)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-28944))))))
- tmp-28947)
- (if (null? x-28944)
- y-28945
- (let ((tmp-28964 (list x-28944 y-28945)))
- (let ((tmp-28965
- ($sc-dispatch tmp-28964 '(each-any any))))
- (if tmp-28965
- (@apply
- (lambda (p-28967 y-28968)
- (cons '#(syntax-object
- "append"
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p y)
- #((top) (top))
- #("l-*-28477" "l-*-28478"))
- #(ribcage #(_) #((top)) #("l-*-28471"))
- #(ribcage () () ())
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28460" "l-*-28461"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- (append p-28967 (list y-28968))))
- tmp-28965)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-28964)))))))))
- (quasilist*-28624
- (lambda (x-28972 y-28973)
- (letrec*
- ((f-28974
- (lambda (x-29063)
- (if (null? x-29063)
- y-28973
- (quasicons-28622
- (car x-29063)
- (f-28974 (cdr x-29063)))))))
- (f-28974 x-28972))))
- (emit-28626
- (lambda (x-29066)
- (let ((tmp-29068
- ($sc-dispatch x-29066 '(#(atom "quote") any))))
- (if tmp-29068
- (@apply
- (lambda (x-29072)
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage #(x) #((top)) #("l-*-28544"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28541"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- x-29072))
- tmp-29068)
- (let ((tmp-29073
- ($sc-dispatch
- x-29066
- '(#(atom "list") . each-any))))
- (if tmp-29073
- (@apply
- (lambda (x-29077)
- (let ((tmp-29078 (map emit-28626 x-29077)))
- (let ((tmp-29079 ($sc-dispatch tmp-29078 'each-any)))
- (if tmp-29079
- (@apply
- (lambda (t-28549-29081)
- (cons '#(syntax-object
- list
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(t-28549)
- #((m-*-28550 top))
- #("l-*-28554"))
- #(ribcage
- #(x)
- #((top))
- #("l-*-28547"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28541"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- t-28549-29081))
- tmp-29079)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-29078)))))
- tmp-29073)
- (let ((tmp-29082
- ($sc-dispatch
- x-29066
- '(#(atom "list*") . #(each+ any (any) ())))))
- (if tmp-29082
- (@apply
- (lambda (x-29086 y-29087)
- (letrec*
- ((f-29088
- (lambda (x*-29091)
- (if (null? x*-29091)
- (emit-28626 y-29087)
- (let ((tmp-29092
- (list (emit-28626 (car x*-29091))
- (f-29088 (cdr x*-29091)))))
- (let ((tmp-29093
- ($sc-dispatch
- tmp-29092
- '(any any))))
- (if tmp-29093
- (@apply
- (lambda (t-28569-29095
- t-28568-29096)
- (list '#(syntax-object
- cons
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(t-28569 t-28568)
- #((m-*-28570 top)
- (m-*-28570 top))
- #("l-*-28574"
- "l-*-28575"))
- #(ribcage () () ())
- #(ribcage
- #(f x*)
- #((top) (top))
- #("l-*-28563"
- "l-*-28564"))
- #(ribcage
- #(x y)
- #((top) (top))
- #("l-*-28559"
- "l-*-28560"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28541"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- t-28569-29095
- t-28568-29096))
- tmp-29093)
- (syntax-violation
- #f
- "source expression failed to match
any pattern"
- tmp-29092))))))))
- (f-29088 x-29086)))
- tmp-29082)
- (let ((tmp-29097
- ($sc-dispatch
- x-29066
- '(#(atom "append") . each-any))))
- (if tmp-29097
- (@apply
- (lambda (x-29101)
- (let ((tmp-29102 (map emit-28626 x-29101)))
- (let ((tmp-29103
- ($sc-dispatch tmp-29102 'each-any)))
- (if tmp-29103
- (@apply
- (lambda (t-28581-29105)
- (cons '#(syntax-object
- append
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(t-28581)
- #((m-*-28582 top))
- #("l-*-28586"))
- #(ribcage
- #(x)
- #((top))
- #("l-*-28579"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28541"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- t-28581-29105))
- tmp-29103)
- (syntax-violation
- #f
- "source expression failed to match any
pattern"
- tmp-29102)))))
- tmp-29097)
- (let ((tmp-29106
- ($sc-dispatch
- x-29066
- '(#(atom "vector") . each-any))))
- (if tmp-29106
- (@apply
- (lambda (x-29110)
- (let ((tmp-29111 (map emit-28626 x-29110)))
- (let ((tmp-29112
- ($sc-dispatch
- tmp-29111
- 'each-any)))
- (if tmp-29112
- (@apply
- (lambda (t-28593-29114)
- (cons '#(syntax-object
- vector
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(t-28593)
- #((m-*-28594 top))
- #("l-*-28598"))
- #(ribcage
- #(x)
- #((top))
- #("l-*-28591"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28541"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- t-28593-29114))
- tmp-29112)
- (syntax-violation
- #f
- "source expression failed to match
any pattern"
- tmp-29111)))))
- tmp-29106)
- (let ((tmp-29115
- ($sc-dispatch
- x-29066
- '(#(atom "list->vector") any))))
- (if tmp-29115
- (@apply
- (lambda (x-29119)
- (let ((tmp-29120 (emit-28626 x-29119)))
- (list '#(syntax-object
- list->vector
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(t-28605)
- #((m-*-28606 top))
- #("l-*-28609"))
- #(ribcage
- #(x)
- #((top))
- #("l-*-28603"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-28541"))
- #(ribcage
- (emit quasivector
- quasilist*
- quasiappend
- quasicons
- vquasi
- quasi)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
- (hygiene guile))
- tmp-29120)))
- tmp-29115)
- (let ((tmp-29123
- ($sc-dispatch
- x-29066
- '(#(atom "value") any))))
- (if tmp-29123
- (@apply
- (lambda (x-29127) x-29127)
- tmp-29123)
- (syntax-violation
- #f
- "source expression failed to match
any pattern"
- x-29066))))))))))))))))))
- (lambda (x-28627)
- (let ((tmp-28629 ($sc-dispatch x-28627 '(_ any))))
- (if tmp-28629
- (@apply
- (lambda (e-28633)
- (emit-28626 (quasi-28620 e-28633 0)))
- tmp-28629)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-28627)))))))
+ tmp-1))))))
+ (quasiappend
+ (lambda (x y)
+ (let ((tmp y))
+ (let ((tmp ($sc-dispatch tmp '(#(atom "quote") ()))))
+ (if tmp
+ (apply (lambda ()
+ (if (null? x)
+ '("quote" ())
+ (if (null? (cdr x))
+ (car x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (p) (cons "append" p)) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ tmp-1)))))))
+ tmp)
+ (if (null? x)
+ y
+ (let ((tmp-1 (list x y)))
+ (let ((tmp ($sc-dispatch tmp-1 '(each-any any))))
+ (if tmp
+ (apply (lambda (p y) (cons "append" (append p (list
y)))) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))))
+ (quasilist*
+ (lambda (x y)
+ (let f ((x x)) (if (null? x) y (quasicons (car x) (f (cdr x)))))))
+ (quasivector
+ (lambda (x)
+ (let ((tmp x))
+ (let ((tmp ($sc-dispatch tmp '(#(atom "quote") each-any))))
+ (if tmp
+ (apply (lambda (x) (list "quote" (list->vector x))) tmp)
+ (let f ((y x)
+ (k (lambda (ls)
+ (let ((tmp-1 ls))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (t) (cons "vector" t)) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ tmp-1)))))))
+ (let ((tmp y))
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
+ (if tmp-1
+ (apply (lambda (y) (k (map (lambda (tmp) (list
"quote" tmp)) y)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") .
each-any))))
+ (if tmp-1
+ (apply (lambda (y) (k y)) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*")
. #(each+ any (any) ())))))
+ (if tmp-1
+ (apply (lambda (y z) (f z (lambda (ls) (k
(append y ls))))) tmp-1)
+ (let ((else tmp))
+ (let ((tmp x)) (let ((t tmp)) (list
"list->vector" t)))))))))))))))))
+ (emit (lambda (x)
+ (let ((tmp x))
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
+ (if tmp-1
+ (apply (lambda (x) (list '#(syntax-object quote ((top))
(hygiene guile)) x))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") .
each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp-1 (map emit x)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (t) (cons
'#(syntax-object list ((top)) (hygiene guile)) t))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match
any pattern"
+ tmp-1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") .
#(each+ any (any) ())))))
+ (if tmp-1
+ (apply (lambda (x y)
+ (let f ((x* x))
+ (if (null? x*)
+ (emit y)
+ (let ((tmp-1 (list (emit (car x*))
(f (cdr x*)))))
+ (let ((tmp ($sc-dispatch tmp-1
'(any any))))
+ (if tmp
+ (apply (lambda (t-1 t)
+ (list
'#(syntax-object cons ((top)) (hygiene guile)) t-1 t))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to
match any pattern"
+ tmp-1)))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "append")
. each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp-1 (map emit x)))
+ (let ((tmp ($sc-dispatch tmp-1
'each-any)))
+ (if tmp
+ (apply (lambda (t)
+ (cons
'#(syntax-object append ((top)) (hygiene guile)) t))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to
match any pattern"
+ tmp-1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom
"vector") . each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp-1 (map emit x)))
+ (let ((tmp ($sc-dispatch tmp-1
'each-any)))
+ (if tmp
+ (apply (lambda (t)
+ (cons
'#(syntax-object vector ((top)) (hygiene guile)) t))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression
failed to match any pattern"
+ tmp-1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom
"list->vector") any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp (emit x)))
+ (let ((t tmp))
+ (list '#(syntax-object
list->vector ((top)) (hygiene guile)) t))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp
'(#(atom "value") any))))
+ (if tmp-1
+ (apply (lambda (x) x) tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to
match any pattern"
+ tmp)))))))))))))))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
+ (if tmp
+ (apply (lambda (e) (emit (quasi e 0))) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
(define include
(make-syntax-transformer
'include
'macro
- (lambda (x-29182)
+ (lambda (x)
(letrec*
- ((read-file-29183
- (lambda (fn-29292 k-29293)
- (let ((p-29294 (open-input-file fn-29292)))
- (letrec*
- ((f-29295
- (lambda (x-29349 result-29350)
- (if (eof-object? x-29349)
- (begin
- (close-input-port p-29294)
- (reverse result-29350))
- (f-29295
- (read p-29294)
- (cons (datum->syntax k-29293 x-29349)
- result-29350))))))
- (f-29295 (read p-29294) '()))))))
- (let ((tmp-29185 ($sc-dispatch x-29182 '(any any))))
- (if tmp-29185
- (@apply
- (lambda (k-29189 filename-29190)
- (let ((fn-29191 (syntax->datum filename-29190)))
- (let ((tmp-29192
- (read-file-29183 fn-29191 filename-29190)))
- (let ((tmp-29193 ($sc-dispatch tmp-29192 'each-any)))
- (if tmp-29193
- (@apply
- (lambda (exp-29211)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage () () ())
- #(ribcage #(exp) #((top)) #("l-*-29179"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(fn) #((top)) #("l-*-29174"))
- #(ribcage
- #(k filename)
- #((top) (top))
- #("l-*-29170" "l-*-29171"))
- #(ribcage
- (read-file)
- ((top))
- ("l-*-29154"))
- #(ribcage #(x) #((top)) #("l-*-29153")))
- (hygiene guile))
- exp-29211))
- tmp-29193)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-29192))))))
- tmp-29185)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-29182)))))))
+ ((read-file
+ (lambda (fn k)
+ (let ((p (open-input-file fn)))
+ (let f ((x (read p)) (result '()))
+ (if (eof-object? x)
+ (begin (close-input-port p) (reverse result))
+ (f (read p) (cons (datum->syntax k x) result))))))))
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (k filename)
+ (let ((fn (syntax->datum filename)))
+ (let ((tmp-1 (read-file fn filename)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (exp)
+ (cons '#(syntax-object begin ((top))
(hygiene guile)) exp))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any
pattern"
+ tmp-1))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
(define include-from-path
(make-syntax-transformer
'include-from-path
'macro
- (lambda (x-29369)
- (let ((tmp-29371 ($sc-dispatch x-29369 '(any any))))
- (if tmp-29371
- (@apply
- (lambda (k-29375 filename-29376)
- (let ((fn-29377 (syntax->datum filename-29376)))
- (let ((tmp-29378
- (datum->syntax
- filename-29376
- (let ((t-29381 (%search-load-path fn-29377)))
- (if t-29381
- t-29381
- (syntax-violation
- 'include-from-path
- "file not found in path"
- x-29369
- filename-29376))))))
- (list '#(syntax-object
- include
- ((top)
- #(ribcage () () ())
- #(ribcage #(fn) #((top)) #("l-*-29363"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(fn) #((top)) #("l-*-29359"))
- #(ribcage
- #(k filename)
- #((top) (top))
- #("l-*-29355" "l-*-29356"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29352")))
- (hygiene guile))
- tmp-29378))))
- tmp-29371)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-29369))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (k filename)
+ (let ((fn (syntax->datum filename)))
+ (let ((tmp (datum->syntax
+ filename
+ (let ((t (%search-load-path fn)))
+ (if t
+ t
+ (syntax-violation
+ 'include-from-path
+ "file not found in path"
+ x
+ filename))))))
+ (let ((fn tmp))
+ (list '#(syntax-object include ((top)) (hygiene
guile)) fn)))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
(define unquote
(make-syntax-transformer
'unquote
'macro
- (lambda (x-29390)
+ (lambda (x)
(syntax-violation
'unquote
"expression not valid outside of quasiquote"
- x-29390))))
+ x))))
(define unquote-splicing
(make-syntax-transformer
'unquote-splicing
'macro
- (lambda (x-29393)
+ (lambda (x)
(syntax-violation
'unquote-splicing
"expression not valid outside of quasiquote"
- x-29393))))
-
-(define case
- (make-syntax-transformer
- 'case
- 'macro
- (lambda (x-29449)
- (let ((tmp-29451
- ($sc-dispatch x-29449 '(_ any any . each-any))))
- (if tmp-29451
- (@apply
- (lambda (e-29455 m1-29456 m2-29457)
- (let ((tmp-29458
- (letrec*
- ((f-29500
- (lambda (clause-29503 clauses-29504)
- (if (null? clauses-29504)
- (let ((tmp-29506
- ($sc-dispatch
- clause-29503
- '(#(free-id
- #(syntax-object
- else
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile)))
- any
- .
- each-any))))
- (if tmp-29506
- (@apply
- (lambda (e1-29510 e2-29511)
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(e1 e2)
- #((top) (top))
- #("l-*-29417" "l-*-29418"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile))
- (cons e1-29510 e2-29511)))
- tmp-29506)
- (let ((tmp-29512
- ($sc-dispatch
- clause-29503
- '(each-any any . each-any))))
- (if tmp-29512
- (@apply
- (lambda (k-29516 e1-29517 e2-29518)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top) (top) (top))
- #("l-*-29423"
- "l-*-29424"
- "l-*-29425"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile))
- (list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top)
- (top)
- (top))
- #("l-*-29423"
- "l-*-29424"
- "l-*-29425"))
- #(ribcage () () ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top)
- (top)
- (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top)
- (top)
- (top))
- #("l-*-29423"
- "l-*-29424"
- "l-*-29425"))
- #(ribcage () () ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top)
- (top)
- (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile))
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top)
- (top)
- (top))
-
#("l-*-29423"
-
"l-*-29424"
-
"l-*-29425"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
-
#("l-*-29408"
-
"l-*-29409"
-
"l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top)
- (top)
- (top))
-
#("l-*-29398"
-
"l-*-29399"
-
"l-*-29400"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
-
#("l-*-29395")))
- (hygiene
- guile))
- k-29516))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top)
- (top)
- (top))
- #("l-*-29423"
- "l-*-29424"
- "l-*-29425"))
- #(ribcage () () ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top)
- (top)
- (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile))
- (cons e1-29517
- e2-29518))))
- tmp-29512)
- (syntax-violation
- 'case
- "bad clause"
- x-29449
- clause-29503)))))
- (let ((tmp-29526
- (f-29500
- (car clauses-29504)
- (cdr clauses-29504))))
- (let ((tmp-29529
- ($sc-dispatch
- clause-29503
- '(each-any any . each-any))))
- (if tmp-29529
- (@apply
- (lambda (k-29533 e1-29534 e2-29535)
- (list '#(syntax-object
- if
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top) (top) (top))
- #("l-*-29439"
- "l-*-29440"
- "l-*-29441"))
- #(ribcage () () ())
- #(ribcage
- #(rest)
- #((top))
- #("l-*-29435"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile))
- (list '#(syntax-object
- memv
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top) (top) (top))
- #("l-*-29439"
- "l-*-29440"
- "l-*-29441"))
- #(ribcage () () ())
- #(ribcage
- #(rest)
- #((top))
- #("l-*-29435"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile))
- '#(syntax-object
- t
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top) (top) (top))
- #("l-*-29439"
- "l-*-29440"
- "l-*-29441"))
- #(ribcage () () ())
- #(ribcage
- #(rest)
- #((top))
- #("l-*-29435"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile))
- (list '#(syntax-object
- quote
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top)
- (top)
- (top))
- #("l-*-29439"
- "l-*-29440"
-
"l-*-29441"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(rest)
- #((top))
-
#("l-*-29435"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(f
- clause
- clauses)
- #((top)
- (top)
- (top))
- #("l-*-29408"
- "l-*-29409"
-
"l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top)
- (top)
- (top))
- #("l-*-29398"
- "l-*-29399"
-
"l-*-29400"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
-
#("l-*-29395")))
- (hygiene guile))
- k-29533))
- (cons '#(syntax-object
- begin
- ((top)
- #(ribcage
- #(k e1 e2)
- #((top) (top) (top))
- #("l-*-29439"
- "l-*-29440"
- "l-*-29441"))
- #(ribcage () () ())
- #(ribcage
- #(rest)
- #((top))
- #("l-*-29435"))
- #(ribcage () () ())
- #(ribcage
- #(f clause clauses)
- #((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile))
- (cons e1-29534 e2-29535))
- tmp-29526))
- tmp-29529)
- (syntax-violation
- 'case
- "bad clause"
- x-29449
- clause-29503))))))))
- (f-29500 m1-29456 m2-29457))))
- (let ((body-29459 tmp-29458))
- (list '#(syntax-object
- let
- ((top)
- #(ribcage () () ())
- #(ribcage #(body) #((top)) #("l-*-29406"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-29398" "l-*-29399" "l-*-29400"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29395")))
- (hygiene guile))
- (list (list '#(syntax-object
- t
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(body)
- #((top))
- #("l-*-29406"))
- #(ribcage
- #(e m1 m2)
- #((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
- (hygiene guile))
- e-29455))
- body-29459))))
- tmp-29451)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-29449))))))
+ x))))
(define make-variable-transformer
- (lambda (proc-29553)
- (if (procedure? proc-29553)
- (letrec*
- ((trans-29554
- (lambda (x-29560) (proc-29553 x-29560))))
- (begin
- (set-procedure-property!
- trans-29554
- 'variable-transformer
- #t)
- trans-29554))
- (error "variable transformer not a procedure"
- proc-29553))))
+ (lambda (proc)
+ (if (procedure? proc)
+ (let ((trans (lambda (x) (proc x))))
+ (set-procedure-property! trans 'variable-transformer #t)
+ trans)
+ (error "variable transformer not a procedure" proc))))
(define identifier-syntax
(make-syntax-transformer
'identifier-syntax
'macro
- (lambda (x-29592)
- (let ((tmp-29594 ($sc-dispatch x-29592 '(_ any))))
- (if tmp-29594
- (@apply
- (lambda (e-29598)
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- '(#(syntax-object
- x
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile)))
- '#((#(syntax-object
- macro-type
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- .
- #(syntax-object
- identifier-syntax
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))))
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- '#(syntax-object
- x
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- '()
- (list '#(syntax-object
- id
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- '(#(syntax-object
- identifier?
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- (#(syntax-object
- syntax
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- #(syntax-object
- id
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(e)
- #((top))
- #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- e-29598))
- (list '(#(syntax-object
- _
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- #(syntax-object
- x
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- #(syntax-object
- ...
- ((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile)))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(e)
- #((top))
- #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- (cons e-29598
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(e)
- #((top))
- #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(e)
- #((top))
- #("l-*-29567"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile)))))))))
- tmp-29594)
- (let ((tmp-29599
- ($sc-dispatch
- x-29592
- '(_ (any any)
- ((#(free-id
- #(syntax-object
- set!
- ((top)
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile)))
- any
- any)
- any)))))
- (if (if tmp-29599
- (@apply
- (lambda (id-29603
- exp1-29604
- var-29605
- val-29606
- exp2-29607)
- (if (identifier? id-29603)
- (identifier? var-29605)
- #f))
- tmp-29599)
- #f)
- (@apply
- (lambda (id-29608
- exp1-29609
- var-29610
- val-29611
- exp2-29612)
- (list '#(syntax-object
- make-variable-transformer
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- (list '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile)))
- '#((#(syntax-object
- macro-type
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))
- .
- #(syntax-object
- variable-transformer
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
- (hygiene guile))))
- (list '#(syntax-object
- syntax-case
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- '#(syntax-object
- x
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- '(#(syntax-object
- set!
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile)))
- (list (list '#(syntax-object
- set!
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- var-29610
- val-29611)
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- exp2-29612))
- (list (cons id-29608
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- (cons exp1-29609
- '(#(syntax-object
- x
- ((top)
- #(ribcage
- #(id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- #(syntax-object
- ...
- ((top)
- #(ribcage
- #(id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))))))
- (list id-29608
- (list '#(syntax-object
- identifier?
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(id
- exp1
- var
- val
- exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- id-29608))
- (list '#(syntax-object
- syntax
- ((top)
- #(ribcage
- #(id exp1 var val exp2)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
- (hygiene guile))
- exp1-29609))))))
- tmp-29599)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-29592))))))))
+ (lambda (xx)
+ (let ((tmp-1 xx))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
+ (if tmp
+ (apply (lambda (e)
+ (list '#(syntax-object lambda ((top)) (hygiene guile))
+ '(#(syntax-object x ((top)) (hygiene guile)))
+ '#((#(syntax-object macro-type ((top)) (hygiene
guile))
+ .
+ #(syntax-object identifier-syntax ((top))
(hygiene guile))))
+ (list '#(syntax-object syntax-case ((top)) (hygiene
guile))
+ '#(syntax-object x ((top)) (hygiene guile))
+ '()
+ (list '#(syntax-object id ((top)) (hygiene
guile))
+ '(#(syntax-object identifier? ((top))
(hygiene guile))
+ (#(syntax-object syntax ((top))
(hygiene guile))
+ #(syntax-object id ((top)) (hygiene
guile))))
+ (list '#(syntax-object syntax ((top))
(hygiene guile)) e))
+ (list '(#(syntax-object _ ((top)) (hygiene
guile))
+ #(syntax-object x ((top)) (hygiene
guile))
+ #(syntax-object ... ((top)) (hygiene
guile)))
+ (list '#(syntax-object syntax ((top))
(hygiene guile))
+ (cons e
+ '(#(syntax-object x ((top))
(hygiene guile))
+ #(syntax-object ...
((top)) (hygiene guile)))))))))
+ tmp)
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(_ (any any)
+ ((#(free-id #(syntax-object set! ((top)) (hygiene
guile))) any any)
+ any)))))
+ (if (if tmp
+ (apply (lambda (id exp1 var val exp2)
+ (if (identifier? id) (identifier? var) #f))
+ tmp)
+ #f)
+ (apply (lambda (id exp1 var val exp2)
+ (list '#(syntax-object make-variable-transformer
((top)) (hygiene guile))
+ (list '#(syntax-object lambda ((top)) (hygiene
guile))
+ '(#(syntax-object x ((top)) (hygiene
guile)))
+ '#((#(syntax-object macro-type ((top))
(hygiene guile))
+ .
+ #(syntax-object variable-transformer
((top)) (hygiene guile))))
+ (list '#(syntax-object syntax-case
((top)) (hygiene guile))
+ '#(syntax-object x ((top)) (hygiene
guile))
+ '(#(syntax-object set! ((top))
(hygiene guile)))
+ (list (list '#(syntax-object set!
((top)) (hygiene guile)) var val)
+ (list '#(syntax-object syntax
((top)) (hygiene guile)) exp2))
+ (list (cons id
+ '(#(syntax-object x
((top)) (hygiene guile))
+ #(syntax-object ...
((top)) (hygiene guile))))
+ (list '#(syntax-object syntax
((top)) (hygiene guile))
+ (cons exp1
+ '(#(syntax-object
x ((top)) (hygiene guile))
+ #(syntax-object
... ((top)) (hygiene guile))))))
+ (list id
+ (list '#(syntax-object
identifier? ((top)) (hygiene guile))
+ (list '#(syntax-object
syntax ((top)) (hygiene guile)) id))
+ (list '#(syntax-object syntax
((top)) (hygiene guile)) exp1))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))
(define define*
(make-syntax-transformer
'define*
'macro
- (lambda (x-29644)
- (let ((tmp-29646
- ($sc-dispatch
- x-29644
- '(_ (any . any) any . each-any))))
- (if tmp-29646
- (@apply
- (lambda (id-29650 args-29651 b0-29652 b1-29653)
- (list '#(syntax-object
- define
- ((top)
- #(ribcage
- #(id args b0 b1)
- #((top) (top) (top) (top))
- #("l-*-29626"
- "l-*-29627"
- "l-*-29628"
- "l-*-29629"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29623")))
- (hygiene guile))
- id-29650
- (cons '#(syntax-object
- lambda*
- ((top)
- #(ribcage
- #(id args b0 b1)
- #((top) (top) (top) (top))
- #("l-*-29626"
- "l-*-29627"
- "l-*-29628"
- "l-*-29629"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29623")))
- (hygiene guile))
- (cons args-29651 (cons b0-29652 b1-29653)))))
- tmp-29646)
- (let ((tmp-29654 ($sc-dispatch x-29644 '(_ any any))))
- (if (if tmp-29654
- (@apply
- (lambda (id-29658 val-29659)
- (identifier?
- '#(syntax-object
- x
- ((top)
- #(ribcage
- #(id val)
- #((top) (top))
- #("l-*-29636" "l-*-29637"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29623")))
- (hygiene guile))))
- tmp-29654)
- #f)
- (@apply
- (lambda (id-29660 val-29661)
- (list '#(syntax-object
- define
- ((top)
- #(ribcage
- #(id val)
- #((top) (top))
- #("l-*-29640" "l-*-29641"))
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29623")))
- (hygiene guile))
- id-29660
- val-29661))
- tmp-29654)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- x-29644))))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
+ (if tmp
+ (apply (lambda (id args b0 b1)
+ (list '#(syntax-object define ((top)) (hygiene guile))
+ id
+ (cons '#(syntax-object lambda* ((top)) (hygiene
guile))
+ (cons args (cons b0 b1)))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any any))))
+ (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f)
+ (apply (lambda (id val)
+ (list '#(syntax-object define ((top)) (hygiene
guile)) id val))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 4290069..6c264a6 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -617,22 +617,15 @@
;; syntax object wraps
- ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
- ;; <subst> ::= <shift> | <subs>
- ;; <subs> ::= #(<old name> <label> (<mark> ...))
- ;; <shift> ::= positive fixnum
+ ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
+ ;; <subst> ::= shift | <subs>
+ ;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
+ ;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
(define-syntax make-wrap (identifier-syntax cons))
(define-syntax wrap-marks (identifier-syntax car))
(define-syntax wrap-subst (identifier-syntax cdr))
- (define-syntax subst-rename? (identifier-syntax vector?))
- (define-syntax-rule (rename-old x) (vector-ref x 0))
- (define-syntax-rule (rename-new x) (vector-ref x 1))
- (define-syntax-rule (rename-marks x) (vector-ref x 2))
- (define-syntax-rule (make-rename old new marks)
- (vector old new marks))
-
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define (gen-label)
@@ -2246,7 +2239,9 @@
(syntax-case e ()
((_ (mod ...) id)
(and (and-map id? #'(mod ...)) (id? #'id))
- (values (syntax->datum #'id) r w #f
+ ;; Strip the wrap from the identifier and return
top-wrap
+ ;; so that the identifier will not be captured by
lexicals.
+ (values (syntax->datum #'id) r top-wrap #f
(syntax->datum
#'(public mod ...)))))))
@@ -2269,9 +2264,20 @@
((fx= i n) v)
(vector-set! v i (remodulate (vector-ref x
i) mod)))))
(else x))))
- (syntax-case e ()
- ((_ (mod ...) exp)
+ (syntax-case e (@@)
+ ((_ (mod ...) id)
+ (and (and-map id? #'(mod ...)) (id? #'id))
+ ;; Strip the wrap from the identifier and return
top-wrap
+ ;; so that the identifier will not be captured by
lexicals.
+ (values (syntax->datum #'id) r top-wrap #f
+ (syntax->datum
+ #'(private mod ...))))
+ ((_ @@ (mod ...) exp)
(and-map id? #'(mod ...))
+ ;; This is a special syntax used to support R6RS
library forms.
+ ;; Unlike the syntax above, the last item is not
restricted to
+ ;; be a single identifier, and the syntax objects are
kept
+ ;; intact, with only their module changed.
(let ((mod (syntax->datum #'(private mod ...))))
(values (remodulate #'exp mod)
r w (source-annotation #'exp)
@@ -2451,7 +2457,7 @@
(if (and (id? #'pat)
(and-map (lambda (x) (not (free-id=?
#'pat x)))
(cons #'(... ...) keys)))
- (if (free-id=? #'pad #'_)
+ (if (free-id=? #'pat #'_)
(expand #'exp r empty-wrap mod)
(let ((labels (list (gen-label)))
(var (gen-var #'pat)))
@@ -2775,8 +2781,8 @@
((out ...) (let () e1 e2 ...)))))))
(define-syntax syntax-rules
- (lambda (x)
- (syntax-case x ()
+ (lambda (xx)
+ (syntax-case xx ()
((_ (k ...) ((keyword . pattern) template) ...)
#'(lambda (x)
;; embed patterns as procedure metadata
@@ -2822,30 +2828,6 @@
(binding (car bindings)))
#'(let (binding) body))))))))
-(define-syntax do
- (lambda (orig-x)
- (syntax-case orig-x ()
- ((_ ((var init . step) ...) (e0 e1 ...) c ...)
- (with-syntax (((step ...)
- (map (lambda (v s)
- (syntax-case s ()
- (() v)
- ((e) #'e)
- (_ (syntax-violation
- 'do "bad step expression"
- orig-x s))))
- #'(var ...)
- #'(step ...))))
- (syntax-case #'(e1 ...) ()
- (() #'(let doloop ((var init) ...)
- (if (not e0)
- (begin c ... (doloop step ...)))))
- ((e1 e2 ...)
- #'(let doloop ((var init) ...)
- (if e0
- (begin e1 e2 ...)
- (begin c ... (doloop step ...)))))))))))
-
(define-syntax quasiquote
(let ()
(define (quasi p lev)
@@ -2995,28 +2977,6 @@
"expression not valid outside of quasiquote"
x)))
-(define-syntax case
- (lambda (x)
- (syntax-case x ()
- ((_ e m1 m2 ...)
- (with-syntax
- ((body (let f ((clause #'m1) (clauses #'(m2 ...)))
- (if (null? clauses)
- (syntax-case clause (else)
- ((else e1 e2 ...) #'(begin e1 e2 ...))
- (((k ...) e1 e2 ...)
- #'(if (memv t '(k ...)) (begin e1 e2 ...)))
- (_ (syntax-violation 'case "bad clause" x clause)))
- (with-syntax ((rest (f (car clauses) (cdr clauses))))
- (syntax-case clause (else)
- (((k ...) e1 e2 ...)
- #'(if (memv t '(k ...))
- (begin e1 e2 ...)
- rest))
- (_ (syntax-violation 'case "bad clause" x
- clause))))))))
- #'(let ((t e)) body))))))
-
(define (make-variable-transformer proc)
(if (procedure? proc)
(let ((trans (lambda (x)
@@ -3027,8 +2987,8 @@
(error "variable transformer not a procedure" proc)))
(define-syntax identifier-syntax
- (lambda (x)
- (syntax-case x (set!)
+ (lambda (xx)
+ (syntax-case xx (set!)
((_ e)
#'(lambda (x)
#((macro-type . identifier-syntax))
@@ -3053,5 +3013,5 @@
(syntax-case x ()
((_ (id . args) b0 b1 ...)
#'(define id (lambda* args b0 b1 ...)))
- ((_ id val) (identifier? #'x)
+ ((_ id val) (identifier? #'id)
#'(define id val)))))
diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm
index 072c8c6..bedfbde 100644
--- a/module/ice-9/r4rs.scm
+++ b/module/ice-9/r4rs.scm
@@ -1,7 +1,7 @@
;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
;;;; Jim Blandy <address@hidden> --- October 1996
-;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010, 2011 Free
Software Foundation, Inc.
+;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010, 2011, 2012 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
@@ -131,8 +131,6 @@ file with the given name already exists, the effect is
unspecified."
"Open file with name STR for both input and output."
(open-file str OPEN_BOTH))
-(define close-io-port close-port)
-
(define (call-with-input-file str proc)
"PROC should be a procedure of one argument, and STR should be a
string naming a file. The file must
diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm
index bf1127e..f71b90b 100644
--- a/module/ice-9/r6rs-libraries.scm
+++ b/module/ice-9/r6rs-libraries.scm
@@ -197,7 +197,7 @@
(export e ...)
(re-export r ...)
(export! x ...)
- (@@ (name name* ...) body)
+ (@@ @@ (name name* ...) body)
...))))))))
(define-syntax import
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index fbb03d2..ce1bcac 100644
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -1,4 +1,5 @@
-;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011 Free
Software Foundation, Inc.
+;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011,
+;;;; 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -20,6 +21,7 @@
#:use-module (ice-9 documentation)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
#:export (help
add-value-help-handler! remove-value-help-handler!
add-name-help-handler! remove-name-help-handler!
@@ -504,14 +506,20 @@ It is an image under the mapping EXTRACT."
if the information cannot be obtained.
The alist keys that are currently defined are `required', `optional',
-`keyword', and `rest'."
+`keyword', `allow-other-keys?', and `rest'."
(cond
((procedure-property proc 'arglist)
- => (lambda (arglist)
- `((required . ,(car arglist))
- (optional . ,(cadr arglist))
- (keyword . ,(caddr arglist))
- (rest . ,(car (cddddr arglist))))))
+ => (match-lambda
+ ((req opt keyword aok? rest)
+ `((required . ,(if (number? req)
+ (make-list req '_)
+ req))
+ (optional . ,(if (number? opt)
+ (make-list opt '_)
+ opt))
+ (keyword . ,keyword)
+ (allow-other-keys? . ,aok?)
+ (rest . ,rest)))))
((procedure-source proc)
=> cadr)
(((@ (system vm program) program?) proc)
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 0ed4b6d..a09b374 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -69,26 +69,19 @@
(define block-growth-factor
(make-fluid 2))
-(define-syntax-rule (define-inline (name formals ...) body ...)
- ;; Work around the lack of an inliner.
- (define-syntax name
- (syntax-rules ()
- ((_ formals ...)
- (begin body ...)))))
-
-(define-inline (make-block base offset size hash-tab?)
- ;; Return a block (and block descriptor) of SIZE elements pointing to BASE
- ;; at OFFSET. If HASH-TAB? is true, a "hash table" is also added.
- ;; Note: We use `next-free' instead of `last-used' as suggested by Bagwell.
-
- ;; XXX: We could improve locality here by having a single vector but
currently
- ;; the extra arithmetic outweighs the benefits (!).
- (vector (make-vector size)
- base offset size 0
- (and hash-tab? (make-vector size #f))))
+(define-inlinable (make-block base offset size hash-tab?)
+ ;; Return a block (and block descriptor) of SIZE elements pointing to
+ ;; BASE at OFFSET. If HASH-TAB? is true, we also reserve space for a
+ ;; "hash table". Note: We use `next-free' instead of `last-used' as
+ ;; suggested by Bagwell.
+ (if hash-tab?
+ (vector (make-vector (* size 3) #f)
+ base offset size 0)
+ (vector (make-vector size)
+ base offset size 0)))
(define-syntax-rule (define-block-accessor name index)
- (define-inline (name block)
+ (define-inlinable (name block)
(vector-ref block index)))
(define-block-accessor block-content 0)
@@ -96,33 +89,51 @@
(define-block-accessor block-offset 2)
(define-block-accessor block-size 3)
(define-block-accessor block-next-free 4)
-(define-block-accessor block-hash-table 5)
-(define-inline (increment-block-next-free! block)
- (vector-set! block 4
- (+ (block-next-free block) 1)))
+(define-inlinable (block-hash-table? block)
+ (< (block-size block) (vector-length (block-content block))))
-(define-inline (block-append! block value)
- ;; This is not thread-safe. To fix it, see Section 2.8 of the paper.
- (let ((offset (block-next-free block)))
- (increment-block-next-free! block)
- (vector-set! (block-content block) offset value)
- #t))
-
-(define-inline (block-ref block offset)
- (vector-ref (block-content block) offset))
-
-(define-inline (block-ref* block offset)
- (let ((v (block-ref block offset)))
- (if (block-hash-table block)
- (car v) ;; hide the vhash link
- v)))
-
-(define-inline (block-hash-table-ref block offset)
- (vector-ref (block-hash-table block) offset))
+(define-inlinable (set-block-next-free! block next-free)
+ (vector-set! block 4 next-free))
-(define-inline (block-hash-table-set! block offset value)
- (vector-set! (block-hash-table block) offset value))
+(define-inlinable (block-append! block value offset)
+ ;; This is not thread-safe. To fix it, see Section 2.8 of the paper.
+ (and (< offset (block-size block))
+ (= offset (block-next-free block))
+ (begin
+ (set-block-next-free! block (1+ offset))
+ (vector-set! (block-content block) offset value)
+ #t)))
+
+;; Return the item at slot OFFSET.
+(define-inlinable (block-ref content offset)
+ (vector-ref content offset))
+
+;; Return the offset of the next item in the hash bucket, after the one
+;; at OFFSET.
+(define-inlinable (block-hash-table-next-offset content size offset)
+ (vector-ref content (+ size size offset)))
+
+;; Save the offset of the next item in the hash bucket, after the one
+;; at OFFSET.
+(define-inlinable (block-hash-table-set-next-offset! content size offset
+ next-offset)
+ (vector-set! content (+ size size offset) next-offset))
+
+;; Returns the index of the last entry stored in CONTENT with
+;; SIZE-modulo hash value KHASH.
+(define-inlinable (block-hash-table-ref content size khash)
+ (vector-ref content (+ size khash)))
+
+(define-inlinable (block-hash-table-set! content size khash offset)
+ (vector-set! content (+ size khash) offset))
+
+;; Add hash table information for the item recently added at OFFSET,
+;; with SIZE-modulo hash KHASH.
+(define-inlinable (block-hash-table-add! content size khash offset)
+ (block-hash-table-set-next-offset! content size offset
+ (block-hash-table-ref content size khash))
+ (block-hash-table-set! content size khash offset))
(define block-null
;; The null block.
@@ -149,13 +160,10 @@
(lambda (vl port)
(cond ((vlist-null? vl)
(format port "#<vlist ()>"))
- ((block-hash-table (vlist-base vl))
+ ((vhash? vl)
(format port "#<vhash ~x ~a pairs>"
(object-address vl)
- (vhash-fold (lambda (k v r)
- (+ 1 r))
- 0
- vl)))
+ (vlist-length vl)))
(else
(format port "#<vlist ~a>"
(vlist->list vl))))))
@@ -165,42 +173,61 @@
;; The empty vlist.
(make-vlist block-null 0))
-(define-inline (block-cons item vlist hash-tab?)
- (let loop ((base (vlist-base vlist))
- (offset (+ 1 (vlist-offset vlist))))
- (if (and (< offset (block-size base))
- (= offset (block-next-free base))
- (block-append! base item))
- (make-vlist base offset)
- (let ((size (cond ((eq? base block-null) 1)
- ((< offset (block-size base))
- ;; new vlist head
- 1)
- (else
- (* (fluid-ref block-growth-factor)
- (block-size base))))))
- ;; Prepend a new block pointing to BASE.
- (loop (make-block base (- offset 1) size hash-tab?)
- 0)))))
+;; Asserting that something is a vlist is actually a win if your next
+;; step is to call record accessors, because that causes CSE to
+;; eliminate the type checks in those accessors.
+;;
+(define-inlinable (assert-vlist val)
+ (unless (vlist? val)
+ (throw 'wrong-type-arg
+ #f
+ "Not a vlist: ~S"
+ (list val)
+ (list val))))
+
+(define-inlinable (block-cons item vlist hash-tab?)
+ (let ((base (vlist-base vlist))
+ (offset (1+ (vlist-offset vlist))))
+ (cond
+ ((block-append! base item offset)
+ ;; Fast path: We added the item directly to the block.
+ (make-vlist base offset))
+ (else
+ ;; Slow path: Allocate a new block.
+ (let* ((size (block-size base))
+ (base (make-block
+ base
+ (1- offset)
+ (cond
+ ((zero? size) 1)
+ ((< offset size) 1) ;; new vlist head
+ (else (* (fluid-ref block-growth-factor) size)))
+ hash-tab?)))
+ (set-block-next-free! base 1)
+ (vector-set! (block-content base) 0 item)
+ (make-vlist base 0))))))
(define (vlist-cons item vlist)
"Return a new vlist with @var{item} as its head and @var{vlist} as its
tail."
- ;; Note: Calling `vlist-cons' on a vhash will not do the right thing: it
- ;; doesn't box ITEM so that it can have the hidden "next" link used by
- ;; vhash items, and it passes `#f' as the HASH-TAB? argument to
- ;; `block-cons'. However, inserting all the checks here has an important
- ;; performance penalty, hence this choice.
+ ;; Note: Although the result of `vlist-cons' on a vhash is a valid
+ ;; vlist, it is not a valid vhash. The new item does not get a hash
+ ;; table entry. If we allocate a new block, the new block will not
+ ;; have a hash table. Perhaps we can do something more sensible here,
+ ;; but this is a hot function, so there are performance impacts.
+ (assert-vlist vlist)
(block-cons item vlist #f))
(define (vlist-head vlist)
"Return the head of @var{vlist}."
+ (assert-vlist vlist)
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
- (block-ref* base offset)))
+ (block-ref (block-content base) offset)))
(define (vlist-tail vlist)
"Return the tail of @var{vlist}."
+ (assert-vlist vlist)
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (> offset 0)
@@ -210,6 +237,7 @@ tail."
(define (vlist-null? vlist)
"Return true if @var{vlist} is empty."
+ (assert-vlist vlist)
(let ((base (vlist-base vlist)))
(and (not (block-base base))
(= 0 (block-size base)))))
@@ -226,6 +254,7 @@ tail."
(define (vlist-fold proc init vlist)
"Fold over @var{vlist}, calling @var{proc} for each element."
;; FIXME: Handle multiple lists.
+ (assert-vlist vlist)
(let loop ((base (vlist-base vlist))
(offset (vlist-offset vlist))
(result init))
@@ -235,19 +264,18 @@ tail."
(done? (< next 0)))
(loop (if done? (block-base base) base)
(if done? (block-offset base) next)
- (proc (block-ref* base offset) result))))))
+ (proc (block-ref (block-content base) offset) result))))))
(define (vlist-fold-right proc init vlist)
"Fold over @var{vlist}, calling @var{proc} for each element, starting from
the last element."
- (define len (vlist-length vlist))
-
- (let loop ((index (1- len))
+ (assert-vlist vlist)
+ (let loop ((index (1- (vlist-length vlist)))
(result init))
(if (< index 0)
result
(loop (1- index)
- (proc (vlist-ref vlist index) result)))))
+ (proc (vlist-ref vlist index) result)))))
(define (vlist-reverse vlist)
"Return a new @var{vlist} whose content are those of @var{vlist} in reverse
@@ -267,11 +295,12 @@ order."
(define (vlist-ref vlist index)
"Return the element at index @var{index} in @var{vlist}."
+ (assert-vlist vlist)
(let loop ((index index)
(base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (<= index offset)
- (block-ref* base (- offset index))
+ (block-ref (block-content base) (- offset index))
(loop (- index offset 1)
(block-base base)
(block-offset base)))))
@@ -279,6 +308,7 @@ order."
(define (vlist-drop vlist count)
"Return a new vlist that does not contain the @var{count} first elements of
@var{vlist}."
+ (assert-vlist vlist)
(let loop ((count count)
(base (vlist-base vlist))
(offset (vlist-offset vlist)))
@@ -319,6 +349,7 @@ satisfy @var{pred}."
(define (vlist-length vlist)
"Return the length of @var{vlist}."
+ (assert-vlist vlist)
(let loop ((base (vlist-base vlist))
(len (vlist-offset vlist)))
(if (eq? base block-null)
@@ -371,98 +402,94 @@ details."
;; associated with K1 and K2, respectively. The resulting layout is a
;; follows:
;;
-;; ,--------------------.
-;; | ,-> (K1 . V1) ---. |
-;; | | | |
-;; | | (K2 . V2) <--' |
-;; | | |
-;; +-|------------------+
-;; | | |
-;; | | |
-;; | `-- O <---------------H
-;; | |
-;; `--------------------'
+;; ,--------------------.
+;; 0| ,-> (K1 . V1) | Vlist array
+;; 1| | |
+;; 2| | (K2 . V2) |
+;; 3| | |
+;; size +-|------------------+
+;; 0| | | Hash table
+;; 1| | |
+;; 2| +-- O <------------- H
+;; 3| | |
+;; size * 2 +-|------------------+
+;; 0| `-> 2 | Chain links
+;; 1| |
+;; 2| #f |
+;; 3| |
+;; size * 3 `--------------------'
+;;
+;; The backing store for the vhash is partitioned into three areas: the
+;; vlist part, the hash table part, and the chain links part. In this
+;; example we have a hash H which, when indexed into the hash table
+;; part, indicates that a value with this hash can be found at offset 0
+;; in the vlist part. The corresponding index (in this case, 0) of the
+;; chain links array holds the index of the next element in this block
+;; with this hash value, or #f if we reached the end of the chain.
;;
-;; The bottom part is the "hash table" part of the vhash, as returned by
-;; `block-hash-table'; the other half is the data part. O is the offset of
-;; the first value associated with a key that hashes to H in the data part.
-;; The (K1 . V1) pair has a "hidden" link to the (K2 . V2) pair; hiding the
-;; link is handled by `block-ref'.
-
-;; This API potentially requires users to repeat which hash function and which
-;; equality predicate to use. This can lead to unpredictable results if they
-;; are used in consistenly, e.g., between `vhash-cons' and `vhash-assoc', which
-;; is undesirable, as argued in http://savannah.gnu.org/bugs/?22159 . OTOH,
two
-;; arguments can be made in favor of this API:
+;; This API potentially requires users to repeat which hash function and
+;; which equality predicate to use. This can lead to unpredictable
+;; results if they are used in consistenly, e.g., between `vhash-cons'
+;; and `vhash-assoc', which is undesirable, as argued in
+;; http://savannah.gnu.org/bugs/?22159 . OTOH, two arguments can be
+;; made in favor of this API:
;;
;; - It's consistent with how alists are handled in SRFI-1.
;;
-;; - In practice, users will probably consistenly use either the `q', the `v',
-;; or the plain variant (`vlist-cons' and `vlist-assoc' without any optional
-;; argument), i.e., they will rarely explicitly pass a hash function or
-;; equality predicate.
+;; - In practice, users will probably consistenly use either the `q',
+;; the `v', or the plain variant (`vlist-cons' and `vlist-assoc'
+;; without any optional argument), i.e., they will rarely explicitly
+;; pass a hash function or equality predicate.
(define (vhash? obj)
"Return true if @var{obj} is a hash list."
(and (vlist? obj)
- (let ((base (vlist-base obj)))
- (and base
- (vector? (block-hash-table base))))))
+ (block-hash-table? (vlist-base obj))))
(define* (vhash-cons key value vhash #:optional (hash hash))
"Return a new hash list based on @var{vhash} where @var{key} is associated
with @var{value}. Use @var{hash} to compute @var{key}'s hash."
- (let* ((key+value (cons key value))
- (entry (cons key+value #f))
- (vlist (block-cons entry vhash #t))
- (base (vlist-base vlist))
- (khash (hash key (block-size base))))
-
- (let ((o (block-hash-table-ref base khash)))
- (if o (set-cdr! entry o)))
-
- (block-hash-table-set! base khash
- (vlist-offset vlist))
-
- vlist))
+ (assert-vlist vhash)
+ ;; We should also assert that it is a hash table. Need to check the
+ ;; performance impacts of that. Also, vlist-null is a valid hash
+ ;; table, which does not pass vhash?. A bug, perhaps.
+ (let* ((vhash (block-cons (cons key value) vhash #t))
+ (base (vlist-base vhash))
+ (offset (vlist-offset vhash))
+ (size (block-size base))
+ (khash (hash key size))
+ (content (block-content base)))
+ (block-hash-table-add! content size khash offset)
+ vhash))
(define vhash-consq (cut vhash-cons <> <> <> hashq))
(define vhash-consv (cut vhash-cons <> <> <> hashv))
-(define-inline (%vhash-fold* proc init key vhash equal? hash)
+(define-inlinable (%vhash-fold* proc init key vhash equal? hash)
;; Fold over all the values associated with KEY in VHASH.
- (define khash
- (let ((size (block-size (vlist-base vhash))))
- (and (> size 0) (hash key size))))
-
- (let loop ((base (vlist-base vhash))
- (khash khash)
- (offset (and khash
- (block-hash-table-ref (vlist-base vhash)
- khash)))
- (max-offset (vlist-offset vhash))
- (result init))
-
- (let ((answer (and offset (block-ref base offset))))
- (cond ((and (pair? answer)
- (<= offset max-offset)
- (let ((answer-key (caar answer)))
- (equal? key answer-key)))
- (let ((result (proc (cdar answer) result))
- (next-offset (cdr answer)))
- (loop base khash next-offset max-offset result)))
- ((and (pair? answer) (cdr answer))
- =>
- (lambda (next-offset)
- (loop base khash next-offset max-offset result)))
- (else
- (let ((next-base (block-base base)))
- (if (and next-base (> (block-size next-base) 0))
- (let* ((khash (hash key (block-size next-base)))
- (offset (block-hash-table-ref next-base khash)))
- (loop next-base khash offset (block-offset base)
- result))
- result)))))))
+ (define (visit-block base max-offset result)
+ (let* ((size (block-size base))
+ (content (block-content base))
+ (khash (hash key size)))
+ (let loop ((offset (block-hash-table-ref content size khash))
+ (result result))
+ (if offset
+ (loop (block-hash-table-next-offset content size offset)
+ (if (and (<= offset max-offset)
+ (equal? key (car (block-ref content offset))))
+ (proc (cdr (block-ref content offset)) result)
+ result))
+ (let ((next-block (block-base base)))
+ (if (> (block-size next-block) 0)
+ (visit-block next-block (block-offset base) result)
+ result))))))
+
+ (assert-vlist vhash)
+ (if (> (block-size (vlist-base vhash)) 0)
+ (visit-block (vlist-base vhash)
+ (vlist-offset vhash)
+ init)
+ init))
(define* (vhash-fold* proc init key vhash
#:optional (equal? equal?) (hash hash))
@@ -480,39 +507,29 @@ value of @var{result} for the first call to @var{proc}."
"Same as @code{vhash-fold*}, but using @code{hashv} and @code{eqv?}."
(%vhash-fold* proc init key vhash eqv? hashv))
-(define-inline (%vhash-assoc key vhash equal? hash)
+(define-inlinable (%vhash-assoc key vhash equal? hash)
;; A specialization of `vhash-fold*' that stops when the first value
;; associated with KEY is found or when the end-of-list is reached. Inline
to
;; make sure `vhash-assq' gets to use the `eq?' instruction instead of
calling
;; the `eq?' subr.
- (define khash
- (let ((size (block-size (vlist-base vhash))))
- (and (> size 0) (hash key size))))
-
- (let loop ((base (vlist-base vhash))
- (khash khash)
- (offset (and khash
- (block-hash-table-ref (vlist-base vhash)
- khash)))
- (max-offset (vlist-offset vhash)))
- (let ((answer (and offset (block-ref base offset))))
- (cond ((and (pair? answer)
- (<= offset max-offset)
- (let ((answer-key (caar answer)))
- (equal? key answer-key)))
- (car answer))
- ((and (pair? answer) (cdr answer))
- =>
- (lambda (next-offset)
- (loop base khash next-offset max-offset)))
- (else
- (let ((next-base (block-base base)))
- (and next-base
- (> (block-size next-base) 0)
- (let* ((khash (hash key (block-size next-base)))
- (offset (block-hash-table-ref next-base khash)))
- (loop next-base khash offset
- (block-offset base))))))))))
+ (define (visit-block base max-offset)
+ (let* ((size (block-size base))
+ (content (block-content base))
+ (khash (hash key size)))
+ (let loop ((offset (block-hash-table-ref content size khash)))
+ (if offset
+ (if (and (<= offset max-offset)
+ (equal? key (car (block-ref content offset))))
+ (block-ref content offset)
+ (loop (block-hash-table-next-offset content size offset)))
+ (let ((next-block (block-base base)))
+ (and (> (block-size next-block) 0)
+ (visit-block next-block (block-offset base))))))))
+
+ (assert-vlist vhash)
+ (and (> (block-size (vlist-base vhash)) 0)
+ (visit-block (vlist-base vhash)
+ (vlist-offset vhash))))
(define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
"Return the first key/value pair from @var{vhash} whose key is equal to
diff --git a/module/language/ecmascript/base.scm
b/module/language/ecmascript/base.scm
index b244bec..6f5c65b 100644
--- a/module/language/ecmascript/base.scm
+++ b/module/language/ecmascript/base.scm
@@ -92,7 +92,7 @@
(pdel o (string->symbol p)))
(define-method (has-property? (o <js-object>) p)
- (if (hashq-get-handle (js-props o) v)
+ (if (hashq-get-handle (js-props o) p)
#t
(let ((proto (js-prototype o)))
(if proto
@@ -176,9 +176,9 @@
((boolean? x) (if x 1 0))
((null? x) 0)
((eq? x *undefined*) +nan.0)
- ((is-a? x <js-object>) (object->number x))
+ ((is-a? x <js-object>) (object->number x #t))
((string? x) (string->number x))
- (else (throw 'TypeError o '->number))))
+ (else (throw 'TypeError x '->number))))
(define (->integer x)
(let ((n (->number x)))
diff --git a/module/language/ecmascript/compile-tree-il.scm
b/module/language/ecmascript/compile-tree-il.scm
index a2401f4..b5f0a35 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -70,6 +70,26 @@
(set-source-properties! res (location x))))
res)))
+(define current-return-tag (make-parameter #f))
+
+(define (return expr)
+ (-> (abort (or (current-return-tag) (error "return outside function"))
+ (list expr)
+ (-> (const '())))))
+
+(define (with-return-prompt body-thunk)
+ (let ((tag (gensym "return")))
+ (parameterize ((current-return-tag
+ (-> (lexical 'return tag))))
+ (-> (let '(return) (list tag)
+ (list (-> (apply (-> (primitive 'make-prompt-tag)))))
+ (-> (prompt (current-return-tag)
+ (body-thunk)
+ (let ((val (gensym "val")))
+ (-> (lambda-case
+ `(((k val) #f #f #f () (,(gensym) ,val))
+ ,(-> (lexical 'val val)))))))))))))
+
(define (comp x e)
(let ((l (location x)))
(define (let1 what proc)
@@ -330,7 +350,9 @@
`(lambda ()
(lambda-case
((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*))
formals) ,syms)
- ,(comp-body e body formals syms))))))
+ ,(with-return-prompt
+ (lambda ()
+ (comp-body e body formals syms))))))))
((call/this ,obj ,prop . ,args)
(@impl call/this*
obj
@@ -352,8 +374,7 @@
`(apply ,(comp proc e)
,@(map (lambda (x) (comp x e)) args)))
((return ,expr)
- (-> (apply (-> (primitive 'return))
- (comp expr e))))
+ (return (comp expr e)))
((array . ,args)
`(apply ,(@implv new-array)
,@(map (lambda (x) (comp x e)) args)))
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index a51fd58..83a5007 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -841,6 +841,7 @@
(values `(,@car-code ,@cdr-code (cons))
(1+ addr)))))
((and (vector? x)
+ (<= (vector-length x) #xffff)
(equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
(receive (codes addr)
(vector-fold2 (lambda (x codes addr)
diff --git a/module/language/scheme/decompile-tree-il.scm
b/module/language/scheme/decompile-tree-il.scm
index 9243f4e..9191b2f 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile VM code converters
-;; Copyright (C) 2001,2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2012 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -20,7 +20,796 @@
(define-module (language scheme decompile-tree-il)
#:use-module (language tree-il)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (system base syntax)
#:export (decompile-tree-il))
-(define (decompile-tree-il x env opts)
- (values (tree-il->scheme x) env))
+(define (decompile-tree-il e env opts)
+ (apply do-decompile e env opts))
+
+(define* (do-decompile e env
+ #:key
+ (use-derived-syntax? #t)
+ (avoid-lambda? #t)
+ (use-case? #t)
+ (strip-numeric-suffixes? #f)
+ #:allow-other-keys)
+
+ (receive (output-name-table occurrence-count-table)
+ (choose-output-names e use-derived-syntax? strip-numeric-suffixes?)
+
+ (define (output-name s) (hashq-ref output-name-table s))
+ (define (occurrence-count s) (hashq-ref occurrence-count-table s))
+
+ (define (const x) (lambda (_) x))
+ (define (atom? x) (not (or (pair? x) (vector? x))))
+
+ (define (build-void) '(if #f #f))
+
+ (define (build-begin es)
+ (match es
+ (() (build-void))
+ ((e) e)
+ (_ `(begin ,@es))))
+
+ (define (build-lambda-body e)
+ (match e
+ (('let () body ...) body)
+ (('begin es ...) es)
+ (_ (list e))))
+
+ (define (build-begin-body e)
+ (match e
+ (('begin es ...) es)
+ (_ (list e))))
+
+ (define (build-define name e)
+ (match e
+ ((? (const avoid-lambda?)
+ ('lambda formals body ...))
+ `(define (,name ,@formals) ,@body))
+ ((? (const avoid-lambda?)
+ ('lambda* formals body ...))
+ `(define* (,name ,@formals) ,@body))
+ (_ `(define ,name ,e))))
+
+ (define (build-let names vals body)
+ (match `(let ,(map list names vals)
+ ,@(build-lambda-body body))
+ ((_ () e) e)
+ ((_ (b) ('let* (bs ...) body ...))
+ `(let* (,b ,@bs) ,@body))
+ ((? (const use-derived-syntax?)
+ (_ (b1) ('let (b2) body ...)))
+ `(let* (,b1 ,b2) ,@body))
+ (e e)))
+
+ (define (build-letrec in-order? names vals body)
+ (match `(,(if in-order? 'letrec* 'letrec)
+ ,(map list names vals)
+ ,@(build-lambda-body body))
+ ((_ () e) e)
+ ((_ () body ...) `(let () ,@body))
+ ((_ ((name ('lambda (formals ...) body ...)))
+ (name args ...))
+ (=> failure)
+ (if (= (length formals) (length args))
+ `(let ,name ,(map list formals args) ,@body)
+ (failure)))
+ ((? (const avoid-lambda?)
+ ('letrec* _ body ...))
+ `(let ()
+ ,@(map build-define names vals)
+ ,@body))
+ (e e)))
+
+ (define (build-if test consequent alternate)
+ (match alternate
+ (('if #f _) `(if ,test ,consequent))
+ (_ `(if ,test ,consequent ,alternate))))
+
+ (define (build-and xs)
+ (match xs
+ (() #t)
+ ((x) x)
+ (_ `(and ,@xs))))
+
+ (define (build-or xs)
+ (match xs
+ (() #f)
+ ((x) x)
+ (_ `(or ,@xs))))
+
+ (define (case-test-var test)
+ (match test
+ (('memv (? atom? v) ('quote (datums ...)))
+ v)
+ (('eqv? (? atom? v) ('quote datum))
+ v)
+ (_ #f)))
+
+ (define (test->datums v test)
+ (match (cons v test)
+ ((v 'memv v ('quote (xs ...)))
+ xs)
+ ((v 'eqv? v ('quote x))
+ (list x))
+ (_ #f)))
+
+ (define (build-else-tail e)
+ (match e
+ (('if #f _) '())
+ (('and xs ... x) `((,(build-and xs) ,@(build-begin-body x))
+ (else #f)))
+ (_ `((else ,@(build-begin-body e))))))
+
+ (define (build-cond-else-tail e)
+ (match e
+ (('cond clauses ...) clauses)
+ (_ (build-else-tail e))))
+
+ (define (build-case-else-tail v e)
+ (match (cons v e)
+ ((v 'case v clauses ...)
+ clauses)
+ ((v 'if ('memv v ('quote (xs ...))) consequent . alternate*)
+ `((,xs ,@(build-begin-body consequent))
+ ,@(build-case-else-tail v (build-begin alternate*))))
+ ((v 'if ('eqv? v ('quote x)) consequent . alternate*)
+ `(((,x) ,@(build-begin-body consequent))
+ ,@(build-case-else-tail v (build-begin alternate*))))
+ (_ (build-else-tail e))))
+
+ (define (clauses+tail clauses)
+ (match clauses
+ ((cs ... (and c ('else . _))) (values cs (list c)))
+ (_ (values clauses '()))))
+
+ (define (build-cond tests consequents alternate)
+ (case (length tests)
+ ((0) alternate)
+ ((1) (build-if (car tests) (car consequents) alternate))
+ (else `(cond ,@(map (lambda (test consequent)
+ `(,test ,@(build-begin-body consequent)))
+ tests consequents)
+ ,@(build-cond-else-tail alternate)))))
+
+ (define (build-cond-or-case tests consequents alternate)
+ (if (not use-case?)
+ (build-cond tests consequents alternate)
+ (let* ((v (and (not (null? tests))
+ (case-test-var (car tests))))
+ (datum-lists (take-while identity
+ (map (cut test->datums v <>)
+ tests)))
+ (n (length datum-lists))
+ (tail (build-case-else-tail v (build-cond
+ (drop tests n)
+ (drop consequents n)
+ alternate))))
+ (receive (clauses tail) (clauses+tail tail)
+ (let ((n (+ n (length clauses)))
+ (datum-lists (append datum-lists
+ (map car clauses)))
+ (consequents (append consequents
+ (map build-begin
+ (map cdr clauses)))))
+ (if (< n 2)
+ (build-cond tests consequents alternate)
+ `(case ,v
+ ,@(map cons datum-lists (map build-begin-body
+ (take consequents n)))
+ ,@tail)))))))
+
+ (define (recurse e)
+
+ (define (recurse-body e)
+ (build-lambda-body (recurse e)))
+
+ (record-case e
+ ((<void>)
+ (build-void))
+
+ ((<const> exp)
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ `(quote ,exp)))
+
+ ((<sequence> exps)
+ (build-begin (map recurse exps)))
+
+ ((<application> proc args)
+ (match `(,(recurse proc) ,@(map recurse args))
+ ((('lambda (formals ...) body ...) args ...)
+ (=> failure)
+ (if (= (length formals) (length args))
+ (build-let formals args (build-begin body))
+ (failure)))
+ (e e)))
+
+ ((<primitive-ref> name)
+ name)
+
+ ((<lexical-ref> gensym)
+ (output-name gensym))
+
+ ((<lexical-set> gensym exp)
+ `(set! ,(output-name gensym) ,(recurse exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp)))
+
+ ((<toplevel-ref> name)
+ name)
+
+ ((<toplevel-set> name exp)
+ `(set! ,name ,(recurse exp)))
+
+ ((<toplevel-define> name exp)
+ (build-define name (recurse exp)))
+
+ ((<lambda> meta body)
+ (let ((body (recurse body))
+ (doc (assq-ref meta 'documentation)))
+ (if (not doc)
+ body
+ (match body
+ (('lambda formals body ...)
+ `(lambda ,formals ,doc ,@body))
+ (('lambda* formals body ...)
+ `(lambda* ,formals ,doc ,@body))
+ (('case-lambda (formals body ...) clauses ...)
+ `(case-lambda (,formals ,doc ,@body) ,@clauses))
+ (('case-lambda* (formals body ...) clauses ...)
+ `(case-lambda* (,formals ,doc ,@body) ,@clauses))
+ (e e)))))
+
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ (let ((names (map output-name gensyms)))
+ (cond
+ ((and (not opt) (not kw) (not alternate))
+ `(lambda ,(if rest (apply cons* names) names)
+ ,@(recurse-body body)))
+ ((and (not opt) (not kw))
+ (let ((alt-expansion (recurse alternate))
+ (formals (if rest (apply cons* names) names)))
+ (case (car alt-expansion)
+ ((lambda)
+ `(case-lambda (,formals ,@(recurse-body body))
+ ,(cdr alt-expansion)))
+ ((lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,(cdr alt-expansion)))
+ ((case-lambda)
+ `(case-lambda (,formals ,@(recurse-body body))
+ ,@(cdr alt-expansion)))
+ ((case-lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,@(cdr alt-expansion))))))
+ (else
+ (let* ((alt-expansion (and alternate (recurse alternate)))
+ (nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (restargs (if rest (list-ref names (+ nreq nopt)) '()))
+ (reqargs (list-head names nreq))
+ (optargs (if opt
+ `(#:optional
+ ,@(map list
+ (list-head (list-tail names nreq)
nopt)
+ (map recurse
+ (list-head inits nopt))))
+ '()))
+ (kwargs (if kw
+ `(#:key
+ ,@(map list
+ (map output-name (map caddr (cdr kw)))
+ (map recurse
+ (list-tail inits nopt))
+ (map car (cdr kw)))
+ ,@(if (car kw)
+ '(#:allow-other-keys)
+ '()))
+ '()))
+ (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
+ (if (not alt-expansion)
+ `(lambda* ,formals ,@(recurse-body body))
+ (case (car alt-expansion)
+ ((lambda lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,(cdr alt-expansion)))
+ ((case-lambda case-lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,@(cdr alt-expansion))))))))))
+
+ ((<conditional> test consequent alternate)
+ (define (simplify-test e)
+ (match e
+ (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b)))
+ `(memv ,v '(,a ,b)))
+ (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs
...))))
+ `(memv ,v '(,a ,@bs)))
+ (('case (? atom? v)
+ ((datum) #t) ...
+ ('else ('eqv? v ('quote last-datum))))
+ `(memv ,v '(,@datum ,last-datum)))
+ (_ e)))
+ (match `(if ,(simplify-test (recurse test))
+ ,(recurse consequent)
+ ,@(if (void? alternate) '()
+ (list (recurse alternate))))
+ (('if test ('if ('and xs ...) consequent))
+ (build-if (build-and (cons test xs))
+ consequent
+ (build-void)))
+ ((? (const use-derived-syntax?)
+ ('if test1 ('if test2 consequent)))
+ (build-if (build-and (list test1 test2))
+ consequent
+ (build-void)))
+ (('if (? atom? x) x ('or ys ...))
+ (build-or (cons x ys)))
+ ((? (const use-derived-syntax?)
+ ('if (? atom? x) x y))
+ (build-or (list x y)))
+ (('if test consequent)
+ `(if ,test ,consequent))
+ (('if test ('and xs ...) #f)
+ (build-and (cons test xs)))
+ ((? (const use-derived-syntax?)
+ ('if test consequent #f))
+ (build-and (list test consequent)))
+ ((? (const use-derived-syntax?)
+ ('if test1 consequent1
+ ('if test2 consequent2 . alternate*)))
+ (build-cond-or-case (list test1 test2)
+ (list consequent1 consequent2)
+ (build-begin alternate*)))
+ (('if test consequent ('cond clauses ...))
+ `(cond (,test ,@(build-begin-body consequent))
+ ,@clauses))
+ (('if ('memv (? atom? v) ('quote (xs ...))) consequent
+ ('case v clauses ...))
+ `(case ,v (,xs ,@(build-begin-body consequent))
+ ,@clauses))
+ (('if ('eqv? (? atom? v) ('quote x)) consequent
+ ('case v clauses ...))
+ `(case ,v ((,x) ,@(build-begin-body consequent))
+ ,@clauses))
+ (e e)))
+
+ ((<let> gensyms vals body)
+ (match (build-let (map output-name gensyms)
+ (map recurse vals)
+ (recurse body))
+ (('let ((v e)) ('or v xs ...))
+ (=> failure)
+ (if (and (not (null? gensyms))
+ (= 3 (occurrence-count (car gensyms))))
+ `(or ,e ,@xs)
+ (failure)))
+ (('let ((v e)) ('case v clauses ...))
+ (=> failure)
+ (if (and (not (null? gensyms))
+ ;; FIXME: This fails if any of the 'memv's were
+ ;; optimized into multiple 'eqv?'s, because the
+ ;; occurrence count will be higher than we expect.
+ (= (occurrence-count (car gensyms))
+ (1+ (length (clauses+tail clauses)))))
+ `(case ,e ,@clauses)
+ (failure)))
+ (e e)))
+
+ ((<letrec> in-order? gensyms vals body)
+ (build-letrec in-order?
+ (map output-name gensyms)
+ (map recurse vals)
+ (recurse body)))
+
+ ((<fix> gensyms vals body)
+ ;; not a typo, we really do translate back to letrec. use letrec*
since it
+ ;; doesn't matter, and the naive letrec* transformation does not
require an
+ ;; inner let.
+ (build-letrec #t
+ (map output-name gensyms)
+ (map recurse vals)
+ (recurse body)))
+
+ ((<let-values> exp body)
+ `(call-with-values (lambda () ,@(recurse-body exp))
+ ,(recurse (make-lambda #f '() body))))
+
+ ((<dynwind> body winder unwinder)
+ `(dynamic-wind ,(recurse winder)
+ (lambda () ,@(recurse-body body))
+ ,(recurse unwinder)))
+
+ ((<dynlet> fluids vals body)
+ `(with-fluids ,(map list
+ (map recurse fluids)
+ (map recurse vals))
+ ,@(recurse-body body)))
+
+ ((<dynref> fluid)
+ `(fluid-ref ,(recurse fluid)))
+
+ ((<dynset> fluid exp)
+ `(fluid-set! ,(recurse fluid) ,(recurse exp)))
+
+ ((<prompt> tag body handler)
+ `(call-with-prompt
+ ,(recurse tag)
+ (lambda () ,@(recurse-body body))
+ ,(recurse handler)))
+
+
+ ((<abort> tag args tail)
+ `(apply abort ,(recurse tag) ,@(map recurse args)
+ ,(recurse tail)))))
+ (values (recurse e) env)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Algorithm for choosing better variable names
+;; ============================================
+;;
+;; First we perform an analysis pass, collecting the following
+;; information:
+;;
+;; * For each gensym: how many occurrences will occur in the output?
+;;
+;; * For each gensym A: which gensyms does A conflict with? Gensym A
+;; and gensym B conflict if they have the same base name (usually the
+;; same as the source name, but see below), and if giving them the
+;; same name would cause a bad variable reference due to unintentional
+;; variable capture.
+;;
+;; The occurrence counter is indexed by gensym and is global (within each
+;; invocation of the algorithm), implemented using a hash table. We also
+;; keep a global mapping from gensym to source name as provided by the
+;; binding construct (we prefer not to trust the source names in the
+;; lexical ref or set).
+;;
+;; As we recurse down into lexical binding forms, we keep track of a
+;; mapping from base name to an ordered list of bindings, innermost
+;; first. When we encounter a variable occurrence, we increment the
+;; counter, look up the base name (preferring not to trust the 'name' in
+;; the lexical ref or set), and then look up the bindings currently in
+;; effect for that base name. Hopefully our gensym will be the first
+;; (innermost) binding. If not, we register a conflict between the
+;; referenced gensym and the other bound gensyms with the same base name
+;; that shadow the binding we want. These are simply the gensyms on the
+;; binding list that come before our gensym.
+;;
+;; Top-level bindings are treated specially. Whenever top-level
+;; references are found, they conflict with every lexical binding
+;; currently in effect with the same base name. They are guaranteed to
+;; be assigned to their source names. For purposes of recording
+;; conflicts (which are normally keyed on gensyms) top-level identifiers
+;; are assigned a pseudo-gensym that is an interned pair of the form
+;; (top-level . <name>). This allows them to be compared using 'eq?'
+;; like other gensyms.
+;;
+;; The base name is normally just the source name. However, if the
+;; source name has a suffix of the form "-N" (where N is a positive
+;; integer without leading zeroes), then we strip that suffix (multiple
+;; times if necessary) to form the base name. We must do this because
+;; we add suffixes of that form in order to resolve conflicts, and we
+;; must ensure that only identifiers with the same base name can
+;; possibly conflict with each other.
+;;
+;; XXX FIXME: Currently, primitives are treated exactly like top-level
+;; bindings. This handles conflicting lexical bindings properly, but
+;; does _not_ handle the case where top-level bindings conflict with the
+;; needed primitives.
+;;
+;; Also note that this requires that 'choose-output-names' be kept in
+;; sync with 'tree-il->scheme'. Primitives that are introduced by
+;; 'tree-il->scheme' must be anticipated by 'choose-output-name'.
+;;
+;; We also ensure that lexically-bound identifiers found in operator
+;; position will never be assigned one of the standard primitive names.
+;; This is needed because 'tree-il->scheme' recognizes primitive names
+;; in operator position and assumes that they have the standard
+;; bindings.
+;;
+;;
+;; How we assign an output name to each gensym
+;; ===========================================
+;;
+;; We process the gensyms in order of decreasing occurrence count, with
+;; each gensym choosing the best output name possible, as long as it
+;; isn't the same name as any of the previously-chosen output names of
+;; conflicting gensyms.
+;;
+
+
+;;
+;; 'choose-output-names' analyzes the top-level form e, chooses good
+;; variable names that are as close as possible to the source names,
+;; and returns two values:
+;;
+;; * a hash table mapping gensym to output name
+;; * a hash table mapping gensym to number of occurrences
+;;
+(define choose-output-names
+ (let ()
+ (define primitive?
+ ;; This is a list of primitives that 'tree-il->scheme' assumes
+ ;; will have the standard bindings when found in operator
+ ;; position.
+ (let* ((primitives '(if quote @ @@ set! define define*
+ begin let let* letrec letrec*
+ and or cond case
+ lambda lambda* case-lambda case-lambda*
+ apply call-with-values dynamic-wind
+ with-fluids fluid-ref fluid-set!
+ call-with-prompt abort memv eqv?))
+ (table (make-hash-table (length primitives))))
+ (for-each (cut hashq-set! table <> #t) primitives)
+ (lambda (name) (hashq-ref table name))))
+
+ ;; Repeatedly strip suffix of the form "-N", where N is a string
+ ;; that could be produced by number->string given a positive
+ ;; integer. In other words, the first digit of N may not be 0.
+ (define compute-base-name
+ (let ((digits (string->char-set "0123456789")))
+ (define (base-name-string str)
+ (let ((i (string-skip-right str digits)))
+ (if (and i (< (1+ i) (string-length str))
+ (eq? #\- (string-ref str i))
+ (not (eq? #\0 (string-ref str (1+ i)))))
+ (base-name-string (substring str 0 i))
+ str)))
+ (lambda (sym)
+ (string->symbol (base-name-string (symbol->string sym))))))
+
+ ;; choose-output-names
+ (lambda (e use-derived-syntax? strip-numeric-suffixes?)
+
+ (define lexical-gensyms '())
+
+ (define top-level-intern!
+ (let ((table (make-hash-table)))
+ (lambda (name)
+ (let ((h (hashq-create-handle! table name #f)))
+ (or (cdr h) (begin (set-cdr! h (cons 'top-level name))
+ (cdr h)))))))
+ (define (top-level? s) (pair? s))
+ (define (top-level-name s) (cdr s))
+
+ (define occurrence-count-table (make-hash-table))
+ (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0))
+ (define (increment-occurrence-count! s)
+ (let ((h (hashq-create-handle! occurrence-count-table s 0)))
+ (if (zero? (cdr h))
+ (set! lexical-gensyms (cons s lexical-gensyms)))
+ (set-cdr! h (1+ (cdr h)))))
+
+ (define base-name
+ (let ((table (make-hash-table)))
+ (lambda (name)
+ (let ((h (hashq-create-handle! table name #f)))
+ (or (cdr h) (begin (set-cdr! h (compute-base-name name))
+ (cdr h)))))))
+
+ (define source-name-table (make-hash-table))
+ (define (set-source-name! s name)
+ (if (not (top-level? s))
+ (let ((name (if strip-numeric-suffixes?
+ (base-name name)
+ name)))
+ (hashq-set! source-name-table s name))))
+ (define (source-name s)
+ (if (top-level? s)
+ (top-level-name s)
+ (hashq-ref source-name-table s)))
+
+ (define conflict-table (make-hash-table))
+ (define (conflicts s) (or (hashq-ref conflict-table s) '()))
+ (define (add-conflict! a b)
+ (define (add! a b)
+ (if (not (top-level? a))
+ (let ((h (hashq-create-handle! conflict-table a '())))
+ (if (not (memq b (cdr h)))
+ (set-cdr! h (cons b (cdr h)))))))
+ (add! a b)
+ (add! b a))
+
+ (let recurse-with-bindings ((e e) (bindings vlist-null))
+ (let recurse ((e e))
+
+ ;; We call this whenever we encounter a top-level ref or set
+ (define (top-level name)
+ (let ((bname (base-name name)))
+ (let ((s (top-level-intern! name))
+ (conflicts (vhash-foldq* cons '() bname bindings)))
+ (for-each (cut add-conflict! s <>) conflicts))))
+
+ ;; We call this whenever we encounter a primitive reference.
+ ;; We must also call it for every primitive that might be
+ ;; inserted by 'tree-il->scheme'. It is okay to call this
+ ;; even when 'tree-il->scheme' will not insert the named
+ ;; primitive; the worst that will happen is for a lexical
+ ;; variable of the same name to be renamed unnecessarily.
+ (define (primitive name) (top-level name))
+
+ ;; We call this whenever we encounter a lexical ref or set.
+ (define (lexical s)
+ (increment-occurrence-count! s)
+ (let ((conflicts
+ (take-while
+ (lambda (s*) (not (eq? s s*)))
+ (reverse! (vhash-foldq* cons
+ '()
+ (base-name (source-name s))
+ bindings)))))
+ (for-each (cut add-conflict! s <>) conflicts)))
+
+ (record-case e
+ ((<void>) (primitive 'if)) ; (if #f #f)
+ ((<const>) (primitive 'quote))
+
+ ((<application> proc args)
+ (if (lexical-ref? proc)
+ (let* ((gensym (lexical-ref-gensym proc))
+ (name (source-name gensym)))
+ ;; If the operator position contains a bare variable
+ ;; reference with the same source name as a standard
+ ;; primitive, we must ensure that it will be given a
+ ;; different name, so that 'tree-il->scheme' will not
+ ;; misinterpret the resulting expression.
+ (if (primitive? name)
+ (add-conflict! gensym (top-level-intern! name)))))
+ (recurse proc)
+ (for-each recurse args))
+
+ ((<primitive-ref> name) (primitive name))
+
+ ((<lexical-ref> gensym) (lexical gensym))
+ ((<lexical-set> gensym exp)
+ (primitive 'set!) (lexical gensym) (recurse exp))
+
+ ((<module-ref> public?) (primitive (if public? '@ '@@)))
+ ((<module-set> public? exp)
+ (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp))
+
+ ((<toplevel-ref> name) (top-level name))
+ ((<toplevel-set> name exp)
+ (primitive 'set!) (top-level name) (recurse exp))
+ ((<toplevel-define> name exp) (top-level name) (recurse exp))
+
+ ((<conditional> test consequent alternate)
+ (cond (use-derived-syntax?
+ (primitive 'and) (primitive 'or)
+ (primitive 'cond) (primitive 'case)
+ (primitive 'else) (primitive '=>)))
+ (primitive 'if)
+ (recurse test) (recurse consequent) (recurse alternate))
+
+ ((<sequence> exps) (primitive 'begin) (for-each recurse exps))
+ ((<lambda> body) (recurse body))
+
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ (primitive 'lambda)
+ (cond ((or opt kw alternate)
+ (primitive 'lambda*)
+ (primitive 'case-lambda)
+ (primitive 'case-lambda*)))
+ (primitive 'let)
+ (if use-derived-syntax? (primitive 'let*))
+ (let* ((names (append req (or opt '()) (if rest (list rest) '())
+ (map cadr (if kw (cdr kw) '()))))
+ (base-names (map base-name names))
+ (body-bindings
+ (fold vhash-consq bindings base-names gensyms)))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (for-each recurse inits)
+ (recurse-with-bindings body body-bindings)
+ (if alternate (recurse alternate))))
+
+ ((<let> names gensyms vals body)
+ (primitive 'let)
+ (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (for-each recurse vals)
+ (recurse-with-bindings
+ body (fold vhash-consq bindings (map base-name names) gensyms)))
+
+ ((<letrec> in-order? names gensyms vals body)
+ (primitive 'let)
+ (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
+ (primitive (if in-order? 'letrec* 'letrec))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (let* ((base-names (map base-name names))
+ (bindings (fold vhash-consq bindings base-names gensyms)))
+ (for-each (cut recurse-with-bindings <> bindings) vals)
+ (recurse-with-bindings body bindings)))
+
+ ((<fix> names gensyms vals body)
+ (primitive 'let)
+ (primitive 'letrec*)
+ (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (let* ((base-names (map base-name names))
+ (bindings (fold vhash-consq bindings base-names gensyms)))
+ (for-each (cut recurse-with-bindings <> bindings) vals)
+ (recurse-with-bindings body bindings)))
+
+ ((<let-values> exp body)
+ (primitive 'call-with-values)
+ (recurse exp) (recurse body))
+
+ ((<dynwind> winder body unwinder)
+ (primitive 'dynamic-wind)
+ (recurse winder) (recurse body) (recurse unwinder))
+
+ ((<dynlet> fluids vals body)
+ (primitive 'with-fluids)
+ (for-each recurse fluids)
+ (for-each recurse vals)
+ (recurse body))
+
+ ((<dynref> fluid) (primitive 'fluid-ref) (recurse fluid))
+ ((<dynset> fluid exp)
+ (primitive 'fluid-set!) (recurse fluid) (recurse exp))
+
+ ((<prompt> tag body handler)
+ (primitive 'call-with-prompt)
+ (primitive 'lambda)
+ (recurse tag) (recurse body) (recurse handler))
+
+ ((<abort> tag args tail)
+ (primitive 'apply)
+ (primitive 'abort)
+ (recurse tag) (for-each recurse args) (recurse tail)))))
+
+ (let ()
+ (define output-name-table (make-hash-table))
+ (define (set-output-name! s name)
+ (hashq-set! output-name-table s name))
+ (define (output-name s)
+ (if (top-level? s)
+ (top-level-name s)
+ (hashq-ref output-name-table s)))
+
+ (define sorted-lexical-gensyms
+ (sort-list lexical-gensyms
+ (lambda (a b) (> (occurrence-count a)
+ (occurrence-count b)))))
+
+ (for-each (lambda (s)
+ (set-output-name!
+ s
+ (let ((the-conflicts (conflicts s))
+ (the-source-name (source-name s)))
+ (define (not-yet-taken? name)
+ (not (any (lambda (s*)
+ (and=> (output-name s*)
+ (cut eq? name <>)))
+ the-conflicts)))
+ (if (not-yet-taken? the-source-name)
+ the-source-name
+ (let ((prefix (string-append
+ (symbol->string the-source-name)
+ "-")))
+ (let loop ((i 1) (name the-source-name))
+ (if (not-yet-taken? name)
+ name
+ (loop (+ i 1)
+ (string->symbol
+ (string-append
+ prefix
+ (number->string i)))))))))))
+ sorted-lexical-gensyms)
+ (values output-name-table occurrence-count-table)))))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1d391c4..1ac1809 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 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
@@ -59,7 +59,10 @@
tree-il-fold
make-tree-il-folder
post-order!
- pre-order!))
+ pre-order!
+
+ tree-il=?
+ tree-il-hash))
(define (print-tree-il exp port)
(format port "#<tree-il ~S>" (unparse-tree-il exp)))
@@ -331,155 +334,10 @@
`(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
,(unparse-tree-il tail)))))
-(define (tree-il->scheme e)
- (record-case e
- ((<void>)
- '(if #f #f))
-
- ((<application> proc args)
- `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
-
- ((<conditional> test consequent alternate)
- (if (void? alternate)
- `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent))
- `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent)
,(tree-il->scheme alternate))))
-
- ((<primitive-ref> name)
- name)
-
- ((<lexical-ref> gensym)
- gensym)
-
- ((<lexical-set> 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> meta body)
- ;; fixme: put in docstring
- (tree-il->scheme body))
-
- ((<lambda-case> req opt rest kw inits gensyms body alternate)
- (cond
- ((and (not opt) (not kw) (not alternate))
- `(lambda ,(if rest (apply cons* gensyms) gensyms)
- ,(tree-il->scheme body)))
- ((and (not opt) (not kw))
- (let ((alt-expansion (tree-il->scheme alternate))
- (formals (if rest (apply cons* gensyms) gensyms)))
- (case (car alt-expansion)
- ((lambda)
- `(case-lambda (,formals ,(tree-il->scheme body))
- ,(cdr alt-expansion)))
- ((lambda*)
- `(case-lambda* (,formals ,(tree-il->scheme body))
- ,(cdr alt-expansion)))
- ((case-lambda)
- `(case-lambda (,formals ,(tree-il->scheme body))
- ,@(cdr alt-expansion)))
- ((case-lambda*)
- `(case-lambda* (,formals ,(tree-il->scheme body))
- ,@(cdr alt-expansion))))))
- (else
- (let* ((alt-expansion (and alternate (tree-il->scheme alternate)))
- (nreq (length req))
- (nopt (if opt (length opt) 0))
- (restargs (if rest (list-ref gensyms (+ nreq nopt)) '()))
- (reqargs (list-head gensyms nreq))
- (optargs (if opt
- `(#:optional
- ,@(map list
- (list-head (list-tail gensyms nreq) nopt)
- (map tree-il->scheme
- (list-head inits nopt))))
- '()))
- (kwargs (if kw
- `(#:key
- ,@(map list
- (map caddr (cdr kw))
- (map tree-il->scheme
- (list-tail inits nopt))
- (map car (cdr kw)))
- ,@(if (car kw)
- '(#:allow-other-keys)
- '()))
- '()))
- (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
- (if (not alt-expansion)
- `(lambda* ,formals ,(tree-il->scheme body))
- (case (car alt-expansion)
- ((lambda lambda*)
- `(case-lambda* (,formals ,(tree-il->scheme body))
- ,(cdr alt-expansion)))
- ((case-lambda case-lambda*)
- `(case-lambda* (,formals ,(tree-il->scheme body))
- ,@(cdr alt-expansion)))))))))
-
- ((<const> exp)
- (if (and (self-evaluating? exp) (not (vector? exp)))
- exp
- (list 'quote exp)))
-
- ((<sequence> exps)
- `(begin ,@(map tree-il->scheme exps)))
-
- ((<let> gensyms vals body)
- `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
-
- ((<letrec> in-order? gensyms vals body)
- `(,(if in-order? 'letrec* 'letrec)
- ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
-
- ((<fix> gensyms vals body)
- ;; not a typo, we really do translate back to letrec. use letrec* since it
- ;; doesn't matter, and the naive letrec* transformation does not require
an
- ;; inner let.
- `(letrec* ,(map list gensyms (map tree-il->scheme vals))
,(tree-il->scheme body)))
-
- ((<let-values> exp body)
- `(call-with-values (lambda () ,(tree-il->scheme exp))
- ,(tree-il->scheme (make-lambda #f '() body))))
-
- ((<dynwind> body winder unwinder)
- `(dynamic-wind ,(tree-il->scheme winder)
- (lambda () ,(tree-il->scheme body))
- ,(tree-il->scheme unwinder)))
-
- ((<dynlet> fluids vals body)
- `(with-fluids ,(map list
- (map tree-il->scheme fluids)
- (map tree-il->scheme vals))
- ,(tree-il->scheme body)))
-
- ((<dynref> fluid)
- `(fluid-ref ,(tree-il->scheme fluid)))
-
- ((<dynset> fluid exp)
- `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp)))
-
- ((<prompt> tag body handler)
- `(call-with-prompt
- ,(tree-il->scheme tag)
- (lambda () ,(tree-il->scheme body))
- ,(tree-il->scheme handler)))
-
-
- ((<abort> tag args tail)
- `(apply abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args)
- ,(tree-il->scheme tail)))))
+(define* (tree-il->scheme e #:optional (env #f) (opts '()))
+ (values ((@ (language scheme decompile-tree-il)
+ decompile-tree-il)
+ e env opts)))
(define (tree-il-fold leaf down up seed tree)
@@ -792,3 +650,67 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(else #f))
x)))
+
+;; FIXME: We should have a better primitive than this.
+(define (struct-nfields x)
+ (/ (string-length (symbol->string (struct-layout x))) 2))
+
+(define (tree-il=? a b)
+ (cond
+ ((struct? a)
+ (and (struct? b)
+ (eq? (struct-vtable a) (struct-vtable b))
+ ;; Assume that all structs are tree-il, so we skip over the
+ ;; src slot.
+ (let lp ((n (1- (struct-nfields a))))
+ (or (zero? n)
+ (and (tree-il=? (struct-ref a n) (struct-ref b n))
+ (lp (1- n)))))))
+ ((pair? a)
+ (and (pair? b)
+ (tree-il=? (car a) (car b))
+ (tree-il=? (cdr a) (cdr b))))
+ (else
+ (equal? a b))))
+
+(define-syntax hash-bits
+ (make-variable-transformer
+ (lambda (x)
+ (syntax-case x ()
+ (var
+ (identifier? #'var)
+ (logcount most-positive-fixnum))))))
+
+(define (tree-il-hash exp)
+ (let ((hash-depth 4)
+ (hash-width 3))
+ (define (hash-exp exp depth)
+ (define (rotate x bits)
+ (logior (ash x (- bits))
+ (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
+ (define (mix h1 h2)
+ (logxor h1 (rotate h2 8)))
+ (define (hash-struct s)
+ (let ((len (struct-nfields s))
+ (h (hashq (struct-vtable s) most-positive-fixnum)))
+ (if (zero? depth)
+ h
+ (let lp ((i (max (- len hash-width) 1)) (h h))
+ (if (< i len)
+ (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
+ h)))))
+ (define (hash-list l)
+ (let ((h (hashq 'list most-positive-fixnum)))
+ (if (zero? depth)
+ h
+ (let lp ((l l) (width 0) (h h))
+ (if (< width hash-width)
+ (lp (cdr l) (1+ width)
+ (mix (hash-exp (car l) (1+ depth)) h))
+ h)))))
+ (cond
+ ((struct? exp) (hash-struct exp))
+ ((list? exp) (hash-list exp))
+ (else (hash exp most-positive-fixnum))))
+
+ (hash-exp exp 0)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 9e6952e..88f81f3 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1008,10 +1008,14 @@ accurate information is missing from a given `tree-il'
element."
(arity:allow-other-keys? a)))
(program-arities proc))))
((procedure? proc)
- (let ((arity (procedure-minimum-arity proc)))
- (values (procedure-name proc)
- (list (list (car arity) (cadr arity) (caddr arity)
- #f #f)))))
+ (if (struct? proc)
+ ;; An applicable struct.
+ (arities (struct-ref proc 0))
+ ;; An applicable smob.
+ (let ((arity (procedure-minimum-arity proc)))
+ (values (procedure-name proc)
+ (list (list (car arity) (cadr arity) (caddr arity)
+ #f #f))))))
(else
(let loop ((name #f)
(proc proc)
@@ -1194,8 +1198,10 @@ accurate information is missing from a given `tree-il'
element."
(false-if-exception
(module-ref env name))))
proc)))
- (if (or (lambda? proc*) (procedure? proc*))
- (validate-arity proc* application (lambda? proc*)))))
+ (cond ((lambda? proc*)
+ (validate-arity proc* application #t))
+ ((procedure? proc*)
+ (validate-arity proc* application #f)))))
toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null)))
@@ -1350,17 +1356,28 @@ accurate information is missing from a given `tree-il'
element."
(define (proc-ref? exp proc special-name env)
"Return #t when EXP designates procedure PROC in ENV. As a last
resort, return #t when EXP refers to the global variable SPECIAL-NAME."
+
+ (define special?
+ (cut eq? <> special-name))
+
(match exp
+ (($ <toplevel-ref> _ (? special?))
+ ;; Allow top-levels like: (define _ (cut gettext <> "my-domain")).
+ #t)
(($ <toplevel-ref> _ name)
- (let ((var (false-if-exception (module-variable env name))))
- (if var
- (eq? (variable-ref var) proc)
- (eq? name special-name)))) ; special hack to support local
aliases
+ (let ((var (module-variable env name)))
+ (and var (variable-bound? var)
+ (eq? (variable-ref var) proc))))
+ (($ <module-ref> _ _ (? special?))
+ #t)
(($ <module-ref> _ module name public?)
- (let ((m (false-if-exception (if public?
- (resolve-interface module)
- (resolve-module module)))))
- (and m (eq? (false-if-exception (module-ref module name)) proc))))
+ (let* ((mod (if public?
+ (false-if-exception (resolve-interface module))
+ (resolve-module module #:ensure #f)))
+ (var (and mod (module-variable mod name))))
+ (and var (variable-bound? var) (eq? (variable-ref var) proc))))
+ (($ <lexical-ref> _ (? special?))
+ #t)
(_ #f)))
(define gettext? (cut proc-ref? <> gettext '_ <>))
diff --git a/module/language/tree-il/canonicalize.scm
b/module/language/tree-il/canonicalize.scm
index 04f5612..c3229ca 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -1,6 +1,6 @@
;;; Tree-il canonicalizer
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -58,10 +58,10 @@
(define (escape-only? handler)
(match handler
(($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
- (tree-il-any (lambda (x)
- (and (lexical-ref? x)
- (eq? (lexical-ref-gensym x) cont)))
- body))
+ (not (tree-il-any (lambda (x)
+ (and (lexical-ref? x)
+ (eq? (lexical-ref-gensym x) cont)))
+ body)))
(else #f)))
(define (thunk-application? x)
(match x
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
new file mode 100644
index 0000000..b8e7229
--- /dev/null
+++ b/module/language/tree-il/cse.scm
@@ -0,0 +1,578 @@
+;;; Common Subexpression Elimination (CSE) on Tree-IL
+
+;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (language tree-il cse)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:use-module (language tree-il effects)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:export (cse))
+
+;;;
+;;; This pass eliminates common subexpressions in Tree-IL. It works
+;;; best locally -- within a function -- so it is meant to be run after
+;;; partial evaluation, which usually inlines functions and so opens up
+;;; a bigger space for CSE to work.
+;;;
+;;; The algorithm traverses the tree of expressions, returning two
+;;; values: the newly rebuilt tree, and a "database". The database is
+;;; the set of expressions that will have been evaluated as part of
+;;; evaluating an expression. For example, in:
+;;;
+;;; (1- (+ (if a b c) (* x y)))
+;;;
+;;; We can say that when it comes time to evaluate (1- <>), that the
+;;; subexpressions +, x, y, and (* x y) must have been evaluated in
+;;; values context. We know that a was evaluated in test context, but
+;;; we don't know if it was true or false.
+;;;
+;;; The expressions in the database /dominate/ any subsequent
+;;; expression: FOO dominates BAR if evaluation of BAR implies that any
+;;; effects associated with FOO have already occured.
+;;;
+;;; When adding expressions to the database, we record the context in
+;;; which they are evaluated. We treat expressions in test context
+;;; specially: the presence of such an expression indicates that the
+;;; expression is true. In this way we can elide duplicate predicates.
+;;;
+;;; Duplicate predicates are not common in code that users write, but
+;;; can occur quite frequently in macro-generated code.
+;;;
+;;; For example:
+;;;
+;;; (and (foo? x) (foo-bar x))
+;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (struct-ref x 1)
+;;; (throw 'not-a-foo))
+;;; #f))
+;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (struct-ref x 1)
+;;; #f)
+;;;
+;;; A conditional bailout in effect context also has the effect of
+;;; adding predicates to the database:
+;;;
+;;; (begin (foo-bar x) (foo-baz x))
+;;; => (begin
+;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (struct-ref x 1)
+;;; (throw 'not-a-foo))
+;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (struct-ref x 2)
+;;; (throw 'not-a-foo)))
+;;; => (begin
+;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (struct-ref x 1)
+;;; (throw 'not-a-foo))
+;;; (struct-ref x 2))
+;;;
+;;; When removing code, we have to ensure that the semantics of the
+;;; source program and the residual program are the same. It's easy to
+;;; ensure that they have the same value, because those manipulations
+;;; are just algebraic, but the tricky thing is to ensure that the
+;;; expressions exhibit the same ordering of effects. For that, we use
+;;; the effects analysis of (language tree-il effects). We only
+;;; eliminate code if the duplicate code commutes with all of the
+;;; dominators on the path from the duplicate to the original.
+;;;
+;;; The implementation uses vhashes as the fundamental data structure.
+;;; This can be seen as a form of global value numbering. This
+;;; algorithm currently spends most of its time in vhash-assoc. I'm not
+;;; sure whether that is due to our bad hash function in Guile 2.0, an
+;;; inefficiency in vhashes, or what. Overall though the complexity
+;;; should be linear, or N log N -- whatever vhash-assoc's complexity
+;;; is. Walking the dominators is nonlinear, but that only happens when
+;;; we've actually found a common subexpression so that should be OK.
+;;;
+
+;; Logging helpers, as in peval.
+;;
+(define-syntax *logging* (identifier-syntax #f))
+;; (define %logging #f)
+;; (define-syntax *logging* (identifier-syntax %logging))
+(define-syntax log
+ (syntax-rules (quote)
+ ((log 'event arg ...)
+ (if (and *logging*
+ (or (eq? *logging* #t)
+ (memq 'event *logging*)))
+ (log* 'event arg ...)))))
+(define (log* event . args)
+ (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print))
+ 'pretty-print)))
+ (pp `(log ,event . ,args))
+ (newline)
+ (values)))
+
+;; A pre-pass on the source program to determine the set of assigned
+;; lexicals.
+;;
+(define* (build-assigned-var-table exp #:optional (table vlist-null))
+ (tree-il-fold
+ (lambda (exp res)
+ res)
+ (lambda (exp res)
+ (match exp
+ (($ <lexical-set> src name gensym exp)
+ (vhash-consq gensym #t res))
+ (_ res)))
+ (lambda (exp res) res)
+ table exp))
+
+(define (boolean-valued-primitive? primitive)
+ (or (negate-primitive primitive)
+ (eq? primitive 'not)
+ (let ((chars (symbol->string primitive)))
+ (eqv? (string-ref chars (1- (string-length chars)))
+ #\?))))
+
+(define (boolean-valued-expression? x ctx)
+ (match x
+ (($ <application> _
+ ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t)
+ (($ <const> _ (? boolean?)) #t)
+ (_ (eq? ctx 'test))))
+
+(define (singly-valued-expression? x ctx)
+ (match x
+ (($ <const>) #t)
+ (($ <lexical-ref>) #t)
+ (($ <void>) #t)
+ (($ <lexical-ref>) #t)
+ (($ <primitive-ref>) #t)
+ (($ <module-ref>) #t)
+ (($ <toplevel-ref>) #t)
+ (($ <application> _
+ ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
+ (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+ (($ <lambda>) #t)
+ (_ (eq? ctx 'value))))
+
+(define* (cse exp)
+ "Eliminate common subexpressions in EXP."
+
+ (define assigned-lexical?
+ (let ((table (build-assigned-var-table exp)))
+ (lambda (sym)
+ (vhash-assq sym table))))
+
+ (define %compute-effects
+ (make-effects-analyzer assigned-lexical?))
+
+ (define (negate exp ctx)
+ (match exp
+ (($ <const> src x)
+ (make-const src (not x)))
+ (($ <void> src)
+ (make-const src #f))
+ (($ <conditional> src test consequent alternate)
+ (make-conditional src test (negate consequent ctx) (negate alternate
ctx)))
+ (($ <application> _ ($ <primitive-ref> _ 'not)
+ ((and x (? (cut boolean-valued-expression? <> ctx)))))
+ x)
+ (($ <application> src
+ ($ <primitive-ref> _ (and pred (? negate-primitive)))
+ args)
+ (make-application src
+ (make-primitive-ref #f (negate-primitive pred))
+ args))
+ (_
+ (make-application #f (make-primitive-ref #f 'not) (list exp)))))
+
+
+ (define (hasher n)
+ (lambda (x size) (modulo n size)))
+
+ (define (add-to-db exp effects ctx db)
+ (let ((v (vector exp effects ctx))
+ (h (tree-il-hash exp)))
+ (vhash-cons v h db (hasher h))))
+
+ (define (control-flow-boundary db)
+ (let ((h (hashq 'lambda most-positive-fixnum)))
+ (vhash-cons 'lambda h db (hasher h))))
+
+ (define (find-dominating-expression exp effects ctx db)
+ (define (entry-matches? v1 v2)
+ (match (if (vector? v1) v1 v2)
+ (#(exp* effects* ctx*)
+ (and (tree-il=? exp exp*)
+ (or (not ctx) (eq? ctx* ctx))))
+ (_ #f)))
+
+ (let ((len (vlist-length db))
+ (h (tree-il-hash exp)))
+ (and (vhash-assoc #t db entry-matches? (hasher h))
+ (let lp ((n 0))
+ (and (< n len)
+ (match (vlist-ref db n)
+ (('lambda . h*)
+ ;; We assume that lambdas can escape and thus be
+ ;; called from anywhere. Thus code inside a lambda
+ ;; only has a dominating expression if it does not
+ ;; depend on any effects.
+ (and (not (depends-on-effects? effects &all-effects))
+ (lp (1+ n))))
+ ((#(exp* effects* ctx*) . h*)
+ (log 'walk (unparse-tree-il exp) effects
+ (unparse-tree-il exp*) effects* ctx*)
+ (or (and (= h h*)
+ (or (not ctx) (eq? ctx ctx*))
+ (tree-il=? exp exp*))
+ (and (effects-commute? effects effects*)
+ (lp (1+ n)))))))))))
+
+ ;; Return #t if EXP is dominated by an instance of itself. In that
+ ;; case, we can exclude *type-check* effects, because the first
+ ;; expression already caused them if needed.
+ (define (has-dominating-effect? exp effects db)
+ (or (constant? effects)
+ (and
+ (effect-free?
+ (exclude-effects effects
+ (logior &zero-values
+ &allocation
+ &type-check)))
+ (find-dominating-expression exp effects #f db))))
+
+ (define (find-dominating-test exp effects db)
+ (and
+ (effect-free?
+ (exclude-effects effects (logior &allocation
+ &type-check)))
+ (match exp
+ (($ <const> src val)
+ (if (boolean? val)
+ exp
+ (make-const src (not (not val)))))
+ ;; For (not FOO), try to prove FOO, then negate the result.
+ (($ <application> src ($ <primitive-ref> _ 'not) (exp*))
+ (match (find-dominating-test exp* effects db)
+ (($ <const> _ val)
+ (log 'inferring exp (not val))
+ (make-const src (not val)))
+ (_
+ #f)))
+ (_
+ (cond
+ ((find-dominating-expression exp effects 'test db)
+ ;; We have an EXP fact, so we infer #t.
+ (log 'inferring exp #t)
+ (make-const (tree-il-src exp) #t))
+ ((find-dominating-expression (negate exp 'test) effects 'test db)
+ ;; We have a (not EXP) fact, so we infer #f.
+ (log 'inferring exp #f)
+ (make-const (tree-il-src exp) #f))
+ (else
+ ;; Otherwise we don't know.
+ #f))))))
+
+ (define (add-to-env exp name sym db env)
+ (let* ((v (vector exp name sym (vlist-length db)))
+ (h (tree-il-hash exp)))
+ (vhash-cons v h env (hasher h))))
+
+ (define (augment-env env names syms exps db)
+ (if (null? names)
+ env
+ (let ((name (car names)) (sym (car syms)) (exp (car exps)))
+ (augment-env (if (or (assigned-lexical? sym)
+ (lexical-ref? exp))
+ env
+ (add-to-env exp name sym db env))
+ (cdr names) (cdr syms) (cdr exps) db))))
+
+ (define (find-dominating-lexical exp effects env db)
+ (define (entry-matches? v1 v2)
+ (match (if (vector? v1) v1 v2)
+ (#(exp* name sym db)
+ (tree-il=? exp exp*))
+ (_ #f)))
+
+ (define (unroll db base n)
+ (or (zero? n)
+ (match (vlist-ref db base)
+ (('lambda . h*)
+ ;; See note in find-dominating-expression.
+ (and (not (depends-on-effects? effects &all-effects))
+ (unroll db (1+ base) (1- n))))
+ ((#(exp* effects* ctx*) . h*)
+ (and (effects-commute? effects effects*)
+ (unroll db (1+ base) (1- n)))))))
+
+ (let ((h (tree-il-hash exp)))
+ (and (effect-free? (exclude-effects effects &type-check))
+ (vhash-assoc exp env entry-matches? (hasher h))
+ (let ((env-len (vlist-length env))
+ (db-len (vlist-length db)))
+ (let lp ((n 0) (m 0))
+ (and (< n env-len)
+ (match (vlist-ref env n)
+ ((#(exp* name sym db-len*) . h*)
+ (and (unroll db m (- db-len db-len*))
+ (if (and (= h h*) (tree-il=? exp* exp))
+ (make-lexical-ref (tree-il-src exp) name sym)
+ (lp (1+ n) (- db-len db-len*))))))))))))
+
+ (define (lookup-lexical sym env)
+ (let ((env-len (vlist-length env)))
+ (let lp ((n 0))
+ (and (< n env-len)
+ (match (vlist-ref env n)
+ ((#(exp _ sym* _) . _)
+ (if (eq? sym sym*)
+ exp
+ (lp (1+ n)))))))))
+
+ (define (intersection db+ db-)
+ (vhash-fold-right
+ (lambda (k h out)
+ (if (vhash-assoc k db- equal? (hasher h))
+ (vhash-cons k h out (hasher h))
+ out))
+ vlist-null
+ db+))
+
+ (define (concat db1 db2)
+ (vhash-fold-right (lambda (k h tail)
+ (vhash-cons k h tail (hasher h)))
+ db2 db1))
+
+ (let visit ((exp exp)
+ (db vlist-null) ; dominating expressions: #(exp effects ctx) ->
hash
+ (env vlist-null) ; named expressions: #(exp name sym db) -> hash
+ (ctx 'values)) ; test, effect, value, or values
+
+ (define (parallel-visit exps db env ctx)
+ (let lp ((in exps) (out '()) (db* vlist-null))
+ (if (pair? in)
+ (call-with-values (lambda () (visit (car in) db env ctx))
+ (lambda (x db**)
+ (lp (cdr in) (cons x out) (concat db** db*))))
+ (values (reverse out) db*))))
+
+ (define (compute-effects exp)
+ (%compute-effects exp (lambda (sym) (lookup-lexical sym env))))
+
+ (define (bailout? exp)
+ (causes-effects? (compute-effects exp) &definite-bailout))
+
+ (define (return exp db*)
+ (let ((effects (compute-effects exp)))
+ (cond
+ ((and (eq? ctx 'effect)
+ (not (lambda-case? exp))
+ (or (effect-free?
+ (exclude-effects effects
+ (logior &zero-values
+ &allocation)))
+ (has-dominating-effect? exp effects db)))
+ (cond
+ ((void? exp)
+ (values exp db*))
+ (else
+ (log 'elide ctx (unparse-tree-il exp))
+ (values (make-void #f) db*))))
+ ((and (boolean-valued-expression? exp ctx)
+ (find-dominating-test exp effects db))
+ => (lambda (exp)
+ (log 'propagate-test ctx (unparse-tree-il exp))
+ (values exp db*)))
+ ((and (singly-valued-expression? exp ctx)
+ (find-dominating-lexical exp effects env db))
+ => (lambda (exp)
+ (log 'propagate-value ctx (unparse-tree-il exp))
+ (values exp db*)))
+ ((and (constant? effects) (memq ctx '(value values)))
+ ;; Adds nothing to the db.
+ (values exp db*))
+ (else
+ (log 'return ctx effects (unparse-tree-il exp) db*)
+ (values exp
+ (add-to-db exp effects ctx db*))))))
+
+ (log 'visit ctx (unparse-tree-il exp) db env)
+
+ (match exp
+ (($ <const>)
+ (return exp vlist-null))
+ (($ <void>)
+ (return exp vlist-null))
+ (($ <lexical-ref> _ _ gensym)
+ (return exp vlist-null))
+ (($ <lexical-set> src name gensym exp)
+ (let*-values (((exp db*) (visit exp db env 'value)))
+ (return (make-lexical-set src name gensym exp)
+ db*)))
+ (($ <let> src names gensyms vals body)
+ (let*-values (((vals db*) (parallel-visit vals db env 'value))
+ ((body db**) (visit body (concat db* db)
+ (augment-env env names gensyms vals
db)
+ ctx)))
+ (return (make-let src names gensyms vals body)
+ (concat db** db*))))
+ (($ <letrec> src in-order? names gensyms vals body)
+ (let*-values (((vals db*) (parallel-visit vals db env 'value))
+ ((body db**) (visit body (concat db* db)
+ (augment-env env names gensyms vals
db)
+ ctx)))
+ (return (make-letrec src in-order? names gensyms vals body)
+ (concat db** db*))))
+ (($ <fix> src names gensyms vals body)
+ (let*-values (((vals db*) (parallel-visit vals db env 'value))
+ ((body db**) (visit body (concat db* db) env ctx)))
+ (return (make-fix src names gensyms vals body)
+ (concat db** db*))))
+ (($ <let-values> src producer consumer)
+ (let*-values (((producer db*) (visit producer db env 'values))
+ ((consumer db**) (visit consumer (concat db* db) env
ctx)))
+ (return (make-let-values src producer consumer)
+ (concat db** db*))))
+ (($ <dynwind> src winder body unwinder)
+ (let*-values (((pre db*) (visit winder db env 'value))
+ ((body db**) (visit body (concat db* db) env ctx))
+ ((post db***) (visit unwinder db env 'value)))
+ (return (make-dynwind src pre body post)
+ (concat db* (concat db** db***)))))
+ (($ <dynlet> src fluids vals body)
+ (let*-values (((fluids db*) (parallel-visit fluids db env 'value))
+ ((vals db**) (parallel-visit vals db env 'value))
+ ((body db***) (visit body (concat db** (concat db* db))
+ env ctx)))
+ (return (make-dynlet src fluids vals body)
+ (concat db*** (concat db** db*)))))
+ (($ <dynref> src fluid)
+ (let*-values (((fluid db*) (visit fluid db env 'value)))
+ (return (make-dynref src fluid)
+ db*)))
+ (($ <dynset> src fluid exp)
+ (let*-values (((fluid db*) (visit fluid db env 'value))
+ ((exp db**) (visit exp db env 'value)))
+ (return (make-dynset src fluid exp)
+ (concat db** db*))))
+ (($ <toplevel-ref>)
+ (return exp vlist-null))
+ (($ <module-ref>)
+ (return exp vlist-null))
+ (($ <module-set> src mod name public? exp)
+ (let*-values (((exp db*) (visit exp db env 'value)))
+ (return (make-module-set src mod name public? exp)
+ db*)))
+ (($ <toplevel-define> src name exp)
+ (let*-values (((exp db*) (visit exp db env 'value)))
+ (return (make-toplevel-define src name exp)
+ db*)))
+ (($ <toplevel-set> src name exp)
+ (let*-values (((exp db*) (visit exp db env 'value)))
+ (return (make-toplevel-set src name exp)
+ db*)))
+ (($ <primitive-ref>)
+ (return exp vlist-null))
+ (($ <conditional> src test consequent alternate)
+ (let*-values
+ (((test db+) (visit test db env 'test))
+ ((converse db-) (visit (negate test 'test) db env 'test))
+ ((consequent db++) (visit consequent (concat db+ db) env ctx))
+ ((alternate db--) (visit alternate (concat db- db) env ctx)))
+ (match (make-conditional src test consequent alternate)
+ (($ <conditional> _ ($ <const> _ exp))
+ (if exp
+ (return consequent (concat db++ db+))
+ (return alternate (concat db-- db-))))
+ ;; (if FOO A A) => (begin FOO A)
+ (($ <conditional> src _
+ ($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
+ (visit (make-sequence #f (list test (make-const #f a)))
+ db env ctx))
+ ;; (if FOO #t #f) => FOO for boolean-valued FOO.
+ (($ <conditional> src
+ (? (cut boolean-valued-expression? <> ctx))
+ ($ <const> _ #t) ($ <const> _ #f))
+ (return test db+))
+ ;; (if FOO #f #t) => (not FOO)
+ (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t))
+ (visit (negate test ctx) db env ctx))
+
+ ;; Allow "and"-like conditions to accumulate in test context.
+ ((and c ($ <conditional> _ _ _ ($ <const> _ #f)))
+ (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null)))
+ ((and c ($ <conditional> _ _ ($ <const> _ #f) _))
+ (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null)))
+
+ ;; Conditional bailouts turn expressions into predicates.
+ ((and c ($ <conditional> _ _ _ (? bailout?)))
+ (return c (concat db++ db+)))
+ ((and c ($ <conditional> _ _ (? bailout?) _))
+ (return c (concat db-- db-)))
+
+ (c
+ (return c (intersection (concat db++ db+) (concat db-- db-)))))))
+ (($ <application> src proc args)
+ (let*-values (((proc db*) (visit proc db env 'value))
+ ((args db**) (parallel-visit args db env 'value)))
+ (return (make-application src proc args)
+ (concat db** db*))))
+ (($ <lambda> src meta body)
+ (let*-values (((body _) (visit body (control-flow-boundary db)
+ env 'values)))
+ (return (make-lambda src meta body)
+ vlist-null)))
+ (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+ (let*-values (((inits _) (parallel-visit inits db env 'value))
+ ((body db*) (visit body db env ctx))
+ ((alt _) (if alt
+ (visit alt db env ctx)
+ (values #f #f))))
+ (return (make-lambda-case src req opt rest kw inits gensyms body alt)
+ (if alt vlist-null db*))))
+ (($ <sequence> src exps)
+ (let lp ((in exps) (out '()) (db* vlist-null))
+ (match in
+ ((last)
+ (let*-values (((last db**) (visit last (concat db* db) env ctx)))
+ (if (null? out)
+ (return last (concat db** db*))
+ (return (make-sequence src (reverse (cons last out)))
+ (concat db** db*)))))
+ ((head . rest)
+ (let*-values (((head db**) (visit head (concat db* db) env
'effect)))
+ (cond
+ ((sequence? head)
+ (lp (append (sequence-exps head) rest) out db*))
+ ((void? head)
+ (lp rest out db*))
+ (else
+ (lp rest (cons head out) (concat db** db*)))))))))
+ (($ <prompt> src tag body handler)
+ (let*-values (((tag db*) (visit tag db env 'value))
+ ((body _) (visit body (concat db* db) env ctx))
+ ((handler _) (visit handler (concat db* db) env ctx)))
+ (return (make-prompt src tag body handler)
+ db*)))
+ (($ <abort> src tag args tail)
+ (let*-values (((tag db*) (visit tag db env 'value))
+ ((args db**) (parallel-visit args db env 'value))
+ ((tail db***) (visit tail db env 'value)))
+ (return (make-abort src tag args tail)
+ (concat db* (concat db** db***))))))))
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
new file mode 100644
index 0000000..4610f7f
--- /dev/null
+++ b/module/language/tree-il/effects.scm
@@ -0,0 +1,376 @@
+;;; Effects analysis on Tree-IL
+
+;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (language tree-il effects)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:use-module (ice-9 match)
+ #:export (make-effects-analyzer
+ &mutable-lexical
+ &toplevel
+ &fluid
+ &definite-bailout
+ &possible-bailout
+ &zero-values
+ &allocation
+ &mutable-data
+ &type-check
+ &all-effects
+ effects-commute?
+ exclude-effects
+ effect-free?
+ constant?
+ depends-on-effects?
+ causes-effects?))
+
+;;;
+;;; Hey, it's some effects analysis! If you invoke
+;;; `make-effects-analyzer', you get a procedure that computes the set
+;;; of effects that an expression depends on and causes. This
+;;; information is useful when writing algorithms that move code around,
+;;; while preserving the semantics of an input program.
+;;;
+;;; The effects set is represented by a bitfield, as a fixnum. The set
+;;; of possible effects is modelled rather coarsely. For example, a
+;;; toplevel reference to FOO is modelled as depending on the &toplevel
+;;; effect, and causing a &type-check effect. If any intervening code
+;;; sets any toplevel variable, that will block motion of FOO.
+;;;
+;;; For each effect, two bits are reserved: one to indicate that an
+;;; expression depends on the effect, and the other to indicate that an
+;;; expression causes the effect.
+;;;
+
+(define-syntax define-effects
+ (lambda (x)
+ (syntax-case x ()
+ ((_ all name ...)
+ (with-syntax (((n ...) (iota (length #'(name ...)))))
+ #'(begin
+ (define-syntax name (identifier-syntax (ash 1 (* n 2))))
+ ...
+ (define-syntax all (identifier-syntax (logior name ...)))))))))
+
+;; Here we define the effects, indicating the meaning of the effect.
+;;
+;; Effects that are described in a "depends on" sense can also be used
+;; in the "causes" sense.
+;;
+;; Effects that are described as causing an effect are not usually used
+;; in a "depends-on" sense. Although the "depends-on" sense is used
+;; when checking for the existence of the "causes" effect, the effects
+;; analyzer will not associate the "depends-on" sense of these effects
+;; with any expression.
+;;
+(define-effects &all-effects
+ ;; Indicates that an expression depends on the value of a mutable
+ ;; lexical variable.
+ &mutable-lexical
+
+ ;; Indicates that an expression depends on the value of a toplevel
+ ;; variable.
+ &toplevel
+
+ ;; Indicates that an expression depends on the value of a fluid
+ ;; variable.
+ &fluid
+
+ ;; Indicates that an expression definitely causes a non-local,
+ ;; non-resumable exit -- a bailout. Only used in the "changes" sense.
+ &definite-bailout
+
+ ;; Indicates that an expression may cause a bailout.
+ &possible-bailout
+
+ ;; Indicates than an expression may return zero values -- a "causes"
+ ;; effect.
+ &zero-values
+
+ ;; Indicates that an expression may return a fresh object -- a
+ ;; "causes" effect.
+ &allocation
+
+ ;; Indicates that an expression depends on the value of a mutable data
+ ;; structure.
+ &mutable-data
+
+ ;; Indicates that an expression may cause a type check. A type check,
+ ;; for the purposes of this analysis, is the possibility of throwing
+ ;; an exception the first time an expression is evaluated. If the
+ ;; expression did not cause an exception to be thrown, users can
+ ;; assume that evaluating the expression again will not cause an
+ ;; exception to be thrown.
+ ;;
+ ;; For example, (+ x y) might throw if X or Y are not numbers. But if
+ ;; it doesn't throw, it should be safe to elide a dominated, common
+ ;; subexpression (+ x y).
+ &type-check)
+
+(define-syntax &no-effects (identifier-syntax 0))
+
+;; Definite bailout is an oddball effect. Since it indicates that an
+;; expression definitely causes bailout, it's not in the set of effects
+;; of a call to an unknown procedure. At the same time, it's also
+;; special in that a definite bailout in a subexpression doesn't always
+;; cause an outer expression to include &definite-bailout in its
+;; effects. For that reason we have to treat it specially.
+;;
+(define-syntax &all-effects-but-bailout
+ (identifier-syntax
+ (logand &all-effects (lognot &definite-bailout))))
+
+(define-inlinable (cause effect)
+ (ash effect 1))
+
+(define-inlinable (&depends-on a)
+ (logand a &all-effects))
+(define-inlinable (&causes a)
+ (logand a (cause &all-effects)))
+
+(define (exclude-effects effects exclude)
+ (logand effects (lognot (cause exclude))))
+(define (effect-free? effects)
+ (zero? (&causes effects)))
+(define (constant? effects)
+ (zero? effects))
+
+(define-inlinable (depends-on-effects? x effects)
+ (not (zero? (logand (&depends-on x) effects))))
+(define-inlinable (causes-effects? x effects)
+ (not (zero? (logand (&causes x) (cause effects)))))
+
+(define-inlinable (effects-commute? a b)
+ (and (not (causes-effects? a (&depends-on b)))
+ (not (causes-effects? b (&depends-on a)))))
+
+(define (make-effects-analyzer assigned-lexical?)
+ "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
+of an expression."
+
+ (let ((cache (make-hash-table)))
+ (define* (compute-effects exp #:optional (lookup (lambda (x) #f)))
+ (define (compute-effects exp)
+ (or (hashq-ref cache exp)
+ (let ((effects (visit exp)))
+ (hashq-set! cache exp effects)
+ effects)))
+
+ (define (accumulate-effects exps)
+ (let lp ((exps exps) (out &no-effects))
+ (if (null? exps)
+ out
+ (lp (cdr exps) (logior out (compute-effects (car exps)))))))
+
+ (define (visit exp)
+ (match exp
+ (($ <const>)
+ &no-effects)
+ (($ <void>)
+ &no-effects)
+ (($ <lexical-ref> _ _ gensym)
+ (if (assigned-lexical? gensym)
+ &mutable-lexical
+ &no-effects))
+ (($ <lexical-set> _ name gensym exp)
+ (logior (cause &mutable-lexical)
+ (compute-effects exp)))
+ (($ <let> _ names gensyms vals body)
+ (logior (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (accumulate-effects vals)
+ (compute-effects body)))
+ (($ <letrec> _ in-order? names gensyms vals body)
+ (logior (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (accumulate-effects vals)
+ (compute-effects body)))
+ (($ <fix> _ names gensyms vals body)
+ (logior (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (accumulate-effects vals)
+ (compute-effects body)))
+ (($ <let-values> _ producer consumer)
+ (logior (compute-effects producer)
+ (compute-effects consumer)
+ (cause &type-check)))
+ (($ <dynwind> _ winder body unwinder)
+ (logior (compute-effects winder)
+ (compute-effects body)
+ (compute-effects unwinder)))
+ (($ <dynlet> _ fluids vals body)
+ (logior (accumulate-effects fluids)
+ (accumulate-effects vals)
+ (cause &type-check)
+ (cause &fluid)
+ (compute-effects body)))
+ (($ <dynref> _ fluid)
+ (logior (compute-effects fluid)
+ (cause &type-check)
+ &fluid))
+ (($ <dynset> _ fluid exp)
+ (logior (compute-effects fluid)
+ (compute-effects exp)
+ (cause &type-check)
+ (cause &fluid)))
+ (($ <toplevel-ref>)
+ (logior &toplevel
+ (cause &type-check)))
+ (($ <module-ref>)
+ (logior &toplevel
+ (cause &type-check)))
+ (($ <module-set> _ mod name public? exp)
+ (logior (cause &toplevel)
+ (cause &type-check)
+ (compute-effects exp)))
+ (($ <toplevel-define> _ name exp)
+ (logior (cause &toplevel)
+ (compute-effects exp)))
+ (($ <toplevel-set> _ name exp)
+ (logior (cause &toplevel)
+ (compute-effects exp)))
+ (($ <primitive-ref>)
+ &no-effects)
+ (($ <conditional> _ test consequent alternate)
+ (let ((tfx (compute-effects test))
+ (cfx (compute-effects consequent))
+ (afx (compute-effects alternate)))
+ (if (causes-effects? (logior tfx (logand afx cfx))
+ &definite-bailout)
+ (logior tfx cfx afx)
+ (exclude-effects (logior tfx cfx afx)
+ &definite-bailout))))
+
+ ;; Zero values.
+ (($ <application> _ ($ <primitive-ref> _ 'values) ())
+ (cause &zero-values))
+
+ ;; Effect-free primitives.
+ (($ <application> _
+ ($ <primitive-ref> _ (or 'values 'eq? 'eqv? 'equal?))
+ args)
+ (accumulate-effects args))
+
+ (($ <application> _
+ ($ <primitive-ref> _ (or 'not 'pair? 'null? 'list? 'symbol?
+ 'vector? 'struct? 'string? 'number?
+ 'char?))
+ (arg))
+ (compute-effects arg))
+
+ ;; Primitives that allocate memory.
+ (($ <application> _ ($ <primitive-ref> _ 'cons) (x y))
+ (logior (compute-effects x) (compute-effects y)
+ &allocation))
+
+ (($ <application> _ ($ <primitive-ref> _ (or 'list 'vector)) args)
+ (logior (accumulate-effects args) &allocation))
+
+ (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ())
+ &allocation)
+
+ (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) (arg))
+ (logior (compute-effects arg) &allocation))
+
+ ;; Primitives that are normally effect-free, but which might
+ ;; cause type checks, allocate memory, or access mutable
+ ;; memory. FIXME: expand, to be more precise.
+ (($ <application> _
+ ($ <primitive-ref> _ (and name
+ (? effect-free-primitive?)))
+ args)
+ (logior (accumulate-effects args)
+ (cause &type-check)
+ (if (constructor-primitive? name)
+ (cause &allocation)
+ (if (accessor-primitive? name)
+ &mutable-data
+ &no-effects))))
+
+ ;; Lambda applications might throw wrong-number-of-args.
+ (($ <application> _ ($ <lambda> _ _ body) args)
+ (logior (accumulate-effects args)
+ (match body
+ (($ <lambda-case> _ req #f #f #f () syms body #f)
+ (logior (compute-effects body)
+ (if (= (length req) (length args))
+ 0
+ (cause &type-check))))
+ (($ <lambda-case>)
+ (logior (compute-effects body)
+ (cause &type-check))))))
+
+ ;; Bailout primitives.
+ (($ <application> src ($ <primitive-ref> _ (? bailout-primitive?
name))
+ args)
+ (logior (accumulate-effects args)
+ (cause &definite-bailout)
+ (cause &possible-bailout)))
+
+ ;; A call to a lexically bound procedure, perhaps labels
+ ;; allocated.
+ (($ <application> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+ (cond
+ ((lookup sym)
+ => (lambda (proc)
+ (compute-effects (make-application #f proc args))))
+ (else
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))))
+
+ ;; A call to an unknown procedure can do anything.
+ (($ <application> _ proc args)
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))
+
+ (($ <lambda> _ meta body)
+ &no-effects)
+ (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
+ (logior (exclude-effects (accumulate-effects inits)
+ &definite-bailout)
+ (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (compute-effects body)
+ (if alt (compute-effects alt) &no-effects)))
+
+ (($ <sequence> _ exps)
+ (let lp ((exps exps) (effects &no-effects))
+ (match exps
+ ((tail)
+ (logior (compute-effects tail)
+ ;; Returning zero values to a for-effect continuation
is
+ ;; not observable.
+ (exclude-effects effects (cause &zero-values))))
+ ((head . tail)
+ (lp tail (logior (compute-effects head) effects))))))
+
+ (($ <prompt> _ tag body handler)
+ (logior (compute-effects tag)
+ (compute-effects body)
+ (compute-effects handler)))
+
+ (($ <abort> _ tag args tail)
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))))
+
+ (compute-effects exp))
+
+ compute-effects))
diff --git a/module/language/tree-il/fix-letrec.scm
b/module/language/tree-il/fix-letrec.scm
index f387df1..60c87e3 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -21,7 +21,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language tree-il)
- #:use-module (language tree-il primitives)
+ #:use-module (language tree-il effects)
#:export (fix-letrec!))
;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
@@ -31,25 +31,24 @@
(define fix-fold
(make-tree-il-folder unref ref set simple lambda complex))
-(define (simple-expression? x bound-vars simple-primitive?)
+(define (simple-expression? x bound-vars simple-primcall?)
(record-case x
((<void>) #t)
((<const>) #t)
((<lexical-ref> gensym)
(not (memq gensym bound-vars)))
((<conditional> test consequent alternate)
- (and (simple-expression? test bound-vars simple-primitive?)
- (simple-expression? consequent bound-vars simple-primitive?)
- (simple-expression? alternate bound-vars simple-primitive?)))
+ (and (simple-expression? test bound-vars simple-primcall?)
+ (simple-expression? consequent bound-vars simple-primcall?)
+ (simple-expression? alternate bound-vars simple-primcall?)))
((<sequence> exps)
- (and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
+ (and-map (lambda (x) (simple-expression? x bound-vars simple-primcall?))
exps))
((<application> proc args)
(and (primitive-ref? proc)
- (simple-primitive? (primitive-ref-name proc))
- ;; FIXME: check arity?
+ (simple-primcall? x)
(and-map (lambda (x)
- (simple-expression? x bound-vars simple-primitive?))
+ (simple-expression? x bound-vars simple-primcall?))
args)))
(else #f)))
@@ -92,6 +91,17 @@
(lambda (x unref ref set simple lambda* complex)
(record-case x
((<letrec> in-order? (orig-gensyms gensyms) vals)
+ (define compute-effects
+ (make-effects-analyzer (lambda (x) (memq x set))))
+ (define (effect-free-primcall? x)
+ (let ((effects (compute-effects x)))
+ (effect-free?
+ (exclude-effects effects (logior &allocation
+ &type-check)))))
+ (define (effect+exception-free-primcall? x)
+ (let ((effects (compute-effects x)))
+ (effect-free?
+ (exclude-effects effects &allocation))))
(let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '()))
(cond
@@ -114,7 +124,7 @@
(not (lambda? (car vals)))
(not (simple-expression?
(car vals) orig-gensyms
- effect+exception-free-primitive?)))
+ effect+exception-free-primcall?)))
(lp (cdr gensyms) (cdr vals)
s l (cons (car gensyms) c))
(lp (cdr gensyms) (cdr vals)
@@ -128,8 +138,8 @@
((simple-expression?
(car vals) orig-gensyms
(if in-order?
- effect+exception-free-primitive?
- effect-free-primitive?))
+ effect+exception-free-primcall?
+ effect-free-primcall?))
;; For letrec*, we can't consider e.g. `car' to be
;; "simple", as it could raise an exception. Hence
;; effect+exception-free-primitive? above.
@@ -181,6 +191,20 @@
'())))
(values unref simple lambda* complex)))
+(define (make-sequence* src exps)
+ (let lp ((in exps) (out '()))
+ (if (null? (cdr in))
+ (if (null? out)
+ (car in)
+ (make-sequence src (reverse (cons (car in) out))))
+ (let ((head (car in)))
+ (record-case head
+ ((<lambda>) (lp (cdr in) out))
+ ((<const>) (lp (cdr in) out))
+ ((<lexical-ref>) (lp (cdr in) out))
+ ((<void>) (lp (cdr in) out))
+ (else (lp (cdr in) (cons head out))))))))
+
(define (fix-letrec! x)
(let-values (((unref simple lambda* complex) (partition-vars x)))
(post-order!
@@ -191,7 +215,7 @@
;; expression, called for effect.
((<lexical-set> gensym exp)
(if (memq gensym unref)
- (make-sequence #f (list exp (make-void #f)))
+ (make-sequence* #f (list exp (make-void #f)))
x))
((<letrec> src in-order? names gensyms vals body)
@@ -219,7 +243,7 @@
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
- (make-sequence
+ (make-sequence*
src
(append
;; The right-hand-sides of the unreferenced
@@ -263,7 +287,7 @@
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
- (make-sequence
+ (make-sequence*
src
(append
;; unreferenced bindings, called for effect.
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index baac915..c6e4fec 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -1,6 +1,6 @@
;;; Tree-il optimizer
-;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011, 2012 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -22,6 +22,7 @@
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:use-module (language tree-il peval)
+ #:use-module (language tree-il cse)
#:use-module (language tree-il fix-letrec)
#:use-module (language tree-il debug)
#:use-module (ice-9 match)
@@ -32,8 +33,15 @@
((#:partial-eval? #f _ ...)
;; Disable partial evaluation.
(lambda (x e) x))
- (_ peval))))
+ (_ peval)))
+ (cse (match (memq #:cse? opts)
+ ((#:cse? #f _ ...)
+ ;; Disable CSE.
+ (lambda (x) x))
+ (_ cse))))
(fix-letrec!
(verify-tree-il
- (peval (expand-primitives! (resolve-primitives! x env))
- env)))))
+ (cse
+ (verify-tree-il
+ (peval (expand-primitives! (resolve-primitives! x env))
+ env)))))))
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 7aad399..81921e3 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -19,6 +19,7 @@
(define-module (language tree-il peval)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
+ #:use-module (language tree-il effects)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
@@ -287,29 +288,38 @@
;; TODO: Record value size in operand structure?
;;
(define-record-type <operand>
- (%make-operand var sym visit source visit-count residualize?
- copyable? residual-value constant-value)
+ (%make-operand var sym visit source visit-count use-count
+ copyable? residual-value constant-value alias-value)
operand?
(var operand-var)
(sym operand-sym)
(visit %operand-visit)
(source operand-source)
(visit-count operand-visit-count set-operand-visit-count!)
- (residualize? operand-residualize? set-operand-residualize?!)
+ (use-count operand-use-count set-operand-use-count!)
(copyable? operand-copyable? set-operand-copyable?!)
(residual-value operand-residual-value %set-operand-residual-value!)
- (constant-value operand-constant-value set-operand-constant-value!))
+ (constant-value operand-constant-value set-operand-constant-value!)
+ (alias-value operand-alias-value set-operand-alias-value!))
-(define* (make-operand var sym #:optional source visit)
- ;; Bind SYM to VAR, with value SOURCE. Bound operands are considered
- ;; copyable until we prove otherwise. If we have a source expression,
- ;; truncate it to one value. Copy propagation does not work on
- ;; multiply-valued expressions.
+(define* (make-operand var sym #:optional source visit alias)
+ ;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are
+ ;; considered copyable until we prove otherwise. If we have a source
+ ;; expression, truncate it to one value. Copy propagation does not
+ ;; work on multiply-valued expressions.
(let ((source (and=> source truncate-values)))
- (%make-operand var sym visit source 0 #f (and source #t) #f #f)))
+ (%make-operand var sym visit source 0 0
+ (and source (not (var-set? var))) #f #f
+ (and (not (var-set? var)) alias))))
-(define (make-bound-operands vars syms sources visit)
- (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
+(define* (make-bound-operands vars syms sources visit #:optional aliases)
+ (if aliases
+ (map (lambda (name sym source alias)
+ (make-operand name sym source visit alias))
+ vars syms sources aliases)
+ (map (lambda (name sym source)
+ (make-operand name sym source visit #f))
+ vars syms sources)))
(define (make-unbound-operands vars syms)
(map make-operand vars syms))
@@ -343,7 +353,12 @@
(if (or counter (and (not effort-limit) (not size-limit)))
((%operand-visit op) (operand-source op) counter ctx)
(let/ec k
- (define (abort) (k #f))
+ (define (abort)
+ ;; If we abort when visiting the value in a
+ ;; fresh context, we won't succeed in any future
+ ;; attempt, so don't try to copy it again.
+ (set-operand-copyable?! op #f)
+ (k #f))
((%operand-visit op)
(operand-source op)
(make-top-counter effort-limit size-limit abort op)
@@ -442,9 +457,18 @@ top-level bindings from ENV and return the resulting
expression."
(let ((x (vhash-assq new store)))
(if x (cdr x) new)))
+ (define (record-operand-use op)
+ (set-operand-use-count! op (1+ (operand-use-count op))))
+
+ (define (unrecord-operand-uses op n)
+ (let ((count (- (operand-use-count op) n)))
+ (when (zero? count)
+ (set-operand-residual-value! op #f))
+ (set-operand-use-count! op count)))
+
(define* (residualize-lexical op #:optional ctx val)
(log 'residualize op)
- (set-operand-residualize?! op #t)
+ (record-operand-use op)
(if (memq ctx '(value values))
(set-operand-residual-value! op val))
(make-lexical-ref #f (var-name (operand-var op)) (operand-sym op)))
@@ -566,51 +590,15 @@ top-level bindings from ENV and return the resulting
expression."
(and tail
(make-sequence src (append head (list tail)))))))))))
+ (define compute-effects
+ (make-effects-analyzer assigned-lexical?))
+
(define (constant-expression? x)
;; Return true if X is constant, for the purposes of copying or
;; elision---i.e., if it is known to have no effects, does not
;; allocate storage for a mutable object, and does not access
;; mutable data (like `car' or toplevel references).
- (let loop ((x x))
- (match x
- (($ <void>) #t)
- (($ <const>) #t)
- (($ <lambda>) #t)
- (($ <lambda-case> _ req opt rest kw inits syms body alternate)
- (and (not (any assigned-lexical? syms))
- (every loop inits) (loop body)
- (or (not alternate) (loop alternate))))
- (($ <lexical-ref> _ _ gensym)
- (not (assigned-lexical? gensym)))
- (($ <primitive-ref>) #t)
- (($ <conditional> _ condition subsequent alternate)
- (and (loop condition) (loop subsequent) (loop alternate)))
- (($ <application> _ ($ <primitive-ref> _ 'values) exps)
- (and (not (null? exps))
- (every loop exps)))
- (($ <application> _ ($ <primitive-ref> _ name) args)
- (and (effect-free-primitive? name)
- (not (constructor-primitive? name))
- (not (accessor-primitive? name))
- (types-check? name args)
- (every loop args)))
- (($ <application> _ ($ <lambda> _ _ body) args)
- (and (loop body) (every loop args)))
- (($ <sequence> _ exps)
- (every loop exps))
- (($ <let> _ _ syms vals body)
- (and (not (any assigned-lexical? syms))
- (every loop vals) (loop body)))
- (($ <letrec> _ _ _ syms vals body)
- (and (not (any assigned-lexical? syms))
- (every loop vals) (loop body)))
- (($ <fix> _ _ _ vals body)
- (and (every loop vals) (loop body)))
- (($ <let-values> _ exp body)
- (and (loop exp) (loop body)))
- (($ <prompt> _ tag body handler)
- (and (loop tag) (loop body) (loop handler)))
- (_ #f))))
+ (constant? (compute-effects x)))
(define (prune-bindings ops in-order? body counter ctx build-result)
;; This helper handles both `let' and `letrec'/`fix'. In the latter
@@ -626,7 +614,8 @@ top-level bindings from ENV and return the resulting
expression."
;; marked as needing residualization. Here we hack around this
;; and treat all bindings as referenced if we are in operator
;; context.
- (or (eq? ctx 'operator) (operand-residualize? op)))
+ (or (eq? ctx 'operator)
+ (not (zero? (operand-use-count op)))))
;; values := (op ...)
;; effects := (op ...)
@@ -746,6 +735,11 @@ top-level bindings from ENV and return the resulting
expression."
((eq? ctx 'effect)
(log 'lexical-for-effect gensym)
(make-void #f))
+ ((operand-alias-value op)
+ ;; This is an unassigned operand that simply aliases some
+ ;; other operand. Recurse to avoid residualizing the leaf
+ ;; binding.
+ => for-tail)
((eq? ctx 'call)
;; Don't propagate copies if we are residualizing a call.
(log 'residualize-lexical-call gensym op)
@@ -835,14 +829,40 @@ top-level bindings from ENV and return the resulting
expression."
exp
(make-sequence src (list exp (make-void #f)))))
(begin
- (set-operand-residualize?! op #t)
+ (record-operand-use op)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
(($ <let> src names gensyms vals body)
+ (define (compute-alias exp)
+ ;; It's very common for macros to introduce something like:
+ ;;
+ ;; ((lambda (x y) ...) x-exp y-exp)
+ ;;
+ ;; In that case you might end up trying to inline something like:
+ ;;
+ ;; (let ((x x-exp) (y y-exp)) ...)
+ ;;
+ ;; But if x-exp is itself a lexical-ref that aliases some much
+ ;; larger expression, perhaps it will fail to inline due to
+ ;; size. However we don't want to introduce a useless alias
+ ;; (in this case, x). So if the RHS of a let expression is a
+ ;; lexical-ref, we record that expression. If we end up having
+ ;; to residualize X, then instead we residualize X-EXP, as long
+ ;; as it isn't assigned.
+ ;;
+ (match exp
+ (($ <lexical-ref> _ _ sym)
+ (let ((op (lookup sym)))
+ (and (not (var-set? (operand-var op)))
+ (or (operand-alias-value op)
+ exp))))
+ (_ #f)))
+
(let* ((vars (map lookup-var gensyms))
(new (fresh-gensyms vars))
(ops (make-bound-operands vars new vals
(lambda (exp counter ctx)
- (loop exp env counter ctx))))
+ (loop exp env counter ctx))
+ (map compute-alias vals)))
(env (fold extend-env env gensyms ops))
(body (loop body env counter ctx)))
(cond
@@ -868,7 +888,9 @@ top-level bindings from ENV and return the resulting
expression."
(($ <letrec> src in-order? names gensyms vals body)
;; Note the difference from the `let' case: here we use letrec*
;; so that the `visit' procedure for the new operands closes over
- ;; an environment that includes the operands.
+ ;; an environment that includes the operands. Also we don't try
+ ;; to elide aliases, because we can't sensibly reduce something
+ ;; like (letrec ((a b) (b a)) a).
(letrec* ((visit (lambda (exp counter ctx)
(loop exp env* counter ctx)))
(vars (map lookup-var gensyms))
@@ -985,14 +1007,79 @@ top-level bindings from ENV and return the resulting
expression."
((test) (make-const #f #t))
(else exp)))
(($ <conditional> src condition subsequent alternate)
- (let ((condition (for-test condition)))
- (if (const? condition)
- (if (const-exp condition)
- (for-tail subsequent)
- (for-tail alternate))
- (make-conditional src condition
- (for-tail subsequent)
- (for-tail alternate)))))
+ (define (call-with-failure-thunk exp proc)
+ (match exp
+ (($ <application> _ _ ()) (proc exp))
+ (($ <const>) (proc exp))
+ (($ <void>) (proc exp))
+ (($ <lexical-ref>) (proc exp))
+ (_
+ (let ((t (gensym "failure-")))
+ (record-new-temporary! 'failure t 2)
+ (make-let
+ src (list 'failure) (list t)
+ (list
+ (make-lambda
+ #f '()
+ (make-lambda-case #f '() #f #f #f '() '() exp #f)))
+ (proc (make-application #f (make-lexical-ref #f 'failure t)
+ '())))))))
+ (define (simplify-conditional c)
+ (match c
+ ;; Swap the arms of (if (not FOO) A B), to simplify.
+ (($ <conditional> src
+ ($ <application> _ ($ <primitive-ref> _ 'not) (pred))
+ subsequent alternate)
+ (simplify-conditional
+ (make-conditional src pred alternate subsequent)))
+ ;; Special cases for common tests in the predicates of chains
+ ;; of if expressions.
+ (($ <conditional> src
+ ($ <conditional> src* outer-test inner-test ($ <const> _ #f))
+ inner-subsequent
+ alternate)
+ (let lp ((alternate alternate))
+ (match alternate
+ ;; Lift a common repeated test out of a chain of if
+ ;; expressions.
+ (($ <conditional> _ (? (cut tree-il=? outer-test <>))
+ other-subsequent alternate)
+ (make-conditional
+ src outer-test
+ (simplify-conditional
+ (make-conditional src* inner-test inner-subsequent
+ other-subsequent))
+ alternate))
+ ;; Likewise, but punching through any surrounding
+ ;; failure continuations.
+ (($ <let> let-src (name) (sym) ((and thunk ($ <lambda>))) body)
+ (make-let
+ let-src (list name) (list sym) (list thunk)
+ (lp body)))
+ ;; Otherwise, rotate AND tests to expose a simple
+ ;; condition in the front. Although this may result in
+ ;; lexically binding failure thunks, the thunks will be
+ ;; compiled to labels allocation, so there's no actual
+ ;; code growth.
+ (_
+ (call-with-failure-thunk
+ alternate
+ (lambda (failure)
+ (make-conditional
+ src outer-test
+ (simplify-conditional
+ (make-conditional src* inner-test inner-subsequent
failure))
+ failure)))))))
+ (_ c)))
+ (match (for-test condition)
+ (($ <const> _ val)
+ (if val
+ (for-tail subsequent)
+ (for-tail alternate)))
+ (c
+ (simplify-conditional
+ (make-conditional src c (for-tail subsequent)
+ (for-tail alternate))))))
(($ <application> src
($ <primitive-ref> _ '@call-with-values)
(producer
@@ -1017,6 +1104,17 @@ top-level bindings from ENV and return the resulting
expression."
(every singly-valued-expression? vals))
(for-tail (make-sequence src (append (cdr vals) (list (car
vals)))))
(make-application src (make-primitive-ref #f 'values) vals))))))
+ (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply
'@apply)))
+ (proc args ... tail))
+ (match (for-value tail)
+ (($ <const> _ (args* ...))
+ (let ((args* (map (lambda (x) (make-const #f x)) args*)))
+ (for-tail (make-application src proc (append args args*)))))
+ (($ <application> _ ($ <primitive-ref> _ 'list) args*)
+ (for-tail (make-application src proc (append args args*))))
+ (tail
+ (let ((args (append (map for-value args) (list tail))))
+ (make-application src apply (cons (for-value proc) args))))))
(($ <application> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
(let ((proc (visit orig-proc 'operator)))
@@ -1219,21 +1317,37 @@ top-level bindings from ENV and return the resulting
expression."
exp
(make-lambda src meta (for-values body))))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
+ (define (lift-applied-lambda body gensyms)
+ (and (not opt) rest (not kw)
+ (match body
+ (($ <application> _
+ ($ <primitive-ref> _ '@apply)
+ (($ <lambda> _ _ lcase)
+ ($ <lexical-ref> _ _ sym)
+ ...))
+ (and (equal? sym gensyms)
+ (not (lambda-case-alternate lcase))
+ lcase))
+ (_ #f))))
(let* ((vars (map lookup-var gensyms))
(new (fresh-gensyms vars))
(env (fold extend-env env gensyms
(make-unbound-operands vars new)))
(new-sym (lambda (old)
- (operand-sym (cdr (vhash-assq old env))))))
- (make-lambda-case src req opt rest
- (match kw
- ((aok? (kw name old) ...)
- (cons aok? (map list kw name (map new-sym old))))
- (_ #f))
- (map (cut loop <> env counter 'value) inits)
- new
- (loop body env counter ctx)
- (and alt (for-tail alt)))))
+ (operand-sym (cdr (vhash-assq old env)))))
+ (body (loop body env counter ctx)))
+ (or
+ ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
+ (lift-applied-lambda body new)
+ (make-lambda-case src req opt rest
+ (match kw
+ ((aok? (kw name old) ...)
+ (cons aok? (map list kw name (map new-sym
old))))
+ (_ #f))
+ (map (cut loop <> env counter 'value) inits)
+ new
+ body
+ (and alt (for-tail alt))))))
(($ <sequence> src exps)
(let lp ((exps exps) (effects '()))
(match exps
@@ -1253,25 +1367,80 @@ top-level bindings from ENV and return the resulting
expression."
(else
(lp rest (cons head effects)))))))))
(($ <prompt> src tag body handler)
- (define (singly-used-definition x)
+ (define (make-prompt-tag? x)
+ (match x
+ (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
+ (or () ((? constant-expression?))))
+ #t)
+ (_ #f)))
+ (define (find-definition x n-aliases)
(cond
- ((and (lexical-ref? x)
- ;; Only fetch definitions with single uses.
- (= (lexical-refcount (lexical-ref-gensym x)) 1)
- (lookup (lexical-ref-gensym x)))
- => (lambda (x)
- (singly-used-definition (visit-operand x counter 'value 10
10))))
- (else x)))
- (match (singly-used-definition tag)
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
- (or () ((? constant-expression?))))
- ;; There is no way that an <abort> could know the tag
- ;; for this <prompt>, so we can elide the <prompt>
- ;; entirely.
- (for-tail body))
- (_
- (make-prompt src (for-value tag) (for-tail body)
- (for-value handler)))))
+ ((lexical-ref? x)
+ (cond
+ ((lookup (lexical-ref-gensym x))
+ => (lambda (op)
+ (let ((y (or (operand-residual-value op)
+ (visit-operand op counter 'value 10 10))))
+ (cond
+ ((and (lexical-ref? y)
+ (= (lexical-refcount (lexical-ref-gensym x)) 1))
+ ;; X is a simple alias for Y. Recurse, regardless of
+ ;; the number of aliases we were expecting.
+ (find-definition y n-aliases))
+ ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
+ ;; We found a definition that is aliased the right
+ ;; number of times. We still recurse in case it is a
+ ;; lexical.
+ (values (find-definition y 1)
+ op))
+ (else
+ ;; We can't account for our aliases.
+ (values #f #f))))))
+ (else
+ ;; A formal parameter. Can't say anything about that.
+ (values #f #f))))
+ ((= n-aliases 1)
+ ;; Not a lexical: success, but only if we are looking for an
+ ;; unaliased value.
+ (values x #f))
+ (else (values #f #f))))
+
+ (let ((tag (for-value tag))
+ (body (for-tail body)))
+ (cond
+ ((find-definition tag 1)
+ (lambda (val op)
+ (make-prompt-tag? val))
+ => (lambda (val op)
+ ;; There is no way that an <abort> could know the tag
+ ;; for this <prompt>, so we can elide the <prompt>
+ ;; entirely.
+ (unrecord-operand-uses op 1)
+ body))
+ ((find-definition tag 2)
+ (lambda (val op)
+ (and (make-prompt-tag? val)
+ (abort? body)
+ (tree-il=? (abort-tag body) tag)))
+ => (lambda (val op)
+ ;; (let ((t (make-prompt-tag)))
+ ;; (call-with-prompt t
+ ;; (lambda () (abort-to-prompt t val ...))
+ ;; (lambda (k arg ...) e ...)))
+ ;; => (let-values (((k arg ...) (values values val ...)))
+ ;; e ...)
+ (unrecord-operand-uses op 2)
+ (for-tail
+ (make-let-values
+ src
+ (make-application #f (make-primitive-ref #f 'apply)
+ `(,(make-primitive-ref #f 'values)
+ ,(make-primitive-ref #f 'values)
+ ,@(abort-args body)
+ ,(abort-tail body)))
+ (for-value handler)))))
+ (else
+ (make-prompt src tag body (for-value handler))))))
(($ <abort> src tag args tail)
(make-abort src (for-value tag) (map for-value args)
(for-value tail))))))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 23f5df5..a1c5adc 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -29,8 +29,11 @@
expand-primitives!
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive? accessor-primitive?
- singly-valued-primitive?))
+ singly-valued-primitive? bailout-primitive?
+ negate-primitive))
+;; When adding to this, be sure to update *multiply-valued-primitives*
+;; if appropriate.
(define *interesting-primitive-names*
'(apply @apply
call-with-values @call-with-values
@@ -43,9 +46,16 @@
memq memv
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
- ash logand logior logxor
+ ash logand logior logxor lognot
not
- pair? null? list? symbol? vector? string? struct?
+ pair? null? list? symbol? vector? string? struct? number? char?
+
+ complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+
+ char<? char<=? char>=? char>?
+
+ integer->char char->integer number->string string->number
+
acons cons cons*
list vector
@@ -69,6 +79,8 @@
@prompt call-with-prompt @abort abort-to-prompt
make-prompt-tag
+ throw error scm-error
+
string-length string-ref string-set!
struct-vtable make-struct struct-ref struct-set!
@@ -122,7 +134,7 @@
'(vector-ref
car cdr
memq memv
- struct-vtable struct-ref
+ struct-ref
string-ref
bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref
@@ -138,9 +150,14 @@
`(values
eq? eqv? equal?
= < > <= >= zero?
+ ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string?
+ pair? null? list? symbol? vector? struct? string? number? char?
+ complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+ char<? char<=? char>=? char>?
+ integer->char char->integer number->string string->number
+ struct-vtable
string-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
@@ -156,59 +173,38 @@
'(values
eq? eqv? equal?
not
- pair? null? list? symbol? vector? struct? string?
+ pair? null? list? symbol? vector? struct? string? number? char?
acons cons cons* list vector))
-;; Primitives that only return one value.
-(define *singly-valued-primitives*
- '(eq? eqv? equal?
- memq memv
- = < > <= >= zero?
- + * - / 1- 1+ quotient remainder modulo
- ash logand logior logxor
- not
- pair? null? list? symbol? vector? acons cons cons*
- list vector
- car cdr
- set-car! set-cdr!
- caar cadr cdar cddr
- caaar caadr cadar caddr cdaar cdadr cddar cdddr
- caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
- cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
- variable-ref variable-set!
- variable-bound?
- fluid-ref fluid-set!
- make-prompt-tag
- struct? struct-vtable make-struct struct-ref struct-set!
- string-length string-ref string-set!
- bytevector-u8-ref bytevector-u8-set!
- bytevector-s8-ref bytevector-s8-set!
- u8vector-ref u8vector-set! s8vector-ref s8vector-set!
- bytevector-u16-ref bytevector-u16-set!
- bytevector-u16-native-ref bytevector-u16-native-set!
- bytevector-s16-ref bytevector-s16-set!
- bytevector-s16-native-ref bytevector-s16-native-set!
- u16vector-ref u16vector-set! s16vector-ref s16vector-set!
- bytevector-u32-ref bytevector-u32-set!
- bytevector-u32-native-ref bytevector-u32-native-set!
- bytevector-s32-ref bytevector-s32-set!
- bytevector-s32-native-ref bytevector-s32-native-set!
- u32vector-ref u32vector-set! s32vector-ref s32vector-set!
- bytevector-u64-ref bytevector-u64-set!
- bytevector-u64-native-ref bytevector-u64-native-set!
- bytevector-s64-ref bytevector-s64-set!
- bytevector-s64-native-ref bytevector-s64-native-set!
- u64vector-ref u64vector-set! s64vector-ref s64vector-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!
- f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+;; Primitives that don't always return one value.
+(define *multiply-valued-primitives*
+ '(apply @apply
+ call-with-values @call-with-values
+ call-with-current-continuation @call-with-current-continuation
+ call/cc
+ dynamic-wind
+ @dynamic-wind
+ values
+ @prompt call-with-prompt @abort abort-to-prompt))
+
+;; Procedures that cause a nonlocal, non-resumable abort.
+(define *bailout-primitives*
+ '(throw error scm-error))
+
+;; Negatable predicates.
+(define *negatable-primitives*
+ '((even? . odd?)
+ (exact? . inexact?)
+ (< . >=)
+ (> . <=)
+ (char<? . char>=?)
+ (char>? . char<=?)))
(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
-(define *singly-valued-primitive-table* (make-hash-table))
+(define *multiply-valued-primitive-table* (make-hash-table))
+(define *bailout-primitive-table* (make-hash-table))
+(define *negatable-primitive-table* (make-hash-table))
(for-each (lambda (x)
(hashq-set! *effect-free-primitive-table* x #t))
@@ -217,8 +213,15 @@
(hashq-set! *effect+exceptions-free-primitive-table* x #t))
*effect+exception-free-primitives*)
(for-each (lambda (x)
- (hashq-set! *singly-valued-primitive-table* x #t))
- *singly-valued-primitives*)
+ (hashq-set! *multiply-valued-primitive-table* x #t))
+ *multiply-valued-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *bailout-primitive-table* x #t))
+ *bailout-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *negatable-primitive-table* (car x) (cdr x))
+ (hashq-set! *negatable-primitive-table* (cdr x) (car x)))
+ *negatable-primitives*)
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
@@ -229,7 +232,11 @@
(define (effect+exception-free-primitive? prim)
(hashq-ref *effect+exceptions-free-primitive-table* prim))
(define (singly-valued-primitive? prim)
- (hashq-ref *singly-valued-primitive-table* prim))
+ (not (hashq-ref *multiply-valued-primitive-table* prim)))
+(define (bailout-primitive? prim)
+ (hashq-ref *bailout-primitive-table* prim))
+(define (negate-primitive prim)
+ (hashq-ref *negatable-primitive-table* prim))
(define (resolve-primitives! x mod)
(post-order!
@@ -240,13 +247,15 @@
(module-variable mod name))
(lambda (name) (make-primitive-ref src name))))
((<module-ref> src mod name public?)
- ;; for the moment, we're disabling primitive resolution for
- ;; public refs because resolve-interface can raise errors.
- (let ((m (and (not public?) (resolve-module mod))))
- (and m
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable m name))
- (lambda (name) (make-primitive-ref src name))))))
+ (and=> (and=> (resolve-module mod)
+ (if public?
+ module-public-interface
+ identity))
+ (lambda (m)
+ (and=> (hashq-ref *interesting-primitive-vars*
+ (module-variable m name))
+ (lambda (name)
+ (make-primitive-ref src name))))))
(else #f)))
x))
@@ -359,6 +368,18 @@
(x) (/ 1 x)
(x y z . rest) (/ x (* y z . rest)))
+(define-primitive-expander logior
+ () 0
+ (x) (logior x 0)
+ (x y) (logior x y)
+ (x y z . rest) (logior x (logior y z . rest)))
+
+(define-primitive-expander logand
+ () -1
+ (x) (logand x -1)
+ (x y) (logand x y)
+ (x y z . rest) (logand x (logand 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)))
@@ -538,22 +559,21 @@
'call-with-prompt
(case-lambda
((src tag thunk handler)
- ;; Sigh. Until the inliner does its job, manually inline
- ;; (let ((h (lambda ...))) (prompt k x h))
- (cond
- ((lambda? handler)
- (let ((args-sym (gensym)))
- (make-prompt
- src tag (make-application #f thunk '())
- ;; If handler itself is a lambda, the inliner can do some
- ;; trickery here.
- (make-lambda-case
- (tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application #f (make-primitive-ref #f 'apply)
- (list handler
- (make-lexical-ref #f 'args
args-sym)))
- #f))))
- (else #f)))
+ (let ((handler-sym (gensym))
+ (args-sym (gensym)))
+ (make-let
+ src '(handler) (list handler-sym) (list handler)
+ (make-prompt
+ src tag (make-application #f thunk '())
+ ;; If handler itself is a lambda, the inliner can do some
+ ;; trickery here.
+ (make-lambda-case
+ (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+ (make-application
+ #f (make-primitive-ref #f 'apply)
+ (list (make-lexical-ref #f 'handler handler-sym)
+ (make-lexical-ref #f 'args args-sym)))
+ #f)))))
(else #f)))
(hashq-set! *primitive-expand-table*
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index e433b86..76f16fb 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012 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,7 @@
#:use-module (oop goops)
#:use-module (oop goops util)
#:use-module (oop goops compile)
+ #:use-module (system base target)
#:export (memoize-method!)
#:no-backtrace)
@@ -178,9 +179,16 @@
'())
(acons gf gf-sym '()))))
(define (comp exp vals)
- (let ((p ((@ (system base compile) compile) exp #:env *dispatch-module*)))
- (apply p vals)))
-
+ ;; When cross-compiling Guile itself, the native Guile must generate
+ ;; code for the host.
+ (with-target %host-type
+ (lambda ()
+ (let ((p ((@ (system base compile) compile) exp
+ #:env *dispatch-module*
+ #:from 'scheme
+ #:opts '(#:partial-eval? #f #:cse? #f))))
+ (apply p vals)))))
+
;; kick it.
(scan))
diff --git a/module/oop/goops/util.scm b/module/oop/goops/util.scm
index 69bb898..af72bc3 100644
--- a/module/oop/goops/util.scm
+++ b/module/oop/goops/util.scm
@@ -17,7 +17,7 @@
(define-module (oop goops util)
- :export (mapappend find-duplicate top-level-env top-level-env?
+ :export (mapappend find-duplicate
map* for-each* length* improper->proper)
:use-module (srfi srfi-1)
:re-export (any every)
@@ -37,15 +37,18 @@
((memv (car l) (cdr l)) (car l))
(else (find-duplicate (cdr l)))))
-(define (top-level-env)
- (let ((mod (current-module)))
- (if mod
- (module-eval-closure mod)
- '())))
+(begin-deprecated
+ (define (top-level-env)
+ (let ((mod (current-module)))
+ (if mod
+ (module-eval-closure mod)
+ '())))
-(define (top-level-env? env)
- (or (null? env)
- (procedure? (car env))))
+ (define (top-level-env? env)
+ (or (null? env)
+ (procedure? (car env))))
+
+ (export top-level-env? top-level-env))
(define (map* fn . l) ; A map which accepts dotted lists (arg lists
(cond ; must be "isomorph"
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index d2b9c94..8f86bce 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -48,14 +48,14 @@
;; The vtable of all condition types.
;; vtable fields: vtable, self, printer
;; user fields: id, parent, all-field-names
- (make-vtable-vtable "prprpr" 0
- (lambda (ct port)
- (if (eq? ct %condition-type-vtable)
- (display "#<condition-type-vtable>")
- (format port "#<condition-type ~a ~a>"
- (condition-type-id ct)
- (number->string (object-address ct)
- 16))))))
+ (let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
+ (lambda (ct port)
+ (format port "#<condition-type ~a ~a>"
+ (condition-type-id ct)
+ (number->string (object-address ct)
+ 16))))))
+ (set-struct-vtable-name! s 'condition-type)
+ s))
(define (%make-condition-type layout id parent all-fields)
(let ((struct (make-struct %condition-type-vtable 0
diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm
index 818ae7a..43f5ef6 100644
--- a/module/srfi/srfi-4.scm
+++ b/module/srfi/srfi-4.scm
@@ -1,6 +1,7 @@
;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
-;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010 Free Software
Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010,
+;; 2012 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
@@ -79,7 +80,8 @@
(apply make-srfi-4-vector ',tag len fill))
(define (,(symbol-append tag 'vector-length) v)
(let ((len (* (uniform-vector-length v)
- (/ ,size (uniform-vector-element-size v)))))
+ (uniform-vector-element-size v)
+ (/ ,size))))
(if (integer? len)
len
(error "fractional length" v ',tag ,size))))
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
index ac22809..39d6350 100644
--- a/module/srfi/srfi-4/gnu.scm
+++ b/module/srfi/srfi-4/gnu.scm
@@ -1,6 +1,6 @@
;;; Extensions to SRFI-4
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 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
@@ -52,7 +52,8 @@
(apply make-srfi-4-vector ',tag len fill))
(define (,(symbol-append tag 'vector-length) v)
(let ((len (* (uniform-vector-length v)
- (/ ,size (uniform-vector-element-size v)))))
+ (uniform-vector-element-size v)
+ (/ ,size))))
(if (integer? len)
len
(error "fractional length" v ',tag ,size))))
diff --git a/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm
index 098b586..7b8bcb1 100644
--- a/module/srfi/srfi-6.scm
+++ b/module/srfi/srfi-6.scm
@@ -1,6 +1,6 @@
;;; srfi-6.scm --- Basic String Ports
-;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2006, 2012 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
@@ -23,10 +23,20 @@
;;; Code:
(define-module (srfi srfi-6)
- #:re-export (open-input-string open-output-string get-output-string))
+ #:replace (open-input-string open-output-string)
+ #:re-export (get-output-string))
-;; Currently, guile provides these functions by default, so no action
-;; is needed, and this file is just a placeholder.
+;; SRFI-6 says nothing about encodings, and assumes that any character
+;; or string can be written to a string port. Thus, make all SRFI-6
+;; string ports Unicode capable. See <http://bugs.gnu.org/11197>.
+
+(define (open-input-string s)
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ ((@ (guile) open-input-string) s)))
+
+(define (open-output-string)
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ ((@ (guile) open-output-string))))
(cond-expand-provide (current-module) '(srfi-6))
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index cb8dd0a..da71d1e 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -1,6 +1,6 @@
;;; srfi-9.scm --- define-record-type
-;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011 Free Software
Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012 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
@@ -188,8 +188,12 @@
(let* ((fields (field-identifiers #'(field-spec ...)))
(field-count (length fields))
(layout (string-concatenate (make-list field-count "pw")))
- (indices (field-indices (map syntax->datum fields))))
+ (indices (field-indices (map syntax->datum fields)))
+ (ctor-name (syntax-case #'constructor-spec ()
+ ((ctor args ...) #'ctor))))
#`(begin
+ #,(constructor #'type-name #'constructor-spec indices)
+
(define type-name
(let ((rtd (make-struct/no-tail
record-type-vtable
@@ -198,13 +202,13 @@
'type-name
'#,fields)))
(set-struct-vtable-name! rtd 'type-name)
+ (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
rtd))
+
(define-inlinable (predicate-name obj)
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
- #,(constructor #'type-name #'constructor-spec indices)
-
#,@(accessors #'type-name #'(field-spec ...) indices)))))))
;;; srfi-9.scm ends here
diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm
index 00563f6..e9b9eb2 100644
--- a/module/system/base/pmatch.scm
+++ b/module/system/base/pmatch.scm
@@ -1,6 +1,6 @@
;;; pmatch, a simple matcher
-;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc
+;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc
;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
;;; Copyright (C) 2007 Daniel P. Friedman
;;;
@@ -35,22 +35,22 @@
;;; Code:
(define-module (system base pmatch)
- #:export (pmatch))
+ #:export-syntax (pmatch))
-(define-syntax pmatch
+(define-syntax-rule (pmatch e cs ...)
+ (let ((v e)) (pmatch1 v cs ...)))
+
+(define-syntax pmatch1
(syntax-rules (else guard)
- ((_ (op arg ...) cs ...)
- (let ((v (op arg ...)))
- (pmatch v cs ...)))
((_ v) (if #f #f))
((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...)
- (let ((fk (lambda () (pmatch v cs ...))))
+ (let ((fk (lambda () (pmatch1 v cs ...))))
(ppat v pat
(if (and g ...) (let () e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
- (let ((fk (lambda () (pmatch v cs ...))))
+ (let ((fk (lambda () (pmatch1 v cs ...))))
(ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index a709c8d..ae8bdea 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -342,7 +342,12 @@ Find bindings/modules/packages."
(define-meta-command (describe repl (form))
"describe OBJ
Show description/documentation."
- (display (object-documentation (repl-eval repl (repl-parse repl form))))
+ (display
+ (object-documentation
+ (let ((input (repl-parse repl form)))
+ (if (symbol? input)
+ (module-ref (current-module) input)
+ (repl-eval repl input)))))
(newline))
(define-meta-command (option repl . args)
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 37f621b..40d4080 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
;;; Guile VM frame functions
-;;; Copyright (C) 2001, 2005, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012 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,8 +32,10 @@
frame-return-values))
(define (frame-bindings frame)
- (program-bindings-for-ip (frame-procedure frame)
- (frame-instruction-pointer frame)))
+ (let ((p (frame-procedure frame)))
+ (if (program? p)
+ (program-bindings-for-ip p (frame-instruction-pointer frame))
+ '())))
(define (frame-lookup-binding frame var)
(let lp ((bindings (frame-bindings frame)))
@@ -72,9 +74,11 @@
(define (frame-next-source frame)
(let ((proc (frame-procedure frame)))
- (program-source proc
- (frame-instruction-pointer frame)
- (program-sources-pre-retire proc))))
+ (if (program? proc)
+ (program-source proc
+ (frame-instruction-pointer frame)
+ (program-sources-pre-retire proc))
+ '())))
;; Basically there are two cases to deal with here:
@@ -95,9 +99,10 @@
(define (frame-call-representation frame)
(let ((p (frame-procedure frame)))
(cons
- (or (procedure-name p) p)
+ (or (false-if-exception (procedure-name p)) p)
(cond
- ((program-arguments-alist p (frame-instruction-pointer frame))
+ ((and (program? p)
+ (program-arguments-alist p (frame-instruction-pointer frame)))
;; case 1
=> (lambda (arguments)
(define (binding-ref sym i)
diff --git a/module/texinfo.scm b/module/texinfo.scm
index 8798eb3..2ffd853 100644
--- a/module/texinfo.scm
+++ b/module/texinfo.scm
@@ -1,6 +1,6 @@
;;;; (texinfo) -- parsing of texinfo into SXML
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
;;;;
@@ -128,6 +128,8 @@ Parsed arguments until end of line
Unparsed arguments ending with @address@hidden
@item INLINE-TEXT
Parsed arguments ending with @address@hidden
address@hidden INLINE-TEXT-ARGS
+Parsed arguments ending with @address@hidden
@item ENVIRON
The tag is an environment tag, expect @code{@@end foo}.
@item TABLE-ENVIRON
@@ -169,7 +171,7 @@ entry.
@item args
Named arguments to the command, in the same format as the formals for a
lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
address@hidden, @code{TABLE-ENVIRON} commands.
address@hidden, @code{ENVIRON}, @code{TABLE-ENVIRON} commands.
@end table"
'(;; Special commands
(include #f) ;; this is a low-level token
@@ -224,6 +226,9 @@ lambda. Only present for @code{INLINE-ARGS},
@code{EOL-ARGS},
(tie INLINE-ARGS . ())
(image INLINE-ARGS . (file #:opt width height alt-text
extension))
+ ;; Inline parsed args commands
+ (acronym INLINE-TEXT-ARGS . (acronym #:opt meaning))
+
;; EOL args elements
(node EOL-ARGS . (name #:opt next previous up))
(c EOL-ARGS . all)
@@ -383,7 +388,9 @@ Examples:
(parser-error #f "Unknown command" command)))
(define (inline-content? content)
- (or (eq? content 'INLINE-TEXT) (eq? content 'INLINE-ARGS)))
+ (case content
+ ((INLINE-TEXT INLINE-ARGS INLINE-TEXT-ARGS) #t)
+ (else #f)))
;;========================================================================
@@ -572,6 +579,7 @@ Examples:
;; Content model Port position
;; ============= =============
;; INLINE-TEXT One character after the #\{.
+;; INLINE-TEXT-ARGS One character after the #\{.
;; INLINE-ARGS The first character after the #\}.
;; EOL-TEXT The first non-whitespace character after the command.
;; ENVIRON, TABLE-ENVIRON, EOL-ARGS, EOL-TEXT
@@ -599,7 +607,9 @@ Examples:
(car names))))
(else
(loop (cdr in) (cdr names) opt?
- (cons (list (car names) (car in)) out))))))
+ (acons (car names)
+ (if (list? (car in)) (car in) (list (car in)))
+ out))))))
(define (parse-table-args command port)
(let* ((line (string-trim-both (read-text-line port)))
@@ -648,6 +658,9 @@ Examples:
((INLINE-ARGS)
(assert-curr-char '(#\{) "Inline element lacks {" port)
(values command (get-arguments type arg-names #\}) type))
+ ((INLINE-TEXT-ARGS)
+ (assert-curr-char '(#\{) "Inline element lacks {" port)
+ (values command '() type))
((EOL-ARGS)
(values command (get-arguments type arg-names #\newline) type))
((ENVIRON ENTRY INDEX)
@@ -998,15 +1011,48 @@ Examples:
(cons (apply string-append strs) result))))
'() #t)))))))
+(define (parse-inline-text-args port spec text)
+ (let lp ((in text) (cur '()) (out '()))
+ (cond
+ ((null? in)
+ (if (and (pair? cur)
+ (string? (car cur))
+ (string-whitespace? (car cur)))
+ (lp in (cdr cur) out)
+ (let ((args (reverse (if (null? cur)
+ out
+ (cons (reverse cur) out)))))
+ (arguments->attlist port args (cddr spec)))))
+ ((pair? (car in))
+ (lp (cdr in) (cons (car in) cur) out))
+ ((string-index (car in) #\,)
+ (let* ((parts (string-split (car in) #\,))
+ (head (string-trim-right (car parts)))
+ (rev-tail (reverse (cdr parts)))
+ (last (string-trim (car rev-tail))))
+ (lp (cdr in)
+ (if (string-null? last) cur (cons last cur))
+ (append (cdr rev-tail)
+ (cons (reverse (if (string-null? head) cur (cons head
cur)))
+ out)))))
+ (else
+ (lp (cdr in)
+ (cons (if (null? cur) (string-trim (car in)) (car in)) cur)
+ out)))))
+
(define (make-dom-parser)
(make-command-parser
(lambda (command args content seed) ; fdown
'())
(lambda (command args parent-seed seed) ; fup
- (let ((seed (reverse-collect-str-drop-ws seed)))
- (acons command
- (if (null? args) seed (acons '% args seed))
- parent-seed)))
+ (let ((seed (reverse-collect-str-drop-ws seed))
+ (spec (command-spec command)))
+ (if (eq? (cadr spec) 'INLINE-TEXT-ARGS)
+ (cons (list command (cons '% (parse-inline-text-args #f spec seed)))
+ parent-seed)
+ (acons command
+ (if (null? args) seed (acons '% args seed))
+ parent-seed))))
(lambda (string1 string2 seed) ; str-handler
(if (string-null? string2)
(cons string1 seed)
diff --git a/module/texinfo/docbook.scm b/module/texinfo/docbook.scm
index 7277926..c5a8d65 100644
--- a/module/texinfo/docbook.scm
+++ b/module/texinfo/docbook.scm
@@ -1,6 +1,6 @@
;;;; (texinfo docbook) -- translating sdocbook into stexinfo
;;;;
-;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc.
;;;; Copyright (C) 2007, 2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -89,14 +89,20 @@ a number of generic rules for transforming docbook into
texinfo."
`(item ,@body))))
. ,(lambda (tag . body)
`(itemize ,@body)))
+ (acronym . ,(lambda (tag . body)
+ `(acronym (% (acronym . ,body)))))
(term . ,detag-one)
(informalexample . ,detag-one)
(section . ,identity)
(subsection . ,identity)
(subsubsection . ,identity)
(ulink . ,(lambda (tag attrs . body)
- `(uref (% ,(assq 'url (cdr attrs))
- (title ,@body)))))
+ (cond
+ ((assq 'url (cdr attrs))
+ => (lambda (url)
+ `(uref (% ,url (title ,@body)))))
+ (else
+ (car body)))))
(*text* . ,detag-one)
(*default* . ,(lambda (tag . body)
(let ((subst (assq tag tag-replacements)))
diff --git a/module/texinfo/serialize.scm b/module/texinfo/serialize.scm
index 6a32d23..1436ad5 100644
--- a/module/texinfo/serialize.scm
+++ b/module/texinfo/serialize.scm
@@ -1,6 +1,6 @@
;;;; (texinfo serialize) -- rendering stexinfo as texinfo
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2012 Free Software Foundation, Inc.
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -98,6 +98,20 @@
","))
"{" command "@" accum))
+(define (inline-text-args exp lp command type formals args accum)
+ (list* "}"
+ (if (not args) ""
+ (apply
+ append
+ (list-intersperse
+ (map
+ (lambda (x) (append-map (lambda (x) (lp x '())) (reverse x)))
+ (drop-while not
+ (map (lambda (x) (assq-ref args x))
+ (reverse formals))))
+ '(","))))
+ "{" command "@" accum))
+
(define (serialize-text-args lp formals args)
(apply
append
@@ -202,6 +216,7 @@
`((EMPTY-COMMAND . ,empty-command)
(INLINE-TEXT . ,inline-text)
(INLINE-ARGS . ,inline-args)
+ (INLINE-TEXT-ARGS . ,inline-text-args)
(EOL-TEXT . ,eol-text)
(EOL-TEXT-ARGS . ,eol-text-args)
(INDEX . ,eol-text-args)
diff --git a/module/web/http.scm b/module/web/http.scm
index c15bc3e..cc5dd5a 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1,6 +1,6 @@
;;; HTTP messages
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -34,11 +34,15 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 q)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
#:use-module (web uri)
#:export (string->header
header->string
declare-header!
+ declare-opaque-header!
known-header?
header-parser
header-validator
@@ -59,7 +63,10 @@
read-request-line
write-request-line
read-response-line
- write-response-line))
+ write-response-line
+
+ make-chunked-input-port
+ make-chunked-output-port))
;;; TODO
@@ -185,7 +192,7 @@ body was reached (i.e., a blank line)."
sym
(read-continuation-line
port
- (string-trim-both line char-whitespace? (1+ delim)))))))))
+ (string-trim-both line char-set:whitespace (1+ delim)))))))))
(define (parse-header sym val)
"Parse @var{val}, a string, with the parser registered for the header
@@ -240,7 +247,22 @@ ordered alist."
(define (bad-header sym val)
(throw 'bad-header sym val))
(define (bad-header-component sym val)
- (throw 'bad-header sym val))
+ (throw 'bad-header-component sym val))
+
+(define (bad-header-printer port key args default-printer)
+ (apply (case-lambda
+ ((sym val)
+ (format port "Bad ~a header: ~a\n" (header->string sym) val))
+ (_ (default-printer)))
+ args))
+(define (bad-header-component-printer port key args default-printer)
+ (apply (case-lambda
+ ((sym val)
+ (format port "Bad ~a header component: ~a\n" sym val))
+ (_ (default-printer)))
+ args))
+(set-exception-printer! 'bad-header bad-header-printer)
+(set-exception-printer! 'bad-header-component bad-header-component-printer)
(define (parse-opaque-string str)
str)
@@ -277,7 +299,7 @@ ordered alist."
(let lp ((i start))
(if (< i end)
(let* ((idx (string-index str delim i end))
- (tok (string-trim-both str char-whitespace? i (or idx end))))
+ (tok (string-trim-both str char-set:whitespace i (or idx end))))
(cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
'())))
@@ -420,13 +442,13 @@ ordered alist."
(cond
((string-rindex part #\;)
=> (lambda (idx)
- (let ((qpart (string-trim-both part char-whitespace? (1+
idx))))
+ (let ((qpart (string-trim-both part char-set:whitespace (1+
idx))))
(if (string-prefix? "q=" qpart)
(cons (parse-quality qpart 2)
- (string-trim-both part char-whitespace? 0 idx))
+ (string-trim-both part char-set:whitespace 0 idx))
(bad-header-component 'quality qpart)))))
(else
- (cons 1000 (string-trim-both part char-whitespace?)))))
+ (cons 1000 (string-trim-both part char-set:whitespace)))))
(string-split str #\,)))
(define (validate-quality-list l)
@@ -541,15 +563,15 @@ ordered alist."
;; param-component = token [ "=" (token | quoted-string) ] \
;; *(";" token [ "=" (token | quoted-string) ])
;;
+(define param-delimiters (char-set #\, #\; #\=))
+(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;))
(define* (parse-param-component str #:optional
(val-parser default-val-parser)
(start 0) (end (string-length str)))
(let lp ((i start) (out '()))
(if (not (< i end))
(values (reverse! out) end)
- (let ((delim (string-index str
- (lambda (c) (memq c '(#\, #\; #\=)))
- i)))
+ (let ((delim (string-index str param-delimiters i)))
(let ((k (string->symbol
(substring str i (trim-whitespace str i (or delim end)))))
(delimc (and delim (string-ref str delim))))
@@ -561,13 +583,8 @@ ordered alist."
(if (and (< i end) (eqv? (string-ref str i) #\"))
(parse-qstring str i end #:incremental? #t)
(let ((delim
- (or (string-index
- str
- (lambda (c)
- (or (eqv? c #\;)
- (eqv? c #\,)
- (char-whitespace? c)))
- i end)
+ (or (string-index str param-value-delimiters
+ i end)
end)))
(values (substring str i delim)
delim)))))
@@ -790,7 +807,7 @@ ordered alist."
port)
(display-digits (date-day date) 2 port)
(display (case (date-month date)
- ((1) " Jan ") ((2) " Feb ") ((3) " Ma ")
+ ((1) " Jan ") ((2) " Feb ") ((3) " Mar ")
((4) " Apr ") ((5) " May ") ((6) " Jun ")
((7) " Jul ") ((8) " Aug ") ((9) " Sep ")
((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
@@ -853,7 +870,7 @@ ordered alist."
(define* (parse-credentials str #:optional (val-parser default-val-parser)
(start 0) (end (string-length str)))
(let* ((start (skip-whitespace str start end))
- (delim (or (string-index str char-whitespace? start end) end)))
+ (delim (or (string-index str char-set:whitespace start end) end)))
(if (= start end)
(bad-header-component 'authorization str))
(let ((scheme (string->symbol
@@ -1038,8 +1055,8 @@ not have to have a scheme or host name. The result is a
URI object."
"Read the first line of an HTTP request from @var{port}, returning
three values: the method, the URI, and the version."
(let* ((line (read-line* port))
- (d0 (string-index line char-whitespace?)) ; "delimiter zero"
- (d1 (string-rindex line char-whitespace?)))
+ (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+ (d1 (string-rindex line char-set:whitespace)))
(if (and d0 d1 (< d0 d1))
(values (parse-http-method line 0 d0)
(parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
@@ -1100,14 +1117,14 @@ three values: the method, the URI, and the version."
three values: the HTTP version, the response code, and the \"reason
phrase\"."
(let* ((line (read-line* port))
- (d0 (string-index line char-whitespace?)) ; "delimiter zero"
- (d1 (and d0 (string-index line char-whitespace?
+ (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+ (d1 (and d0 (string-index line char-set:whitespace
(skip-whitespace line d0)))))
(if (and d0 d1)
(values (parse-http-version line 0 d0)
(parse-non-negative-integer line (skip-whitespace line d0 d1)
d1)
- (string-trim-both line char-whitespace? d1))
+ (string-trim-both line char-set:whitespace d1))
(bad-response "Bad Response-Line: ~s" line))))
(define (write-response-line version code reason-phrase port)
@@ -1129,6 +1146,8 @@ phrase\"."
;; emacs: (put 'declare-header! 'scheme-indent-function 1)
;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
(define (declare-opaque-header! name)
+ "Declares a given header as \"opaque\", meaning that its value is not
+treated specially, and is just returned as a plain string."
(declare-header! name
parse-opaque-string validate-opaque-string write-opaque-string))
@@ -1488,9 +1507,10 @@ phrase\"."
(map (lambda (x)
(let ((eq (string-index x #\=)))
(if (and eq (= eq (string-rindex x #\=)))
- (cons (string->symbol
- (string-trim x char-whitespace? 0 eq))
- (string-trim-right x char-whitespace? (1+ eq)))
+ (cons
+ (string->symbol
+ (string-trim x char-set:whitespace 0 eq))
+ (string-trim-right x char-set:whitespace (1+ eq)))
(bad-header 'content-type str))))
(cdr parts)))))
(lambda (val)
@@ -1788,3 +1808,99 @@ phrase\"."
;; WWW-Authenticate = 1#challenge
;;
(declare-challenge-list-header! "WWW-Authenticate")
+
+
+;; Chunked Responses
+(define (read-chunk-header port)
+ (let* ((str (read-line port))
+ (extension-start (string-index str (lambda (c) (or (char=? c #\;)
+ (char=? c #\return)))))
+ (size (string->number (if extension-start ; unnecessary?
+ (substring str 0 extension-start)
+ str)
+ 16)))
+ size))
+
+(define (read-chunk port)
+ (let ((size (read-chunk-header port)))
+ (read-chunk-body port size)))
+
+(define (read-chunk-body port size)
+ (let ((bv (get-bytevector-n port size)))
+ (get-u8 port) ; CR
+ (get-u8 port) ; LF
+ bv))
+
+(define* (make-chunked-input-port port #:key (keep-alive? #f))
+ "Returns a new port which translates HTTP chunked transfer encoded
+data from @var{port} into a non-encoded format. Returns eof when it has
+read the final chunk from @var{port}. This does not necessarily mean
+that there is no more data on @var{port}. When the returned port is
+closed it will also close @var{port}, unless the KEEP-ALIVE? is true."
+ (define (next-chunk)
+ (read-chunk port))
+ (define finished? #f)
+ (define (close)
+ (unless keep-alive?
+ (close-port port)))
+ (define buffer #vu8())
+ (define buffer-size 0)
+ (define buffer-pointer 0)
+ (define (read! bv idx to-read)
+ (define (loop to-read num-read)
+ (cond ((or finished? (zero? to-read))
+ num-read)
+ ((<= to-read (- buffer-size buffer-pointer))
+ (bytevector-copy! buffer buffer-pointer
+ bv (+ idx num-read)
+ to-read)
+ (set! buffer-pointer (+ buffer-pointer to-read))
+ (loop 0 (+ num-read to-read)))
+ (else
+ (let ((n (- buffer-size buffer-pointer)))
+ (bytevector-copy! buffer buffer-pointer
+ bv (+ idx num-read)
+ n)
+ (set! buffer (next-chunk))
+ (set! buffer-pointer 0)
+ (set! buffer-size (bytevector-length buffer))
+ (set! finished? (= buffer-size 0))
+ (loop (- to-read n)
+ (+ num-read n))))))
+ (loop to-read 0))
+ (make-custom-binary-input-port "chunked input port" read! #f #f close))
+
+(define* (make-chunked-output-port port #:key (keep-alive? #f))
+ "Returns a new port which translates non-encoded data into a HTTP
+chunked transfer encoded data and writes this to @var{port}. Data
+written to this port is buffered until the port is flushed, at which
+point it is all sent as one chunk. Take care to close the port when
+done, as it will output the remaining data, and encode the final zero
+chunk. When the port is closed it will also close @var{port}, unless
+KEEP-ALIVE? is true."
+ (define (q-for-each f q)
+ (while (not (q-empty? q))
+ (f (deq! q))))
+ (define queue (make-q))
+ (define (put-char c)
+ (enq! queue c))
+ (define (put-string s)
+ (string-for-each (lambda (c) (enq! queue c))
+ s))
+ (define (flush)
+ ;; It is important that we do _not_ write a chunk if the queue is
+ ;; empty, since it will be treated as the final chunk.
+ (unless (q-empty? queue)
+ (let ((len (q-length queue)))
+ (display (number->string len 16) port)
+ (display "\r\n" port)
+ (q-for-each (lambda (elem) (write-char elem port))
+ queue)
+ (display "\r\n" port))))
+ (define (close)
+ (flush)
+ (display "0\r\n" port)
+ (force-output port)
+ (unless keep-alive?
+ (close-port port)))
+ (make-soft-port (vector put-char put-string flush #f close) "w"))
diff --git a/module/web/request.scm b/module/web/request.scm
index 8259887..40d4a66 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -1,6 +1,6 @@
;;; HTTP request objects
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012 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
@@ -131,6 +131,17 @@
(define (bad-request message . args)
(throw 'bad-request message args))
+(define (bad-request-printer port key args default-printer)
+ (apply (case-lambda
+ ((msg args)
+ (display "Bad request: " port)
+ (apply format port msg args)
+ (newline port))
+ (_ (default-printer)))
+ args))
+
+(set-exception-printer! 'bad-request bad-request-printer)
+
(define (non-negative-integer? n)
(and (number? n) (>= n 0) (exact? n) (integer? n)))
diff --git a/module/web/response.scm b/module/web/response.scm
index 07e1245..6eba69d 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -227,13 +227,17 @@ This is true for some response types, like those with
code 304."
(define (read-response-body r)
"Reads the response body from @var{r}, as a bytevector. Returns
@code{#f} if there was no response body."
- (let ((nbytes (response-content-length r)))
- (and nbytes
- (let ((bv (get-bytevector-n (response-port r) nbytes)))
- (if (= (bytevector-length bv) nbytes)
- bv
- (bad-response "EOF while reading response body: ~a bytes of ~a"
- (bytevector-length bv) nbytes))))))
+ (if (member '(chunked) (response-transfer-encoding r))
+ (let ((chunk-port (make-chunked-input-port (response-port r)
+ #:keep-alive? #t)))
+ (get-bytevector-all chunk-port))
+ (let ((nbytes (response-content-length r)))
+ (and nbytes
+ (let ((bv (get-bytevector-n (response-port r) nbytes)))
+ (if (= (bytevector-length bv) nbytes)
+ bv
+ (bad-response "EOF while reading response body: ~a bytes of
~a"
+ (bytevector-length bv) nbytes)))))))
(define (write-response-body r bv)
"Write @var{bv}, a bytevector, to the port corresponding to the HTTP
diff --git a/module/web/server/http.scm b/module/web/server/http.scm
index a9a9049..cda44f4 100644
--- a/module/web/server/http.scm
+++ b/module/web/server/http.scm
@@ -1,6 +1,6 @@
;;; Web I/O: HTTP
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012 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
@@ -69,6 +69,11 @@
(poll-set-add! poll-set socket *events*)
(make-http-server socket 0 poll-set)))
+(define (bad-request port)
+ (write-response (build-response #:version '(1 . 0) #:code 400
+ #:headers '((content-length . 0)))
+ port))
+
;; -> (client request body | #f #f #f)
(define (http-read server)
(let* ((poll-set (http-poll-set server)))
@@ -123,7 +128,14 @@
req
(read-request-body req))))
(lambda (k . args)
- (false-if-exception (close-port port)))))))))))))
+ (define-syntax-rule (cleanup-catch statement)
+ (catch #t
+ (lambda () statement)
+ (lambda (k . args)
+ (format (current-error-port) "In ~a:\n" 'statement)
+ (print-exception (current-error-port) #f k args))))
+ (cleanup-catch (bad-request port))
+ (cleanup-catch (close-port port)))))))))))))
(define (keep-alive? response)
(let ((v (response-version response)))
diff --git a/module/web/uri.scm b/module/web/uri.scm
index a2a930a..109118b 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -91,7 +91,7 @@ consistency checks to make sure that the constructed URI is
valid."
(define ipv4-regexp
(make-regexp "^([0-9.]+)$"))
(define ipv6-regexp
- (make-regexp "^\\[([0-9a-fA-F:]+)\\]+$"))
+ (make-regexp "^([0-9a-fA-F:.]+)$"))
(define domain-label-regexp
(make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
(define top-label-regexp
@@ -116,12 +116,14 @@ consistency checks to make sure that the constructed URI
is valid."
"[a-zA-Z0-9_.!~*'();:&=+$,-]+")
(define host-pat
"[a-zA-Z0-9.-]+")
+(define ipv6-host-pat
+ "[0-9a-fA-F:.]+")
(define port-pat
"[0-9]*")
(define authority-regexp
(make-regexp
- (format #f "^//((~a)@)?(~a)(:(~a))?$"
- userinfo-pat host-pat port-pat)))
+ (format #f "^//((~a)@)?((~a)|(\\[(~a)\\]))(:(~a))?$"
+ userinfo-pat host-pat ipv6-host-pat port-pat)))
(define (parse-authority authority fail)
(if (equal? authority "//")
@@ -129,10 +131,12 @@ consistency checks to make sure that the constructed URI
is valid."
;; file:/etc/hosts.
(values #f #f #f)
(let ((m (regexp-exec authority-regexp authority)))
- (if (and m (valid-host? (match:substring m 3)))
+ (if (and m (valid-host? (or (match:substring m 4)
+ (match:substring m 6))))
(values (match:substring m 2)
- (match:substring m 3)
- (let ((port (match:substring m 5)))
+ (or (match:substring m 4)
+ (match:substring m 6))
+ (let ((port (match:substring m 8)))
(and port (not (string-null? port))
(string->number port))))
(fail)))))
@@ -216,7 +220,9 @@ printed."
(string-append "//"
(if userinfo (string-append userinfo "@")
"")
- host
+ (if (string-index host #\:)
+ (string-append "[" host "]")
+ host)
(if (default-port? (uri-scheme uri) port)
""
(string-append ":" (number->string port))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 5353700..22c5b19 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -1,7 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-## 2010, 2011 Software Foundation, Inc.
+## 2010, 2011, 2012 Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -39,6 +39,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/control.test \
tests/continuations.test \
tests/coverage.test \
+ tests/cse.test \
tests/curried-definitions.test \
tests/ecmascript.test \
tests/elisp.test \
@@ -75,6 +76,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/optargs.test \
tests/options.test \
tests/parameters.test \
+ tests/peval.test \
tests/print.test \
tests/procprop.test \
tests/procs.test \
@@ -166,7 +168,7 @@ SCM_TESTS = tests/00-initial-env.test \
EXTRA_DIST = \
guile-test \
- lib.scm \
+ test-suite/lib.scm \
$(SCM_TESTS) \
tests/rnrs-test-a.scm
ChangeLog-2008
diff --git a/test-suite/standalone/test-conversion.c
b/test-suite/standalone/test-conversion.c
index 09b74bf..700e5b3 100644
--- a/test-suite/standalone/test-conversion.c
+++ b/test-suite/standalone/test-conversion.c
@@ -1079,6 +1079,74 @@ test_locale_strings ()
}
static void
+test_to_utf8_stringn ()
+{
+ scm_t_wchar wstr[] = { 0x20, /* 0x20 */
+ 0xDF, /* 0xC3, 0x9F */
+ 0x65E5, /* 0xE6, 0x97, 0xA5 */
+ 0x1D400 }; /* 0xF0, 0x9D, 0x90, 0x80 */
+
+ SCM str0 = scm_from_utf32_stringn (wstr, 1); /* ASCII */
+ SCM str1 = scm_from_utf32_stringn (wstr, 2); /* Narrow */
+ SCM str2 = scm_from_utf32_stringn (wstr, 4); /* Wide */
+
+ char cstr0[] = { 0x20, 0 };
+ char cstr1[] = { 0x20, 0xC3, 0x9F, 0 };
+ char cstr2[] = { 0x20, 0xC3, 0x9F, 0xE6, 0x97, 0xA5,
+ 0xF0, 0x9D, 0x90, 0x80, 0 };
+ char *cstr;
+ size_t len;
+
+ /* Test conversion of ASCII string */
+ cstr = scm_to_utf8_stringn (str0, &len);
+ if (len + 1 != sizeof (cstr0) || memcmp (cstr, cstr0, len))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<ASCII>, &len)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+ cstr = scm_to_utf8_stringn (str0, NULL);
+ if (memcmp (cstr, cstr0, len + 1))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<ASCII>, NULL)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+
+ /* Test conversion of narrow string */
+ cstr = scm_to_utf8_stringn (str1, &len);
+ if (len + 1 != sizeof (cstr1) || memcmp (cstr, cstr1, len))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<NARROW>, &len)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+ cstr = scm_to_utf8_stringn (str1, NULL);
+ if (memcmp (cstr, cstr1, len + 1))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<NARROW>, NULL)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+
+ /* Test conversion of wide string */
+ cstr = scm_to_utf8_stringn (str2, &len);
+ if (len + 1 != sizeof (cstr2) || memcmp (cstr, cstr2, len))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<WIDE>, &len)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+ cstr = scm_to_utf8_stringn (str2, NULL);
+ if (memcmp (cstr, cstr2, len + 1))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<WIDE>, NULL)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+}
+
+static void
test_is_exact ()
{
if (1 != scm_is_exact (scm_c_eval_string ("3")))
@@ -1122,6 +1190,7 @@ tests (void *data, int argc, char **argv)
test_from_double ();
test_to_double ();
test_locale_strings ();
+ test_to_utf8_stringn ();
test_is_exact ();
test_is_inexact ();
}
diff --git a/test-suite/lib.scm b/test-suite/test-suite/lib.scm
similarity index 95%
rename from test-suite/lib.scm
rename to test-suite/test-suite/lib.scm
index 681a0d1..385cdfa 100644
--- a/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -283,7 +283,7 @@
(define exception:system-error
(cons 'system-error ".*"))
(define exception:encoding-error
- (cons 'encoding-error "(cannot convert to output locale|input (locale
conversion|decoding) error)"))
+ (cons 'encoding-error "(cannot convert.* to output locale|input (locale
conversion|decoding) error)"))
(define exception:miscellaneous-error
(cons 'misc-error "^.*"))
(define exception:read-error
@@ -314,34 +314,33 @@
;;; The central testing routine.
;;; The idea is taken from Greg, the GNUstep regression test environment.
-(define run-test #f)
-(let ((test-running #f))
- (define (local-run-test name expect-pass thunk)
- (if test-running
- (error "Nested calls to run-test are not permitted.")
- (let ((test-name (full-name name)))
- (set! test-running #t)
- (catch #t
- (lambda ()
- (let ((result (thunk)))
- (if (eq? result #t) (throw 'pass))
- (if (eq? result #f) (throw 'fail))
- (throw 'unresolved)))
- (lambda (key . args)
- (case key
- ((pass)
- (report (if expect-pass 'pass 'upass) test-name))
- ((fail)
- (report (if expect-pass 'fail 'xfail) test-name))
- ((unresolved untested unsupported)
- (report key test-name))
- ((quit)
- (report 'unresolved test-name)
- (quit))
- (else
- (report 'error test-name (cons key args))))))
- (set! test-running #f))))
- (set! run-test local-run-test))
+(define run-test
+ (let ((test-running #f))
+ (lambda (name expect-pass thunk)
+ (if test-running
+ (error "Nested calls to run-test are not permitted."))
+ (let ((test-name (full-name name)))
+ (set! test-running #t)
+ (catch #t
+ (lambda ()
+ (let ((result (thunk)))
+ (if (eq? result #t) (throw 'pass))
+ (if (eq? result #f) (throw 'fail))
+ (throw 'unresolved)))
+ (lambda (key . args)
+ (case key
+ ((pass)
+ (report (if expect-pass 'pass 'upass) test-name))
+ ((fail)
+ (report (if expect-pass 'fail 'xfail) test-name))
+ ((unresolved untested unsupported)
+ (report key test-name))
+ ((quit)
+ (report 'unresolved test-name)
+ (quit))
+ (else
+ (report 'error test-name (cons key args))))))
+ (set! test-running #f)))))
;;; A short form for tests that are expected to pass, taken from Greg.
(define-syntax pass-if
diff --git a/test-suite/tests/asm-to-bytecode.test
b/test-suite/tests/asm-to-bytecode.test
index d36b33d..4ea3dd3 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -16,7 +16,7 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-suite tests asm-to-bytecode)
+(define-module (tests asm-to-bytecode)
#:use-module (rnrs bytevectors)
#:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib)
diff --git a/test-suite/tests/brainfuck.test b/test-suite/tests/brainfuck.test
index f612fb5..cdbceaa 100644
--- a/test-suite/tests/brainfuck.test
+++ b/test-suite/tests/brainfuck.test
@@ -14,7 +14,7 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-suite tests brainfuck)
+(define-module (tests brainfuck)
#:use-module (test-suite lib)
#:use-module (system base compile))
diff --git a/test-suite/tests/bytevectors.test
b/test-suite/tests/bytevectors.test
index 3007434..4ba5012 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -1,6 +1,6 @@
;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8;
-*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -325,6 +325,18 @@
(with-test-prefix/c&e "2.8 Operations on IEEE-754 Representations"
+ (pass-if "single, little endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 4)))
+ (bytevector-ieee-single-set! b 0 1.0 (endianness little))
+ (equal? #vu8(0 0 128 63) b)))
+
+ (pass-if "single, big endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 4)))
+ (bytevector-ieee-single-set! b 0 1.0 (endianness big))
+ (equal? #vu8(63 128 0 0) b)))
+
(pass-if "bytevector-ieee-single-native-{ref,set!}"
(let ((b (make-bytevector 4))
(number 3.00))
@@ -348,6 +360,18 @@
(equal? (bytevector-ieee-single-ref b 1 (endianness little))
(bytevector-ieee-single-ref b 5 (endianness big)))))
+ (pass-if "double, little endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 8)))
+ (bytevector-ieee-double-set! b 0 1.0 (endianness little))
+ (equal? #vu8(0 0 0 0 0 0 240 63) b)))
+
+ (pass-if "double, big endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 8)))
+ (bytevector-ieee-double-set! b 0 1.0 (endianness big))
+ (equal? #vu8(63 240 0 0 0 0 0 0) b)))
+
(pass-if "bytevector-ieee-double-native-{ref,set!}"
(let ((b (make-bytevector 8))
(number 3.14))
@@ -653,3 +677,7 @@
(pass-if "bitvector > 8"
(let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
(= (bytevector-length bv) 2))))
+
+;;; Local Variables:
+;;; eval: (put 'with-test-prefix/c&e 'scheme-indent-function 1)
+;;; End:
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index ee688c0..619b167 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012 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
@@ -15,7 +15,7 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-suite tests compiler)
+(define-module (tests compiler)
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
#:use-module (system base compile)
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 4ac4043..b29de0f 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -1,6 +1,6 @@
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 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
@@ -216,6 +216,16 @@
(= 3 result)
(not (procedure-execution-count data proc))))))
+ (pass-if "applicable struct"
+ (let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
+ (proc (lambda args (length args)))
+ (b (make-struct <box> 0 proc)))
+ (let-values (((data result)
+ (with-code-coverage %test-vm b)))
+ (and (coverage-data? data)
+ (= 0 result)
+ (= (procedure-execution-count data proc) 1)))))
+
(pass-if "called from C"
;; The `scm_call_N' functions use the VM returned by `the-vm'. This
;; test makes sure that they get to use %TEST-VM.
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
new file mode 100644
index 0000000..523635f
--- /dev/null
+++ b/test-suite/tests/cse.test
@@ -0,0 +1,295 @@
+;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
+;;;; Andy Wingo <address@hidden> --- May 2009
+;;;;
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-suite tree-il)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system base pmatch)
+ #:use-module (system base message)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il canonicalize)
+ #:use-module (language tree-il primitives)
+ #:use-module (language tree-il fix-letrec)
+ #:use-module (language tree-il cse)
+ #:use-module (language tree-il peval)
+ #:use-module (language glil)
+ #:use-module (srfi srfi-13))
+
+(define-syntax pass-if-cse
+ (syntax-rules ()
+ ((_ in pat)
+ (pass-if 'in
+ (let ((evaled (unparse-tree-il
+ (canonicalize!
+ (fix-letrec!
+ (cse
+ (peval
+ (expand-primitives!
+ (resolve-primitives!
+ (compile 'in #:from 'scheme #:to 'tree-il)
+ (current-module))))))))))
+ (pmatch evaled
+ (pat #t)
+ (_ (pk 'cse-mismatch)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'in)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ evaled)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'pat)
+ (newline)
+ #f)))))))
+
+
+(with-test-prefix "cse"
+
+ ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is
+ ;; boolean-valued.
+ (pass-if-cse
+ (lambda (x y)
+ (and (eq? x y)
+ (eq? x y)))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (apply (primitive eq?) (lexical x _) (lexical y _))))))
+
+ ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
+ (pass-if-cse
+ (lambda (x y)
+ (if (eq? x y) #f #t))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (apply (primitive not)
+ (apply (primitive eq?) (lexical x _) (lexical y _)))))))
+
+ ;; (if TEST (not TEST) #f)
+ ;; => (if TEST #f #f)
+ ;; => (begin TEST #f)
+ ;; => #f
+ (pass-if-cse
+ (lambda (x y)
+ (and (eq? x y) (not (eq? x y))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (const #f)))))
+
+ ;; (if TEST #f TEST) => (if TEST #f #f) => ...
+ (pass-if-cse
+ (lambda (x y)
+ (if (eq? x y) #f (eq? x y)))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (const #f)))))
+
+ ;; The same, but side-effecting primitives do not propagate.
+ (pass-if-cse
+ (lambda (x y)
+ (and (set-car! x y) (not (set-car! x y))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (if (apply (primitive set-car!)
+ (lexical x _)
+ (lexical y _))
+ (apply (primitive not)
+ (apply (primitive set-car!)
+ (lexical x _)
+ (lexical y _)))
+ (const #f))))))
+
+ ;; Primitives that access mutable memory can propagate, as long as
+ ;; there is no intervening mutation.
+ (pass-if-cse
+ (lambda (x y)
+ (and (string-ref x y)
+ (begin
+ (string-ref x y)
+ (not (string-ref x y)))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (begin
+ (apply (primitive string-ref)
+ (lexical x _)
+ (lexical y _))
+ (const #f))))))
+
+ ;; However, expressions with dependencies on effects do not propagate
+ ;; through a lambda.
+ (pass-if-cse
+ (lambda (x y)
+ (and (string-ref x y)
+ (lambda ()
+ (and (string-ref x y) #t))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (if (apply (primitive string-ref)
+ (lexical x _)
+ (lexical y _))
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (if (apply (primitive string-ref)
+ (lexical x _)
+ (lexical y _))
+ (const #t)
+ (const #f)))))
+ (const #f))))))
+
+ ;; A mutation stops the propagation.
+ (pass-if-cse
+ (lambda (x y)
+ (and (string-ref x y)
+ (begin
+ (string-set! x #\!)
+ (not (string-ref x y)))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (if (apply (primitive string-ref)
+ (lexical x _)
+ (lexical y _))
+ (begin
+ (apply (primitive string-set!)
+ (lexical x _)
+ (const #\!))
+ (apply (primitive not)
+ (apply (primitive string-ref)
+ (lexical x _)
+ (lexical y _))))
+ (const #f))))))
+
+ ;; Predicates are only added to the database if they are in a
+ ;; predicate context.
+ (pass-if-cse
+ (lambda (x y)
+ (begin (eq? x y) (eq? x y)))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (apply (primitive eq?) (lexical x _) (lexical y _))))))
+
+ ;; Conditional bailouts do cause primitives to be added to the DB.
+ (pass-if-cse
+ (lambda (x y)
+ (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (begin
+ (if (apply (primitive eq?)
+ (lexical x _) (lexical y _))
+ (void)
+ (apply (primitive 'throw) (const 'foo)))
+ (const #t))))))
+
+ ;; A chain of tests in a conditional bailout add data to the DB
+ ;; correctly.
+ (pass-if-cse
+ (lambda (x y)
+ (begin
+ (unless (and (struct? x) (eq? (struct-vtable x) x-vtable))
+ (throw 'foo))
+ (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
+ (struct-ref x y)
+ (throw 'bar))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (begin
+ (fix (failure) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (primitive throw) (const foo))))))
+ (if (apply (primitive struct?) (lexical x _))
+ (if (apply (primitive eq?)
+ (apply (primitive struct-vtable)
+ (lexical x _))
+ (toplevel x-vtable))
+ (void)
+ (apply (lexical failure _)))
+ (apply (lexical failure _))))
+ (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
+
+ ;; Strict argument evaluation also adds info to the DB.
+ (pass-if-cse
+ (lambda (x)
+ ((lambda (z)
+ (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
+ (struct-ref x 2)
+ (throw 'bar))))
+ (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
+ (struct-ref x 1)
+ (throw 'foo))))
+
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (let (z) (_)
+ ((fix (failure) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (primitive throw) (const foo))))))
+ (if (apply (primitive struct?) (lexical x _))
+ (if (apply (primitive eq?)
+ (apply (primitive struct-vtable)
+ (lexical x _))
+ (toplevel x-vtable))
+ (apply (primitive struct-ref) (lexical x _) (const
1))
+ (apply (lexical failure _)))
+ (apply (lexical failure _)))))
+ (apply (primitive +) (lexical z _)
+ (apply (primitive struct-ref) (lexical x _) (const
2))))))))
+
+ ;; Replacing named expressions with lexicals.
+ (pass-if-cse
+ (let ((x (car y)))
+ (cons x (car y)))
+ (let (x) (_) ((apply (primitive car) (toplevel y)))
+ (apply (primitive cons) (lexical x _) (lexical x _))))
+
+ ;; Dominating expressions only provide predicates when evaluated in
+ ;; test context.
+ (pass-if-cse
+ (let ((t (car x)))
+ (if (car x)
+ 'one
+ 'two))
+ ;; Actually this one should reduce in other ways, but this is the
+ ;; current reduction:
+ (begin
+ (apply (primitive car) (toplevel x))
+ (if (apply (primitive car) (toplevel x))
+ (const one)
+ (const two))))
+
+ (pass-if-cse
+ (begin (cons 1 2 3) 4)
+ (begin
+ (apply (primitive cons) (const 1) (const 2) (const 3))
+ (const 4))))
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 6eafe95..60d8630 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -25,6 +25,7 @@
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 format)
#:use-module (test-suite lib))
@@ -160,6 +161,29 @@
(with-test-prefix "pointer<->string"
+ (pass-if-exception "%default-port-conversion-strategy is error"
+ exception:encoding-error
+ (let ((s "ÏαοÏ"))
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (string->pointer s "ISO-8859-1"))))
+
+ (pass-if "%default-port-conversion-strategy is escape"
+ (let ((s "teĥniko"))
+ (equal? (with-fluids ((%default-port-conversion-strategy 'escape))
+ (pointer->string (string->pointer s "ISO-8859-1")))
+ (format #f "te\\u~4,'0xniko"
+ (char->integer #\Ä¥)))))
+
+ (pass-if "%default-port-conversion-strategy is substitute"
+ (let ((s "teĥniko")
+ (member (negate (negate member))))
+ (member (with-fluids ((%default-port-conversion-strategy 'substitute))
+ (pointer->string (string->pointer s "ISO-8859-1")))
+ '("te?niko"
+
+ ;; This form is found on FreeBSD 8.2 and Darwin 10.8.0.
+ "te^hniko"))))
+
(pass-if "bijection"
(let ((s "hello, world"))
(string=? s (pointer->string (string->pointer s)))))
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index be983a1..33537d0 100644
--- a/test-suite/tests/ftw.test
+++ b/test-suite/tests/ftw.test
@@ -90,6 +90,9 @@
(define %test-dir
(string-append %top-srcdir "/test-suite"))
+(define %test-suite-lib-dir
+ (string-append %top-srcdir "/test-suite/test-suite"))
+
(define (make-file-tree dir tree)
"Make file system TREE at DIR."
(define (touch file)
@@ -152,7 +155,8 @@
(let ((enter? (lambda (n s r)
;; Enter only `test-suite/tests/'.
(if (member `(down ,%test-dir) r)
- (string=? (basename n) "tests")
+ (or (string=? (basename n) "tests")
+ (string=? (basename n) "test-suite"))
(string=? (basename n) "test-suite"))))
(leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r)))
@@ -167,7 +171,7 @@
((('down (? (cut string=? <> %test-dir)))
between ...
('up (? (cut string=? <> %test-dir))))
- (and (any (match-lambda (('leaf (= basename "lib.scm")) #t) (_ #f))
+ (and (any (match-lambda (('down (= basename "test-suite")) #t) (_ #f))
between)
(any (match-lambda (('down (= basename "tests")) #t) (_ #f))
between)
@@ -195,7 +199,7 @@
(up (lambda (n s r) (cons `(up ,n) r)))
(skip (lambda (n s r) (cons `(skip ,n) r)))
(error (lambda (n s e r) (cons `(error ,n) r)))
- (name (string-append %test-dir "/lib.scm")))
+ (name (string-append %test-suite-lib-dir "/lib.scm")))
(equal? (file-system-fold enter? leaf down up skip error '() name)
`((leaf ,name)))))
@@ -306,14 +310,17 @@
(pass-if "test-suite"
(let ((select? (cut string-suffix? ".test" <>)))
(match (scandir (string-append %test-dir "/tests") select?)
- (("." ".." "00-initial-env.test" (? select?) ...)
+ (("00-initial-env.test" (? select?) ...)
#t))))
(pass-if "flat file"
(not (scandir (string-append %test-dir "/Makefile.am"))))
(pass-if "EACCES"
- (not (scandir "/.does-not-exist."))))
+ (not (scandir "/.does-not-exist.")))
+
+ (pass-if "no select"
+ (null? (scandir %test-dir (lambda (_) #f)))))
;;; Local Variables:
;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index e13c8f7..a969752 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -16,7 +16,7 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-suite tests gc)
+(define-module (tests gc)
#:use-module (ice-9 documentation)
#:use-module (test-suite lib)
#:use-module ((system base compile) #:select (compile)))
diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test
index 8b19ff7..6bf5bdd 100644
--- a/test-suite/tests/match.test
+++ b/test-suite/tests/match.test
@@ -1,6 +1,6 @@
;;;; match.test --- (ice-9 match) -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 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
@@ -205,4 +205,4 @@
(test-end (syntax-rules ()
((_) #t))))
(with-test-prefix "upstream tests"
- (include-from-path "test-suite/tests/match.test.upstream")))
+ (include-from-path "tests/match.test.upstream")))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
new file mode 100644
index 0000000..7fae423
--- /dev/null
+++ b/test-suite/tests/peval.test
@@ -0,0 +1,1078 @@
+;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
+;;;; Andy Wingo <address@hidden> --- May 2009
+;;;;
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-suite tree-il)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system base pmatch)
+ #:use-module (system base message)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:use-module (language glil)
+ #:use-module (srfi srfi-13))
+
+(define peval
+ ;; The partial evaluator.
+ (@@ (language tree-il optimize) peval))
+
+(define-syntax pass-if-peval
+ (syntax-rules (resolve-primitives)
+ ((_ in pat)
+ (pass-if-peval in pat
+ (compile 'in #:from 'scheme #:to 'tree-il)))
+ ((_ resolve-primitives in pat)
+ (pass-if-peval in pat
+ (expand-primitives!
+ (resolve-primitives!
+ (compile 'in #:from 'scheme #:to 'tree-il)
+ (current-module)))))
+ ((_ in pat code)
+ (pass-if 'in
+ (let ((evaled (unparse-tree-il (peval code))))
+ (pmatch evaled
+ (pat #t)
+ (_ (pk 'peval-mismatch)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'in)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ evaled)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'pat)
+ (newline)
+ #f)))))))
+
+
+(with-test-prefix "partial evaluation"
+
+ (pass-if-peval
+ ;; First order, primitive.
+ (let ((x 1) (y 2)) (+ x y))
+ (const 3))
+
+ (pass-if-peval
+ ;; First order, thunk.
+ (let ((x 1) (y 2))
+ (let ((f (lambda () (+ x y))))
+ (f)))
+ (const 3))
+
+ (pass-if-peval resolve-primitives
+ ;; First order, let-values (requires primitive expansion for
+ ;; `call-with-values'.)
+ (let ((x 0))
+ (call-with-values
+ (lambda () (if (zero? x) (values 1 2) (values 3 4)))
+ (lambda (a b)
+ (+ a b))))
+ (const 3))
+
+ (pass-if-peval resolve-primitives
+ ;; First order, multiple values.
+ (let ((x 1) (y 2))
+ (values x y))
+ (apply (primitive values) (const 1) (const 2)))
+
+ (pass-if-peval resolve-primitives
+ ;; First order, multiple values truncated.
+ (let ((x (values 1 'a)) (y 2))
+ (values x y))
+ (apply (primitive values) (const 1) (const 2)))
+
+ (pass-if-peval resolve-primitives
+ ;; First order, multiple values truncated.
+ (or (values 1 2) 3)
+ (const 1))
+
+ (pass-if-peval
+ ;; First order, coalesced, mutability preserved.
+ (cons 0 (cons 1 (cons 2 (list 3 4 5))))
+ (apply (primitive list)
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+
+ (pass-if-peval
+ ;; First order, coalesced, immutability preserved.
+ (cons 0 (cons 1 (cons 2 '(3 4 5))))
+ (apply (primitive cons) (const 0)
+ (apply (primitive cons) (const 1)
+ (apply (primitive cons) (const 2)
+ (const (3 4 5))))))
+
+ ;; These two tests doesn't work any more because we changed the way we
+ ;; deal with constants -- now the algorithm will see a construction as
+ ;; being bound to the lexical, so it won't propagate it. It can't
+ ;; even propagate it in the case that it is only referenced once,
+ ;; because:
+ ;;
+ ;; (let ((x (cons 1 2))) (lambda () x))
+ ;;
+ ;; is not the same as
+ ;;
+ ;; (lambda () (cons 1 2))
+ ;;
+ ;; Perhaps if we determined that not only was it only referenced once,
+ ;; it was not closed over by a lambda, then we could propagate it, and
+ ;; re-enable these two tests.
+ ;;
+ #;
+ (pass-if-peval
+ ;; First order, mutability preserved.
+ (let loop ((i 3) (r '()))
+ (if (zero? i)
+ r
+ (loop (1- i) (cons (cons i i) r))))
+ (apply (primitive list)
+ (apply (primitive cons) (const 1) (const 1))
+ (apply (primitive cons) (const 2) (const 2))
+ (apply (primitive cons) (const 3) (const 3))))
+ ;;
+ ;; See above.
+ #;
+ (pass-if-peval
+ ;; First order, evaluated.
+ (let loop ((i 7)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r))))
+ (const 1))
+
+ ;; Instead here are tests for what happens for the above cases: they
+ ;; unroll but they don't fold.
+ (pass-if-peval
+ (let loop ((i 3) (r '()))
+ (if (zero? i)
+ r
+ (loop (1- i) (cons (cons i i) r))))
+ (let (r) (_)
+ ((apply (primitive list)
+ (apply (primitive cons) (const 3) (const 3))))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (apply (primitive cons) (const 2) (const 2))
+ (lexical r _)))
+ (apply (primitive cons)
+ (apply (primitive cons) (const 1) (const 1))
+ (lexical r _)))))
+
+ ;; See above.
+ (pass-if-peval
+ (let loop ((i 4)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r))))
+ (let (r) (_)
+ ((apply (primitive list) (const 4)))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (const 3)
+ (lexical r _)))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (const 2)
+ (lexical r _)))
+ (let (r) (_)
+ ((apply (primitive cons)
+ (const 1)
+ (lexical r _)))
+ (apply (primitive car)
+ (lexical r _)))))))
+
+ ;; Static sums.
+ (pass-if-peval
+ (let loop ((l '(1 2 3 4)) (sum 0))
+ (if (null? l)
+ sum
+ (loop (cdr l) (+ sum (car l)))))
+ (const 10))
+
+ (pass-if-peval resolve-primitives
+ (let ((string->chars
+ (lambda (s)
+ (define (char-at n)
+ (string-ref s n))
+ (define (len)
+ (string-length s))
+ (let loop ((i 0))
+ (if (< i (len))
+ (cons (char-at i)
+ (loop (1+ i)))
+ '())))))
+ (string->chars "yo"))
+ (apply (primitive list) (const #\y) (const #\o)))
+
+ (pass-if-peval
+ ;; Primitives in module-refs are resolved (the expansion of `pmatch'
+ ;; below leads to calls to (@@ (system base pmatch) car) and
+ ;; similar, which is what we want to be inlined.)
+ (begin
+ (use-modules (system base pmatch))
+ (pmatch '(a b c d)
+ ((a b . _)
+ #t)))
+ (begin
+ (apply . _)
+ (const #t)))
+
+ (pass-if-peval
+ ;; Mutability preserved.
+ ((lambda (x y z) (list x y z)) 1 2 3)
+ (apply (primitive list) (const 1) (const 2) (const 3)))
+
+ (pass-if-peval
+ ;; Don't propagate effect-free expressions that operate on mutable
+ ;; objects.
+ (let* ((x (list 1))
+ (y (car x)))
+ (set-car! x 0)
+ y)
+ (let (x) (_) ((apply (primitive list) (const 1)))
+ (let (y) (_) ((apply (primitive car) (lexical x _)))
+ (begin
+ (apply (toplevel set-car!) (lexical x _) (const 0))
+ (lexical y _)))))
+
+ (pass-if-peval
+ ;; Don't propagate effect-free expressions that operate on objects we
+ ;; don't know about.
+ (let ((y (car x)))
+ (set-car! x 0)
+ y)
+ (let (y) (_) ((apply (primitive car) (toplevel x)))
+ (begin
+ (apply (toplevel set-car!) (toplevel x) (const 0))
+ (lexical y _))))
+
+ (pass-if-peval
+ ;; Infinite recursion
+ ((lambda (x) (x x)) (lambda (x) (x x)))
+ (let (x) (_)
+ ((lambda _
+ (lambda-case
+ (((x) _ _ _ _ _)
+ (apply (lexical x _) (lexical x _))))))
+ (apply (lexical x _) (lexical x _))))
+
+ (pass-if-peval
+ ;; First order, aliased primitive.
+ (let* ((x *) (y (x 1 2))) y)
+ (const 2))
+
+ (pass-if-peval
+ ;; First order, shadowed primitive.
+ (begin
+ (define (+ x y) (pk x y))
+ (+ 1 2))
+ (begin
+ (define +
+ (lambda (_)
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (apply (toplevel pk) (lexical x _) (lexical y _))))))
+ (apply (toplevel +) (const 1) (const 2))))
+
+ (pass-if-peval
+ ;; First-order, effects preserved.
+ (let ((x 2))
+ (do-something!)
+ x)
+ (begin
+ (apply (toplevel do-something!))
+ (const 2)))
+
+ (pass-if-peval
+ ;; First order, residual bindings removed.
+ (let ((x 2) (y 3))
+ (* (+ x y) z))
+ (apply (primitive *) (const 5) (toplevel z)))
+
+ (pass-if-peval
+ ;; First order, with lambda.
+ (define (foo x)
+ (define (bar z) (* z z))
+ (+ x (bar 3)))
+ (define foo
+ (lambda (_)
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (apply (primitive +) (lexical x _) (const 9)))))))
+
+ (pass-if-peval
+ ;; First order, with lambda inlined & specialized twice.
+ (let ((f (lambda (x y)
+ (+ (* x top) y)))
+ (x 2)
+ (y 3))
+ (+ (* x (f x y))
+ (f something x)))
+ (apply (primitive +)
+ (apply (primitive *)
+ (const 2)
+ (apply (primitive +) ; (f 2 3)
+ (apply (primitive *)
+ (const 2)
+ (toplevel top))
+ (const 3)))
+ (let (x) (_) ((toplevel something)) ; (f
something 2)
+ ;; `something' is not const, so preserve order of
+ ;; effects with a lexical binding.
+ (apply (primitive +)
+ (apply (primitive *)
+ (lexical x _)
+ (toplevel top))
+ (const 2)))))
+
+ (pass-if-peval
+ ;; First order, with lambda inlined & specialized 3 times.
+ (let ((f (lambda (x y) (if (> x 0) y x))))
+ (+ (f -1 0)
+ (f 1 0)
+ (f -1 y)
+ (f 2 y)
+ (f z y)))
+ (apply (primitive +)
+ (const -1) ; (f -1 0)
+ (const 0) ; (f 1 0)
+ (begin (toplevel y) (const -1)) ; (f -1 y)
+ (toplevel y) ; (f 2 y)
+ (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
+ (if (apply (primitive >) (lexical x _) (const 0))
+ (lexical y _)
+ (lexical x _)))))
+
+ (pass-if-peval
+ ;; First order, conditional.
+ (let ((y 2))
+ (lambda (x)
+ (if (> y 0)
+ (display x)
+ 'never-reached)))
+ (lambda ()
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (apply (toplevel display) (lexical x _))))))
+
+ (pass-if-peval
+ ;; First order, recursive procedure.
+ (letrec ((fibo (lambda (n)
+ (if (<= n 1)
+ n
+ (+ (fibo (- n 1))
+ (fibo (- n 2)))))))
+ (fibo 4))
+ (const 3))
+
+ (pass-if-peval
+ ;; Don't propagate toplevel references, as intervening expressions
+ ;; could alter their bindings.
+ (let ((x top))
+ (foo)
+ x)
+ (let (x) (_) ((toplevel top))
+ (begin
+ (apply (toplevel foo))
+ (lexical x _))))
+
+ (pass-if-peval
+ ;; Higher order.
+ ((lambda (f x)
+ (f (* (car x) (cadr x))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 7))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (default value).
+ ((lambda* (f x #:optional (y 0))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 7))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (caller-supplied value).
+ ((lambda* (f x #:optional (y 0))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ 35)
+ (const 42))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (side-effecting default
+ ;; value).
+ ((lambda* (f x #:optional (y (foo)))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (let (y) (_) ((apply (toplevel foo)))
+ (apply (primitive +) (lexical y _) (const 7))))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (caller-supplied value).
+ ((lambda* (f x #:optional (y (foo)))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ 35)
+ (const 42))
+
+ (pass-if-peval
+ ;; Higher order.
+ ((lambda (f) (f x)) (lambda (x) x))
+ (toplevel x))
+
+ (pass-if-peval
+ ;; Bug reported at
+ ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
+ (let ((fold (lambda (f g) (f (g top)))))
+ (fold 1+ (lambda (x) x)))
+ (apply (primitive 1+) (toplevel top)))
+
+ (pass-if-peval
+ ;; Procedure not inlined when residual code contains recursive calls.
+ ;; <http://debbugs.gnu.org/9542>
+ (letrec ((fold (lambda (f x3 b null? car cdr)
+ (if (null? x3)
+ b
+ (f (car x3) (fold f (cdr x3) b null? car cdr))))))
+ (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
+ (letrec (fold) (_) (_)
+ (apply (lexical fold _)
+ (primitive *)
+ (toplevel x)
+ (const 1)
+ (primitive zero?)
+ (lambda ()
+ (lambda-case
+ (((x1) #f #f #f () (_))
+ (lexical x1 _))))
+ (lambda ()
+ (lambda-case
+ (((x2) #f #f #f () (_))
+ (apply (primitive -) (lexical x2 _) (const 1))))))))
+
+ (pass-if "inlined lambdas are alpha-renamed"
+ ;; In this example, `make-adder' is inlined more than once; thus,
+ ;; they should use different gensyms for their arguments, because
+ ;; the various optimization passes assume uniquely-named variables.
+ ;;
+ ;; Bug reported at
+ ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
+ ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
+ (pmatch (unparse-tree-il
+ (peval (compile
+ '(let ((make-adder
+ (lambda (x) (lambda (y) (+ x y)))))
+ (cons (make-adder 1) (make-adder 2)))
+ #:to 'tree-il)))
+ ((apply (primitive cons)
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym1))
+ (apply (primitive +)
+ (const 1)
+ (lexical y ,ref1)))))
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym2))
+ (apply (primitive +)
+ (const 2)
+ (lexical y ,ref2))))))
+ (and (eq? gensym1 ref1)
+ (eq? gensym2 ref2)
+ (not (eq? gensym1 gensym2))))
+ (_ #f)))
+
+ (pass-if-peval
+ ;; Unused letrec bindings are pruned.
+ (letrec ((a (lambda () (b)))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (c 10))
+ (const 10))
+
+ (pass-if-peval
+ ;; Unused letrec bindings are pruned.
+ (letrec ((a (foo!))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (c 10))
+ (begin (apply (toplevel foo!))
+ (const 10)))
+
+ (pass-if-peval
+ ;; Higher order, mutually recursive procedures.
+ (letrec ((even? (lambda (x)
+ (or (= 0 x)
+ (odd? (- x 1)))))
+ (odd? (lambda (x)
+ (not (even? x)))))
+ (and (even? 4) (odd? 7)))
+ (const #t))
+
+ (pass-if-peval
+ ;; Memv with constants.
+ (memv 1 '(3 2 1))
+ (const '(1)))
+
+ (pass-if-peval
+ ;; Memv with non-constant list. It could fold but doesn't
+ ;; currently.
+ (memv 1 (list 3 2 1))
+ (apply (primitive memv)
+ (const 1)
+ (apply (primitive list) (const 3) (const 2) (const 1))))
+
+ (pass-if-peval
+ ;; Memv with non-constant key, constant list, test context
+ (case foo
+ ((3 2 1) 'a)
+ (else 'b))
+ (let (key) (_) ((toplevel foo))
+ (if (if (apply (primitive eqv?) (lexical key _) (const 3))
+ (const #t)
+ (if (apply (primitive eqv?) (lexical key _) (const 2))
+ (const #t)
+ (apply (primitive eqv?) (lexical key _) (const 1))))
+ (const a)
+ (const b))))
+
+ (pass-if-peval
+ ;; Memv with non-constant key, empty list, test context. Currently
+ ;; doesn't fold entirely.
+ (case foo
+ (() 'a)
+ (else 'b))
+ (begin (toplevel foo) (const b)))
+
+ ;;
+ ;; Below are cases where constant propagation should bail out.
+ ;;
+
+ (pass-if-peval
+ ;; Non-constant lexical is not propagated.
+ (let ((v (make-vector 6 #f)))
+ (lambda (n)
+ (vector-set! v n n)))
+ (let (v) (_)
+ ((apply (toplevel make-vector) (const 6) (const #f)))
+ (lambda ()
+ (lambda-case
+ (((n) #f #f #f () (_))
+ (apply (toplevel vector-set!)
+ (lexical v _) (lexical n _) (lexical n _)))))))
+
+ (pass-if-peval
+ ;; Mutable lexical is not propagated.
+ (let ((v (vector 1 2 3)))
+ (lambda ()
+ v))
+ (let (v) (_)
+ ((apply (primitive vector) (const 1) (const 2) (const 3)))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ())
+ (lexical v _))))))
+
+ (pass-if-peval
+ ;; Lexical that is not provably pure is not inlined nor propagated.
+ (let* ((x (if (> p q) (frob!) (display 'chbouib)))
+ (y (* x 2)))
+ (+ x x y))
+ (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
+ (apply (toplevel frob!))
+ (apply (toplevel display) (const chbouib))))
+ (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
+ (apply (primitive +)
+ (lexical x _) (lexical x _) (lexical y _)))))
+
+ (pass-if-peval
+ ;; Non-constant arguments not propagated to lambdas.
+ ((lambda (x y z)
+ (vector-set! x 0 0)
+ (set-car! y 0)
+ (set-cdr! z '()))
+ (vector 1 2 3)
+ (make-list 10)
+ (list 1 2 3))
+ (let (x y z) (_ _ _)
+ ((apply (primitive vector) (const 1) (const 2) (const 3))
+ (apply (toplevel make-list) (const 10))
+ (apply (primitive list) (const 1) (const 2) (const 3)))
+ (begin
+ (apply (toplevel vector-set!)
+ (lexical x _) (const 0) (const 0))
+ (apply (toplevel set-car!)
+ (lexical y _) (const 0))
+ (apply (toplevel set-cdr!)
+ (lexical z _) (const ())))))
+
+ (pass-if-peval
+ (let ((foo top-foo) (bar top-bar))
+ (let* ((g (lambda (x y) (+ x y)))
+ (f (lambda (g x) (g x x))))
+ (+ (f g foo) (f g bar))))
+ (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
+ (apply (primitive +)
+ (apply (primitive +) (lexical foo _) (lexical foo _))
+ (apply (primitive +) (lexical bar _) (lexical bar _)))))
+
+ (pass-if-peval
+ ;; Fresh objects are not turned into constants, nor are constants
+ ;; turned into fresh objects.
+ (let* ((c '(2 3))
+ (x (cons 1 c))
+ (y (cons 0 x)))
+ y)
+ (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
+ (apply (primitive cons) (const 0) (lexical x _))))
+
+ (pass-if-peval
+ ;; Bindings mutated.
+ (let ((x 2))
+ (set! x 3)
+ x)
+ (let (x) (_) ((const 2))
+ (begin
+ (set! (lexical x _) (const 3))
+ (lexical x _))))
+
+ (pass-if-peval
+ ;; Bindings mutated.
+ (letrec ((x 0)
+ (f (lambda ()
+ (set! x (+ 1 x))
+ x)))
+ (frob f) ; may mutate `x'
+ x)
+ (letrec (x) (_) ((const 0))
+ (begin
+ (apply (toplevel frob) (lambda _ _))
+ (lexical x _))))
+
+ (pass-if-peval
+ ;; Bindings mutated.
+ (letrec ((f (lambda (x)
+ (set! f (lambda (_) x))
+ x)))
+ (f 2))
+ (letrec _ . _))
+
+ (pass-if-peval
+ ;; Bindings possibly mutated.
+ (let ((x (make-foo)))
+ (frob! x) ; may mutate `x'
+ x)
+ (let (x) (_) ((apply (toplevel make-foo)))
+ (begin
+ (apply (toplevel frob!) (lexical x _))
+ (lexical x _))))
+
+ (pass-if-peval
+ ;; Inlining stops at recursive calls with dynamic arguments.
+ (let loop ((x x))
+ (if (< x 0) x (loop (1- x))))
+ (letrec (loop) (_) ((lambda (_)
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (if _ _
+ (apply (lexical loop _)
+ (apply (primitive 1-)
+ (lexical x _))))))))
+ (apply (lexical loop _) (toplevel x))))
+
+ (pass-if-peval
+ ;; Recursion on the 2nd argument is fully evaluated.
+ (let ((x (top)))
+ (let loop ((x x) (y 10))
+ (if (> y 0)
+ (loop x (1- y))
+ (foo x y))))
+ (let (x) (_) ((apply (toplevel top)))
+ (apply (toplevel foo) (lexical x _) (const 0))))
+
+ (pass-if-peval
+ ;; Inlining aborted when residual code contains recursive calls.
+ ;;
+ ;; <http://debbugs.gnu.org/9542>
+ (let loop ((x x) (y 0))
+ (if (> y 0)
+ (loop (1- x) (1- y))
+ (if (< x 0)
+ x
+ (loop (1+ x) (1+ y)))))
+ (letrec (loop) (_) ((lambda (_)
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (if (apply (primitive >)
+ (lexical y _) (const 0))
+ _ _)))))
+ (apply (lexical loop _) (toplevel x) (const 0))))
+
+ (pass-if-peval
+ ;; Infinite recursion: `peval' gives up and leaves it as is.
+ (letrec ((f (lambda (x) (g (1- x))))
+ (g (lambda (x) (h (1+ x))))
+ (h (lambda (x) (f x))))
+ (f 0))
+ (letrec _ . _))
+
+ (pass-if-peval
+ ;; Infinite recursion: all the arguments to `loop' are static, but
+ ;; unrolling it would lead `peval' to enter an infinite loop.
+ (let loop ((x 0))
+ (and (< x top)
+ (loop (1+ x))))
+ (letrec (loop) (_) ((lambda . _))
+ (apply (lexical loop _) (const 0))))
+
+ (pass-if-peval
+ ;; This test checks that the `start' binding is indeed residualized.
+ ;; See the `referenced?' procedure in peval's `prune-bindings'.
+ (let ((pos 0))
+ (let ((here (let ((start pos)) (lambda () start))))
+ (set! pos 1) ;; Cause references to `pos' to residualize.
+ (here)))
+ (let (pos) (_) ((const 0))
+ (let (here) (_) (_)
+ (begin
+ (set! (lexical pos _) (const 1))
+ (apply (lexical here _))))))
+
+ (pass-if-peval
+ ;; FIXME: should this one residualize the binding?
+ (letrec ((a a))
+ 1)
+ (const 1))
+
+ (pass-if-peval
+ ;; This is a fun one for peval to handle.
+ (letrec ((a a))
+ a)
+ (letrec (a) (_) ((lexical a _))
+ (lexical a _)))
+
+ (pass-if-peval
+ ;; Another interesting recursive case.
+ (letrec ((a b) (b a))
+ a)
+ (letrec (a) (_) ((lexical a _))
+ (lexical a _)))
+
+ (pass-if-peval
+ ;; Another pruning case, that `a' is residualized.
+ (letrec ((a (lambda () (a)))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (let ((d (foo b)))
+ (c d)))
+
+ ;; "b c a" is the current order that we get with unordered letrec,
+ ;; but it's not important to this test, so if it changes, just adapt
+ ;; the test.
+ (letrec (b c a) (_ _ _)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (lexical a _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (lexical x _))))
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (lexical a _))))))
+ (let (d)
+ (_)
+ ((apply (toplevel foo) (lexical b _)))
+ (apply (lexical c _)
+ (lexical d _)))))
+
+ (pass-if-peval
+ ;; In this case, we can prune the bindings. `a' ends up being copied
+ ;; because it is only referenced once in the source program. Oh
+ ;; well.
+ (letrec* ((a (lambda (x) (top x)))
+ (b (lambda () a)))
+ (foo (b) (b)))
+ (apply (toplevel foo)
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (apply (toplevel top) (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (apply (toplevel top) (lexical x _)))))))
+
+ (pass-if-peval
+ ;; Constant folding: cons of #nil does not make list
+ (cons 1 #nil)
+ (apply (primitive cons) (const 1) (const '#nil)))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (begin (cons 1 2) #f)
+ (const #f))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (begin (cons (foo) 2) #f)
+ (begin (apply (toplevel foo)) (const #f)))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (if (cons 0 0) 1 2)
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: car+cons
+ (car (cons 1 0))
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+cons
+ (cdr (cons 1 0))
+ (const 0))
+
+ (pass-if-peval
+ ;; Constant folding: car+cons, impure
+ (car (cons 1 (bar)))
+ (begin (apply (toplevel bar)) (const 1)))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+cons, impure
+ (cdr (cons (bar) 0))
+ (begin (apply (toplevel bar)) (const 0)))
+
+ (pass-if-peval
+ ;; Constant folding: car+list
+ (car (list 1 0))
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+list
+ (cdr (list 1 0))
+ (apply (primitive list) (const 0)))
+
+ (pass-if-peval
+ ;; Constant folding: car+list, impure
+ (car (list 1 (bar)))
+ (begin (apply (toplevel bar)) (const 1)))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+list, impure
+ (cdr (list (bar) 0))
+ (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
+
+ (pass-if-peval
+ resolve-primitives
+ ;; Non-constant guards get lexical bindings.
+ (dynamic-wind foo (lambda () bar) baz)
+ (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
+ (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+
+ (pass-if-peval
+ resolve-primitives
+ ;; Constant guards don't need lexical bindings.
+ (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
+ (dynwind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (toplevel bar)
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+
+ (pass-if-peval
+ resolve-primitives
+ ;; Prompt is removed if tag is unreferenced
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda args args)))
+ (const 1))
+
+ (pass-if-peval
+ resolve-primitives
+ ;; Prompt is removed if tag is unreferenced, with explicit stem
+ (let ((tag (make-prompt-tag "foo")))
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda args args)))
+ (const 1))
+
+ ;; Handler lambda inlined
+ (pass-if-peval
+ resolve-primitives
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda (k x) x))
+ (prompt (toplevel tag)
+ (const 1)
+ (lambda-case
+ (((k x) #f #f #f () (_ _))
+ (lexical x _)))))
+
+ ;; Handler toplevel not inlined
+ (pass-if-peval
+ resolve-primitives
+ (call-with-prompt tag
+ (lambda () 1)
+ handler)
+ (let (handler) (_) ((toplevel handler))
+ (prompt (toplevel tag)
+ (const 1)
+ (lambda-case
+ ((() #f args #f () (_))
+ (apply (primitive @apply)
+ (lexical handler _)
+ (lexical args _)))))))
+
+ (pass-if-peval
+ resolve-primitives
+ ;; `while' without `break' or `continue' has no prompts and gets its
+ ;; condition folded. Unfortunately the outer `lp' does not yet get
+ ;; elided, and the continuation tag stays around. (The continue tag
+ ;; stays around because although it is not referenced, recursively
+ ;; visiting the loop in the continue handler manages to visit the tag
+ ;; twice before aborting. The abort doesn't unroll the recursive
+ ;; reference.)
+ (while #t #t)
+ (let (_) (_) ((apply (primitive make-prompt-tag) . _))
+ (letrec (lp) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (letrec (loop) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (lexical loop _))))))
+ (apply (lexical loop _)))))))
+ (apply (lexical lp _)))))
+
+ (pass-if-peval
+ resolve-primitives
+ (lambda (a . rest)
+ (apply (lambda (x y) (+ x y))
+ a rest))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ _))))
+
+ (pass-if-peval resolve-primitives
+ (car '(1 2))
+ (const 1))
+
+ ;; If we bail out when inlining an identifier because it's too big,
+ ;; but the identifier simply aliases some other identifier, then avoid
+ ;; residualizing a reference to the leaf identifier. The bailout is
+ ;; driven by the recursive-effort-limit, which is currently 100. We
+ ;; make sure to trip it with this recursive sum thing.
+ (pass-if-peval resolve-primitives
+ (let ((x (let sum ((n 0) (out 0))
+ (if (< n 10000)
+ (sum (1+ n) (+ out n))
+ out))))
+ ((lambda (y) (list y)) x))
+ (let (x) (_) (_)
+ (apply (primitive list) (lexical x _))))
+
+ ;; Here we test that a common test in a chain of ifs gets lifted.
+ (pass-if-peval resolve-primitives
+ (if (and (struct? x) (eq? (struct-vtable x) A))
+ (foo x)
+ (if (and (struct? x) (eq? (struct-vtable x) B))
+ (bar x)
+ (if (and (struct? x) (eq? (struct-vtable x) C))
+ (baz x)
+ (qux x))))
+ (let (failure) (_) ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (toplevel qux) (toplevel x))))))
+ (if (apply (primitive struct?) (toplevel x))
+ (if (apply (primitive eq?)
+ (apply (primitive struct-vtable) (toplevel x))
+ (toplevel A))
+ (apply (toplevel foo) (toplevel x))
+ (if (apply (primitive eq?)
+ (apply (primitive struct-vtable) (toplevel x))
+ (toplevel B))
+ (apply (toplevel bar) (toplevel x))
+ (if (apply (primitive eq?)
+ (apply (primitive struct-vtable) (toplevel x))
+ (toplevel C))
+ (apply (toplevel baz) (toplevel x))
+ (apply (lexical failure _)))))
+ (apply (lexical failure _)))))
+
+ ;; Multiple common tests should get lifted as well.
+ (pass-if-peval resolve-primitives
+ (if (and (struct? x) (eq? (struct-vtable x) A) B)
+ (foo x)
+ (if (and (struct? x) (eq? (struct-vtable x) A) C)
+ (bar x)
+ (if (and (struct? x) (eq? (struct-vtable x) A) D)
+ (baz x)
+ (qux x))))
+ (let (failure) (_) ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (apply (toplevel qux) (toplevel x))))))
+ (if (apply (primitive struct?) (toplevel x))
+ (if (apply (primitive eq?)
+ (apply (primitive struct-vtable) (toplevel x))
+ (toplevel A))
+ (if (toplevel B)
+ (apply (toplevel foo) (toplevel x))
+ (if (toplevel C)
+ (apply (toplevel bar) (toplevel x))
+ (if (toplevel D)
+ (apply (toplevel baz) (toplevel x))
+ (apply (lexical failure _)))))
+ (apply (lexical failure _)))
+ (apply (lexical failure _)))))
+
+ (pass-if-peval resolve-primitives
+ (apply (lambda (x y) (cons x y)) '(1 2))
+ (apply (primitive cons) (const 1) (const 2)))
+
+ (pass-if-peval resolve-primitives
+ (apply (lambda (x y) (cons x y)) (list 1 2))
+ (apply (primitive cons) (const 1) (const 2)))
+
+ (pass-if-peval resolve-primitives
+ (let ((t (make-prompt-tag)))
+ (call-with-prompt t
+ (lambda () (abort-to-prompt t 1 2 3))
+ (lambda (k x y z) (list x y z))))
+ (apply (primitive 'list) (const 1) (const 2) (const 3))))
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index d4a333f..613d269 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -2,7 +2,7 @@
;;;; Jim Blandy <address@hidden> --- May 1999
;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
-;;;; 2011 Free Software Foundation, Inc.
+;;;; 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -58,6 +58,34 @@
string))
+
+(with-test-prefix "%default-port-conversion-strategy"
+
+ (pass-if "initial value"
+ (eq? 'substitute (fluid-ref %default-port-conversion-strategy)))
+
+ (pass-if "file port"
+ (let ((strategies '(error substitute escape)))
+ (equal? (map (lambda (s)
+ (with-fluids ((%default-port-conversion-strategy s))
+ (call-with-output-file "/dev/null"
+ (lambda (p)
+ (port-conversion-strategy p)))))
+ strategies)
+ strategies)))
+
+ (pass-if "(set-port-conversion-strategy! #f sym)"
+ (begin
+ (set-port-conversion-strategy! #f 'error)
+ (and (eq? (fluid-ref %default-port-conversion-strategy) 'error)
+ (begin
+ (set-port-conversion-strategy! #f 'substitute)
+ (eq? (fluid-ref %default-port-conversion-strategy)
+ 'substitute)))))
+
+)
+
+
;;;; Normal file ports.
;;; Write out an s-expression, and read it back.
@@ -385,6 +413,22 @@
(pass-if "output check"
(string=? text result)))
+ (pass-if "encoding failure leads to exception"
+ ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
+ ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
+ (catch 'encoding-error
+ (lambda ()
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (let ((p (open-input-string "λ"))) ; raise an exception
+ #f)))
+ (lambda (key . rest)
+ #t)
+ (lambda (key . rest)
+ ;; At this point, the port-table mutex used to be still held,
+ ;; hence the deadlock. This situation would occur when trying
+ ;; to print a backtrace, for instance.
+ (input-port? (open-input-string "foo")))))
+
(pass-if "%default-port-encoding is honored"
(let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
(equal? (map (lambda (e)
@@ -396,6 +440,20 @@
encodings)
encodings)))
+ (pass-if "%default-port-conversion-strategy is honored"
+ (let ((strategies '(error substitute escape)))
+ (equal? (map (lambda (s)
+ (with-fluids ((%default-port-conversion-strategy s))
+ (call-with-output-string
+ (lambda (p)
+ (and (eq? s (port-conversion-strategy p))
+ (begin
+ (set-port-conversion-strategy! p s)
+ (display (port-conversion-strategy p)
+ p)))))))
+ strategies)
+ (map symbol->string strategies))))
+
(pass-if "suitable encoding [latin-1]"
(let ((str "hello, world"))
(with-fluids ((%default-port-encoding "ISO-8859-1"))
@@ -412,15 +470,17 @@
(lambda ()
(display str)))))))
- (pass-if "wrong encoding"
+ (pass-if "wrong encoding, error"
(let ((str "Äu bone?"))
(catch 'encoding-error
(lambda ()
;; Latin-1 cannot represent âÄâ.
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (with-fluids ((%default-port-encoding "ISO-8859-1")
+ (%default-port-conversion-strategy 'error))
(with-output-to-string
(lambda ()
- (display str)))))
+ (display str))))
+ #f) ; so the test really fails here
(lambda (key subr message errno port chr)
(and (eq? chr #\Ä)
(string? (strerror errno)))))))
@@ -1064,8 +1124,75 @@
(list read read-char read-line)
'("read" "read-char" "read-line")))
+
+
+(with-test-prefix "setvbuf"
+
+ (pass-if "line/column number preserved"
+ ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's
+ ;; line and/or column number.
+ (call-with-output-file (test-file)
+ (lambda (p)
+ (display "This is GNU Guile.\nWelcome." p)))
+ (call-with-input-file (test-file)
+ (lambda (p)
+ (and (eq? #\T (read-char p))
+ (let ((line (port-line p))
+ (col (port-column p)))
+ (and (= line 0) (= col 1)
+ (begin
+ (setvbuf p _IOFBF 777)
+ (let ((line* (port-line p))
+ (col* (port-column p)))
+ (and (= line line*)
+ (= col col*)))))))))))
+
+
+
+(define-syntax-rule (with-load-path path body ...)
+ (let ((new path)
+ (old %load-path))
+ (dynamic-wind
+ (lambda ()
+ (set! %load-path new))
+ (lambda ()
+ body ...)
+ (lambda ()
+ (set! %load-path old)))))
+
+(with-test-prefix "%file-port-name-canonicalization"
+
+ (pass-if "absolute file name & empty %load-path entry"
+ ;; In Guile 2.0.5 and earlier, this would return "dev/null" instead
+ ;; of "/dev/null". See
+ ;; <http://lists.gnu.org/archive/html/guile-devel/2012-05/msg00059.html>
+ ;; for a discussion.
+ (equal? "/dev/null"
+ (with-load-path (cons "" (delete "/" %load-path))
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename (open-input-file "/dev/null"))))))
+
+ (pass-if "relative canonicalization with /"
+ (equal? "dev/null"
+ (with-load-path (cons "/" %load-path)
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename (open-input-file "/dev/null"))))))
+
+ (pass-if "relative canonicalization from ice-9"
+ (equal? "ice-9/q.scm"
+ (with-fluids ((%file-port-name-canonicalization 'relative))
+ (port-filename
+ (open-input-file (%search-load-path "ice-9/q.scm"))))))
+
+ (pass-if "absolute canonicalization from ice-9"
+ (equal? (string-append (assoc-ref %guile-build-info 'top_srcdir)
+ "/module/ice-9/q.scm")
+ (with-fluids ((%file-port-name-canonicalization 'absolute))
+ (port-filename (open-input-file (%search-load-path
"ice-9/q.scm")))))))
+
(delete-file (test-file))
;;; Local Variables:
;;; eval: (put 'test-decoding-error 'scheme-indent-function 3)
+;;; eval: (put 'with-load-path 'scheme-indent-function 1)
;;; End:
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index f3e8c2c..46da67f 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,6 +1,6 @@
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -306,10 +306,12 @@
(bv (string->utf16 str)))
(catch 'decoding-error
(lambda ()
- (with-fluids ((%default-port-encoding "UTF-32"))
+ (with-fluids ((%default-port-encoding "UTF-32")
+ (%default-port-conversion-strategy 'error))
(call-with-output-string
(lambda (port)
- (put-bytevector port bv)))))
+ (put-bytevector port bv)))
+ #f)) ; fail if we reach this point
(lambda (key subr message errno port)
(string? (strerror errno)))))))
@@ -662,7 +664,8 @@
(tp (transcoded-port b t)))
(guard (c ((i/o-decoding-error? c)
(eq? (i/o-error-port c) tp)))
- (get-line tp))))
+ (get-line tp)
+ #f))) ; fail if we reach this point
(pass-if "transcoded-port [error handling mode = replace]"
(let* ((t (make-transcoder (utf-8-codec) (native-eol-style)
diff --git a/test-suite/tests/rnrs-libraries.test
b/test-suite/tests/rnrs-libraries.test
index e162714..e961c28 100644
--- a/test-suite/tests/rnrs-libraries.test
+++ b/test-suite/tests/rnrs-libraries.test
@@ -1,5 +1,5 @@
;;;; rnrs-libraries.test --- test library and import forms -*- scheme -*-
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012 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
@@ -15,7 +15,7 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-suite tests rnrs-libraries)
+(define-module (tests rnrs-libraries)
#:use-module (test-suite lib))
;; First, check that Guile modules are r6rs modules.
@@ -71,7 +71,7 @@
(pass-if "import"
(eval '(begin
- (import (test-suite tests rnrs-test-a))
+ (import (tests rnrs-test-a))
#t)
(current-module)))
@@ -79,18 +79,18 @@
(not (module-local-variable (current-module) 'double)))
(pass-if "resolve-interface"
- (module? (resolve-interface '(test-suite tests rnrs-test-a))))
+ (module? (resolve-interface '(tests rnrs-test-a))))
- (set! iface (resolve-interface '(test-suite tests rnrs-test-a)))
+ (set! iface (resolve-interface '(tests rnrs-test-a)))
(pass-if "resolve-interface (2)"
- (eq? iface (resolve-interface '(test-suite tests rnrs-test-a))))
+ (eq? iface (resolve-interface '(tests rnrs-test-a))))
(pass-if "resolve-r6rs-interface"
- (eq? iface (resolve-r6rs-interface '(test-suite tests rnrs-test-a))))
+ (eq? iface (resolve-r6rs-interface '(tests rnrs-test-a))))
(pass-if "resolve-r6rs-interface (2)"
- (eq? iface (resolve-r6rs-interface '(library (test-suite tests
rnrs-test-a)))))
+ (eq? iface (resolve-r6rs-interface '(library (tests rnrs-test-a)))))
(pass-if "module uses"
(and (memq iface (module-uses (current-module))) #t))
diff --git a/test-suite/tests/rnrs-test-a.scm b/test-suite/tests/rnrs-test-a.scm
index 7b46fd6..474069b 100644
--- a/test-suite/tests/rnrs-test-a.scm
+++ b/test-suite/tests/rnrs-test-a.scm
@@ -1,6 +1,6 @@
;;; test of defining rnrs libraries
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -17,7 +17,7 @@
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-(library (test-suite tests rnrs-test-a)
+(library (tests rnrs-test-a)
(export double)
(import (guile))
diff --git a/test-suite/tests/session.test b/test-suite/tests/session.test
index 1697471..ec992f1 100644
--- a/test-suite/tests/session.test
+++ b/test-suite/tests/session.test
@@ -1,7 +1,7 @@
;;;; session.test --- test suite for (ice-9 session) -*- scheme -*-
;;;; Jose Antonio Ortega Ruiz <address@hidden> -- August 2010
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -20,6 +20,8 @@
(define-module (test-suite session)
#:use-module (test-suite lib)
+ #:use-module (ice-9 match)
+ #:use-module (system base compile)
#:use-module (ice-9 session))
(define (find-module mod)
@@ -51,3 +53,72 @@
(with-test-prefix "apropos-fold-exported"
(pass-if "a child of test-suite" (find-interface '(test-suite lib)))
(pass-if "a child of ice-9" (find-interface '(ice-9 session))))
+
+(with-test-prefix "procedure-arguments"
+
+ (define-syntax-rule (pass-if-valid-arguments name proc expected)
+ (pass-if name
+ (let ((args (procedure-arguments (compile 'proc #:to 'value))))
+ (or (equal? args 'expected)
+ (pk 'invalid-args args #f)))))
+
+ (pass-if-valid-arguments "lambda"
+ (lambda (a b c) #f)
+ ((required . (a b c)) (optional) (keyword)
+ (allow-other-keys? . #f) (rest . #f)))
+ (pass-if-valid-arguments "lambda with rest"
+ (lambda (a b . r) #f)
+ ((required . (a b)) (optional) (keyword)
+ (allow-other-keys? . #f) (rest . r)))
+ (pass-if-valid-arguments "lambda* with optionals"
+ (lambda* (a b #:optional (p 1) (q 2)) #f)
+ ((required . (a b)) (optional . (p q))
+ (keyword) (allow-other-keys? . #f) (rest . #f)))
+ (pass-if-valid-arguments "lambda* with keywords"
+ (lambda* (a b #:key (k 42) l) #f)
+ ((required . (a b)) (optional)
+ (keyword . ((#:k . 2) (#:l . 3))) (allow-other-keys? . #f)
+ (rest . #f)))
+ (pass-if-valid-arguments "lambda* with keywords and a-o-k"
+ (lambda* (a b #:key (k 42) #:allow-other-keys) #f)
+ ((required . (a b)) (optional)
+ (keyword . ((#:k . 2))) (allow-other-keys? . #t)
+ (rest . #f)))
+ (pass-if-valid-arguments "lambda* with optionals, keys, and rest"
+ (lambda* (a b #:optional o p #:key k l #:rest r) #f)
+ ((required . (a b)) (optional . (o p))
+ (keyword . ((#:k . 5) (#:l . 6))) (allow-other-keys? . #f)
+ (rest . k)))
+
+ (pass-if "aok? is preserved"
+ ;; See <http://bugs.gnu.org/10938>.
+ (let* ((proc (compile '(lambda (a b) #f) #:to 'value))
+ (args (procedure-arguments proc)))
+ (set-procedure-property! proc 'arglist (map cdr args))
+ (equal? args (procedure-arguments proc))))
+
+ (pass-if "interpreted procedures (simple)"
+ (match (procedure-arguments
+ (eval '(lambda (x y) #f) (current-module)))
+ (((required _ _)
+ (optional)
+ (keyword)
+ (allow-other-keys? . #f)
+ (rest . #f))
+ #t)
+ (_ #f)))
+
+ (pass-if "interpreted procedures (complex)"
+ (match (procedure-arguments
+ (eval '(lambda* (a b #:optional c #:key d) #f) (current-module)))
+ (((required _ _)
+ (optional _)
+ (keyword (#:d . 3))
+ (allow-other-keys? . #f)
+ (rest . #f))
+ #t)
+ (_ #f))))
+
+;;; Local Variables:
+;;; eval: (put 'pass-if-valid-arguments 'scheme-indent-function 1)
+;;; End:
diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
index b769ce1..47f8f7f 100644
--- a/test-suite/tests/srfi-18.test
+++ b/test-suite/tests/srfi-18.test
@@ -1,7 +1,7 @@
;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
;;;; Julian Graham, 2007-10-26
;;;;
-;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007, 2008, 2012 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,461 +25,458 @@
(if (provided? 'threads)
(use-modules (srfi srfi-18)))
-(and
- (provided? 'threads)
+(cond
+ ((provided? 'threads)
+ (with-test-prefix "current-thread"
-(with-test-prefix "current-thread"
+ (pass-if "current-thread eq current-thread"
+ (eq? (current-thread) (current-thread))))
- (pass-if "current-thread eq current-thread"
- (eq? (current-thread) (current-thread))))
+ (with-test-prefix "thread?"
-(with-test-prefix "thread?"
+ (pass-if "current-thread is thread"
+ (thread? (current-thread)))
- (pass-if "current-thread is thread"
- (thread? (current-thread)))
+ (pass-if "foo not thread"
+ (not (thread? 'foo))))
- (pass-if "foo not thread"
- (not (thread? 'foo))))
+ (with-test-prefix "make-thread"
-(with-test-prefix "make-thread"
+ (pass-if "make-thread creates new thread"
+ (let* ((n (length (all-threads)))
+ (t (make-thread (lambda () 'foo) 'make-thread-1))
+ (r (> (length (all-threads)) n)))
+ (thread-terminate! t) r)))
- (pass-if "make-thread creates new thread"
- (let* ((n (length (all-threads)))
- (t (make-thread (lambda () 'foo) 'make-thread-1))
- (r (> (length (all-threads)) n)))
- (thread-terminate! t) r)))
+ (with-test-prefix "thread-name"
-(with-test-prefix "thread-name"
+ (pass-if "make-thread with name binds name"
+ (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
+ (r (eq? (thread-name t) 'thread-name-1)))
+ (thread-terminate! t) r))
- (pass-if "make-thread with name binds name"
- (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
- (r (eq? (thread-name t) 'thread-name-1)))
- (thread-terminate! t) r))
+ (pass-if "make-thread without name does not bind name"
+ (let* ((t (make-thread (lambda () 'foo)))
+ (r (not (thread-name t))))
+ (thread-terminate! t) r)))
- (pass-if "make-thread without name does not bind name"
- (let* ((t (make-thread (lambda () 'foo)))
- (r (not (thread-name t))))
- (thread-terminate! t) r)))
+ (with-test-prefix "thread-specific"
-(with-test-prefix "thread-specific"
+ (pass-if "thread-specific is initially #f"
+ (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
+ (r (not (thread-specific t))))
+ (thread-terminate! t) r))
- (pass-if "thread-specific is initially #f"
- (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
- (r (not (thread-specific t))))
- (thread-terminate! t) r))
+ (pass-if "thread-specific-set! can set value"
+ (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
+ (thread-specific-set! t "hello")
+ (let ((r (equal? (thread-specific t) "hello")))
+ (thread-terminate! t) r))))
- (pass-if "thread-specific-set! can set value"
- (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
- (thread-specific-set! t "hello")
- (let ((r (equal? (thread-specific t) "hello")))
- (thread-terminate! t) r))))
+ (with-test-prefix "thread-start!"
-(with-test-prefix "thread-start!"
+ (pass-if "thread activates only after start"
+ (let* ((started #f)
+ (m (make-mutex 'thread-start-mutex))
+ (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
+ (and (not started) (thread-start! t) (thread-join! t) started))))
- (pass-if "thread activates only after start"
- (let* ((started #f)
- (m (make-mutex 'thread-start-mutex))
- (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
- (and (not started) (thread-start! t) (thread-join! t) started))))
+ (with-test-prefix "thread-yield!"
-(with-test-prefix "thread-yield!"
+ (pass-if "thread yield suceeds"
+ (thread-yield!) #t))
- (pass-if "thread yield suceeds"
- (thread-yield!) #t))
+ (with-test-prefix "thread-sleep!"
-(with-test-prefix "thread-sleep!"
+ (pass-if "thread sleep with time"
+ (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
+ (unspecified? (thread-sleep! future-time))))
- (pass-if "thread sleep with time"
- (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
- (unspecified? (thread-sleep! future-time))))
+ (pass-if "thread sleep with number"
+ (let ((old-secs (car (current-time))))
+ (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
- (pass-if "thread sleep with number"
- (let ((old-secs (car (current-time))))
- (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
+ (pass-if "thread does not sleep on past time"
+ (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
+ (unspecified? (thread-sleep! past-time)))))
- (pass-if "thread does not sleep on past time"
- (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
- (unspecified? (thread-sleep! past-time)))))
-
-(with-test-prefix "thread-terminate!"
+ (with-test-prefix "thread-terminate!"
- (pass-if "termination destroys non-started thread"
- (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
- (num-threads (length (all-threads)))
- (success #f))
- (thread-terminate! t)
- (with-exception-handler
- (lambda (obj) (set! success (terminated-thread-exception? obj)))
- (lambda () (thread-join! t)))
- success))
-
- (pass-if "termination destroys started thread"
- (let* ((m1 (make-mutex 'thread-terminate-2a))
- (m2 (make-mutex 'thread-terminate-2b))
- (c (make-condition-variable 'thread-terminate-2))
- (t (make-thread (lambda ()
- (mutex-lock! m1)
- (condition-variable-signal! c)
- (mutex-unlock! m1)
- (mutex-lock! m2))
- 'thread-terminate-2))
- (success #f))
- (mutex-lock! m1)
- (mutex-lock! m2)
- (thread-start! t)
- (mutex-unlock! m1 c)
- (thread-terminate! t)
- (with-exception-handler
- (lambda (obj) (set! success (terminated-thread-exception? obj)))
- (lambda () (thread-join! t)))
- success)))
-
-(with-test-prefix "thread-join!"
-
- (pass-if "join receives result of thread"
- (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
- (thread-start! t)
- (eq? (thread-join! t) 'foo)))
-
- (pass-if "join receives timeout val if timeout expires"
- (let* ((m (make-mutex 'thread-join-2))
- (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
- (mutex-lock! m)
- (thread-start! t)
- (let ((r (thread-join! t (current-time) 'bar)))
- (thread-terminate! t)
- (eq? r 'bar))))
-
- (pass-if "join throws exception on timeout without timeout val"
- (let* ((m (make-mutex 'thread-join-3))
- (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
- (success #f))
- (mutex-lock! m)
- (thread-start! t)
- (with-exception-handler
- (lambda (obj) (set! success (join-timeout-exception? obj)))
- (lambda () (thread-join! t (current-time))))
- (thread-terminate! t)
- success))
-
- (pass-if "join waits on timeout"
- (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
- (thread-start! t)
- (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
-
-(with-test-prefix "mutex?"
-
- (pass-if "make-mutex creates mutex"
- (mutex? (make-mutex)))
-
- (pass-if "symbol not mutex"
- (not (mutex? 'foo))))
-
-(with-test-prefix "mutex-name"
-
- (pass-if "make-mutex with name binds name"
- (let* ((m (make-mutex 'mutex-name-1)))
- (eq? (mutex-name m) 'mutex-name-1)))
-
- (pass-if "make-mutex without name does not bind name"
- (let* ((m (make-mutex)))
- (not (mutex-name m)))))
-
-(with-test-prefix "mutex-specific"
-
- (pass-if "mutex-specific is initially #f"
- (let ((m (make-mutex 'mutex-specific-1)))
- (not (mutex-specific m))))
-
- (pass-if "mutex-specific-set! can set value"
- (let ((m (make-mutex 'mutex-specific-2)))
- (mutex-specific-set! m "hello")
- (equal? (mutex-specific m) "hello"))))
-
-(with-test-prefix "mutex-state"
-
- (pass-if "mutex state is initially not-abandoned"
- (let ((m (make-mutex 'mutex-state-1)))
- (eq? (mutex-state m) 'not-abandoned)))
-
- (pass-if "mutex state of locked, owned mutex is owner thread"
- (let ((m (make-mutex 'mutex-state-2)))
- (mutex-lock! m)
- (eq? (mutex-state m) (current-thread))))
+ (pass-if "termination destroys non-started thread"
+ (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
+ (num-threads (length (all-threads)))
+ (success #f))
+ (thread-terminate! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (terminated-thread-exception? obj)))
+ (lambda () (thread-join! t)))
+ success))
+
+ (pass-if "termination destroys started thread"
+ (let* ((m1 (make-mutex 'thread-terminate-2a))
+ (m2 (make-mutex 'thread-terminate-2b))
+ (c (make-condition-variable 'thread-terminate-2))
+ (t (make-thread (lambda ()
+ (mutex-lock! m1)
+ (condition-variable-signal! c)
+ (mutex-unlock! m1)
+ (mutex-lock! m2))
+ 'thread-terminate-2))
+ (success #f))
+ (mutex-lock! m1)
+ (mutex-lock! m2)
+ (thread-start! t)
+ (mutex-unlock! m1 c)
+ (thread-terminate! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (terminated-thread-exception? obj)))
+ (lambda () (thread-join! t)))
+ success)))
+
+ (with-test-prefix "thread-join!"
+
+ (pass-if "join receives result of thread"
+ (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
+ (thread-start! t)
+ (eq? (thread-join! t) 'foo)))
+
+ (pass-if "join receives timeout val if timeout expires"
+ (let* ((m (make-mutex 'thread-join-2))
+ (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
+ (mutex-lock! m)
+ (thread-start! t)
+ (let ((r (thread-join! t (current-time) 'bar)))
+ (thread-terminate! t)
+ (eq? r 'bar))))
+
+ (pass-if "join throws exception on timeout without timeout val"
+ (let* ((m (make-mutex 'thread-join-3))
+ (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
+ (success #f))
+ (mutex-lock! m)
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (join-timeout-exception? obj)))
+ (lambda () (thread-join! t (current-time))))
+ (thread-terminate! t)
+ success))
+
+ (pass-if "join waits on timeout"
+ (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
+ (thread-start! t)
+ (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
+
+ (with-test-prefix "mutex?"
+
+ (pass-if "make-mutex creates mutex"
+ (mutex? (make-mutex)))
+
+ (pass-if "symbol not mutex"
+ (not (mutex? 'foo))))
+
+ (with-test-prefix "mutex-name"
+
+ (pass-if "make-mutex with name binds name"
+ (let* ((m (make-mutex 'mutex-name-1)))
+ (eq? (mutex-name m) 'mutex-name-1)))
+
+ (pass-if "make-mutex without name does not bind name"
+ (let* ((m (make-mutex)))
+ (not (mutex-name m)))))
+
+ (with-test-prefix "mutex-specific"
+
+ (pass-if "mutex-specific is initially #f"
+ (let ((m (make-mutex 'mutex-specific-1)))
+ (not (mutex-specific m))))
+
+ (pass-if "mutex-specific-set! can set value"
+ (let ((m (make-mutex 'mutex-specific-2)))
+ (mutex-specific-set! m "hello")
+ (equal? (mutex-specific m) "hello"))))
+
+ (with-test-prefix "mutex-state"
+
+ (pass-if "mutex state is initially not-abandoned"
+ (let ((m (make-mutex 'mutex-state-1)))
+ (eq? (mutex-state m) 'not-abandoned)))
+
+ (pass-if "mutex state of locked, owned mutex is owner thread"
+ (let ((m (make-mutex 'mutex-state-2)))
+ (mutex-lock! m)
+ (eq? (mutex-state m) (current-thread))))
- (pass-if "mutex state of locked, unowned mutex is not-owned"
- (let ((m (make-mutex 'mutex-state-3)))
- (mutex-lock! m #f #f)
- (eq? (mutex-state m) 'not-owned)))
-
- (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
- (let* ((m (make-mutex 'mutex-state-4))
- (t (make-thread (lambda () (mutex-lock! m)))))
- (thread-start! t)
- (thread-join! t)
- (eq? (mutex-state m) 'abandoned))))
-
-(with-test-prefix "mutex-lock!"
+ (pass-if "mutex state of locked, unowned mutex is not-owned"
+ (let ((m (make-mutex 'mutex-state-3)))
+ (mutex-lock! m #f #f)
+ (eq? (mutex-state m) 'not-owned)))
+
+ (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
+ (let* ((m (make-mutex 'mutex-state-4))
+ (t (make-thread (lambda () (mutex-lock! m)))))
+ (thread-start! t)
+ (thread-join! t)
+ (eq? (mutex-state m) 'abandoned))))
+
+ (with-test-prefix "mutex-lock!"
- (pass-if "mutex-lock! returns true on successful lock"
- (let* ((m (make-mutex 'mutex-lock-1)))
- (mutex-lock! m)))
-
- (pass-if "mutex-lock! returns false on timeout"
- (let* ((m (make-mutex 'mutex-lock-2))
- (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
- (mutex-lock! m)
- (thread-start! t)
- (not (thread-join! t))))
-
- (pass-if "mutex-lock! returns true when lock obtained within timeout"
- (let* ((m (make-mutex 'mutex-lock-3))
- (t (make-thread (lambda ()
- (mutex-lock! m (+ (time->seconds (current-time))
- 100)
- #f)))))
- (mutex-lock! m)
- (thread-start! t)
- (mutex-unlock! m)
- (thread-join! t)))
-
- (pass-if "can lock mutex for non-current thread"
- (let* ((m1 (make-mutex 'mutex-lock-4a))
- (m2 (make-mutex 'mutex-lock-4b))
- (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
- (mutex-lock! m1)
- (thread-start! t)
- (mutex-lock! m2 #f t)
- (let ((success (eq? (mutex-state m2) t)))
- (thread-terminate! t) success)))
-
- (pass-if "locking abandoned mutex throws exception"
- (let* ((m (make-mutex 'mutex-lock-5))
- (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
- (success #f))
- (thread-start! t)
- (thread-join! t)
- (with-exception-handler
- (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
- (lambda () (mutex-lock! m)))
- (and success (eq? (mutex-state m) (current-thread)))))
-
- (pass-if "sleeping threads notified of abandonment"
- (let* ((m1 (make-mutex 'mutex-lock-6a))
- (m2 (make-mutex 'mutex-lock-6b))
- (c (make-condition-variable 'mutex-lock-6))
- (t (make-thread (lambda ()
- (mutex-lock! m1)
- (mutex-lock! m2)
- (condition-variable-signal! c))))
- (success #f))
- (mutex-lock! m1)
- (thread-start! t)
- (with-exception-handler
- (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
- (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
- success)))
-
-(with-test-prefix "mutex-unlock!"
+ (pass-if "mutex-lock! returns true on successful lock"
+ (let* ((m (make-mutex 'mutex-lock-1)))
+ (mutex-lock! m)))
+
+ (pass-if "mutex-lock! returns false on timeout"
+ (let* ((m (make-mutex 'mutex-lock-2))
+ (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (not (thread-join! t))))
+
+ (pass-if "mutex-lock! returns true when lock obtained within timeout"
+ (let* ((m (make-mutex 'mutex-lock-3))
+ (t (make-thread (lambda ()
+ (mutex-lock! m (+ (time->seconds
(current-time))
+ 100)
+ #f)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (mutex-unlock! m)
+ (thread-join! t)))
+
+ (pass-if "can lock mutex for non-current thread"
+ (let* ((m1 (make-mutex 'mutex-lock-4a))
+ (m2 (make-mutex 'mutex-lock-4b))
+ (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
+ (mutex-lock! m1)
+ (thread-start! t)
+ (mutex-lock! m2 #f t)
+ (let ((success (eq? (mutex-state m2) t)))
+ (thread-terminate! t) success)))
+
+ (pass-if "locking abandoned mutex throws exception"
+ (let* ((m (make-mutex 'mutex-lock-5))
+ (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
+ (success #f))
+ (thread-start! t)
+ (thread-join! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
+ (lambda () (mutex-lock! m)))
+ (and success (eq? (mutex-state m) (current-thread)))))
+
+ (pass-if "sleeping threads notified of abandonment"
+ (let* ((m1 (make-mutex 'mutex-lock-6a))
+ (m2 (make-mutex 'mutex-lock-6b))
+ (c (make-condition-variable 'mutex-lock-6))
+ (t (make-thread (lambda ()
+ (mutex-lock! m1)
+ (mutex-lock! m2)
+ (condition-variable-signal! c))))
+ (success #f))
+ (mutex-lock! m1)
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
+ (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
+ success)))
+
+ (with-test-prefix "mutex-unlock!"
- (pass-if "unlock changes mutex state"
- (let* ((m (make-mutex 'mutex-unlock-1)))
- (mutex-lock! m)
- (mutex-unlock! m)
- (eq? (mutex-state m) 'not-abandoned)))
-
- (pass-if "can unlock from any thread"
- (let* ((m (make-mutex 'mutex-unlock-2))
- (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
- (mutex-lock! m)
- (thread-start! t)
- (thread-join! t)
- (eq? (mutex-state m) 'not-abandoned)))
-
- (pass-if "mutex unlock is true when condition is signalled"
- (let* ((m (make-mutex 'mutex-unlock-3))
- (c (make-condition-variable 'mutex-unlock-3))
- (t (make-thread (lambda ()
- (mutex-lock! m)
- (condition-variable-signal! c)
- (mutex-unlock! m)))))
- (mutex-lock! m)
- (thread-start! t)
- (mutex-unlock! m c)))
-
- (pass-if "mutex unlock is false when condition times out"
- (let* ((m (make-mutex 'mutex-unlock-4))
- (c (make-condition-variable 'mutex-unlock-4)))
- (mutex-lock! m)
- (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
-
-(with-test-prefix "condition-variable?"
-
- (pass-if "make-condition-variable creates condition variable"
- (condition-variable? (make-condition-variable)))
-
- (pass-if "symbol not condition variable"
- (not (condition-variable? 'foo))))
-
-(with-test-prefix "condition-variable-name"
-
- (pass-if "make-condition-variable with name binds name"
- (let* ((c (make-condition-variable 'condition-variable-name-1)))
- (eq? (condition-variable-name c) 'condition-variable-name-1)))
-
- (pass-if "make-condition-variable without name does not bind name"
- (let* ((c (make-condition-variable)))
- (not (condition-variable-name c)))))
-
-(with-test-prefix "condition-variable-specific"
-
- (pass-if "condition-variable-specific is initially #f"
- (let ((c (make-condition-variable 'condition-variable-specific-1)))
- (not (condition-variable-specific c))))
-
- (pass-if "condition-variable-specific-set! can set value"
- (let ((c (make-condition-variable 'condition-variable-specific-1)))
- (condition-variable-specific-set! c "hello")
- (equal? (condition-variable-specific c) "hello"))))
-
-(with-test-prefix "condition-variable-signal!"
+ (pass-if "unlock changes mutex state"
+ (let* ((m (make-mutex 'mutex-unlock-1)))
+ (mutex-lock! m)
+ (mutex-unlock! m)
+ (eq? (mutex-state m) 'not-abandoned)))
+
+ (pass-if "can unlock from any thread"
+ (let* ((m (make-mutex 'mutex-unlock-2))
+ (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
+ (mutex-lock! m)
+ (thread-start! t)
+ (thread-join! t)
+ (eq? (mutex-state m) 'not-abandoned)))
+
+ (pass-if "mutex unlock is true when condition is signalled"
+ (let* ((m (make-mutex 'mutex-unlock-3))
+ (c (make-condition-variable 'mutex-unlock-3))
+ (t (make-thread (lambda ()
+ (mutex-lock! m)
+ (condition-variable-signal! c)
+ (mutex-unlock! m)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (mutex-unlock! m c)))
+
+ (pass-if "mutex unlock is false when condition times out"
+ (let* ((m (make-mutex 'mutex-unlock-4))
+ (c (make-condition-variable 'mutex-unlock-4)))
+ (mutex-lock! m)
+ (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
+
+ (with-test-prefix "condition-variable?"
+
+ (pass-if "make-condition-variable creates condition variable"
+ (condition-variable? (make-condition-variable)))
+
+ (pass-if "symbol not condition variable"
+ (not (condition-variable? 'foo))))
+
+ (with-test-prefix "condition-variable-name"
+
+ (pass-if "make-condition-variable with name binds name"
+ (let* ((c (make-condition-variable 'condition-variable-name-1)))
+ (eq? (condition-variable-name c) 'condition-variable-name-1)))
+
+ (pass-if "make-condition-variable without name does not bind name"
+ (let* ((c (make-condition-variable)))
+ (not (condition-variable-name c)))))
+
+ (with-test-prefix "condition-variable-specific"
+
+ (pass-if "condition-variable-specific is initially #f"
+ (let ((c (make-condition-variable 'condition-variable-specific-1)))
+ (not (condition-variable-specific c))))
+
+ (pass-if "condition-variable-specific-set! can set value"
+ (let ((c (make-condition-variable 'condition-variable-specific-1)))
+ (condition-variable-specific-set! c "hello")
+ (equal? (condition-variable-specific c) "hello"))))
+
+ (with-test-prefix "condition-variable-signal!"
- (pass-if "condition-variable-signal! wakes up single thread"
- (let* ((m (make-mutex 'condition-variable-signal-1))
- (c (make-condition-variable 'condition-variable-signal-1))
- (t (make-thread (lambda ()
- (mutex-lock! m)
- (condition-variable-signal! c)
- (mutex-unlock! m)))))
- (mutex-lock! m)
- (thread-start! t)
- (mutex-unlock! m c))))
-
-(with-test-prefix "condition-variable-broadcast!"
-
- (pass-if "condition-variable-broadcast! wakes up multiple threads"
- (let* ((sem 0)
- (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
- (m1 (make-mutex 'condition-variable-broadcast-1-a))
- (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
- (m2 (make-mutex 'condition-variable-broadcast-1-b))
- (inc-sem! (lambda ()
- (mutex-lock! m1)
- (set! sem (+ sem 1))
- (condition-variable-broadcast! c1)
- (mutex-unlock! m1)))
- (dec-sem! (lambda ()
- (mutex-lock! m1)
- (while (eqv? sem 0) (wait-condition-variable c1 m1))
- (set! sem (- sem 1))
- (mutex-unlock! m1)))
- (t1 (make-thread (lambda ()
- (mutex-lock! m2)
- (inc-sem!)
- (mutex-unlock! m2 c2)
- (inc-sem!))))
- (t2 (make-thread (lambda ()
- (mutex-lock! m2)
- (inc-sem!)
- (mutex-unlock! m2 c2)
- (inc-sem!)))))
- (thread-start! t1)
- (thread-start! t2)
- (dec-sem!)
- (dec-sem!)
- (mutex-lock! m2)
- (condition-variable-broadcast! c2)
- (mutex-unlock! m2)
- (dec-sem!)
- (dec-sem!))))
-
-(with-test-prefix "time?"
-
- (pass-if "current-time is time" (time? (current-time)))
- (pass-if "number is not time" (not (time? 123)))
- (pass-if "symbol not time" (not (time? 'foo))))
-
-(with-test-prefix "time->seconds"
-
- (pass-if "time->seconds makes time into rational"
- (rational? (time->seconds (current-time))))
-
- (pass-if "time->seconds is reversible"
- (let ((t (current-time)))
- (equal? t (seconds->time (time->seconds t))))))
-
-(with-test-prefix "seconds->time"
-
- (pass-if "seconds->time makes rational into time"
- (time? (seconds->time 123.456)))
-
- (pass-if "seconds->time is reversible"
- (let ((t (time->seconds (current-time))))
- (equal? t (time->seconds (seconds->time t))))))
-
-(with-test-prefix "current-exception-handler"
-
- (pass-if "current handler returned at top level"
- (procedure? (current-exception-handler)))
-
- (pass-if "specified handler set under with-exception-handler"
- (let ((h (lambda (key . args) 'nothing)))
- (with-exception-handler h (lambda () (eq? (current-exception-handler)
- h)))))
-
- (pass-if "multiple levels of handler nesting"
- (let ((h (lambda (key . args) 'nothing))
- (i (current-exception-handler)))
- (and (with-exception-handler h (lambda ()
- (eq? (current-exception-handler) h)))
- (eq? (current-exception-handler) i))))
-
- (pass-if "exception handler installation is thread-safe"
- (let* ((h1 (current-exception-handler))
- (h2 (lambda (key . args) 'nothing-2))
- (m (make-mutex 'current-exception-handler-4))
- (c (make-condition-variable 'current-exception-handler-4))
- (t (make-thread (lambda ()
- (with-exception-handler
- h2 (lambda ()
- (mutex-lock! m)
- (condition-variable-signal! c)
- (wait-condition-variable c m)
- (and (eq? (current-exception-handler) h2)
- (mutex-unlock! m)))))
- 'current-exception-handler-4)))
- (mutex-lock! m)
- (thread-start! t)
- (wait-condition-variable c m)
- (and (eq? (current-exception-handler) h1)
- (condition-variable-signal! c)
- (mutex-unlock! m)
- (thread-join! t)))))
-
-(with-test-prefix "uncaught-exception-reason"
-
- (pass-if "initial handler captures top level exception"
- (let ((t (make-thread (lambda () (raise 'foo))))
- (success #f))
- (thread-start! t)
- (with-exception-handler
- (lambda (obj)
- (and (uncaught-exception? obj)
- (eq? (uncaught-exception-reason obj) 'foo)
- (set! success #t)))
- (lambda () (thread-join! t)))
- success))
-
- (pass-if "initial handler captures non-SRFI-18 throw"
- (let ((t (make-thread (lambda () (throw 'foo))))
- (success #f))
- (thread-start! t)
- (with-exception-handler
- (lambda (obj)
- (and (uncaught-exception? obj)
- (eq? (uncaught-exception-reason obj) 'foo)
- (set! success #t)))
- (lambda () (thread-join! t)))
- success)))
-
-)
+ (pass-if "condition-variable-signal! wakes up single thread"
+ (let* ((m (make-mutex 'condition-variable-signal-1))
+ (c (make-condition-variable 'condition-variable-signal-1))
+ (t (make-thread (lambda ()
+ (mutex-lock! m)
+ (condition-variable-signal! c)
+ (mutex-unlock! m)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (mutex-unlock! m c))))
+
+ (with-test-prefix "condition-variable-broadcast!"
+
+ (pass-if "condition-variable-broadcast! wakes up multiple threads"
+ (let* ((sem 0)
+ (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
+ (m1 (make-mutex 'condition-variable-broadcast-1-a))
+ (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
+ (m2 (make-mutex 'condition-variable-broadcast-1-b))
+ (inc-sem! (lambda ()
+ (mutex-lock! m1)
+ (set! sem (+ sem 1))
+ (condition-variable-broadcast! c1)
+ (mutex-unlock! m1)))
+ (dec-sem! (lambda ()
+ (mutex-lock! m1)
+ (while (eqv? sem 0) (wait-condition-variable c1 m1))
+ (set! sem (- sem 1))
+ (mutex-unlock! m1)))
+ (t1 (make-thread (lambda ()
+ (mutex-lock! m2)
+ (inc-sem!)
+ (mutex-unlock! m2 c2)
+ (inc-sem!))))
+ (t2 (make-thread (lambda ()
+ (mutex-lock! m2)
+ (inc-sem!)
+ (mutex-unlock! m2 c2)
+ (inc-sem!)))))
+ (thread-start! t1)
+ (thread-start! t2)
+ (dec-sem!)
+ (dec-sem!)
+ (mutex-lock! m2)
+ (condition-variable-broadcast! c2)
+ (mutex-unlock! m2)
+ (dec-sem!)
+ (dec-sem!))))
+
+ (with-test-prefix "time?"
+
+ (pass-if "current-time is time" (time? (current-time)))
+ (pass-if "number is not time" (not (time? 123)))
+ (pass-if "symbol not time" (not (time? 'foo))))
+
+ (with-test-prefix "time->seconds"
+
+ (pass-if "time->seconds makes time into rational"
+ (rational? (time->seconds (current-time))))
+
+ (pass-if "time->seconds is reversible"
+ (let ((t (current-time)))
+ (equal? t (seconds->time (time->seconds t))))))
+
+ (with-test-prefix "seconds->time"
+
+ (pass-if "seconds->time makes rational into time"
+ (time? (seconds->time 123.456)))
+
+ (pass-if "seconds->time is reversible"
+ (let ((t (time->seconds (current-time))))
+ (equal? t (time->seconds (seconds->time t))))))
+
+ (with-test-prefix "current-exception-handler"
+
+ (pass-if "current handler returned at top level"
+ (procedure? (current-exception-handler)))
+
+ (pass-if "specified handler set under with-exception-handler"
+ (let ((h (lambda (key . args) 'nothing)))
+ (with-exception-handler h (lambda () (eq? (current-exception-handler)
+ h)))))
+
+ (pass-if "multiple levels of handler nesting"
+ (let ((h (lambda (key . args) 'nothing))
+ (i (current-exception-handler)))
+ (and (with-exception-handler h (lambda ()
+ (eq? (current-exception-handler) h)))
+ (eq? (current-exception-handler) i))))
+
+ (pass-if "exception handler installation is thread-safe"
+ (let* ((h1 (current-exception-handler))
+ (h2 (lambda (key . args) 'nothing-2))
+ (m (make-mutex 'current-exception-handler-4))
+ (c (make-condition-variable 'current-exception-handler-4))
+ (t (make-thread (lambda ()
+ (with-exception-handler
+ h2 (lambda ()
+ (mutex-lock! m)
+ (condition-variable-signal! c)
+ (wait-condition-variable c m)
+ (and (eq? (current-exception-handler) h2)
+ (mutex-unlock! m)))))
+ 'current-exception-handler-4)))
+ (mutex-lock! m)
+ (thread-start! t)
+ (wait-condition-variable c m)
+ (and (eq? (current-exception-handler) h1)
+ (condition-variable-signal! c)
+ (mutex-unlock! m)
+ (thread-join! t)))))
+
+ (with-test-prefix "uncaught-exception-reason"
+
+ (pass-if "initial handler captures top level exception"
+ (let ((t (make-thread (lambda () (raise 'foo))))
+ (success #f))
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj)
+ (and (uncaught-exception? obj)
+ (eq? (uncaught-exception-reason obj) 'foo)
+ (set! success #t)))
+ (lambda () (thread-join! t)))
+ success))
+
+ (pass-if "initial handler captures non-SRFI-18 throw"
+ (let ((t (make-thread (lambda () (throw 'foo))))
+ (success #f))
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj)
+ (and (uncaught-exception? obj)
+ (eq? (uncaught-exception-reason obj) 'foo)
+ (set! success #t)))
+ (lambda () (thread-join! t)))
+ success)))))
\ No newline at end of file
diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test
index 2e7f0d5..033e39f 100644
--- a/test-suite/tests/srfi-4.test
+++ b/test-suite/tests/srfi-4.test
@@ -515,3 +515,28 @@
(pass-if-exception "generalized-vector-set!, out-of-range"
exception:out-of-range
(generalized-vector-set! (c64vector 1.0) 1 2.0)))
+
+(with-test-prefix "accessing uniform vectors of different types"
+
+ (pass-if "u32vector-length of u16vector"
+ (= 2 (u32vector-length (make-u16vector 4))))
+
+ (pass-if "u32vector-length of u8vector"
+ (= 2 (u32vector-length (make-u8vector 8))))
+
+ (pass-if "u8vector-length of u16vector"
+ (= 4 (u8vector-length (make-u16vector 2))))
+
+ (pass-if "u8vector-length of u32vector"
+ (= 8 (u8vector-length (make-u32vector 2))))
+
+ (pass-if "u32vector-set! of u16vector"
+ (let ((v (make-u16vector 4 #xFFFF)))
+ (u32vector-set! v 1 0)
+ (equal? v #u16(#xFFFF #xFFFF 0 0))))
+
+ (pass-if "u16vector-set! of u32vector"
+ (let ((v (make-u32vector 2 #xFFFFFFFF)))
+ (u16vector-set! v 2 0)
+ (u16vector-set! v 3 0)
+ (equal? v #u32(#xFFFFFFFF 0)))))
diff --git a/test-suite/tests/srfi-6.test b/test-suite/tests/srfi-6.test
index 68fc70d..bd9167c 100644
--- a/test-suite/tests/srfi-6.test
+++ b/test-suite/tests/srfi-6.test
@@ -1,6 +1,6 @@
;;;; srfi-6.test --- test suite for SRFI-6 -*- scheme -*-
;;;;
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2012 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
@@ -37,13 +37,21 @@
(char=? #\y (read-char port))
(char=? #\z (read-char port))
(eof-object? (read-char port)))))
-
+
+ (pass-if "read-char, Unicode"
+ ;; String ports should always be Unicode-capable.
+ ;; See <http://bugs.gnu.org/11197>.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (let ((port (open-input-string "λμ")))
+ (and (char=? #\λ (read-char port))
+ (char=? #\μ (read-char port))))))
+
(with-test-prefix "unread-char"
(pass-if "one char"
(let ((port (open-input-string "")))
- (unread-char #\x port)
- (and (char=? #\x (read-char port))
+ (unread-char #\x port)
+ (and (char=? #\x (read-char port))
(eof-object? (read-char port)))))
(pass-if "after eof"
@@ -75,7 +83,15 @@
(let ((port (open-output-string)))
(display "xyz" port)
(string=? "xyz" (get-output-string port))))
-
+
+ (pass-if "λ"
+ ;; Writing to an output string should always work.
+ ;; See <http://bugs.gnu.org/11197>.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (let ((port (open-output-string)))
+ (display "λ" port)
+ (string=? "λ" (get-output-string port)))))
+
(pass-if "seek"
(let ((port (open-output-string)))
(display "abcdef" port)
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index f26a7a2..321fe16 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -1,7 +1,7 @@
;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-05-10
;;;;
-;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 2012 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
@@ -110,3 +110,12 @@
(let ((frotz (make-frotz 1 2)))
(and (= (frotz-a frotz) 1)
(= (frotz-b frotz) 2)))))
+
+(with-test-prefix "record compatibility"
+
+ (pass-if "record?"
+ (record? (make-foo 1)))
+
+ (pass-if "record-constructor"
+ (equal? ((record-constructor :foo) 1)
+ (make-foo 1))))
diff --git a/test-suite/tests/sxml.match.test b/test-suite/tests/sxml.match.test
index b3dbbe7..fcb089f 100644
--- a/test-suite/tests/sxml.match.test
+++ b/test-suite/tests/sxml.match.test
@@ -1,6 +1,6 @@
;;;; sxml.simple.test --- (sxml simple) -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -42,4 +42,4 @@
;; FIXME: The `xyzpq' variable in there is originally named `x' but using that
;; name triggers a psyntax "identifier out of context" error.
-(include-from-path "test-suite/tests/sxml-match-tests.ss")
+(include-from-path "tests/sxml-match-tests.ss")
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index 6183df8..0e81f65 100644
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -115,16 +115,16 @@
'foo)))
(with-test-prefix "changes to expansion environment"
- (pass-if "expander detects changes to current-module with @@"
+ (pass-if "expander detects changes to current-module with @@ @@"
(compile '(begin
(define-module (new-module))
- (@@ (new-module)
- (define-syntax new-module-macro
- (lambda (stx)
- (syntax-case stx ()
- ((_ arg) (syntax arg))))))
- (@@ (new-module)
- (new-module-macro #t)))
+ (@@ @@ (new-module)
+ (define-syntax new-module-macro
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ arg) (syntax arg))))))
+ (@@ @@ (new-module)
+ (new-module-macro #t)))
#:env (current-module))))
(define-module (test-suite test-syncase-2)
diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test
index 49d1086..98c44b9 100644
--- a/test-suite/tests/texinfo.test
+++ b/test-suite/tests/texinfo.test
@@ -1,6 +1,6 @@
;;;; texinfo.test -*- scheme -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -177,8 +177,9 @@
(test (string-append "foo bar address@hidden " title "\n" str)
expected-res))
(define (test-body str expected-res)
- (pass-if (equal? expected-res
- (cddr (try-with-title "zog" str)))))
+ (pass-if str
+ (equal? expected-res
+ (cddr (try-with-title "zog" str)))))
(define (list-intersperse src-l elem)
(if (null? src-l) src-l
@@ -218,6 +219,19 @@
'((para (code "abc " (code)))))
(test-body "@code{ arg }"
'((para (code "arg"))))
+
+ (test-body "@acronym{GNU}"
+ '((para (acronym (% (acronym "GNU"))))))
+
+ (test-body "@acronym{GNU, not unix}"
+ '((para (acronym (% (acronym "GNU")
+ (meaning "not unix"))))))
+
+ (test-body "@acronym{GNU, @acronym{GNU}'s Not Unix}"
+ '((para (acronym (% (acronym "GNU")
+ (meaning (acronym (% (acronym "GNU")))
+ "'s Not Unix"))))))
+
(test-body "@example\n foo asdf asd sadf asd address@hidden example\n"
'((example " foo asdf asd sadf asd ")))
(test-body (join-lines
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 945b236..4ffdce0 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -69,38 +69,6 @@
(pat (guard guard-exp) #t)
(_ #f))))))
-(define peval
- ;; The partial evaluator.
- (@@ (language tree-il optimize) peval))
-
-(define-syntax pass-if-peval
- (syntax-rules (resolve-primitives)
- ((_ in pat)
- (pass-if-peval in pat
- (compile 'in #:from 'scheme #:to 'tree-il)))
- ((_ resolve-primitives in pat)
- (pass-if-peval in pat
- (expand-primitives!
- (resolve-primitives!
- (compile 'in #:from 'scheme #:to 'tree-il)
- (current-module)))))
- ((_ in pat code)
- (pass-if 'in
- (let ((evaled (unparse-tree-il (peval code))))
- (pmatch evaled
- (pat #t)
- (_ (pk 'peval-mismatch)
- ((@ (ice-9 pretty-print) pretty-print)
- 'in)
- (newline)
- ((@ (ice-9 pretty-print) pretty-print)
- evaled)
- (newline)
- ((@ (ice-9 pretty-print) pretty-print)
- 'pat)
- (newline)
- #f)))))))
-
(with-test-prefix "tree-il->scheme"
(pass-if-tree-il->scheme
@@ -180,7 +148,7 @@
(lexical #t #f ref 0) (call return 1)
(unbind)))
- (assert-tree-il->glil without-partial-evaluation
+ (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
@@ -657,901 +625,6 @@
#:opts '(#:partial-eval? #f)))))
-(with-test-prefix "partial evaluation"
-
- (pass-if-peval
- ;; First order, primitive.
- (let ((x 1) (y 2)) (+ x y))
- (const 3))
-
- (pass-if-peval
- ;; First order, thunk.
- (let ((x 1) (y 2))
- (let ((f (lambda () (+ x y))))
- (f)))
- (const 3))
-
- (pass-if-peval resolve-primitives
- ;; First order, let-values (requires primitive expansion for
- ;; `call-with-values'.)
- (let ((x 0))
- (call-with-values
- (lambda () (if (zero? x) (values 1 2) (values 3 4)))
- (lambda (a b)
- (+ a b))))
- (const 3))
-
- (pass-if-peval resolve-primitives
- ;; First order, multiple values.
- (let ((x 1) (y 2))
- (values x y))
- (apply (primitive values) (const 1) (const 2)))
-
- (pass-if-peval resolve-primitives
- ;; First order, multiple values truncated.
- (let ((x (values 1 'a)) (y 2))
- (values x y))
- (apply (primitive values) (const 1) (const 2)))
-
- (pass-if-peval resolve-primitives
- ;; First order, multiple values truncated.
- (or (values 1 2) 3)
- (const 1))
-
- (pass-if-peval
- ;; First order, coalesced, mutability preserved.
- (cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
-
- (pass-if-peval
- ;; First order, coalesced, mutability preserved.
- (cons 0 (cons 1 (cons 2 (list 3 4 5))))
- ;; This must not be a constant.
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
-
- (pass-if-peval
- ;; First order, coalesced, immutability preserved.
- (cons 0 (cons 1 (cons 2 '(3 4 5))))
- (apply (primitive cons) (const 0)
- (apply (primitive cons) (const 1)
- (apply (primitive cons) (const 2)
- (const (3 4 5))))))
-
- ;; These two tests doesn't work any more because we changed the way we
- ;; deal with constants -- now the algorithm will see a construction as
- ;; being bound to the lexical, so it won't propagate it. It can't
- ;; even propagate it in the case that it is only referenced once,
- ;; because:
- ;;
- ;; (let ((x (cons 1 2))) (lambda () x))
- ;;
- ;; is not the same as
- ;;
- ;; (lambda () (cons 1 2))
- ;;
- ;; Perhaps if we determined that not only was it only referenced once,
- ;; it was not closed over by a lambda, then we could propagate it, and
- ;; re-enable these two tests.
- ;;
- #;
- (pass-if-peval
- ;; First order, mutability preserved.
- (let loop ((i 3) (r '()))
- (if (zero? i)
- r
- (loop (1- i) (cons (cons i i) r))))
- (apply (primitive list)
- (apply (primitive cons) (const 1) (const 1))
- (apply (primitive cons) (const 2) (const 2))
- (apply (primitive cons) (const 3) (const 3))))
- ;;
- ;; See above.
- #;
- (pass-if-peval
- ;; First order, evaluated.
- (let loop ((i 7)
- (r '()))
- (if (<= i 0)
- (car r)
- (loop (1- i) (cons i r))))
- (const 1))
-
- ;; Instead here are tests for what happens for the above cases: they
- ;; unroll but they don't fold.
- (pass-if-peval
- (let loop ((i 3) (r '()))
- (if (zero? i)
- r
- (loop (1- i) (cons (cons i i) r))))
- (let (r) (_)
- ((apply (primitive list)
- (apply (primitive cons) (const 3) (const 3))))
- (let (r) (_)
- ((apply (primitive cons)
- (apply (primitive cons) (const 2) (const 2))
- (lexical r _)))
- (apply (primitive cons)
- (apply (primitive cons) (const 1) (const 1))
- (lexical r _)))))
-
- ;; See above.
- (pass-if-peval
- (let loop ((i 4)
- (r '()))
- (if (<= i 0)
- (car r)
- (loop (1- i) (cons i r))))
- (let (r) (_)
- ((apply (primitive list) (const 4)))
- (let (r) (_)
- ((apply (primitive cons)
- (const 3)
- (lexical r _)))
- (let (r) (_)
- ((apply (primitive cons)
- (const 2)
- (lexical r _)))
- (let (r) (_)
- ((apply (primitive cons)
- (const 1)
- (lexical r _)))
- (apply (primitive car)
- (lexical r _)))))))
-
- ;; Static sums.
- (pass-if-peval
- (let loop ((l '(1 2 3 4)) (sum 0))
- (if (null? l)
- sum
- (loop (cdr l) (+ sum (car l)))))
- (const 10))
-
- (pass-if-peval resolve-primitives
- (let ((string->chars
- (lambda (s)
- (define (char-at n)
- (string-ref s n))
- (define (len)
- (string-length s))
- (let loop ((i 0))
- (if (< i (len))
- (cons (char-at i)
- (loop (1+ i)))
- '())))))
- (string->chars "yo"))
- (apply (primitive list) (const #\y) (const #\o)))
-
- (pass-if-peval
- ;; Primitives in module-refs are resolved (the expansion of `pmatch'
- ;; below leads to calls to (@@ (system base pmatch) car) and
- ;; similar, which is what we want to be inlined.)
- (begin
- (use-modules (system base pmatch))
- (pmatch '(a b c d)
- ((a b . _)
- #t)))
- (begin
- (apply . _)
- (const #t)))
-
- (pass-if-peval
- ;; Mutability preserved.
- ((lambda (x y z) (list x y z)) 1 2 3)
- (apply (primitive list) (const 1) (const 2) (const 3)))
-
- (pass-if-peval
- ;; Don't propagate effect-free expressions that operate on mutable
- ;; objects.
- (let* ((x (list 1))
- (y (car x)))
- (set-car! x 0)
- y)
- (let (x) (_) ((apply (primitive list) (const 1)))
- (let (y) (_) ((apply (primitive car) (lexical x _)))
- (begin
- (apply (toplevel set-car!) (lexical x _) (const 0))
- (lexical y _)))))
-
- (pass-if-peval
- ;; Don't propagate effect-free expressions that operate on objects we
- ;; don't know about.
- (let ((y (car x)))
- (set-car! x 0)
- y)
- (let (y) (_) ((apply (primitive car) (toplevel x)))
- (begin
- (apply (toplevel set-car!) (toplevel x) (const 0))
- (lexical y _))))
-
- (pass-if-peval
- ;; Infinite recursion
- ((lambda (x) (x x)) (lambda (x) (x x)))
- (let (x) (_)
- ((lambda _
- (lambda-case
- (((x) _ _ _ _ _)
- (apply (lexical x _) (lexical x _))))))
- (apply (lexical x _) (lexical x _))))
-
- (pass-if-peval
- ;; First order, aliased primitive.
- (let* ((x *) (y (x 1 2))) y)
- (const 2))
-
- (pass-if-peval
- ;; First order, shadowed primitive.
- (begin
- (define (+ x y) (pk x y))
- (+ 1 2))
- (begin
- (define +
- (lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (toplevel pk) (lexical x _) (lexical y _))))))
- (apply (toplevel +) (const 1) (const 2))))
-
- (pass-if-peval
- ;; First-order, effects preserved.
- (let ((x 2))
- (do-something!)
- x)
- (begin
- (apply (toplevel do-something!))
- (const 2)))
-
- (pass-if-peval
- ;; First order, residual bindings removed.
- (let ((x 2) (y 3))
- (* (+ x y) z))
- (apply (primitive *) (const 5) (toplevel z)))
-
- (pass-if-peval
- ;; First order, with lambda.
- (define (foo x)
- (define (bar z) (* z z))
- (+ x (bar 3)))
- (define foo
- (lambda (_)
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (primitive +) (lexical x _) (const 9)))))))
-
- (pass-if-peval
- ;; First order, with lambda inlined & specialized twice.
- (let ((f (lambda (x y)
- (+ (* x top) y)))
- (x 2)
- (y 3))
- (+ (* x (f x y))
- (f something x)))
- (apply (primitive +)
- (apply (primitive *)
- (const 2)
- (apply (primitive +) ; (f 2 3)
- (apply (primitive *)
- (const 2)
- (toplevel top))
- (const 3)))
- (let (x) (_) ((toplevel something)) ; (f
something 2)
- ;; `something' is not const, so preserve order of
- ;; effects with a lexical binding.
- (apply (primitive +)
- (apply (primitive *)
- (lexical x _)
- (toplevel top))
- (const 2)))))
-
- (pass-if-peval
- ;; First order, with lambda inlined & specialized 3 times.
- (let ((f (lambda (x y) (if (> x 0) y x))))
- (+ (f -1 0)
- (f 1 0)
- (f -1 y)
- (f 2 y)
- (f z y)))
- (apply (primitive +)
- (const -1) ; (f -1 0)
- (const 0) ; (f 1 0)
- (begin (toplevel y) (const -1)) ; (f -1 y)
- (toplevel y) ; (f 2 y)
- (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
- (if (apply (primitive >) (lexical x _) (const 0))
- (lexical y _)
- (lexical x _)))))
-
- (pass-if-peval
- ;; First order, conditional.
- (let ((y 2))
- (lambda (x)
- (if (> y 0)
- (display x)
- 'never-reached)))
- (lambda ()
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel display) (lexical x _))))))
-
- (pass-if-peval
- ;; First order, recursive procedure.
- (letrec ((fibo (lambda (n)
- (if (<= n 1)
- n
- (+ (fibo (- n 1))
- (fibo (- n 2)))))))
- (fibo 4))
- (const 3))
-
- (pass-if-peval
- ;; Don't propagate toplevel references, as intervening expressions
- ;; could alter their bindings.
- (let ((x top))
- (foo)
- x)
- (let (x) (_) ((toplevel top))
- (begin
- (apply (toplevel foo))
- (lexical x _))))
-
- (pass-if-peval
- ;; Higher order.
- ((lambda (f x)
- (f (* (car x) (cadr x))))
- (lambda (x)
- (+ x 1))
- '(2 3))
- (const 7))
-
- (pass-if-peval
- ;; Higher order with optional argument (default value).
- ((lambda* (f x #:optional (y 0))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3))
- (const 7))
-
- (pass-if-peval
- ;; Higher order with optional argument (caller-supplied value).
- ((lambda* (f x #:optional (y 0))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3)
- 35)
- (const 42))
-
- (pass-if-peval
- ;; Higher order with optional argument (side-effecting default
- ;; value).
- ((lambda* (f x #:optional (y (foo)))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3))
- (let (y) (_) ((apply (toplevel foo)))
- (apply (primitive +) (lexical y _) (const 7))))
-
- (pass-if-peval
- ;; Higher order with optional argument (caller-supplied value).
- ((lambda* (f x #:optional (y (foo)))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3)
- 35)
- (const 42))
-
- (pass-if-peval
- ;; Higher order.
- ((lambda (f) (f x)) (lambda (x) x))
- (toplevel x))
-
- (pass-if-peval
- ;; Bug reported at
- ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
- (let ((fold (lambda (f g) (f (g top)))))
- (fold 1+ (lambda (x) x)))
- (apply (primitive 1+) (toplevel top)))
-
- (pass-if-peval
- ;; Procedure not inlined when residual code contains recursive calls.
- ;; <http://debbugs.gnu.org/9542>
- (letrec ((fold (lambda (f x3 b null? car cdr)
- (if (null? x3)
- b
- (f (car x3) (fold f (cdr x3) b null? car cdr))))))
- (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
- (letrec (fold) (_) (_)
- (apply (lexical fold _)
- (primitive *)
- (toplevel x)
- (const 1)
- (primitive zero?)
- (lambda ()
- (lambda-case
- (((x1) #f #f #f () (_))
- (lexical x1 _))))
- (lambda ()
- (lambda-case
- (((x2) #f #f #f () (_))
- (apply (primitive -) (lexical x2 _) (const 1))))))))
-
- (pass-if "inlined lambdas are alpha-renamed"
- ;; In this example, `make-adder' is inlined more than once; thus,
- ;; they should use different gensyms for their arguments, because
- ;; the various optimization passes assume uniquely-named variables.
- ;;
- ;; Bug reported at
- ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
- ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
- (pmatch (unparse-tree-il
- (peval (compile
- '(let ((make-adder
- (lambda (x) (lambda (y) (+ x y)))))
- (cons (make-adder 1) (make-adder 2)))
- #:to 'tree-il)))
- ((apply (primitive cons)
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym1))
- (apply (primitive +)
- (const 1)
- (lexical y ,ref1)))))
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym2))
- (apply (primitive +)
- (const 2)
- (lexical y ,ref2))))))
- (and (eq? gensym1 ref1)
- (eq? gensym2 ref2)
- (not (eq? gensym1 gensym2))))
- (_ #f)))
-
- (pass-if-peval
- ;; Unused letrec bindings are pruned.
- (letrec ((a (lambda () (b)))
- (b (lambda () (a)))
- (c (lambda (x) x)))
- (c 10))
- (const 10))
-
- (pass-if-peval
- ;; Unused letrec bindings are pruned.
- (letrec ((a (foo!))
- (b (lambda () (a)))
- (c (lambda (x) x)))
- (c 10))
- (begin (apply (toplevel foo!))
- (const 10)))
-
- (pass-if-peval
- ;; Higher order, mutually recursive procedures.
- (letrec ((even? (lambda (x)
- (or (= 0 x)
- (odd? (- x 1)))))
- (odd? (lambda (x)
- (not (even? x)))))
- (and (even? 4) (odd? 7)))
- (const #t))
-
- (pass-if-peval
- ;; Memv with constants.
- (memv 1 '(3 2 1))
- (const '(1)))
-
- (pass-if-peval
- ;; Memv with non-constant list. It could fold but doesn't
- ;; currently.
- (memv 1 (list 3 2 1))
- (apply (primitive memv)
- (const 1)
- (apply (primitive list) (const 3) (const 2) (const 1))))
-
- (pass-if-peval
- ;; Memv with non-constant key, constant list, test context
- (case foo
- ((3 2 1) 'a)
- (else 'b))
- (let (key) (_) ((toplevel foo))
- (if (if (apply (primitive eqv?) (lexical key _) (const 3))
- (const #t)
- (if (apply (primitive eqv?) (lexical key _) (const 2))
- (const #t)
- (apply (primitive eqv?) (lexical key _) (const 1))))
- (const a)
- (const b))))
-
- (pass-if-peval
- ;; Memv with non-constant key, empty list, test context. Currently
- ;; doesn't fold entirely.
- (case foo
- (() 'a)
- (else 'b))
- (begin (toplevel foo) (const b)))
-
- ;;
- ;; Below are cases where constant propagation should bail out.
- ;;
-
- (pass-if-peval
- ;; Non-constant lexical is not propagated.
- (let ((v (make-vector 6 #f)))
- (lambda (n)
- (vector-set! v n n)))
- (let (v) (_)
- ((apply (toplevel make-vector) (const 6) (const #f)))
- (lambda ()
- (lambda-case
- (((n) #f #f #f () (_))
- (apply (toplevel vector-set!)
- (lexical v _) (lexical n _) (lexical n _)))))))
-
- (pass-if-peval
- ;; Mutable lexical is not propagated.
- (let ((v (vector 1 2 3)))
- (lambda ()
- v))
- (let (v) (_)
- ((apply (primitive vector) (const 1) (const 2) (const 3)))
- (lambda ()
- (lambda-case
- ((() #f #f #f () ())
- (lexical v _))))))
-
- (pass-if-peval
- ;; Lexical that is not provably pure is not inlined nor propagated.
- (let* ((x (if (> p q) (frob!) (display 'chbouib)))
- (y (* x 2)))
- (+ x x y))
- (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
- (apply (toplevel frob!))
- (apply (toplevel display) (const chbouib))))
- (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
- (apply (primitive +)
- (lexical x _) (lexical x _) (lexical y _)))))
-
- (pass-if-peval
- ;; Non-constant arguments not propagated to lambdas.
- ((lambda (x y z)
- (vector-set! x 0 0)
- (set-car! y 0)
- (set-cdr! z '()))
- (vector 1 2 3)
- (make-list 10)
- (list 1 2 3))
- (let (x y z) (_ _ _)
- ((apply (primitive vector) (const 1) (const 2) (const 3))
- (apply (toplevel make-list) (const 10))
- (apply (primitive list) (const 1) (const 2) (const 3)))
- (begin
- (apply (toplevel vector-set!)
- (lexical x _) (const 0) (const 0))
- (apply (toplevel set-car!)
- (lexical y _) (const 0))
- (apply (toplevel set-cdr!)
- (lexical z _) (const ())))))
-
- (pass-if-peval
- (let ((foo top-foo) (bar top-bar))
- (let* ((g (lambda (x y) (+ x y)))
- (f (lambda (g x) (g x x))))
- (+ (f g foo) (f g bar))))
- (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
- (apply (primitive +)
- (apply (primitive +) (lexical foo _) (lexical foo _))
- (apply (primitive +) (lexical bar _) (lexical bar _)))))
-
- (pass-if-peval
- ;; Fresh objects are not turned into constants, nor are constants
- ;; turned into fresh objects.
- (let* ((c '(2 3))
- (x (cons 1 c))
- (y (cons 0 x)))
- y)
- (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
- (apply (primitive cons) (const 0) (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (let ((x 2))
- (set! x 3)
- x)
- (let (x) (_) ((const 2))
- (begin
- (set! (lexical x _) (const 3))
- (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (letrec ((x 0)
- (f (lambda ()
- (set! x (+ 1 x))
- x)))
- (frob f) ; may mutate `x'
- x)
- (letrec (x) (_) ((const 0))
- (begin
- (apply (toplevel frob) (lambda _ _))
- (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (letrec ((f (lambda (x)
- (set! f (lambda (_) x))
- x)))
- (f 2))
- (letrec _ . _))
-
- (pass-if-peval
- ;; Bindings possibly mutated.
- (let ((x (make-foo)))
- (frob! x) ; may mutate `x'
- x)
- (let (x) (_) ((apply (toplevel make-foo)))
- (begin
- (apply (toplevel frob!) (lexical x _))
- (lexical x _))))
-
- (pass-if-peval
- ;; Inlining stops at recursive calls with dynamic arguments.
- (let loop ((x x))
- (if (< x 0) x (loop (1- x))))
- (letrec (loop) (_) ((lambda (_)
- (lambda-case
- (((x) #f #f #f () (_))
- (if _ _
- (apply (lexical loop _)
- (apply (primitive 1-)
- (lexical x _))))))))
- (apply (lexical loop _) (toplevel x))))
-
- (pass-if-peval
- ;; Recursion on the 2nd argument is fully evaluated.
- (let ((x (top)))
- (let loop ((x x) (y 10))
- (if (> y 0)
- (loop x (1- y))
- (foo x y))))
- (let (x) (_) ((apply (toplevel top)))
- (apply (toplevel foo) (lexical x _) (const 0))))
-
- (pass-if-peval
- ;; Inlining aborted when residual code contains recursive calls.
- ;;
- ;; <http://debbugs.gnu.org/9542>
- (let loop ((x x) (y 0))
- (if (> y 0)
- (loop (1- x) (1- y))
- (if (< x 0)
- x
- (loop (1+ x) (1+ y)))))
- (letrec (loop) (_) ((lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (if (apply (primitive >)
- (lexical y _) (const 0))
- _ _)))))
- (apply (lexical loop _) (toplevel x) (const 0))))
-
- (pass-if-peval
- ;; Infinite recursion: `peval' gives up and leaves it as is.
- (letrec ((f (lambda (x) (g (1- x))))
- (g (lambda (x) (h (1+ x))))
- (h (lambda (x) (f x))))
- (f 0))
- (letrec _ . _))
-
- (pass-if-peval
- ;; Infinite recursion: all the arguments to `loop' are static, but
- ;; unrolling it would lead `peval' to enter an infinite loop.
- (let loop ((x 0))
- (and (< x top)
- (loop (1+ x))))
- (letrec (loop) (_) ((lambda . _))
- (apply (lexical loop _) (const 0))))
-
- (pass-if-peval
- ;; This test checks that the `start' binding is indeed residualized.
- ;; See the `referenced?' procedure in peval's `prune-bindings'.
- (let ((pos 0))
- (set! pos 1) ;; Cause references to `pos' to residualize.
- (let ((here (let ((start pos)) (lambda () start))))
- (here)))
- (let (pos) (_) ((const 0))
- (begin
- (set! (lexical pos _) (const 1))
- (let (here) (_) (_)
- (apply (lexical here _))))))
-
- (pass-if-peval
- ;; FIXME: should this one residualize the binding?
- (letrec ((a a))
- 1)
- (const 1))
-
- (pass-if-peval
- ;; This is a fun one for peval to handle.
- (letrec ((a a))
- a)
- (letrec (a) (_) ((lexical a _))
- (lexical a _)))
-
- (pass-if-peval
- ;; Another interesting recursive case.
- (letrec ((a b) (b a))
- a)
- (letrec (a) (_) ((lexical a _))
- (lexical a _)))
-
- (pass-if-peval
- ;; Another pruning case, that `a' is residualized.
- (letrec ((a (lambda () (a)))
- (b (lambda () (a)))
- (c (lambda (x) x)))
- (let ((d (foo b)))
- (c d)))
-
- ;; "b c a" is the current order that we get with unordered letrec,
- ;; but it's not important to this test, so if it changes, just adapt
- ;; the test.
- (letrec (b c a) (_ _ _)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (apply (lexical a _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (lambda _
- (lambda-case
- ((() #f #f #f () ())
- (apply (lexical a _))))))
- (let (d)
- (_)
- ((apply (toplevel foo) (lexical b _)))
- (apply (lexical c _)
- (lexical d _)))))
-
- (pass-if-peval
- ;; In this case, we can prune the bindings. `a' ends up being copied
- ;; because it is only referenced once in the source program. Oh
- ;; well.
- (letrec* ((a (lambda (x) (top x)))
- (b (lambda () a)))
- (foo (b) (b)))
- (apply (toplevel foo)
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))))
-
- (pass-if-peval
- ;; Constant folding: cons of #nil does not make list
- (cons 1 #nil)
- (apply (primitive cons) (const 1) (const '#nil)))
-
- (pass-if-peval
- ;; Constant folding: cons
- (begin (cons 1 2) #f)
- (const #f))
-
- (pass-if-peval
- ;; Constant folding: cons
- (begin (cons (foo) 2) #f)
- (begin (apply (toplevel foo)) (const #f)))
-
- (pass-if-peval
- ;; Constant folding: cons
- (if (cons 0 0) 1 2)
- (const 1))
-
- (pass-if-peval
- ;; Constant folding: car+cons
- (car (cons 1 0))
- (const 1))
-
- (pass-if-peval
- ;; Constant folding: cdr+cons
- (cdr (cons 1 0))
- (const 0))
-
- (pass-if-peval
- ;; Constant folding: car+cons, impure
- (car (cons 1 (bar)))
- (begin (apply (toplevel bar)) (const 1)))
-
- (pass-if-peval
- ;; Constant folding: cdr+cons, impure
- (cdr (cons (bar) 0))
- (begin (apply (toplevel bar)) (const 0)))
-
- (pass-if-peval
- ;; Constant folding: car+list
- (car (list 1 0))
- (const 1))
-
- (pass-if-peval
- ;; Constant folding: cdr+list
- (cdr (list 1 0))
- (apply (primitive list) (const 0)))
-
- (pass-if-peval
- ;; Constant folding: car+list, impure
- (car (list 1 (bar)))
- (begin (apply (toplevel bar)) (const 1)))
-
- (pass-if-peval
- ;; Constant folding: cdr+list, impure
- (cdr (list (bar) 0))
- (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
-
- (pass-if-peval
- resolve-primitives
- ;; Non-constant guards get lexical bindings.
- (dynamic-wind foo (lambda () bar) baz)
- (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
-
- (pass-if-peval
- resolve-primitives
- ;; Constant guards don't need lexical bindings.
- (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
- (dynwind
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
- (toplevel bar)
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel baz))))))
-
- (pass-if-peval
- resolve-primitives
- ;; Prompt is removed if tag is unreferenced
- (let ((tag (make-prompt-tag)))
- (call-with-prompt tag
- (lambda () 1)
- (lambda args args)))
- (const 1))
-
- (pass-if-peval
- resolve-primitives
- ;; Prompt is removed if tag is unreferenced, with explicit stem
- (let ((tag (make-prompt-tag "foo")))
- (call-with-prompt tag
- (lambda () 1)
- (lambda args args)))
- (const 1))
-
- (pass-if-peval
- resolve-primitives
- ;; `while' without `break' or `continue' has no prompts and gets its
- ;; condition folded. Unfortunately the outer `lp' does not yet get
- ;; elided.
- (while #t #t)
- (letrec (lp) (_)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (letrec (loop) (_)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (apply (lexical loop _))))))
- (apply (lexical loop _)))))))
- (apply (lexical lp _)))))
-
-
-
(with-test-prefix "tree-il-fold"
(pass-if "empty tree"
@@ -2030,6 +1103,26 @@
w "wrong number of arguments to"))))
w)))))
+ (pass-if "top-level applicable struct"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((p current-warning-port))
+ (p (+ (p) 1))
+ (p))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+
+ (pass-if "top-level applicable struct with wrong arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(let ((p current-warning-port))
+ (p 1 2 3))
+ #:opts %opts-w-arity
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "wrong number of arguments to")))))
+
(pass-if "local toplevel-defines"
(let ((w (call-with-warnings
(lambda ()
@@ -2169,6 +1262,31 @@
#:opts %opts-w-format
#:to 'assembly)))))
+ (pass-if "non-literal format string using gettext as top-level _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(begin
+ (define (_ s) (gettext s "my-domain"))
+ (format #t (_ "~A ~A!") "hello" "world"))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using gettext as module-ref _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "non-literal format string using gettext as lexical _"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((_ (lambda (s)
+ (gettext s "my-domain"))))
+ (format #t (_ "~A ~A!") "hello" "world"))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
(pass-if "non-literal format string using ngettext"
(null? (call-with-warnings
(lambda ()
@@ -2184,6 +1302,16 @@
#:opts %opts-w-format
#:to 'assembly)))))
+ (pass-if "non-literal format string with (define _ gettext)"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(begin
+ (define _ gettext)
+ (define (foo)
+ (format #t (_ "~A ~A!") "hello" "world")))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
(pass-if "wrong format string"
(let ((w (call-with-warnings
(lambda ()
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index 7984565..97f5559 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -20,6 +20,7 @@
(define-module (test-suite web-http)
#:use-module (web uri)
#:use-module (web http)
+ #:use-module (rnrs io ports)
#:use-module (ice-9 regex)
#:use-module (ice-9 control)
#:use-module (srfi srfi-19)
@@ -232,3 +233,22 @@
(pass-if-parse vary "foo, bar" '(foo bar))
(pass-if-parse www-authenticate "Basic realm=\"guile\""
'((basic (realm . "guile")))))
+
+(with-test-prefix "chunked encoding"
+ (let* ((s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n")
+ (p (make-chunked-input-port (open-input-string s))))
+ (pass-if (equal? "First line\n Second line"
+ (get-string-all p)))
+ (pass-if (port-eof? (make-chunked-input-port (open-input-string
"0\r\n")))))
+ (pass-if
+ (equal? (call-with-output-string
+ (lambda (out-raw)
+ (let ((out-chunked (make-chunked-output-port out-raw
+ #:keep-alive?
#t)))
+ (display "First chunk" out-chunked)
+ (force-output out-chunked)
+ (display "Second chunk" out-chunked)
+ (force-output out-chunked)
+ (display "Third chunk" out-chunked)
+ (close-port out-chunked))))
+ "b\r\nFirst chunk\r\nc\r\nSecond chunk\r\nb\r\nThird
chunk\r\n0\r\n")))
diff --git a/test-suite/tests/web-response.test
b/test-suite/tests/web-response.test
index a21a702..ddd55a7 100644
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -40,6 +40,19 @@ Content-Type: text/html; charset=utf-8\r
\r
abcdefghijklmnopqrstuvwxyz0123456789")
+(define example-2
+ "HTTP/1.1 200 OK\r
+Transfer-Encoding: chunked\r
+Content-Type: text/plain
+\r
+1c\r
+Lorem ipsum dolor sit amet, \r
+1d\r
+consectetur adipisicing elit,\r
+43\r
+ sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.\r
+0\r\n")
+
(define (responses-equal? r1 body1 r2 body2)
(and (equal? (response-version r1) (response-version r2))
(equal? (response-code r1) (response-code r2))
@@ -100,3 +113,14 @@ abcdefghijklmnopqrstuvwxyz0123456789")
(pass-if "by accessor"
(equal? (response-content-encoding r) '(gzip)))))
+
+(with-test-prefix "example-2"
+ (let* ((r (read-response (open-input-string example-2)))
+ (b (read-response-body r)))
+ (pass-if (equal? '((chunked))
+ (response-transfer-encoding r)))
+ (pass-if (equal? b
+ (string->utf8
+ (string-append
+ "Lorem ipsum dolor sit amet, consectetur adipisicing
elit,"
+ " sed do eiusmod tempor incididunt ut labore et dolore
magna aliqua."))))))
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 940fb31..4621a19 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -90,6 +90,23 @@
(uri=? (build-uri 'http #:host "bad.host.1" #:validate? #f)
#:scheme 'http #:host "bad.host.1" #:path ""))
+ (pass-if "http://1.good.host";
+ (uri=? (build-uri 'http #:host "1.good.host")
+ #:scheme 'http #:host "1.good.host" #:path ""))
+
+ (when (memq 'socket *features*)
+ (pass-if "http://192.0.2.1";
+ (uri=? (build-uri 'http #:host "192.0.2.1")
+ #:scheme 'http #:host "192.0.2.1" #:path ""))
+
+ (pass-if "http://[2001:db8::1]";
+ (uri=? (build-uri 'http #:host "2001:db8::1")
+ #:scheme 'http #:host "2001:db8::1" #:path ""))
+
+ (pass-if "http://[::ffff:192.0.2.1]";
+ (uri=? (build-uri 'http #:host "::ffff:192.0.2.1")
+ #:scheme 'http #:host "::ffff:192.0.2.1" #:path "")))
+
(pass-if-uri-exception "http://foo:not-a-port";
"Expected.*port"
(build-uri 'http #:host "foo" #:port "not-a-port"))
@@ -135,6 +152,30 @@
(pass-if "http://bad.host.1";
(not (string->uri "http://bad.host.1";)))
+ (pass-if "http://1.good.host";
+ (uri=? (string->uri "http://1.good.host";)
+ #:scheme 'http #:host "1.good.host" #:path ""))
+
+ (when (memq 'socket *features*)
+ (pass-if "http://192.0.2.1";
+ (uri=? (string->uri "http://192.0.2.1";)
+ #:scheme 'http #:host "192.0.2.1" #:path ""))
+
+ (pass-if "http://[2001:db8::1]";
+ (uri=? (string->uri "http://[2001:db8::1]";)
+ #:scheme 'http #:host "2001:db8::1" #:path ""))
+
+ (pass-if "http://[2001:db8::1]:80";
+ (uri=? (string->uri "http://[2001:db8::1]:80";)
+ #:scheme 'http
+ #:host "2001:db8::1"
+ #:port 80
+ #:path ""))
+
+ (pass-if "http://[::ffff:192.0.2.1]";
+ (uri=? (string->uri "http://[::ffff:192.0.2.1]";)
+ #:scheme 'http #:host "::ffff:192.0.2.1" #:path "")))
+
(pass-if "http://foo:";
(uri=? (string->uri "http://foo:";)
#:scheme 'http #:host "foo" #:path ""))
@@ -188,6 +229,19 @@
(equal? "ftp://address@hidden:22/baz";
(uri->string (string->uri "ftp://address@hidden:22/baz";))))
+ (when (memq 'socket *features*)
+ (pass-if "http://192.0.2.1";
+ (equal? "http://192.0.2.1";
+ (uri->string (string->uri "http://192.0.2.1";))))
+
+ (pass-if "http://[2001:db8::1]";
+ (equal? "http://[2001:db8::1]";
+ (uri->string (string->uri "http://[2001:db8::1]";))))
+
+ (pass-if "http://[::ffff:192.0.2.1]";
+ (equal? "http://[::ffff:192.0.2.1]";
+ (uri->string (string->uri "http://[::ffff:192.0.2.1]";)))))
+
(pass-if "http://foo:";
(equal? "http://foo";
(uri->string (string->uri "http://foo:";))))
@@ -197,7 +251,11 @@
(uri->string (string->uri "http://foo:/";)))))
(with-test-prefix "decode"
- (pass-if (equal? "foo bar" (uri-decode "foo%20bar"))))
+ (pass-if "foo%20bar"
+ (equal? "foo bar" (uri-decode "foo%20bar")))
+
+ (pass-if "foo+bar"
+ (equal? "foo bar" (uri-decode "foo+bar"))))
(with-test-prefix "encode"
(pass-if (equal? "foo%20bar" (uri-encode "foo bar"))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] | Current Thread | [Next in Thread] |